Fix for reshape
Thomas Koenig
Thomas.Koenig@online.de
Wed Apr 20 19:27:00 GMT 2005
PM +0200, Tobias Schlüter wrote:
> Thomas Koenig wrote:
> > OK for mainline (and for 4.0 once it's open)?
> Yes, but you need to do essentially the same thing in the generic
> implementation (that is the implementation for types whose size doesn't match
> INTEGER*{4|8}), as well. See intrinsics/reshape_generic.c.
Done (see attached patch).
Bubblestrapped and regression-tested. OK?
Thomas
2005-04-19 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/20074
PR libfortran/20436
PR libfortran/21108
* m4/reshape.m4 (reshape_`'rtype_kind): rs, rex: New
variables, to be used in calculation of return array sizes.
Populate return array descriptor if ret->data is NULL.
Fix condition for early return (it used to test something
undefined if order was used).
Remove duplicate check wether pad is used.
* intrinsics/reshape_generic.c (reshape_generic): Likewise.
Fix a few places where the wrong variables were set.
* generated/reshape_i4.c: Regenerated.
* generated/reshape_i8.c: Regenerated.
205-04-19 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/20074
PR libfortran/20436
PR libfortran/21108
* gfortran.dg/nested_reshape.f90: new test
* gfortran.dg/reshape-alloc.f90: new test
* gfortran.dg/reshape.f90: new test
-------------- next part --------------
Index: m4/reshape.m4
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/m4/reshape.m4,v
retrieving revision 1.7
diff -c -r1.7 reshape.m4
*** m4/reshape.m4 17 Apr 2005 20:26:55 -0000 1.7
--- m4/reshape.m4 20 Apr 2005 19:14:22 -0000
***************
*** 55,60 ****
--- 55,62 ----
index_type rstride0;
index_type rdim;
index_type rsize;
+ index_type rs;
+ index_type rex;
rtype_name *rptr;
/* s.* indicates the source array. */
index_type scount[GFC_MAX_DIMENSIONS];
***************
*** 76,83 ****
int n;
int dim;
- if (ret->dim[0].stride == 0)
- ret->dim[0].stride = 1;
if (source->dim[0].stride == 0)
source->dim[0].stride = 1;
if (shape->dim[0].stride == 0)
--- 78,83 ----
***************
*** 87,93 ****
if (order && order->dim[0].stride == 0)
order->dim[0].stride = 1;
! rdim = GFC_DESCRIPTOR_RANK (ret);
rsize = 1;
for (n = 0; n < rdim; n++)
{
--- 87,115 ----
if (order && order->dim[0].stride == 0)
order->dim[0].stride = 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];
! ret->dim[n].ubound = rex - 1;
! ret->dim[n].stride = rs;
! rs *= rex;
! }
! ret->base = 0;
! 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 (ret->dim[0].stride == 0)
! ret->dim[0].stride = 1;
! }
!
rsize = 1;
for (n = 0; n < rdim; n++)
{
***************
*** 107,113 ****
rsize *= rextent[n];
else
rsize = 0;
! if (rextent[dim] <= 0)
return;
}
--- 129,135 ----
rsize *= rextent[n];
else
rsize = 0;
! if (rextent[n] <= 0)
return;
}
***************
*** 129,136 ****
if (pad)
{
- if (pad->dim[0].stride == 0)
- pad->dim[0].stride = 1;
pdim = GFC_DESCRIPTOR_RANK (pad);
psize = 1;
for (n = 0; n < pdim; n++)
--- 151,156 ----
Index: intrinsics/reshape_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/reshape_generic.c,v
retrieving revision 1.7
diff -c -r1.7 reshape_generic.c
*** intrinsics/reshape_generic.c 17 Apr 2005 20:26:56 -0000 1.7
--- intrinsics/reshape_generic.c 20 Apr 2005 19:14:23 -0000
***************
*** 54,59 ****
--- 54,61 ----
index_type rstride0;
index_type rdim;
index_type rsize;
+ index_type rs;
+ index_type rex;
char *rptr;
/* s.* indicates the source array. */
index_type scount[GFC_MAX_DIMENSIONS];
***************
*** 76,84 ****
int dim;
int size;
- size = GFC_DESCRIPTOR_SIZE (ret);
- if (ret->dim[0].stride == 0)
- ret->dim[0].stride = 1;
if (source->dim[0].stride == 0)
source->dim[0].stride = 1;
if (shape->dim[0].stride == 0)
--- 78,83 ----
***************
*** 88,94 ****
if (order && order->dim[0].stride == 0)
order->dim[0].stride = 1;
! rdim = GFC_DESCRIPTOR_RANK (ret);
rsize = 1;
for (n = 0; n < rdim; n++)
{
--- 87,117 ----
if (order && order->dim[0].stride == 0)
order->dim[0].stride = 1;
! if (ret->data == NULL)
! {
! size = GFC_DESCRIPTOR_SIZE (ret);
! 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];
! ret->dim[n].ubound = rex - 1;
! ret->dim[n].stride = rs;
! rs *= rex;
! }
! ret->base = 0;
! ret->data = internal_malloc_size ( rs * size );
! ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
! }
! else
! {
! size = GFC_DESCRIPTOR_SIZE (ret);
! rdim = GFC_DESCRIPTOR_RANK (ret);
! if (ret->dim[0].stride == 0)
! ret->dim[0].stride = 1;
! }
!
rsize = 1;
for (n = 0; n < rdim; n++)
{
***************
*** 108,114 ****
rsize *= rextent[n];
else
rsize = 0;
! if (rextent[dim] <= 0)
return;
}
--- 131,137 ----
rsize *= rextent[n];
else
rsize = 0;
! if (rextent[n] <= 0)
return;
}
***************
*** 122,128 ****
if (sextent[n] <= 0)
abort ();
! if (rsize == sstride[n])
ssize *= sextent[n];
else
ssize = 0;
--- 145,151 ----
if (sextent[n] <= 0)
abort ();
! if (ssize == sstride[n])
ssize *= sextent[n];
else
ssize = 0;
***************
*** 130,137 ****
if (pad)
{
- if (pad->dim[0].stride == 0)
- pad->dim[0].stride = 1;
pdim = GFC_DESCRIPTOR_RANK (pad);
psize = 1;
for (n = 0; n < pdim; n++)
--- 153,158 ----
***************
*** 144,150 ****
if (psize == pstride[n])
psize *= pextent[n];
else
! rsize = 0;
}
pptr = pad->data;
}
--- 165,171 ----
if (psize == pstride[n])
psize *= pextent[n];
else
! psize = 0;
}
pptr = pad->data;
}
-------------- next part --------------
! { dg-do run }
! This tests a few reshape PRs.
program resh
implicit none
real, dimension (2,3) :: a,c
real, dimension (12) :: b
character (len=80) line1, line2
integer :: i
! PR 21108: This used to give undefined results.
b = (/(i,i=1,12)/)
a = reshape(b(1:12:2),shape(a),order=(/2,1/))
c = reshape(b(1:12:2),shape(a),order=(/2,1/))
if (any (a /= c)) call abort
! Test callee-allocated memory with a write statement
write (line1,'(6F8.3)') reshape(b(1:12:2),shape(a),order=(/2,1/))
write (line2,'(6F8.3)') a
if (line1 /= line2 ) call abort
end
-------------- next part --------------
! { dg-do run }
! PR 20436: This used to give a runtime error.
program nested_reshape
implicit none
real :: k(8,2)
real :: o(8,2)
k = reshape((/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0, &
9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0/), (/8,2/))
o = reshape(reshape(k, (/2,8/), order=(/2,1/)), (/8,2/))
end program
-------------- next part --------------
! { dg-do run }
! PR 20074: This used to segfault at runtime.
! Test case contributed by "Alfredo Buttari" <pitagoras@tin.it>
program tryreshape
integer,allocatable :: vect1(:),resh1(:,:)
integer,pointer :: vect(:),resh(:,:)
integer :: vect2(2*4), resh2(2,4)
integer :: r, s(2)
r=2; nb=4
s(:)=(/r,nb/)
allocate(vect(nb*r),vect1(nb*r))
allocate(resh(r,nb),resh1(r,nb))
vect =1
vect1=1
vect2=1
resh2 = reshape(vect2,s)
if (resh2(1,1) /= 1.0) call abort
resh1 = reshape(vect1,s)
if (resh1(1,1) /= 1.0) call abort
resh = reshape(vect,s)
if (resh(1,1) /= 1.0) call abort
end program tryreshape
More information about the Gcc-patches
mailing list