gcc/testsuite/gfortran.dg/class_result_1.f03

   1 ! { dg-do run }
   2 ! { dg-options "-fcheck=all" }
   3 !
   4 ! PR 50225: [OOP] The allocation status for polymorphic allocatable function results is not set properly
   5 !
   6 ! Contributed by Arjen Markus <arjen.markus895@gmail.com>
   7
   8 module points2d
   9
  10   implicit none
  11
  12   type point2d
  13       real :: x, y
  14   end type
  15
  16 contains
  17
  18  subroutine print( point )
  19    class(point2d) :: point
  20    write(*,'(2f10.4)') point%x, point%y
  21  end subroutine
  22
  23  subroutine random_vector( point )
  24    class(point2d) :: point
  25    call random_number( point%x )
  26    call random_number( point%y )
  27    point%x = 2.0 * (point%x - 0.5)
  28    point%y = 2.0 * (point%y - 0.5)
  29  end subroutine
  30
  31  function add_vector( point, vector )
  32    class(point2d), intent(in)  :: point, vector
  33    class(point2d), allocatable :: add_vector
  34    allocate( add_vector )
  35    add_vector%x = point%x + vector%x
  36    add_vector%y = point%y + vector%y
  37  end function
  38
  39 end module points2d
  40
  41
  42 program random_walk
  43
  44   use points2d
  45   implicit none
  46
  47   type(point2d), target   :: point_2d, vector_2d
  48   class(point2d), pointer :: point, vector
  49   integer :: i
  50
  51   point  => point_2d
  52   vector => vector_2d
  53
  54   do i=1,2
  55     call random_vector(point)
  56     call random_vector(vector)
  57     call print(add_vector(point, vector))
  58   end do
  59
  60 end program random_walk