From bfb708fdb6c313473a3054be710c630dcdebf69d Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sun, 21 May 2023 22:25:29 +0200
Subject: [PATCH] Fortran: checking and simplification of RESHAPE intrinsic
[PR103794]
gcc/fortran/ChangeLog:
PR fortran/103794
* check.cc (gfc_check_reshape): Expand constant arguments SHAPE and
ORDER before checking.
* gfortran.h (gfc_is_constant_array_expr): Add prototype.
* iresolve.cc (gfc_resolve_reshape): Expand constant argument SHAPE.
* simplify.cc (is_constant_array_expr): If array is determined to be
constant, expand small array constructors if needed.
(gfc_is_constant_array_expr): Wrapper for is_constant_array_expr.
(gfc_simplify_reshape): Fix check for insufficient elements in SOURCE
when no padding specified.
gcc/testsuite/ChangeLog:
PR fortran/103794
* gfortran.dg/reshape_10.f90: New test.
* gfortran.dg/reshape_11.f90: New test.
---
gcc/fortran/check.cc | 6 +++--
gcc/fortran/gfortran.h | 1 +
gcc/fortran/iresolve.cc | 2 +-
gcc/fortran/simplify.cc | 25 ++++++++++++++---
gcc/testsuite/gfortran.dg/reshape_10.f90 | 34 ++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/reshape_11.f90 | 15 +++++++++++
6 files changed, 77 insertions(+), 6 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/reshape_10.f90
create mode 100644 gcc/testsuite/gfortran.dg/reshape_11.f90
@@ -4723,7 +4723,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
}
gfc_simplify_expr (shape, 0);
- shape_is_const = gfc_is_constant_expr (shape);
+ shape_is_const = gfc_is_constant_array_expr (shape);
if (shape->expr_type == EXPR_ARRAY && shape_is_const)
{
@@ -4732,6 +4732,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
for (i = 0; i < shape_size; ++i)
{
e = gfc_constructor_lookup_expr (shape->value.constructor, i);
+ if (e == NULL)
+ break;
if (e->expr_type != EXPR_CONSTANT)
continue;
@@ -4764,7 +4766,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (!type_check (order, 3, BT_INTEGER))
return false;
- if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
+ if (order->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (order))
{
int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
gfc_expr *e;
@@ -3970,6 +3970,7 @@ bool gfc_fix_implicit_pure (gfc_namespace *);
void gfc_convert_mpz_to_signed (mpz_t, int);
gfc_expr *gfc_simplify_ieee_functions (gfc_expr *);
+bool gfc_is_constant_array_expr (gfc_expr *);
bool gfc_is_size_zero_array (gfc_expr *);
/* trans-array.cc */
@@ -2424,7 +2424,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
break;
}
- if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
+ if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
{
gfc_constructor *c;
f->shape = gfc_get_shape (f->rank);
@@ -254,12 +254,19 @@ is_constant_array_expr (gfc_expr *e)
break;
}
- /* Check and expand the constructor. */
- if (!array_OK && gfc_init_expr_flag && e->rank == 1)
+ /* Check and expand the constructor. We do this when either
+ gfc_init_expr_flag is set or for not too large array constructors. */
+ bool expand;
+ expand = (e->rank == 1
+ && e->shape
+ && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
+
+ if (!array_OK && (gfc_init_expr_flag || expand) && e->rank == 1)
{
+ bool saved_init_expr_flag = gfc_init_expr_flag;
array_OK = gfc_reduce_init_expr (e);
/* gfc_reduce_init_expr resets the flag. */
- gfc_init_expr_flag = true;
+ gfc_init_expr_flag = saved_init_expr_flag;
}
else
return array_OK;
@@ -284,6 +291,13 @@ is_constant_array_expr (gfc_expr *e)
return array_OK;
}
+bool
+gfc_is_constant_array_expr (gfc_expr *e)
+{
+ return is_constant_array_expr (e);
+}
+
+
/* Test for a size zero array. */
bool
gfc_is_size_zero_array (gfc_expr *array)
@@ -7001,6 +7015,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
if (npad <= 0)
{
mpz_clear (index);
+ if (pad == NULL)
+ gfc_error ("Without padding, there are not enough elements "
+ "in the intrinsic RESHAPE source at %L to match "
+ "the shape", &source->where);
+ gfc_free_expr (result);
return NULL;
}
j = j - nsource;
new file mode 100644
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fmax-array-constructor=65536 -fdump-tree-original" }
+! PR fortran/103794
+
+program p
+ integer :: i, j
+ integer, parameter :: a(2) = 2
+ integer, parameter :: e(*) = [(reshape([1,2,3,4], (a*i)), i=1,1)]
+ integer, parameter :: f(*,*) = reshape([1,2,3,4], [(a*i, i=1,1)])
+ integer, parameter :: g(*,*) = reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)])
+ integer, parameter :: s1(*) = &
+ shape(reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)]))
+ logical, parameter :: l1 = all (e == [1,2,3,4])
+ logical, parameter :: l2 = all (f == reshape([1,2,3,4],[2,2]))
+ logical, parameter :: l3 = size (s1) == 2 .and. all (s1 == 2)
+ logical, parameter :: l4 = all (f == g)
+ print *, e
+ print *, f
+ if (.not. l1) stop 1
+ if (.not. l2) stop 2
+ if (.not. l3) stop 3
+ if (.not. l4) stop 4
+ if (any (shape (reshape([1,2], [([2]*i, i=1,1)])) /= 2)) stop 5
+ ! The following is compile-time simplified due to shape():
+ print *, shape(reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)]))
+ if (any (shape(reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)])) /= 2)) stop 6
+ if (any (reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)]) /= f)) stop 7
+ ! The following is not compile-time simplified:
+ print *, reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)])
+ if (any (reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)]) /= f)) stop 8
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_reshape_4" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 1 "original" } }
new file mode 100644
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fmax-array-constructor=65536" }
+! PR fortran/103794
+
+program p
+ integer :: i, j
+ integer, parameter :: a(2) = 2, m = 20000
+ integer, parameter :: e(*) = &
+ [(reshape([1,2,3], (a*i)), i=1,1)] ! { dg-error "not enough elements" }
+ integer, parameter :: g(*,*) = &
+ reshape([([1,2,3,4],j=1,m)],[(a*i,i=1,1)]) ! { dg-error "number of elements" }
+ print *, reshape([([1,2,3,4],j=1,m)],[(a*i,i=1,1)])
+ print *, reshape([1,2,3], [(a*i, i=1,1)]) ! { dg-error "not enough elements" }
+ print *, [(reshape([1,2,3], (a*i)),i=1,1)] ! { dg-error "not enough elements" }
+end
--
2.35.3