gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90

   1 ! { dg-do run }
   2 ! Test the fix for PR47517
   3 !
   4 ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
   5 ! from a testcase by James Van Buskirk
   6 module mytypes
   7    implicit none
   8    type label
   9       integer, allocatable :: parts(:)
  10    end type label
  11    type table
  12       type(label), allocatable :: headers(:)
  13    end type table
  14 end module mytypes
  15
  16 program allocate_assign
  17    use mytypes
  18    implicit none
  19    integer, parameter :: ik8 = selected_int_kind(18)
  20    type(table) x1(2)
  21    type(table) x2(3)
  22    type(table), allocatable :: x(:)
  23    integer i, j, k
  24    integer(ik8) s
  25    call foo
  26    s = 0
  27    do k = 1, 10000
  28       x = x1
  29       s = s+x(2)%headers(2)%parts(2)
  30       x = x2
  31       s = s+x(2)%headers(2)%parts(2)
  32    end do
  33    if (s .ne. 40000) call abort
  34 contains
  35 !
  36 ! TODO - these assignments lose 1872 bytes on x86_64/FC17
  37 ! This is PR38319
  38 !
  39    subroutine foo
  40        x1 = [table([(label([(j,j=1,3)]),i=1,3)]), &
  41              table([(label([(j,j=1,4)]),i=1,4)])]
  42
  43        x2 = [table([(label([(j,j=1,4)]),i=1,4)]), &
  44              table([(label([(j,j=1,5)]),i=1,5)]), &
  45              table([(label([(j,j=1,6)]),i=1,6)])]
  46    end subroutine
  47 end program allocate_assign