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.

6 files changed, 77 insertions, 6 deletions

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 3dd1711..4086dc7 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -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;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9dd6b45..8cfa8fd 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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  */
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 7880aba..571e1bd 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.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);
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6ba2040..3f77203 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -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;
diff --git a/gcc/testsuite/gfortran.dg/reshape_10.f90 b/gcc/testsuite/gfortran.dg/reshape_10.f90
new file mode 100644
index 0000000..a148e0a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reshape_10.f90
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/reshape_11.f90 b/gcc/testsuite/gfortran.dg/reshape_11.f90
new file mode 100644
index 0000000..17c1406
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reshape_11.f90
@@ -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