+2009-06-04 Daniel Franke <franke.daniel@gmail.com>
+
+ PR fortran/37203
+ * check.c (gfc_check_reshape): Additional checks for the
+ SHAPE and ORDER arguments.
+ * simplify.c (gfc_simplify_reshape): Converted argument checks
+ to asserts.
+
2009-06-03 Tobias Burnus <burnus@net-b.de>
* gfortran.texi: Add mixed-language programming, mention
{
mpz_t size;
mpz_t nelems;
- int m;
+ int shape_size;
if (array_check (source, 0) == FAILURE)
return FAILURE;
return FAILURE;
}
- m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
+ shape_size = mpz_get_ui (size);
mpz_clear (size);
- if (m > 0)
+ if (shape_size <= 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &shape->where);
+ return FAILURE;
+ }
+ else if (shape_size > GFC_MAX_DIMENSIONS)
{
gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
return FAILURE;
}
+ else if (shape->expr_type == EXPR_ARRAY)
+ {
+ gfc_expr *e;
+ int i, extent;
+ for (i = 0; i < shape_size; ++i)
+ {
+ e = gfc_get_array_element (shape, i);
+ if (e->expr_type != EXPR_CONSTANT)
+ {
+ gfc_free_expr (e);
+ continue;
+ }
+
+ gfc_extract_int (e, &extent);
+ if (extent < 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "negative element (%d)", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &e->where, extent);
+ return FAILURE;
+ }
+
+ gfc_free_expr (e);
+ }
+ }
if (pad != NULL)
{
if (same_type_check (source, 0, pad, 2) == FAILURE)
return FAILURE;
+
if (array_check (pad, 2) == FAILURE)
return FAILURE;
}
- if (order != NULL && array_check (order, 3) == FAILURE)
- return FAILURE;
+ if (order != NULL)
+ {
+ if (array_check (order, 3) == FAILURE)
+ return FAILURE;
+
+ if (type_check (order, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (order->expr_type == EXPR_ARRAY)
+ {
+ int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+ perm[i] = 0;
+
+ gfc_array_size (order, &size);
+ order_size = mpz_get_ui (size);
+ mpz_clear (size);
+
+ if (order_size != shape_size)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "has wrong number of elements (%d/%d)",
+ gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &order->where,
+ order_size, shape_size);
+ return FAILURE;
+ }
+
+ for (i = 1; i <= order_size; ++i)
+ {
+ e = gfc_get_array_element (order, i-1);
+ if (e->expr_type != EXPR_CONSTANT)
+ {
+ gfc_free_expr (e);
+ continue;
+ }
+
+ gfc_extract_int (e, &dim);
+
+ if (dim < 1 || dim > order_size)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "has out-of-range dimension (%d)",
+ gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &e->where, dim);
+ return FAILURE;
+ }
+
+ if (perm[dim-1] != 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid permutation of dimensions (dimension "
+ "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &e->where, dim);
+ return FAILURE;
+ }
+
+ perm[dim-1] = 1;
+ gfc_free_expr (e);
+ }
+ }
+ }
if (pad == NULL && shape->expr_type == EXPR_ARRAY
&& gfc_is_constant_expr (shape)
gfc_expr *e;
/* Check that argument expression types are OK. */
- if (!is_constant_array_expr (source))
- return NULL;
-
- if (!is_constant_array_expr (shape_exp))
- return NULL;
-
- if (!is_constant_array_expr (pad))
- return NULL;
-
- if (!is_constant_array_expr (order_exp))
+ if (!is_constant_array_expr (source)
+ || !is_constant_array_expr (shape_exp)
+ || !is_constant_array_expr (pad)
+ || !is_constant_array_expr (order_exp))
return NULL;
/* Proceed with simplification, unpacking the array. */
if (e == NULL)
break;
- if (gfc_extract_int (e, &shape[rank]) != NULL)
- {
- gfc_error ("Integer too large in shape specification at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
+ gfc_extract_int (e, &shape[rank]);
- if (rank >= GFC_MAX_DIMENSIONS)
- {
- gfc_error ("Too many dimensions in shape specification for RESHAPE "
- "at %L", &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
-
- if (shape[rank] < 0)
- {
- gfc_error ("Shape specification at %L cannot be negative",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
+ gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
+ gcc_assert (shape[rank] >= 0);
gfc_free_expr (e);
rank++;
}
- if (rank == 0)
- {
- gfc_error ("Shape specification at %L cannot be the null array",
- &shape_exp->where);
- goto bad_reshape;
- }
+ gcc_assert (rank > 0);
/* Now unpack the order array if present. */
if (order_exp == NULL)
for (i = 0; i < rank; i++)
{
e = gfc_get_array_element (order_exp, i);
- if (e == NULL)
- {
- gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
- "size as SHAPE parameter", &order_exp->where);
- goto bad_reshape;
- }
-
- if (gfc_extract_int (e, &order[i]) != NULL)
- {
- gfc_error ("Error in ORDER parameter of RESHAPE at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
-
- if (order[i] < 1 || order[i] > rank)
- {
- gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
-
- order[i]--;
-
- if (x[order[i]])
- {
- gfc_error ("Invalid permutation in ORDER parameter at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
+ gcc_assert (e);
+ gfc_extract_int (e, &order[i]);
gfc_free_expr (e);
+ gcc_assert (order[i] >= 1 && order[i] <= rank);
+ order[i]--;
+ gcc_assert (x[order[i]] == 0);
x[order[i]] = 1;
}
}
e = gfc_get_array_element (source, j);
else
{
- j = j - nsource;
-
- if (npad == 0)
- {
- gfc_error ("PAD parameter required for short SOURCE parameter "
- "at %L", &source->where);
- goto bad_reshape;
- }
+ gcc_assert (npad > 0);
+ j = j - nsource;
j = j % npad;
e = gfc_get_array_element (pad, j);
}
+ gcc_assert (e);
if (head == NULL)
head = tail = gfc_get_constructor ();
tail = tail->next;
}
- if (e == NULL)
- goto bad_reshape;
-
tail->where = e->where;
tail->expr = e;
e->rank = rank;
return e;
-
-bad_reshape:
- gfc_free_constructor (head);
- mpz_clear (index);
- return &gfc_bad_expr;
}
+2009-06-04 Daniel Franke <franke.daniel@gmail.com>
+
+ PR fortran/37203
+ * gfortran.dg/reshape_order_5.f90: New.
+ * gfortran.dg/reshape_shape_1.f90: New.
+
2009-06-04 Jason Merrill <jason@redhat.com>
* g++.dg/template/error38.C: Add pointer-to-typedef case.
--- /dev/null
+! { dg-do "compile" }
+!
+! PR fortran/37203 - check RESHAPE arguments
+!
+
+ integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /)
+ integer, dimension(2) :: shape1 = (/ 2, 5/)
+ integer, dimension(2) :: pad1 = (/ 0, 0/)
+ integer, dimension(2) :: t(2,5)
+
+ t = reshape(source1, shape1, pad1, (/2, 1/)) ! ok
+ t = reshape(source1, shape1, pad1, (/2.1, 1.2/)) ! { dg-error "must be INTEGER" }
+ t = reshape(source1, shape1, pad1, (/2, 2/)) ! { dg-error "invalid permutation" }
+ t = reshape(source1, shape1, pad1, (/2, 3/)) ! { dg-error "out-of-range dimension" }
+ t = reshape(source1, shape1, pad1, (/2/)) ! { dg-error "wrong number of elements" }
+end
--- /dev/null
+! { dg-do "compile" }
+!
+! PR fortran/37203 - check RESHAPE arguments
+!
+
+ integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /)
+ integer, dimension(2) :: pad1 = (/ 0, 0/)
+ integer, dimension(2) :: t(2,5)
+ integer :: i
+
+ t = reshape(source1, SHAPE(0), pad1, (/2, 1/)) ! { dg-error "is empty" }
+ t = reshape(source1, (/(i,i=1,32)/), pad1, (/2, 1/)) ! { dg-error "has more than" }
+ t = reshape(source1, (/ 2, -5/), pad1, (/2, 1/)) ! { dg-error "negative element" }
+end
OSDN Git Service
