From f6879cdcc1de83c86eb47bfae33d06fd00f51a99 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 13 Dec 2021 20:50:19 +0100
Subject: [PATCH] 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.
---
 .../gfortran.dg/intrinsic_pack_6.f90          | 57 +++++++++++++++++++
 libgfortran/intrinsics/pack_generic.c         |  9 +++
 2 files changed, 66 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90

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 00000000000..917944d8846
--- /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
diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c
index cad2fbbfbcd..15880e74348 100644
--- a/libgfortran/intrinsics/pack_generic.c
+++ b/libgfortran/intrinsics/pack_generic.c
@@ -85,6 +85,7 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
 
   index_type count[GFC_MAX_DIMENSIONS];
   index_type extent[GFC_MAX_DIMENSIONS];
+  bool zero_sized;
   index_type n;
   index_type dim;
   index_type nelem;
@@ -114,10 +115,13 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
   else
     runtime_error ("Funny sized logical array");
 
+  zero_sized = false;
   for (n = 0; n < dim; n++)
     {
       count[n] = 0;
       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+      if (extent[n] <= 0)
+	zero_sized = true;
       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
     }
@@ -126,6 +130,11 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
   if (mstride[0] == 0)
     mstride[0] = mask_kind;
 
+  if (zero_sized)
+    sptr = NULL;
+  else
+    sptr = array->base_addr;
+
   if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
     {
       /* Count the elements, either for allocating memory or
-- 
2.26.2