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! 7module 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 18contains 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 32end module 33 34program 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)) call abort 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)) call abort 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])) call abort 61 end select 62end program 63