+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.
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
+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
#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,
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];
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);
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);
}
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));
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);
{
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;
{
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;
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);
}
}
}
+
+/* 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;
+}
OSDN Git Service
