gcc/testsuite/gfortran.dg/class_allocate_8.f03

   1 ! { dg-do run }
   2 ! PR51870 - ALLOCATE with class function expression for SOURCE failed.
   3 ! This version of the test allocates class arrays.
   4 !
   5 ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
   6 !
   7 module show_producer_class
   8   implicit none
   9   type integrand
  10     integer :: variable = 0
  11   end type integrand
  12
  13   type show_producer
  14   contains
  15     procedure ,nopass :: create_show
  16     procedure ,nopass :: create_show_array
  17   end type
  18 contains
  19   function create_show () result(new_integrand)
  20     class(integrand) ,allocatable :: new_integrand
  21     allocate(new_integrand)
  22     new_integrand%variable = -1
  23   end function
  24   function create_show_array (n) result(new_integrand)
  25     class(integrand) ,allocatable :: new_integrand(:)
  26     integer :: n, i
  27     allocate(new_integrand(n))
  28     select type (new_integrand)
  29       type is (integrand); new_integrand%variable = [(i, i= 1, n)]
  30     end select
  31   end function
  32 end module
  33
  34 program main
  35   use show_producer_class
  36   implicit none
  37   class(integrand) ,allocatable :: kernel(:)
  38   type(show_producer) :: executive_producer
  39
  40   allocate(kernel(5),source=executive_producer%create_show_array (5))
  41   select type(kernel)
  42     type is (integrand);  if (any (kernel%variable .ne. [1,2,3,4,5])) call abort
  43   end select
  44
  45   deallocate (kernel)
  46
  47   allocate(kernel(3),source=executive_producer%create_show ())
  48   select type(kernel)
  49     type is (integrand); if (any (kernel%variable .ne. -1)) call abort
  50   end select
  51 end program
  52 ! { dg-final { cleanup-modules "show_producer_class" } }
  53