[patch, libfortran] Fix PR 33298, spread on zero-sized arrays

[Thomas Koenig <tkoenig at alice-dsl dot net>]

:ADDPATCH fortran:

Hello world,

this patch fixes PR 33298, in which zero-sized arrays were
handled incorrectly for spread.  While I was at it, I also
added runtime bounds checking.  For code without -fbounds-check,
the additional overhead is one if statement (which shouldn't hurt
performance too much).

Regression-tested on i686-pc-linux-gnu.  OK for trunk?

	Thomas


2007-09-05  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-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

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

Index: intrinsics/spread_generic.c
===================================================================
--- intrinsics/spread_generic.c	(revision 128136)
+++ intrinsics/spread_generic.c	(working copy)
@@ -110,26 +110,75 @@ spread_internal (gfc_array_char *ret, co
     }
   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;
+
+	      ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
+	      if (n == *along - 1)
+		{
+		  rdelta = ret->dim[n].stride * size;
+
+		  if (ret_extent != ncopies)
+		    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) 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
+	}
+      else
+	{
+	  for (n = 0; n < rrank; n++)
 	    {
-	      count[dim] = 0;
-	      extent[dim] = source->dim[dim].ubound + 1
-		- source->dim[dim].lbound;
-	      sstride[dim] = source->dim[dim].stride * size;
-	      rstride[dim] = ret->dim[n].stride * size;
-	      dim++;
+	      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;
     }

! { 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"

! { 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