The attached ptch implements additional checks on the
ORDER dummy argument for the RESHAPE intrinsic function.
Built and regression tested on x86_64-*-freebsd. OK to
commit?
2019-08-27 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/91565
* simplify.c (gfc_simplify_reshape): Add additional checks of the
ORDER dummy argument.
2019-08-27 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/91565
* gfortran.dg/pr91565.f90: New test.
--
Steve
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 274961)
+++ gcc/fortran/simplify.c (working copy)
@@ -6495,7 +6503,14 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
+ /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
+ warning. */
+ tmp1 = warn_conversion;
+ tmp2 = warn_conversion_extra;
+ warn_conversion = warn_conversion_extra = 0;
result = gfc_convert_constant (e, BT_REAL, kind);
+ warn_conversion = tmp1;
+ warn_conversion_extra = tmp2;
if (result == &gfc_bad_expr)
return &gfc_bad_expr;
@@ -6668,6 +6683,9 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shap
mpz_init (index);
rank = 0;
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ x[i] = 0;
+
for (;;)
{
e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
@@ -6692,9 +6710,29 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shap
}
else
{
- for (i = 0; i < rank; i++)
- x[i] = 0;
+ mpz_t size;
+ int order_size, shape_size;
+ if (order_exp->rank != shape_exp->rank)
+ {
+ gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
+ &order_exp->where, &shape_exp->where);
+ return &gfc_bad_expr;
+ }
+
+ gfc_array_size (shape_exp, &size);
+ shape_size = mpz_get_ui (size);
+ mpz_clear (size);
+ gfc_array_size (order_exp, &size);
+ order_size = mpz_get_ui (size);
+ mpz_clear (size);
+ if (order_size != shape_size)
+ {
+ gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
+ &order_exp->where, &shape_exp->where);
+ return &gfc_bad_expr;
+ }
+
for (i = 0; i < rank; i++)
{
e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
@@ -6704,7 +6742,12 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shap
gcc_assert (order[i] >= 1 && order[i] <= rank);
order[i]--;
- gcc_assert (x[order[i]] == 0);
+ if (x[order[i]] != 0)
+ {
+ gfc_error ("ORDER at %L is not a permutation of the size of "
+ "SHAPE at %L", &order_exp->where, &shape_exp->where);
+ return &gfc_bad_expr;
+ }
x[order[i]] = 1;
}
}
Index: gcc/testsuite/gfortran.dg/pr91565.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr91565.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr91565.f90 (working copy)
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! PR fortran/91565
+! Contributed by Gerhard Steinmetz
+program p
+ integer, parameter :: a(2) = [2,2] ! { dg-error "\(1\)" }
+ print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "not a permutation" }
+end
+
+subroutine foo
+ integer, parameter :: a(1) = 1 ! { dg-error "\(1\)" }
+ print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" }
+end
+
+subroutine bar
+ integer, parameter :: a(1,2) = 1 ! { dg-error "\(1\)" }
+ print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" }
+end
