This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, libfortran] Fix PR 35960, zero-sized reshape
- From: Thomas Koenig <tkoenig at netcologne dot de>
- To: fortran at gcc dot gnu dot org
- Cc: gcc-patches at gcc dot gnu dot org
- Date: Sun, 20 Apr 2008 21:06:40 +0200
- Subject: [patch, libfortran] Fix PR 35960, zero-sized reshape
Hello world,
the following patch is a straightforward fix for when the SHAPE argument
is zero for the reshape intrinsic. The test case is the reporter's.
Regression-tested on i686-pc-linux-gnu.
OK for trunk?
Thomas
2008-04-20 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/35960
* intrinsics/reshape_generic.c (reshape_internal): If the size
of the resized array is zero, as determined by the SHAPE
argument, return early.
* m4/reshape.m4: Likewise.
* generated/reshape_i4.c: Regererated.
* generated/reshape_i8.c: Regenerated.
* generated/reshape_i16.c: Regenerated.
* generated/reshape_r4.c: Regenerated.
* generated/reshape_r8.c: Regenerated.
* generated/reshape_r10.c: Regenerated.
* generated/reshape_r16.c: Regenerated.
* generated/reshape_c4.c: Regenerated.
* generated/reshape_c8.c: Regenerated.
* generated/reshape_c10.c: Regenerated.
* generated/reshape_c16.c: Regenerated.
2008-04-20 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/35960
* gfortran.dg/reshape_zerosize_1.f90: New file.
Index: intrinsics/reshape_generic.c
===================================================================
--- intrinsics/reshape_generic.c (revision 134203)
+++ intrinsics/reshape_generic.c (working copy)
@@ -69,7 +69,24 @@ reshape_internal (parray *ret, parray *s
const char *src;
int n;
int dim;
- int sempty, pempty;
+ int sempty, pempty, shape_empty;
+ index_type shape_data[GFC_MAX_DIMENSIONS];
+
+ rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
+ if (rdim != GFC_DESCRIPTOR_RANK(ret))
+ runtime_error("rank of return array incorrect in RESHAPE intrinsic");
+
+ shape_empty = 0;
+
+ for (n = 0; n < rdim; n++)
+ {
+ shape_data[n] = shape->data[n * shape->dim[0].stride];
+ if (shape_data[n] <= 0)
+ {
+ shape_data[n] = 0;
+ shape_empty = 1;
+ }
+ }
if (ret->data == NULL)
{
@@ -78,7 +95,7 @@ reshape_internal (parray *ret, parray *s
for (n = 0; n < rdim; n++)
{
ret->dim[n].lbound = 0;
- rex = shape->data[n * shape->dim[0].stride];
+ rex = shape_data[n];
ret->dim[n].ubound = rex - 1;
ret->dim[n].stride = rs;
rs *= rex;
@@ -87,10 +104,9 @@ reshape_internal (parray *ret, parray *s
ret->data = internal_malloc_size ( rs * size );
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
}
- else
- {
- rdim = GFC_DESCRIPTOR_RANK (ret);
- }
+
+ if (shape_empty)
+ return;
rsize = 1;
for (n = 0; n < rdim; n++)
@@ -104,7 +120,7 @@ reshape_internal (parray *ret, parray *s
rstride[n] = ret->dim[dim].stride;
rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
- if (rextent[n] != shape->data[dim * shape->dim[0].stride])
+ if (rextent[n] != shape_data[dim])
runtime_error ("shape and target do not conform");
if (rsize == rstride[n])
Index: m4/reshape.m4
===================================================================
--- m4/reshape.m4 (revision 134203)
+++ m4/reshape.m4 (working copy)
@@ -85,16 +85,32 @@ reshape_'rtype_ccode` ('rtype` * const r
const 'rtype_name` *src;
int n;
int dim;
- int sempty, pempty;
+ int sempty, pempty, shape_empty;
+ index_type shape_data[GFC_MAX_DIMENSIONS];
+
+ rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
+ if (rdim != GFC_DESCRIPTOR_RANK(ret))
+ runtime_error("rank of return array incorrect in RESHAPE intrinsic");
+
+ shape_empty = 0;
+
+ for (n = 0; n < rdim; n++)
+ {
+ shape_data[n] = shape->data[n * shape->dim[0].stride];
+ if (shape_data[n] <= 0)
+ {
+ shape_data[n] = 0;
+ shape_empty = 1;
+ }
+ }
if (ret->data == NULL)
{
- rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
rs = 1;
for (n = 0; n < rdim; n++)
{
ret->dim[n].lbound = 0;
- rex = shape->data[n * shape->dim[0].stride];
+ rex = shape_data[n];
ret->dim[n].ubound = rex - 1;
ret->dim[n].stride = rs;
rs *= rex;
@@ -103,10 +119,9 @@ reshape_'rtype_ccode` ('rtype` * const r
ret->data = internal_malloc_size ( rs * sizeof ('rtype_name`));
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
}
- else
- {
- rdim = GFC_DESCRIPTOR_RANK (ret);
- }
+
+ if (shape_empty)
+ return;
rsize = 1;
for (n = 0; n < rdim; n++)
@@ -119,8 +134,10 @@ reshape_'rtype_ccode` ('rtype` * const r
rcount[n] = 0;
rstride[n] = ret->dim[dim].stride;
rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
+ if (rextent[n] < 0)
+ rextent[n] == 0;
- if (rextent[n] != shape->data[dim * shape->dim[0].stride])
+ if (rextent[n] != shape_data[dim])
runtime_error ("shape and target do not conform");
if (rsize == rstride[n])
! { dg-do run }
! PR 35960 - there was a run-time abort when the SHAPE argument to
! RESHAPE was zero-sized.
! Test case contributed by Dick Henderson.
program try_gf1065
! fails on Windows XP
! gcc version 4.4.0 20080312 (experimental) [trunk revision 133139]
call gf1065(1, 2, 3, 4, 7, 8, 9)
end
SUBROUTINE GF1065(nf1,nf2,nf3,nf4,nf7,nf8,nf9)
REAL RDA(10,9)
REAL RCA1(90)
integer ila(2)
RDA(NF9:NF8, NF7:NF3) = RESHAPE(RCA1,(/0,0/), (/1.0/),(/2,1/))
rDA(NF9:NF8, NF7:NF3) = RESHAPE(rCA1,(/0,0/),ORDER=(/2,1/))
ILA(1) = 5
ILA(2) = 0
rDA(NF4:NF8, NF7:NF3) = RESHAPE(rcA1,ILA)
RdA(NF4:NF8, NF7:NF3) = RESHAPE(RcA1,ILA,PAD=(/-1.0/))
ILA(1) = 0
ILA(2) = 5
RdA(NF9:NF8,NF4:NF8)=RESHAPE(RcA1,ILA,(/-1.0/),(/NF2,NF1/))
ILA(1) = 5
ILA(2) = 0
RdA(NF4:NF8, NF7:NF3) = RESHAPE(RcA1,ILA,ORDER=(/NF1,NF2/))
END SUBROUTINE