gcc/testsuite/gfortran.dg/class_defined_operator_1.f03

   1 ! { dg-do run }
   2 ! Test the fix for PR42385, in which CLASS defined operators
   3 ! compiled but were not correctly dynamically dispatched.
   4 !
   5 ! Contributed by Janus Weil  <janus@gcc.gnu.org>
   6 !
   7 module foo_module
   8  implicit none
   9  private
  10  public :: foo
  11
  12  type :: foo
  13    integer :: foo_x
  14  contains
  15    procedure :: times => times_foo
  16    procedure :: assign => assign_foo
  17    generic :: operator(*) => times
  18    generic :: assignment(=) => assign
  19  end type
  20
  21 contains
  22
  23    function times_foo(this,factor) result(product)
  24      class(foo) ,intent(in) :: this
  25      class(foo) ,allocatable :: product
  26      integer, intent(in) :: factor
  27      allocate (product, source = this)
  28      product%foo_x = -product%foo_x * factor
  29    end function
  30
  31    subroutine assign_foo(lhs,rhs)
  32      class(foo) ,intent(inout) :: lhs
  33      class(foo) ,intent(in) :: rhs
  34      lhs%foo_x = -rhs%foo_x
  35    end subroutine
  36
  37 end module
  38
  39 module bar_module
  40  use foo_module ,only : foo
  41  implicit none
  42  private
  43  public :: bar
  44
  45  type ,extends(foo) :: bar
  46    integer :: bar_x
  47  contains
  48    procedure :: times => times_bar
  49    procedure :: assign => assign_bar
  50  end type
  51
  52 contains
  53  subroutine assign_bar(lhs,rhs)
  54    class(bar) ,intent(inout) :: lhs
  55    class(foo) ,intent(in) :: rhs
  56    select type(rhs)
  57      type is (bar)
  58        lhs%bar_x = rhs%bar_x
  59        lhs%foo_x = -rhs%foo_x
  60    end select
  61  end subroutine
  62  function times_bar(this,factor) result(product)
  63    class(bar) ,intent(in) :: this
  64    integer, intent(in) :: factor
  65    class(foo), allocatable :: product
  66    select type(this)
  67      type is (bar)
  68        allocate(product,source=this)
  69        select type(product)
  70          type is(bar)
  71            product%bar_x = 2*this%bar_x*factor
  72        end select
  73    end select
  74  end function
  75 end module
  76
  77 program main
  78  use foo_module ,only : foo
  79  use bar_module ,only : bar
  80  implicit none
  81  type(foo) :: unitf
  82  type(bar) :: unitb
  83
  84 ! foo's assign negates, whilst its '*' negates and mutliplies.
  85  unitf%foo_x = 1
  86  call rescale(unitf, 42)
  87  if (unitf%foo_x .ne. 42) call abort
  88
  89 ! bar's assign negates foo_x, whilst its '*' copies foo_x
  90 ! and does a multiply by twice factor.
  91  unitb%foo_x = 1
  92  unitb%bar_x = 2
  93  call rescale(unitb, 3)
  94  if (unitb%bar_x .ne. 12) call abort
  95  if (unitb%foo_x .ne. -1) call abort
  96 contains
  97  subroutine rescale(this,scale)
  98    class(foo) ,intent(inout) :: this
  99    integer, intent(in) :: scale
 100    this = this*scale
 101  end subroutine
 102 end program