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