2009-08-25 Thomas Koenig <tkoenig@gcc.gnu.org>

	PR libfortran/34670
	* runtime/bounds.c (count_0):  New function.
	* intrinsics/unpack_generic (unpack_bounds):  New function.
	(unpack_internal):  Remove zero stride checks.
	(unpack1):  Use unpack_bounds.
	(unpack1_char):  Likeweise.
	(unpack1_char4):  Likewise
	(unpack0):  Likewise.
	(unpack0_char):  Likewise.
	(unpack0_char4):  Likewise.

2009-08-25  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34670
	* gfortran.dg/unpack_bounds_1.f90:  New test.
	* gfortran.dg/unpack_bounds_2.f90:  New test.
	* gfortran.dg/unpack_bounds_3.f90:  New test.




git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151085 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 46 insertions, 9 deletions

diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c
index 47d4a6dddef..4a4c2192e9d 100644
--- a/libgfortran/intrinsics/unpack_generic.c
+++ b/libgfortran/intrinsics/unpack_generic.c
@@ -28,6 +28,32 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include <assert.h>
 #include <string.h>
 
+/* All the bounds checking for unpack in one function.  If field is NULL,
+   we don't check it, for the unpack0 functions.  */
+
+static void
+unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
+	 const gfc_array_l1 *mask, const gfc_array_char *field)
+{
+  index_type vec_size, mask_count;
+  vec_size = size0 ((array_t *) vector);
+  mask_count = count_0 (mask);
+  if (vec_size < mask_count)
+    runtime_error ("Incorrect size of return value in UNPACK"
+		   " intrinsic: should be at least %ld, is"
+		   " %ld", (long int) mask_count,
+		   (long int) vec_size);
+
+  if (field != NULL)
+    bounds_equal_extents ((array_t *) field, (array_t *) mask,
+			  "FIELD", "UNPACK");
+
+  if (ret->data != NULL)
+    bounds_equal_extents ((array_t *) ret, (array_t *) mask,
+			  "return value", "UNPACK");
+
+}
+
 static void
 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
 		 const gfc_array_l1 *mask, const gfc_array_char *field,
@@ -113,21 +139,12 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
 	  fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
 	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
 	}
-      if (rstride[0] == 0)
-	rstride[0] = size;
     }
 
   if (empty)
     return;
 
-  if (fstride[0] == 0)
-    fstride[0] = fsize;
-  if (mstride[0] == 0)
-    mstride[0] = 1;
-
   vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
-  if (vstride0 == 0)
-    vstride0 = size;
   rstride0 = rstride[0];
   fstride0 = fstride[0];
   mstride0 = mstride[0];
@@ -193,6 +210,9 @@ unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
   index_type type_size;
   index_type size;
 
+  if (unlikely(compile_options.bounds_check))
+    unpack_bounds (ret, vector, mask, field);
+
   type_size = GFC_DTYPE_TYPE_SIZE (vector);
   size = GFC_DESCRIPTOR_SIZE (vector);
 
@@ -343,6 +363,10 @@ unpack1_char (gfc_array_char *ret,
 	      const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 	      GFC_INTEGER_4 field_length)
 {
+
+  if (unlikely(compile_options.bounds_check))
+    unpack_bounds (ret, vector, mask, field);
+
   unpack_internal (ret, vector, mask, field, vector_length, field_length);
 }
 
@@ -360,6 +384,10 @@ unpack1_char4 (gfc_array_char *ret,
 	       const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 	       GFC_INTEGER_4 field_length)
 {
+
+  if (unlikely(compile_options.bounds_check))
+    unpack_bounds (ret, vector, mask, field);
+
   unpack_internal (ret, vector, mask, field,
 		   vector_length * sizeof (gfc_char4_t),
 		   field_length * sizeof (gfc_char4_t));
@@ -379,6 +407,9 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
   index_type type_size;
   index_type size;
 
+  if (unlikely(compile_options.bounds_check))
+    unpack_bounds (ret, vector, mask, NULL);
+
   type_size = GFC_DTYPE_TYPE_SIZE (vector);
   size = GFC_DESCRIPTOR_SIZE (vector);
 
@@ -530,6 +561,9 @@ unpack0_char (gfc_array_char *ret,
 {
   gfc_array_char tmp;
 
+  if (unlikely(compile_options.bounds_check))
+    unpack_bounds (ret, vector, mask, NULL);
+
   memset (&tmp, 0, sizeof (tmp));
   tmp.dtype = 0;
   tmp.data = field;
@@ -551,6 +585,9 @@ unpack0_char4 (gfc_array_char *ret,
 {
   gfc_array_char tmp;
 
+  if (unlikely(compile_options.bounds_check))
+    unpack_bounds (ret, vector, mask, NULL);
+
   memset (&tmp, 0, sizeof (tmp));
   tmp.dtype = 0;
   tmp.data = field;