1! { dg-do run } 2! { dg-options "-fdump-tree-original" } 3! Test constructors of derived type with allocatable components (PR 20541). 4! 5! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> 6! and Paul Thomas <pault@gcc.gnu.org> 7! 8 9Program test_constructor 10 11 implicit none 12 13 type :: thytype 14 integer(4) :: a(2,2) 15 end type thytype 16 17 type :: mytype 18 integer(4), allocatable :: a(:, :) 19 type(thytype), allocatable :: q(:) 20 end type mytype 21 22 type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2])) 23 integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2]) 24 25 BLOCK ! Add scoping unit as the vars are otherwise implicitly SAVEd 26 27 type (mytype) :: x 28 integer, allocatable :: yy(:,:) 29 type (thytype), allocatable :: bar(:) 30 integer :: i 31 32 ! Check that null() works 33 x = mytype(null(), null()) 34 if (allocated(x%a) .or. allocated(x%q)) call abort() 35 36 ! Check that unallocated allocatables work 37 x = mytype(yy, bar) 38 if (allocated(x%a) .or. allocated(x%q)) call abort() 39 40 ! Check that non-allocatables work 41 x = mytype(y, [foo, foo]) 42 if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() 43 if (any(lbound(x%a) /= lbound(y))) call abort() 44 if (any(ubound(x%a) /= ubound(y))) call abort() 45 if (any(x%a /= y)) call abort() 46 if (size(x%q) /= 2) call abort() 47 do i = 1, 2 48 if (any(x%q(i)%a /= foo%a)) call abort() 49 end do 50 51 ! Check that allocated allocatables work 52 allocate(yy(size(y,1), size(y,2))) 53 yy = y 54 allocate(bar(2)) 55 bar = [foo, foo] 56 x = mytype(yy, bar) 57 if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() 58 if (any(x%a /= y)) call abort() 59 if (size(x%q) /= 2) call abort() 60 do i = 1, 2 61 if (any(x%q(i)%a /= foo%a)) call abort() 62 end do 63 64 ! Functions returning arrays 65 x = mytype(bluhu(), null()) 66 if (.not.allocated(x%a) .or. allocated(x%q)) call abort() 67 if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort() 68 69 ! Functions returning allocatable arrays 70 x = mytype(blaha(), null()) 71 if (.not.allocated(x%a) .or. allocated(x%q)) call abort() 72 if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort() 73 74 ! Check that passing the constructor to a procedure works 75 call check_mytype (mytype(y, [foo, foo])) 76 END BLOCK 77contains 78 79 subroutine check_mytype(x) 80 type(mytype), intent(in) :: x 81 integer :: i 82 83 if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() 84 if (any(lbound(x%a) /= lbound(y))) call abort() 85 if (any(ubound(x%a) /= ubound(y))) call abort() 86 if (any(x%a /= y)) call abort() 87 if (size(x%q) /= 2) call abort() 88 do i = 1, 2 89 if (any(x%q(i)%a /= foo%a)) call abort() 90 end do 91 92 end subroutine check_mytype 93 94 95 function bluhu() 96 integer :: bluhu(2,2) 97 98 bluhu = reshape ([41, 98, 54, 76], [2,2]) 99 end function bluhu 100 101 102 function blaha() 103 integer, allocatable :: blaha(:,:) 104 105 allocate(blaha(2,2)) 106 blaha = reshape ([40, 97, 53, 75], [2,2]) 107 end function blaha 108 109end program test_constructor 110! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } } 111! { dg-final { cleanup-tree-dump "original" } } 112