gcc/testsuite/gfortran.dg/overload_3.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fno-tree-vrp" }
   3 ! PR fortran/89282
   4 ! Contributed by Federico Perini.
   5 !
   6 module myclass
   7     use iso_fortran_env, only: real64
   8     implicit none
   9
  10     ! My generic type
  11     type :: t
  12
  13         integer :: n=0
  14         real(real64), allocatable :: x(:)
  15
  16         contains
  17
  18           procedure :: init => t_init
  19           procedure :: destroy => t_destroy
  20           procedure :: print => t_print
  21
  22           procedure, private, pass(this) :: x_minus_t
  23           generic :: operator(-) => x_minus_t
  24
  25
  26     end type t
  27
  28     contains
  29
  30     elemental subroutine t_destroy(this)
  31        class(t), intent(inout) :: this
  32        this%n=0
  33        if (allocated(this%x)) deallocate(this%x)
  34     end subroutine t_destroy
  35
  36     subroutine t_init(this,n)
  37       class(t), intent(out) :: this
  38       integer, intent(in) :: n
  39       call this%destroy()
  40       this%n=n
  41       allocate(this%x(n))
  42     end subroutine t_init
  43
  44     type(t) function x_minus_t(x,this) result(xmt)
  45        real(real64), intent(in) :: x
  46        class(t), intent(in) :: this
  47        call xmt%init(this%n)
  48        xmt%x(:) = x-this%x(:)
  49     end function x_minus_t
  50
  51     subroutine t_print(this,msg)
  52        class(t), intent(in) :: this
  53        character(*), intent(in) :: msg
  54
  55        integer :: i
  56
  57        print "('type(t) object <',a,'>, size=',i0)", msg,this%n
  58        do i=1,this%n
  59          print "('  x(',i0,') =',1pe12.5)",i,this%x(i)
  60        end do
  61
  62     end subroutine t_print
  63
  64 end module myclass
  65
  66
  67 program test_overloaded
  68     use myclass
  69     implicit none
  70
  71     type(t) :: t1,r1
  72
  73     ! Error with result (5)
  74     call t1%init(5);  t1%x(:) = 1.0_real64; r1 = 3.0_real64 - t1
  75     if (any(r1%x /= 2.0)) stop 1
  76 !    call r1%print('r1')
  77
  78     ! No errors
  79     call t1%init(6);  t1%x(:) = 1.0_real64; r1 = 3.0_real64 - t1
  80     if (any(r1%x /= 2.0)) stop 2
  81 !    call r1%print('r1')
  82     return
  83
  84 end program test_overloaded