Fortran: PACK intrinsic should not try to read from zero-sized array

libgfortran/ChangeLog:

	PR libfortran/103634
	* intrinsics/pack_generic.c (pack_internal): Handle case when the
	array argument of PACK has one or more extents of size zero to
	avoid invalid reads.

gcc/testsuite/ChangeLog:

	PR libfortran/103634
	* gfortran.dg/intrinsic_pack_6.f90: New test.

1 files changed, 57 insertions, 0 deletions

diff --git a/gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90 b/gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90
new file mode 100644
index 0000000..917944d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90
@@ -0,0 +1,57 @@
+! { dg-do run }
+! PR libfortran/103634 - Runtime crash with PACK on zero-sized arrays
+! Exercise PACK intrinsic for cases when it calls pack_internal
+
+program p
+  implicit none
+  type t
+     real :: r(24) = -99.
+  end type
+  type(t), allocatable :: new(:), old(:), vec(:)
+  logical, allocatable :: mask(:)
+  integer              :: n, m
+! m = 1    ! works
+  m = 0    ! failed with SIGSEGV in pack_internal
+  do m = 0, 2
+     print *, m
+     allocate (old(m), mask(m), vec(m))
+     if (m > 0) vec(m)% r(1) = 42
+     mask(:) = .true.
+     n = count (mask)
+     allocate (new(n))
+
+     mask(:) = .false.
+     if (size (pack (old, mask)) /= 0) stop 1
+     mask(:) = .true.
+     if (size (pack (old, mask)) /= m) stop 2
+     new(:) = pack (old, mask)              ! this used to segfault for m=0
+
+     mask(:) = .false.
+     if (size (pack (old, mask, vector=vec)) /= m) stop 3
+     new(:) = t()
+     new(:) = pack (old, mask, vector=vec)  ! this used to segfault for m=0
+     if (m > 0) then
+        if (     new( m  )% r(1) /=  42)  stop 4
+        if (any (new(:m-1)% r(1) /= -99)) stop 5
+     end if
+
+     if (m > 0) mask(m) = .true.
+     if (size (pack (old, mask, vector=vec)) /= m) stop 6
+     new(:) = t()
+     new(:) = pack (old, mask, vector=vec)  ! this used to segfault for m=0
+     if (m > 0) then
+        if (new(1)% r(1) /= -99) stop 7
+     end if
+     if (m > 1) then
+        if (new(m)% r(1) /=  42) stop 8
+     end if
+
+     if (size (pack (old(:0), mask(:0), vector=vec)) /= m) stop 9
+     new(:) = t()
+     new(:) = pack (old(:0), mask(:0), vector=vec) ! did segfault for m=0
+     if (m > 0) then
+        if (new(m)% r(1) /= 42) stop 10
+     end if
+     deallocate (old, mask, new, vec)
+  end do
+end