gcc/testsuite/gfortran.dg/typebound_operator_7.f03

   1 ! { dg-do run }
   2 ! PR46328 - complex expressions involving typebound operators of class objects.
   3 !
   4 module field_module
   5   implicit none
   6   type ,abstract :: field
   7   contains
   8     procedure(field_op_real) ,deferred :: multiply_real
   9     procedure(field_plus_field) ,deferred :: plus
  10     procedure(assign_field) ,deferred :: assn
  11     generic :: operator(*) => multiply_real
  12     generic :: operator(+) => plus
  13     generic :: ASSIGNMENT(=) => assn
  14   end type
  15   abstract interface
  16     function field_plus_field(lhs,rhs)
  17       import :: field
  18       class(field) ,intent(in)  :: lhs
  19       class(field) ,intent(in)  :: rhs
  20       class(field) ,allocatable :: field_plus_field
  21     end function
  22   end interface
  23   abstract interface
  24     function field_op_real(lhs,rhs)
  25       import :: field
  26       class(field) ,intent(in)  :: lhs
  27       real ,intent(in) :: rhs
  28       class(field) ,allocatable :: field_op_real
  29     end function
  30   end interface
  31   abstract interface
  32     subroutine assign_field(lhs,rhs)
  33       import :: field
  34       class(field) ,intent(OUT)  :: lhs
  35       class(field) ,intent(IN)  :: rhs
  36     end subroutine
  37   end interface
  38 end module
  39
  40 module i_field_module
  41   use field_module
  42   implicit none
  43   type, extends (field)  :: i_field
  44     integer :: i
  45   contains
  46     procedure :: multiply_real => i_multiply_real
  47     procedure :: plus => i_plus_i
  48     procedure :: assn => i_assn
  49   end type
  50 contains
  51   function i_plus_i(lhs,rhs)
  52     class(i_field) ,intent(in)  :: lhs
  53     class(field) ,intent(in)  :: rhs
  54     class(field) ,allocatable :: i_plus_i
  55     integer :: m = 0
  56     select type (lhs)
  57       type is (i_field); m = lhs%i
  58     end select
  59     select type (rhs)
  60       type is (i_field); m = rhs%i + m
  61     end select
  62     allocate (i_plus_i, source = i_field (m))
  63   end function
  64   function i_multiply_real(lhs,rhs)
  65     class(i_field) ,intent(in)  :: lhs
  66     real ,intent(in) :: rhs
  67     class(field) ,allocatable :: i_multiply_real
  68     integer :: m = 0
  69     select type (lhs)
  70       type is (i_field); m = lhs%i * int (rhs)
  71     end select
  72     allocate (i_multiply_real, source = i_field (m))
  73   end function
  74   subroutine i_assn(lhs,rhs)
  75     class(i_field) ,intent(OUT)  :: lhs
  76     class(field) ,intent(IN)  :: rhs
  77     select type (lhs)
  78       type is (i_field)
  79         select type (rhs)
  80           type is (i_field)
  81             lhs%i = rhs%i
  82         end select
  83       end select
  84     end subroutine
  85 end module
  86
  87 program main
  88   use i_field_module
  89   implicit none
  90   class(i_field) ,allocatable :: u
  91   allocate (u, source = i_field (99))
  92
  93   u = (u)*2.
  94   u = (u*2.0*4.0) + u*4.0
  95   u = u%multiply_real (2.0)*4.0
  96   u = i_multiply_real (u, 2.0) * 4.0
  97
  98   select type (u)
  99     type is (i_field); if (u%i .ne. 152064) STOP 1
 100   end select
 101 end program