This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[gfortran,patch] Fix transformational intrinsics for zero-sized arrays
- From: FX Coudert <fxcoudert at gmail dot com>
- To: patch <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Sun, 25 Jun 2006 22:00:50 +0200
- Subject: [gfortran,patch] Fix transformational intrinsics for zero-sized arrays
:ADDPATCH libfortran:
Attached patch fixes the behaviour of the transformational intrinsics
when they encounter zero-sized arrays. Current situation goes from
"almost right" to "abort at runtime on valid code" (see PR fortran/17895
for details).
Bootstrapped and regtested on i686-linux. OK for mainline? OK for 4.1?
FX
2006-06-25 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/27895
* intrinsics/cshift0.c (cshift0): Allocate one byte of memory
for zero-sized return array.
* intrinsics/pack_generic.c (pack_internal): Take care of cases
where source array or mask array are zero-sized.
* intrinsics/spread_generic.c (spread_internal): Allocate one byte
of memory for zero-sized return array.
* intrinsics/reshape_generic.c (reshape_internal): Take care of
zero-sized source array.
* m4/reshape.m4: Likewise.
* generated/reshape_i4.c: Regenerate.
* generated/reshape_i8.c: Regenerate.
* generated/reshape_i16.c: Regenerate.
* generated/reshape_r4.c: Regenerate.
* generated/reshape_r8.c: Regenerate.
* generated/reshape_r10.c: Regenerate.
* generated/reshape_r16.c: Regenerate.
* generated/reshape_c4.c: Regenerate.
* generated/reshape_c8.c: Regenerate.
* generated/reshape_c10.c: Regenerate.
* generated/reshape_c16.c: Regenerate.
2006-06-25 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/27895
* gcc/testsuite/gfortran.dg/zero_sized.f90: New test.
Index: libgfortran/intrinsics/cshift0.c
===================================================================
--- libgfortran/intrinsics/cshift0.c (revision 114972)
+++ libgfortran/intrinsics/cshift0.c (working copy)
@@ -144,8 +144,8 @@
if (ret->data == NULL)
{
int i;
+ index_type arraysize = size0 ((array_t *)array);
- ret->data = internal_malloc_size (size * size0 ((array_t *)array));
ret->offset = 0;
ret->dtype = array->dtype;
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
@@ -156,8 +156,17 @@
if (i == 0)
ret->dim[i].stride = 1;
else
- ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
+ ret->dim[i].stride = (ret->dim[i-1].ubound + 1)
+ * ret->dim[i-1].stride;
}
+
+ if (arraysize > 0)
+ ret->data = internal_malloc_size (size * arraysize);
+ else
+ {
+ ret->data = internal_malloc_size (1);
+ return;
+ }
}
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
Index: libgfortran/intrinsics/pack_generic.c
===================================================================
--- libgfortran/intrinsics/pack_generic.c (revision 114972)
+++ libgfortran/intrinsics/pack_generic.c (working copy)
@@ -195,12 +195,15 @@
ret->dim[0].ubound = total - 1;
ret->dim[0].stride = 1;
- ret->data = internal_malloc_size (size * total);
ret->offset = 0;
-
if (total == 0)
- /* In this case, nothing remains to be done. */
- return;
+ {
+ /* In this case, nothing remains to be done. */
+ ret->data = internal_malloc_size (1);
+ return;
+ }
+ else
+ ret->data = internal_malloc_size (size * total);
}
rstride0 = ret->dim[0].stride * size;
@@ -210,7 +213,7 @@
mstride0 = mstride[0];
rptr = ret->data;
- while (sptr)
+ while (sptr && mptr)
{
/* Test this element. */
if (*mptr)
@@ -315,14 +318,17 @@
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
+ index_type ssize;
index_type nelem;
dim = GFC_DESCRIPTOR_RANK (array);
+ ssize = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
sstride[n] = array->dim[n].stride * size;
+ ssize *= extent[n];
}
if (sstride[0] == 0)
sstride[0] = size;
@@ -352,25 +358,23 @@
total *= extent[n];
}
else
- {
- /* The result array will be empty. */
- ret->dim[0].lbound = 0;
- ret->dim[0].ubound = -1;
- ret->dim[0].stride = 1;
- ret->data = internal_malloc_size (0);
- ret->offset = 0;
-
- return;
- }
+ /* The result array will be empty. */
+ total = 0;
}
/* Setup the array descriptor. */
ret->dim[0].lbound = 0;
ret->dim[0].ubound = total - 1;
ret->dim[0].stride = 1;
+ ret->offset = 0;
- ret->data = internal_malloc_size (size * total);
- ret->offset = 0;
+ if (total == 0)
+ {
+ ret->data = internal_malloc_size (1);
+ return;
+ }
+ else
+ ret->data = internal_malloc_size (size * total);
}
rstride0 = ret->dim[0].stride * size;
@@ -384,7 +388,7 @@
If MASK is .FALSE., we have to copy VECTOR into the result
array. If VECTOR were not present we would have already returned. */
- if (*mask)
+ if (*mask && ssize != 0)
{
while (sptr)
{
Index: libgfortran/intrinsics/reshape_generic.c
===================================================================
--- libgfortran/intrinsics/reshape_generic.c (revision 114972)
+++ libgfortran/intrinsics/reshape_generic.c (working copy)
@@ -125,8 +125,8 @@
scount[n] = 0;
sstride[n] = source->dim[n].stride;
sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
- if (sextent[n] <= 0)
- abort ();
+ if (sextent[n] < 0)
+ sextent[n] = 0;
if (ssize == sstride[n])
ssize *= sextent[n];
@@ -176,12 +176,15 @@
while (rptr)
{
/* Select between the source and pad arrays. */
- memcpy(rptr, src, size);
- /* Advance to the next element. */
- rptr += rstride0;
- src += sstride0;
- rcount[0]++;
- scount[0]++;
+ if (ssize > 0)
+ {
+ memcpy(rptr, src, size);
+ /* Advance to the next element. */
+ rptr += rstride0;
+ src += sstride0;
+ rcount[0]++;
+ scount[0]++;
+ }
/* Advance to the next destination element. */
n = 0;
while (rcount[n] == rextent[n])
@@ -207,7 +210,7 @@
}
/* Advance to the next source element. */
n = 0;
- while (scount[n] == sextent[n])
+ while (scount[n] == sextent[n] || ssize == 0)
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
@@ -229,6 +232,7 @@
sextent[dim] = pextent[dim];
sstride[dim] = pstride[dim];
sstride0 = sstride[0] * size;
+ ssize = psize;
}
}
/* We now start again from the beginning of the pad array. */
Index: libgfortran/intrinsics/spread_generic.c
===================================================================
--- libgfortran/intrinsics/spread_generic.c (revision 114972)
+++ libgfortran/intrinsics/spread_generic.c (working copy)
@@ -101,7 +101,13 @@
}
}
ret->offset = 0;
- ret->data = internal_malloc_size (rs * size);
+ if (rs > 0)
+ ret->data = internal_malloc_size (rs * size);
+ else
+ {
+ ret->data = internal_malloc_size (1);
+ return;
+ }
}
else
{
Index: libgfortran/m4/reshape.m4
===================================================================
--- libgfortran/m4/reshape.m4 (revision 114972)
+++ libgfortran/m4/reshape.m4 (working copy)
@@ -137,8 +137,8 @@
scount[n] = 0;
sstride[n] = source->dim[n].stride;
sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
- if (sextent[n] <= 0)
- abort ();
+ if (sextent[n] < 0)
+ sextent[n] = 0;
if (ssize == sstride[n])
ssize *= sextent[n];
@@ -188,12 +188,15 @@
while (rptr)
{
/* Select between the source and pad arrays. */
- *rptr = *src;
- /* Advance to the next element. */
- rptr += rstride0;
- src += sstride0;
- rcount[0]++;
- scount[0]++;
+ if (ssize > 0)
+ {
+ *rptr = *src;
+ /* Advance to the next element. */
+ rptr += rstride0;
+ src += sstride0;
+ rcount[0]++;
+ scount[0]++;
+ }
/* Advance to the next destination element. */
n = 0;
while (rcount[n] == rextent[n])
@@ -219,7 +222,7 @@
}
/* Advance to the next source element. */
n = 0;
- while (scount[n] == sextent[n])
+ while (scount[n] == sextent[n] || ssize == 0)
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
@@ -241,6 +244,7 @@
sextent[dim] = pextent[dim];
sstride[dim] = pstride[dim];
sstride0 = sstride[0];
+ ssize = psize;
}
}
/* We now start again from the beginning of the pad array. */
Index: gcc/testsuite/gfortran.dg/zero_sized.f90
===================================================================
--- gcc/testsuite/gfortran.dg/zero_sized.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/zero_sized.f90 (revision 0)
@@ -0,0 +1,197 @@
+! { dg-do run }
+! Transformational functions for zero-sized array and array sections
+! Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr>
+
+subroutine test_cshift
+ real :: tempn(1), tempm(1,2)
+ real,allocatable :: foo(:),bar(:,:),gee(:,:)
+ tempn = 2.0
+ tempm = 1.0
+ allocate(foo(0),bar(2,0),gee(0,7))
+ if (any(cshift(foo,dim=1,shift=1)/= 0)) call abort
+ if (any(cshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort
+ if (any(cshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(cshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort
+ if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
+ if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
+ if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort
+ deallocate(foo,bar,gee)
+end
+
+subroutine test_eoshift
+ real :: tempn(1), tempm(1,2)
+ real,allocatable :: foo(:),bar(:,:),gee(:,:)
+ tempn = 2.0
+ tempm = 1.0
+ allocate(foo(0),bar(2,0),gee(0,7))
+ if (any(eoshift(foo,dim=1,shift=1)/= 0)) call abort
+ if (any(eoshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort
+ if (any(eoshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(eoshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort
+ if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
+ if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
+ if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
+ if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort
+
+ if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
+ if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
+
+ if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+ if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
+ deallocate(foo,bar,gee)
+end
+
+subroutine test_transpose
+ character(len=1) :: tempn(1,2)
+ character(len=1),allocatable :: foo(:,:), bar(:,:)
+ integer :: tempm(1,2)
+ integer,allocatable :: x(:,:), y(:,:)
+ tempn = 'a'
+ allocate(foo(3,0),bar(-2:-4,7:9))
+ tempm = -42
+ allocate(x(3,0),y(-2:-4,7:9))
+ if (any(transpose(tempn(-7:-8,:)) /= 'b')) call abort
+ if (any(transpose(tempn(:,9:8)) /= 'b')) call abort
+ if (any(transpose(foo) /= 'b')) call abort
+ if (any(transpose(bar) /= 'b')) call abort
+ if (any(transpose(tempm(-7:-8,:)) /= 0)) call abort
+ if (any(transpose(tempm(:,9:8)) /= 0)) call abort
+ if (any(transpose(x) /= 0)) call abort
+ if (any(transpose(y) /= 0)) call abort
+ deallocate(foo,bar,x,y)
+end
+
+subroutine test_reshape
+ character(len=1) :: tempn(1,2)
+ character(len=1),allocatable :: foo(:,:), bar(:,:)
+ integer :: tempm(1,2)
+ integer,allocatable :: x(:,:), y(:,:)
+ tempn = 'b'
+ tempm = -42
+ allocate(foo(3,0),bar(-2:-4,7:9),x(3,0),y(-2:-4,7:9))
+
+ if (size(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/))) /= 9 .or. &
+ any(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/))) /= 27 .or. &
+ any(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. &
+ any(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(foo,(/3,3/),pad=(/'a'/))) /= 9 .or. &
+ any(reshape(foo,(/3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(foo,(/3,3,3/),pad=(/'a'/))) /= 27 .or. &
+ any(reshape(foo,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. &
+ any(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(bar,(/3,3/),pad=(/'a'/))) /= 9 .or. &
+ any(reshape(bar,(/3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(bar,(/3,3,3/),pad=(/'a'/))) /= 27 .or. &
+ any(reshape(bar,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort
+ if (size(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. &
+ any(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort
+
+ if (size(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/))) /= 9 .or. &
+ any(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/))) /= 27 .or. &
+ any(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. &
+ any(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(x,(/3,3/),pad=(/7/))) /= 9 .or. &
+ any(reshape(x,(/3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(x,(/3,3,3/),pad=(/7/))) /= 27 .or. &
+ any(reshape(x,(/3,3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. &
+ any(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(y,(/3,3/),pad=(/7/))) /= 9 .or. &
+ any(reshape(y,(/3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(y,(/3,3,3/),pad=(/7/))) /= 27 .or. &
+ any(reshape(y,(/3,3,3/),pad=(/7/)) /= 7)) call abort
+ if (size(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. &
+ any(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort
+
+ deallocate(foo,bar,x,y)
+end
+
+subroutine test_pack
+ integer :: tempn(1,5)
+ integer,allocatable :: foo(:,:)
+ tempn = 2
+ allocate(foo(0,1:7))
+ if (size(pack(foo,foo/=0)) /= 0 .or. any(pack(foo,foo/=0) /= -42)) call abort
+ if (size(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
+ sum(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 30) call abort
+ if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0)) /= 0 .or. &
+ any(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0) /= -42)) call abort
+ if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
+ sum(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 30) &
+ call abort
+ if (size(pack(foo,.true.)) /= 0 .or. any(pack(foo,.true.) /= -42)) &
+ call abort
+ if (size(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
+ sum(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort
+ if (size(pack(tempn(:,-4:-5),.true.)) /= 0 .or. &
+ any(pack(foo,.true.) /= -42)) call abort
+ if (size(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
+ sum(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort
+ deallocate(foo)
+end
+
+subroutine test_unpack
+ integer :: tempn(1,5), tempv(5)
+ integer,allocatable :: foo(:,:), bar(:)
+ tempn = 2
+ tempv = 5
+ allocate(foo(0,1:7),bar(0:-1))
+ if (any(unpack(tempv,tempv/=0,tempv) /= 5) .or. &
+ size(unpack(tempv,tempv/=0,tempv)) /= 5) call abort
+ if (any(unpack(tempv(1:0),tempv/=0,tempv) /= 5) .or. &
+ size(unpack(tempv(1:0),tempv/=0,tempv)) /= 5) call abort
+ if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort
+ if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort
+ if (any(unpack(bar,foo==foo,foo) /= -47)) call abort
+ deallocate(foo,bar)
+end
+
+subroutine test_spread
+ real :: tempn(1)
+ real,allocatable :: foo(:)
+ tempn = 2.0
+ allocate(foo(0))
+ if (any(spread(1,dim=1,ncopies=0) /= -17.0) .or. &
+ size(spread(1,dim=1,ncopies=0)) /= 0) call abort
+ if (any(spread(foo,dim=1,ncopies=1) /= -17.0) .or. &
+ size(spread(foo,dim=1,ncopies=1)) /= 0) call abort
+ if (any(spread(tempn(2:1),dim=1,ncopies=1) /= -17.0) .or. &
+ size(spread(tempn(2:1),dim=1,ncopies=1)) /= 0) call abort
+ deallocate(foo)
+end
+
+program test
+ call test_cshift
+ call test_eoshift
+ call test_transpose
+ call test_unpack
+ call test_spread
+ call test_pack
+ call test_reshape
+end