gcc/testsuite/gfortran.dg/typebound_operator_13.f03

   1 ! { dg-do run }
   2 ! PR51634 - Handle allocatable components correctly in expressions
   3 ! involving typebound operators. From comment 2 of PR but using
   4 ! classes throughout.
   5 !
   6 ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
   7 !
   8 module soop_stars_class
   9   implicit none
  10   type soop_stars
  11     real, dimension(:), allocatable :: position,velocity
  12   contains
  13     procedure :: total
  14     procedure :: mult
  15     procedure :: assign
  16     generic :: operator(+) => total
  17     generic :: operator(*) => mult
  18     generic :: assignment(=) => assign
  19   end type
  20 contains
  21   function mult(lhs,rhs)
  22     class(soop_stars) ,intent(in) :: lhs
  23     real ,intent(in) :: rhs
  24     class(soop_stars), allocatable :: mult
  25     type(soop_stars) :: tmp
  26     tmp = soop_stars (lhs%position*rhs, lhs%velocity*rhs)
  27     allocate (mult, source = tmp)
  28   end function
  29
  30   function total(lhs,rhs)
  31     class(soop_stars) ,intent(in) :: lhs,rhs
  32     class(soop_stars), allocatable :: total
  33     type(soop_stars) :: tmp
  34     tmp = soop_stars (lhs%position + rhs%position, &
  35                       lhs%velocity + rhs%velocity)
  36     allocate (total, source = tmp)
  37   end function
  38
  39   subroutine assign(lhs,rhs)
  40     class(soop_stars), intent(in) :: rhs
  41     class(soop_stars), intent(out) :: lhs
  42     lhs%position = rhs%position
  43     lhs%velocity = rhs%velocity
  44   end subroutine
  45 end module
  46
  47 program main
  48   use soop_stars_class ,only : soop_stars
  49   implicit none
  50   class(soop_stars), allocatable :: fireworks
  51   real :: dt
  52   allocate (fireworks, source = soop_stars ([1,2,3], [4,5,6]))
  53   dt = 5
  54   fireworks = fireworks + fireworks*dt
  55   if (any (fireworks%position .ne. [6, 12, 18])) STOP 1
  56   if (any (fireworks%velocity .ne. [24, 30, 36])) STOP 2
  57 end program