Subversion Repositories openrisc

! { dg-do run }

! Test the fix for PR42385, in which CLASS defined operators

! compiled but were not correctly dynamically dispatched.

!

! Contributed by Janus Weil  

!

module foo_module

 implicit none

 private

 public :: foo

 type :: foo

   integer :: foo_x

 contains

   procedure :: times => times_foo

   procedure :: assign => assign_foo

   generic :: operator(*) => times

   generic :: assignment(=) => assign

 end type

contains

   function times_foo(this,factor) result(product)

     class(foo) ,intent(in) :: this

     class(foo) ,allocatable :: product

     integer, intent(in) :: factor

     allocate (product, source = this)

     product%foo_x = -product%foo_x * factor

   end function

   subroutine assign_foo(lhs,rhs)

     class(foo) ,intent(inout) :: lhs

     class(foo) ,intent(in) :: rhs

     lhs%foo_x = -rhs%foo_x

   end subroutine

end module

module bar_module

 use foo_module ,only : foo

 implicit none

 private

 public :: bar

 type ,extends(foo) :: bar

   integer :: bar_x

 contains

   procedure :: times => times_bar

   procedure :: assign => assign_bar

 end type

contains

 subroutine assign_bar(lhs,rhs)

   class(bar) ,intent(inout) :: lhs

   class(foo) ,intent(in) :: rhs

   select type(rhs)

     type is (bar)

       lhs%bar_x = rhs%bar_x

       lhs%foo_x = -rhs%foo_x

   end select

 end subroutine

 function times_bar(this,factor) result(product)

   class(bar) ,intent(in) :: this

   integer, intent(in) :: factor

   class(foo), allocatable :: product

   select type(this)

     type is (bar)

       allocate(product,source=this)

       select type(product)

         type is(bar)

           product%bar_x = 2*this%bar_x*factor

       end select

   end select

 end function

end module

program main

 use foo_module ,only : foo

 use bar_module ,only : bar

 implicit none

 type(foo) :: unitf

 type(bar) :: unitb

! foo's assign negates, whilst its '*' negates and mutliplies.

 unitf%foo_x = 1

 call rescale(unitf, 42)

 if (unitf%foo_x .ne. 42) call abort

! bar's assign negates foo_x, whilst its '*' copies foo_x

! and does a multiply by twice factor.

 unitb%foo_x = 1

 unitb%bar_x = 2

 call rescale(unitb, 3)

 if (unitb%bar_x .ne. 12) call abort

 if (unitb%foo_x .ne. -1) call abort

contains

 subroutine rescale(this,scale)

   class(foo) ,intent(inout) :: this

   integer, intent(in) :: scale

   this = this*scale

 end subroutine

end program

! { dg-final { cleanup-modules "bar_module foo_module" } }