re PR libfortran/27895 (problem with RESHAPE and zero-sized arrays)

	PR libfortran/27895

	* intrinsics/cshift0.c: Special cases for zero-sized arrays.
	* intrinsics/pack_generic.c: Likewise.
	* intrinsics/spread_generic.c: Likewise.

	* gfortran.dg/zero_sized_1.f90: New test.

From-SVN: r117890

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index eb5d88fd80c0c440461e75730710137905957736..be06e215328c17791f5f763da76878c279d7a734 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2006-10-19  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+       PR libfortran/27895
+       * gfortran.dg/zero_sized_1.f90: New test.
+
 2006-10-19  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gcc.dg/div-compare-1.c: New test.
@@ -26,10 +31,10 @@
        * gfortran.dg/streamio_4.f90: Update test.
        * gfortran.dg/streamio_11.f90: New test.
 
-2006-10-17  Lee Millward  <lee.millward@codesuorcery.com>
+2006-10-17  Lee Millward  <lee.millward@codesourcery.com>
 
-        PR c++/27952
-        * g++.dg/inherit/virtual1.C: New test.
+       PR c++/27952
+       * g++.dg/inherit/virtual1.C: New test.
        
 2006-10-17  Mark Mitchell  <mark@codesourcery.com>
 

diff --git a/gcc/testsuite/gfortran.dg/zero_sized_1.f90 b/gcc/testsuite/gfortran.dg/zero_sized_1.f90
new file mode 100644 (file)
index 0000000..c70bddd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/zero_sized_1.f90
@@ -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

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 9001e2c979ea31e09fd0449c49f9dfcc54b2d9a8..5a51c53cadbee0e04d9a101b2f8ba019fc4b2dcf 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,10 @@
+2006-10-19  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+       PR libfortran/27895
+       * intrinsics/cshift0.c: Special cases for zero-sized arrays.
+       * intrinsics/pack_generic.c: Likewise.
+       * intrinsics/spread_generic.c: Likewise.
+
 2006-10-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR libgfortran/29277

diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c
index 4df90ad0fbb544e6a11ee2ac14c5ec36d252848c..f2c2219dd3054c94e812434690d2b079b1eba58e 100644 (file)
--- a/libgfortran/intrinsics/cshift0.c
+++ b/libgfortran/intrinsics/cshift0.c
@@ -1,5 +1,5 @@
 /* Generic implementation of the CSHIFT intrinsic
-   Copyright 2003, 2005 Free Software Foundation, Inc.
+   Copyright 2003, 2005, 2006 Free Software Foundation, Inc.
    Contributed by Feng Wang <wf_cs@yahoo.com>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -144,8 +144,8 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
   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 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
           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++)

diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c
index 27a22ec8d54ff8cd621ce6db7dda61237ec8a1b7..1b0d7250540313179f91c1ce1a9ca64f351c1171 100644 (file)
--- a/libgfortran/intrinsics/pack_generic.c
+++ b/libgfortran/intrinsics/pack_generic.c
@@ -1,5 +1,5 @@
 /* Generic implementation of the PACK intrinsic
-   Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc.
+   Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -195,12 +195,15 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
       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 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
   mstride0 = mstride[0];
   rptr = ret->data;
 
-  while (sptr)
+  while (sptr && mptr)
     {
       /* Test this element.  */
       if (*mptr)
@@ -315,14 +318,17 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
   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 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
                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->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 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
        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)
        {

diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c
index cbc5c4985dffdfd8c4edf8227f762392e8726857..9ea6b12ef16dc10e90c64a37ddbbf88153706a78 100644 (file)
--- a/libgfortran/intrinsics/spread_generic.c
+++ b/libgfortran/intrinsics/spread_generic.c
@@ -101,7 +101,13 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source,
            }
        }
       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
     {