This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: {patch, fortran] PR37203: additional checks for RESHAPE
- From: Daniel Franke <franke dot daniel at gmail dot com>
- To: Mikael Morin <mikael dot morin at tele2 dot fr>
- Cc: gcc-patches at gcc dot gnu dot org, "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>
- Date: Tue, 6 Jan 2009 05:21:11 +0100
- Subject: Re: {patch, fortran] PR37203: additional checks for RESHAPE
- References: <200901042216.28919.franke.daniel@gmail.com> <496284C7.6080400@tele2.fr>
On Monday 05 January 2009 23:08:07 Mikael Morin wrote:
> > I think that the checks during simplification could be removed, but I
> > left them untouched for now.
>
> Hum, we will forget about it, so we should remove them now.
In attached patch, I turned all the checks during simplification into
equivalent asserts. If ever any of the asserts triggers, something is amiss in
gfc_check_reshape(). If neither catches an error and still the result of
reshape is wrong, then it's an untested case anyway.
Ok for 4.5, trunk or the to-be-created sandbox?
Regards
Daniel
Index: check.c
===================================================================
--- check.c (revision 143089)
+++ check.c (working copy)
@@ -2324,7 +2324,7 @@ gfc_check_reshape (gfc_expr *source, gfc
{
mpz_t size;
mpz_t nelems;
- int m;
+ int shape_size;
if (array_check (source, 0) == FAILURE)
return FAILURE;
@@ -2342,26 +2342,121 @@ gfc_check_reshape (gfc_expr *source, gfc
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)
Index: simplify.c
===================================================================
--- simplify.c (revision 143053)
+++ simplify.c (working copy)
@@ -3446,16 +3446,10 @@ gfc_simplify_reshape (gfc_expr *source,
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. */
@@ -3470,40 +3464,16 @@ gfc_simplify_reshape (gfc_expr *source,
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)
@@ -3519,42 +3489,15 @@ gfc_simplify_reshape (gfc_expr *source,
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);
- x[order[i]] = 1;
+ gcc_assert (order[i] >= 1 && order[i] <= rank);
+ gcc_assert (x[order[i-1]] == 0);
+
+ x[order[i-1]] = 1;
}
}
@@ -3601,18 +3544,13 @@ gfc_simplify_reshape (gfc_expr *source,
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 ();
@@ -3622,9 +3560,6 @@ gfc_simplify_reshape (gfc_expr *source,
tail = tail->next;
}
- if (e == NULL)
- goto bad_reshape;
-
tail->where = e->where;
tail->expr = e;
@@ -3656,11 +3591,6 @@ inc:
e->rank = rank;
return e;
-
-bad_reshape:
- gfc_free_constructor (head);
- mpz_clear (index);
- return &gfc_bad_expr;
}