[patch, fortran] Fix PR 30814, bounds checking for pack

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

Hello world,

the attached patch introduces bounds checking for pack.

As this operation is potentially expensive, it is only done
if -fbounds-check is passed in compilation to the main
program.  The changes for this are also included in the
patch.

As a future project, we could also make other intrinsics
aware of bounds-checking.

The test case passes; otherwise, the patch is currently
regression-testing on i686-pc-linux-gnu.

OK for trunk if it passes?
	Thomas

2007-07-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/30814
	* trans-decl.c (generate_function_code):  Add argument
	for flag_bounds_check to the array for set_options.

2007-07-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/30814
	* libgfortran.h:  Add bounds_check to compile_options_t.
	* runtime/compile_options.c (set_options):  Add handling
	of compile_options.bounds_check.
	* intrinsics/pack_generic.c (pack_internal):  Also determine
	the number of elements if compile_options.bounds_check is
	true.  Raise runtime error if a different array shape is
	detected.

2007-07-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/30814
	* gfortran.dg/pack_bounds_1.f90:  New test case.
	

Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 126729)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -3178,9 +3178,13 @@ gfc_generate_function_code (gfc_namespac
 			 build_int_cst (gfc_c_int_type_node,
 					gfc_option.flag_sign_zero), array);
 
+      array = tree_cons (NULL_TREE,
+			 build_int_cst (gfc_c_int_type_node,
+					flag_bounds_check), array);
+
       array_type = build_array_type (gfc_c_int_type_node,
 				     build_index_type (build_int_cst (NULL_TREE,
-								      5)));
+								      6)));
       array = build_constructor_from_list (array_type, nreverse (array));
       TREE_CONSTANT (array) = 1;
       TREE_INVARIANT (array) = 1;
@@ -3196,7 +3200,7 @@ gfc_generate_function_code (gfc_namespac
       var = gfc_build_addr_expr (pvoid_type_node, var);
 
       tmp = build_call_expr (gfor_fndecl_set_options, 2,
-			     build_int_cst (gfc_c_int_type_node, 6), var);
+			     build_int_cst (gfc_c_int_type_node, 7), var);
       gfc_add_expr_to_block (&body, tmp);
     }
 
Index: libgfortran/runtime/compile_options.c
===================================================================
--- libgfortran/runtime/compile_options.c	(revision 126729)
+++ libgfortran/runtime/compile_options.c	(working copy)
@@ -54,6 +54,8 @@ set_options (int num, int options[])
     compile_options.backtrace = options[4];
   if (num >= 6)
     compile_options.sign_zero = options[5];
+  if (num >= 7)
+    compile_options.bounds_check = options[6];
 }
 
 
Index: libgfortran/intrinsics/pack_generic.c
===================================================================
--- libgfortran/intrinsics/pack_generic.c	(revision 126729)
+++ libgfortran/intrinsics/pack_generic.c	(working copy)
@@ -97,6 +97,7 @@ pack_internal (gfc_array_char *ret, cons
   index_type n;
   index_type dim;
   index_type nelem;
+  index_type total;
 
   dim = GFC_DESCRIPTOR_RANK (array);
   zero_sized = 0;
@@ -127,10 +128,10 @@ pack_internal (gfc_array_char *ret, cons
       mptr = GFOR_POINTER_L8_TO_L4 (mptr);
     }
 
-  if (ret->data == NULL)
+  if (ret->data == NULL || compile_options.bounds_check)
     {
-      /* Allocate the memory for the result.  */
-      int total;
+      /* Count the elements, either for allocating memory or
+	 for bounds checking.  */
 
       if (vector != NULL)
 	{
@@ -196,20 +197,30 @@ pack_internal (gfc_array_char *ret, cons
 	    }
 	}
 
-      /* Setup the array descriptor.  */
-      ret->dim[0].lbound = 0;
-      ret->dim[0].ubound = total - 1;
-      ret->dim[0].stride = 1;
+      if (ret->data == NULL)
+	{
+	  /* Setup the array descriptor.  */
+	  ret->dim[0].lbound = 0;
+	  ret->dim[0].ubound = total - 1;
+	  ret->dim[0].stride = 1;
 
-      ret->offset = 0;
-      if (total == 0)
+	  ret->offset = 0;
+	  if (total == 0)
+	    {
+	      /* In this case, nothing remains to be done.  */
+	      ret->data = internal_malloc_size (1);
+	      return;
+	    }
+	  else
+	    ret->data = internal_malloc_size (size * total);
+	}
+      else 
 	{
-	  /* In this case, nothing remains to be done.  */
-	  ret->data = internal_malloc_size (1);
-	  return;
+	  /* We come here because of range checking.  */
+	  if (total != ret->dim[0].ubound + 1 - ret->dim[0].lbound)
+	    runtime_error ("Different array shape in return value of"
+			   " PACK intrinsic");
 	}
-      else
-	ret->data = internal_malloc_size (size * total);
     }
 
   rstride0 = ret->dim[0].stride * size;
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h	(revision 126729)
+++ libgfortran/libgfortran.h	(working copy)
@@ -385,6 +385,7 @@ typedef struct
   int sign_zero;
   size_t record_marker;
   int max_subrecord_length;
+  int bounds_check;
 }
 compile_options_t;