gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90

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