OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Harald Anlauf 2021-12-13 20:50:19 +01:00
parent 3305135c29
commit 1c613165a5
2 changed files with 66 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90 Normal file
View File

@ -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

9
libgfortran/intrinsics/pack_generic.c
View File

@ -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