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

8 files changed, 200 insertions, 9 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7cfcccd1752..702fb685ceb 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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.
+
 2009-08-25  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/slice7.adb: New test.
diff --git a/gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 b/gcc/testsuite/gfortran.dg/unpack_bounds_1.f90
new file mode 100755
index 00000000000..360790b5705
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unpack_bounds_1.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
+program main
+  integer, allocatable, dimension(:) :: vector
+  integer, allocatable, dimension(:,:) :: res
+  logical, allocatable, dimension(:,:) :: mask
+
+  allocate (vector(2))
+  allocate (mask(2,2))
+  allocate (res(2,1))
+
+  vector = 1
+  mask = reshape((/ .TRUE., .FALSE., .FALSE., .TRUE. /),(/2,2/))
+  res = unpack(vector, mask, 0)
+  print *,res
+end program main
+! { dg-output "Fortran runtime error: Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
diff --git a/gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 b/gcc/testsuite/gfortran.dg/unpack_bounds_2.f90
new file mode 100755
index 00000000000..fd049f5abbb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unpack_bounds_2.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" }
+program main
+  integer, allocatable, dimension(:) :: vector
+  integer, allocatable, dimension(:,:) :: res
+  logical, allocatable, dimension(:,:) :: mask
+
+  allocate (vector(2))
+  allocate (mask(2,2))
+  allocate (res(2,2))
+
+  vector = 1
+  mask = reshape((/ .TRUE., .TRUE., .FALSE., .TRUE. /),(/2,2/))
+  res = unpack(vector, mask, 0)
+  print *,res
+end program main
+! { dg-output "Fortran runtime error: Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" }
diff --git a/gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 b/gcc/testsuite/gfortran.dg/unpack_bounds_3.f90
new file mode 100755
index 00000000000..c6734b14c1f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unpack_bounds_3.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" }
+program main
+  integer, allocatable, dimension(:) :: vector
+  integer, allocatable, dimension(:,:) :: res
+  integer, allocatable, dimension(:,:) :: field
+  logical, allocatable, dimension(:,:) :: mask
+
+  allocate (vector(3))
+  allocate (mask(2,2))
+  allocate (res(2,2))
+  allocate (field(3,2))
+
+  vector = 1
+  field = 0
+  mask = reshape((/ .TRUE., .TRUE., .FALSE., .TRUE. /),(/2,2/))
+  res = unpack(vector, mask, field)
+  print *,res
+end program main
+! { dg-output "Fortran runtime error: Incorrect extent in FIELD of UNPACK intrinsic in dimension 1: is 3, should be 2" }
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index b1494ca0c50..8ef88c0d025 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,16 @@
+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-24  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/41157
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;
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 439c791fca2..40cb080a78c 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -1282,6 +1282,10 @@ extern void bounds_ifunction_return (array_t *, const index_type *,
 				     const char *, const char *);
 internal_proto(bounds_ifunction_return);
 
+extern index_type count_0 (const gfc_array_l1 *);
+
+internal_proto(count_0);
+
 /* Internal auxiliary functions for cshift */
 
 void cshift0_i1 (gfc_array_i1 *, const gfc_array_i1 *, ssize_t, int);
diff --git a/libgfortran/runtime/bounds.c b/libgfortran/runtime/bounds.c
index 8a7affd2e18..2d2ed76e6b8 100644
--- a/libgfortran/runtime/bounds.c
+++ b/libgfortran/runtime/bounds.c
@@ -197,3 +197,76 @@ bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name,
 	}
     }
 }
+
+/* count_0 - count all the true elements in an array.  The front
+   end usually inlines this, we need this for bounds checking
+   for unpack.  */
+
+index_type count_0 (const gfc_array_l1 * array)
+{
+  const GFC_LOGICAL_1 * restrict base;
+  index_type rank;
+  int kind;
+  int continue_loop;
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type sstride[GFC_MAX_DIMENSIONS];
+  index_type result;
+  index_type n;
+
+  rank = GFC_DESCRIPTOR_RANK (array);
+  kind = GFC_DESCRIPTOR_SIZE (array);
+
+  base = array->data;
+
+  if (kind == 1 || kind == 2 || kind == 4 || kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+      || kind == 16
+#endif
+    )
+    {
+      if (base)
+	base = GFOR_POINTER_TO_L1 (base, kind);
+    }
+  else
+    internal_error (NULL, "Funny sized logical array in count_0");
+
+  for (n = 0; n < rank; n++)
+    {
+      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
+      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+      count[n] = 0;
+
+      if (extent[n] < 0)
+	return 0;
+    }
+
+  result = 0;
+  continue_loop = 1;
+  while (continue_loop)
+    {
+      if (*base)
+	result ++;
+
+      count[0]++;
+      base += sstride[0];
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  base -= sstride[n] * extent[n];
+	  n++;
+	  if (n == rank)
+	    {
+	      continue_loop = 0;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      base += sstride[n];
+	    }
+	}
+    }
+  return result;
+}