gcc/testsuite/gfortran.dg/class_allocate_10.f03

   1 ! { dg-do run }
   2 ! PR51870 - ALLOCATE with class function expression for SOURCE failed.
   3 ! This version of the test allocates class arrays with MOLD.
   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 = 1
  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 :: kernel1(:), kernel2(:)
  38   type(show_producer) :: executive_producer
  39
  40   allocate(kernel1(5), kernel2(5),mold=executive_producer%create_show_array (5))
  41   select type(kernel1)
  42     type is (integrand);  if (any (kernel1%variable .ne. 1)) STOP 1
  43   end select
  44
  45   deallocate (kernel1)
  46
  47   allocate(kernel1(3),mold=executive_producer%create_show ())
  48   select type(kernel1)
  49     type is (integrand); if (any (kernel1%variable .ne. 1)) STOP 2
  50   end select
  51
  52   deallocate (kernel1)
  53
  54   select type(kernel2)
  55     type is (integrand); kernel2%variable = [1,2,3,4,5]
  56   end select
  57
  58   allocate(kernel1(3),source = kernel2(3:5))
  59   select type(kernel1)
  60     type is (integrand); if (any (kernel1%variable .ne. [3,4,5])) STOP 3
  61   end select
  62 end program