re PR libfortran/33298 (Wrong code for SPREAD on zero-sized arrays)

2007-09-06  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/33298
	* intrinsics/spread_generic.c(spread_internal): Enable
	bounds checking by comparing extents if the bounds_check
	option has been set.  If any extent is <=0, return early.

2007-09-06  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/33298
	* spread_zerosize_1.f90:  New test case.
	* spread_bounds_1.f90:  New test case.

From-SVN: r128206

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2007-09-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/33298
+	* spread_zerosize_1.f90:  New test case.
+	* spread_bounds_1.f90:  New test case.
+
 2007-09-06  Paolo Carlini  <pcarlini@suse.de>
 
 	PR c++/32674

gcc/testsuite/gfortran.dg/spread_bounds_1.f90

@@ -0,0 +1,12 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Incorrect extent in return value of SPREAD intrinsic in dimension 2: is 3, should be 2" }
+program main
+  integer :: source(2), target(2,3)
+  data source /1,2/
+  integer :: times
+  times = 2
+  target = spread(source,2,times)
+end program main
+! { dg-output "Fortran runtime error:  Incorrect extent in return value of SPREAD intrinsic in dimension 2: is 3, should be 2"
+

gcc/testsuite/gfortran.dg/spread_zerosize_1.f90

@@ -0,0 +1,8 @@
+! { dg-do run }
+! PR 33298 - zero-sized arrays for spread were handled
+!            incorrectly.
+
+program main
+  real :: x(0,3), y(0)
+  x = spread(y,2,3)
+end

libgfortran/ChangeLog

@@ -1,3 +1,10 @@
+2007-09-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/33298
+	* intrinsics/spread_generic.c(spread_internal): Enable
+	bounds checking by comparing extents if the bounds_check
+	option has been set.  If any extent is <=0, return early.
+
 2007-09-06  David Edelsohn  <edelsohn@gnu.org>
 
 	* libgfortran.h: Include config.h first.

libgfortran/intrinsics/spread_generic.c

@@ -110,26 +110,75 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source,
     }
   else
     {
+      int zero_sized;
+
+      zero_sized = 0;
+
       dim = 0;
       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
 	runtime_error ("rank mismatch in spread()");
 
-      for (n = 0; n < rrank; n++)
+      if (compile_options.bounds_check)
 	{
-	  if (n == *along - 1)
+	  for (n = 0; n < rrank; n++)
 	    {
-	      rdelta = ret->dim[n].stride * size;
+	      index_type ret_extent;
-	    }
+
-	  else
+	      ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
-	    {
+	      if (n == *along - 1)
-	      count[dim] = 0;
+		{
-	      extent[dim] = source->dim[dim].ubound + 1
+		  rdelta = ret->dim[n].stride * size;
-		- source->dim[dim].lbound;
+
-	      sstride[dim] = source->dim[dim].stride * size;
+		  if (ret_extent != ncopies)
-	      rstride[dim] = ret->dim[n].stride * size;
+		    runtime_error("Incorrect extent in return value of SPREAD"
-	      dim++;
+				  " intrinsic in dimension %d: is %ld,"
+				  " should be %ld", n+1, (long int) ret_extent,
+				  (long int) ncopies);
+		}
+	      else
+		{
+		  count[dim] = 0;
+		  extent[dim] = source->dim[dim].ubound + 1
+		    - source->dim[dim].lbound;
+		  if (ret_extent != extent[dim])
+		    runtime_error("Incorrect extent in return value of SPREAD"
+				  " intrinsic in dimension %d: is %ld,"
+				  " should be %ld", n+1, (long int) ret_extent,
+				  (long int) extent[dim]);
+		    
+		  if (extent[dim] <= 0)
+		    zero_sized = 1;
+		  sstride[dim] = source->dim[dim].stride * size;
+		  rstride[dim] = ret->dim[n].stride * size;
+		  dim++;
+		}
 	    }
 	}
+      else
+	{
+	  for (n = 0; n < rrank; n++)
+	    {
+	      if (n == *along - 1)
+		{
+		  rdelta = ret->dim[n].stride * size;
+		}
+	      else
+		{
+		  count[dim] = 0;
+		  extent[dim] = source->dim[dim].ubound + 1
+		    - source->dim[dim].lbound;
+		  if (extent[dim] <= 0)
+		    zero_sized = 1;
+		  sstride[dim] = source->dim[dim].stride * size;
+		  rstride[dim] = ret->dim[n].stride * size;
+		  dim++;
+		}
+	    }
+	}
+
+      if (zero_sized)
+	return;
+
       if (sstride[0] == 0)
 	sstride[0] = size;
     }