Subversion Repositories openrisc

! { dg-do run }
! PR46328 - complex expressions involving typebound operators of class objects.
!
module field_module
  implicit none
  type ,abstract :: field
  contains
    procedure(field_op_real) ,deferred :: multiply_real
    procedure(field_plus_field) ,deferred :: plus
    procedure(assign_field) ,deferred :: assn
    generic :: operator(*) => multiply_real
    generic :: operator(+) => plus
    generic :: ASSIGNMENT(=) => assn
  end type
  abstract interface
    function field_plus_field(lhs,rhs)
      import :: field
      class(field) ,intent(in)  :: lhs
      class(field) ,intent(in)  :: rhs
      class(field) ,allocatable :: field_plus_field
    end function
  end interface
  abstract interface
    function field_op_real(lhs,rhs)
      import :: field
      class(field) ,intent(in)  :: lhs
      real ,intent(in) :: rhs
      class(field) ,allocatable :: field_op_real
    end function
  end interface
  abstract interface
    subroutine assign_field(lhs,rhs)
      import :: field
      class(field) ,intent(OUT)  :: lhs
      class(field) ,intent(IN)  :: rhs
    end subroutine
  end interface
end module

module i_field_module
  use field_module
  implicit none
  type, extends (field)  :: i_field
    integer :: i
  contains
    procedure :: multiply_real => i_multiply_real
    procedure :: plus => i_plus_i
    procedure :: assn => i_assn
  end type
contains
  function i_plus_i(lhs,rhs)
    class(i_field) ,intent(in)  :: lhs
    class(field) ,intent(in)  :: rhs
    class(field) ,allocatable :: i_plus_i
    integer :: m = 0
    select type (lhs)
      type is (i_field); m = lhs%i
    end select
    select type (rhs)
      type is (i_field); m = rhs%i + m
    end select
    allocate (i_plus_i, source = i_field (m))
  end function
  function i_multiply_real(lhs,rhs)
    class(i_field) ,intent(in)  :: lhs
    real ,intent(in) :: rhs
    class(field) ,allocatable :: i_multiply_real
    integer :: m = 0
    select type (lhs)
      type is (i_field); m = lhs%i * int (rhs)
    end select
    allocate (i_multiply_real, source = i_field (m))
  end function
  subroutine i_assn(lhs,rhs)
    class(i_field) ,intent(OUT)  :: lhs
    class(field) ,intent(IN)  :: rhs
    select type (lhs)
      type is (i_field)
        select type (rhs)
          type is (i_field)
            lhs%i = rhs%i
        end select         
      end select
    end subroutine
end module

program main
  use i_field_module
  implicit none
  class(i_field) ,allocatable :: u
  allocate (u, source = i_field (99))

  u = (u)*2.
  u = (u*2.0*4.0) + u*4.0
  u = u%multiply_real (2.0)*4.0
  u = i_multiply_real (u, 2.0) * 4.0
  
  select type (u)
    type is (i_field); if (u%i .ne. 152064) call abort
  end select
end program
! { dg-final { cleanup-modules "field_module i_field_module" } }