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)) STOP 1 35 36 ! Check that unallocated allocatables work 37 x = mytype(yy, bar) 38 if (allocated(x%a) .or. allocated(x%q)) STOP 2 39 40 ! Check that non-allocatables work 41 x = mytype(y, [foo, foo]) 42 if (.not.allocated(x%a) .or. .not.allocated(x%q)) STOP 3 43 if (any(lbound(x%a) /= lbound(y))) STOP 4 44 if (any(ubound(x%a) /= ubound(y))) STOP 5 45 if (any(x%a /= y)) STOP 6 46 if (size(x%q) /= 2) STOP 7 47 do i = 1, 2 48 if (any(x%q(i)%a /= foo%a)) STOP 8 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)) STOP 9 58 if (any(x%a /= y)) STOP 10 59 if (size(x%q) /= 2) STOP 11 60 do i = 1, 2 61 if (any(x%q(i)%a /= foo%a)) STOP 12 62 end do 63 64 ! Functions returning arrays 65 x = mytype(bluhu(), null()) 66 if (.not.allocated(x%a) .or. allocated(x%q)) STOP 13 67 if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) STOP 14 68 69 ! Functions returning allocatable arrays 70 x = mytype(blaha(), null()) 71 if (.not.allocated(x%a) .or. allocated(x%q)) STOP 15 72 if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) STOP 16 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)) STOP 17 84 if (any(lbound(x%a) /= lbound(y))) STOP 18 85 if (any(ubound(x%a) /= ubound(y))) STOP 19 86 if (any(x%a /= y)) STOP 20 87 if (size(x%q) /= 2) STOP 21 88 do i = 1, 2 89 if (any(x%q(i)%a /= foo%a)) STOP 22 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