gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90

   1 ! { dg-do run }
   2 ! PR libfortran/103634 - Runtime crash with PACK on zero-sized arrays
   3 ! Exercise PACK intrinsic for cases when it calls pack_internal
   4
   5 program p
   6   implicit none
   7   type t
   8      real :: r(24) = -99.
   9   end type
  10   type(t), allocatable :: new(:), old(:), vec(:)
  11   logical, allocatable :: mask(:)
  12   integer              :: n, m
  13 ! m = 1    ! works
  14   m = 0    ! failed with SIGSEGV in pack_internal
  15   do m = 0, 2
  16      print *, m
  17      allocate (old(m), mask(m), vec(m))
  18      if (m > 0) vec(m)% r(1) = 42
  19      mask(:) = .true.
  20      n = count (mask)
  21      allocate (new(n))
  22
  23      mask(:) = .false.
  24      if (size (pack (old, mask)) /= 0) stop 1
  25      mask(:) = .true.
  26      if (size (pack (old, mask)) /= m) stop 2
  27      new(:) = pack (old, mask)              ! this used to segfault for m=0
  28
  29      mask(:) = .false.
  30      if (size (pack (old, mask, vector=vec)) /= m) stop 3
  31      new(:) = t()
  32      new(:) = pack (old, mask, vector=vec)  ! this used to segfault for m=0
  33      if (m > 0) then
  34         if (     new( m  )% r(1) /=  42)  stop 4
  35         if (any (new(:m-1)% r(1) /= -99)) stop 5
  36      end if
  37
  38      if (m > 0) mask(m) = .true.
  39      if (size (pack (old, mask, vector=vec)) /= m) stop 6
  40      new(:) = t()
  41      new(:) = pack (old, mask, vector=vec)  ! this used to segfault for m=0
  42      if (m > 0) then
  43         if (new(1)% r(1) /= -99) stop 7
  44      end if
  45      if (m > 1) then
  46         if (new(m)% r(1) /=  42) stop 8
  47      end if
  48
  49      if (size (pack (old(:0), mask(:0), vector=vec)) /= m) stop 9
  50      new(:) = t()
  51      new(:) = pack (old(:0), mask(:0), vector=vec) ! did segfault for m=0
  52      if (m > 0) then
  53         if (new(m)% r(1) /= 42) stop 10
  54      end if
  55      deallocate (old, mask, new, vec)
  56   end do
  57 end