Fortran] PR 92996 – fix rank resolution EXPR_ARRAY

        PR fortran/92996
        gcc/fortran/
        * expr.c (simplify_parameter_variable): Call gfc_resolve_ref and
        gfc_expression_rank; fix location info.
        * gfortran.h (gfc_resolve_ref, gfc_expression_rank): Declare.
        * match.c (gfc_match_stopcode): Remove redundant setting of
        gfc_init_expr_flag; early return if gfc_simplify_expr has an error.
        * resolve.c (gfc_expression_rank): Renamed from expression_rank;
        minor cleanup.
        (gfc_resolve_ref): Removed static and renamed from resolve_ref.
        (resolve_variable, resolve_typebound_function,
        resolve_typebound_subroutine, resolve_ppc_call, resolve_expr_ppc,
        gfc_resolve_expr, resolve_procedure): Update calls.

        PR fortran/92996
        gcc/testsuite/
        * gfortran.dg/array_simplify_4.f90: New.
        * gfortran.dg/pr91565.f90: Update dg-error.
        * gfortran.dg/pr91801.f90: Likewise.

From-SVN: r279638

gcc/fortran/ChangeLog

 2019-12-20  Tobias Burnus  <tobias@codesourcery.com>
 
+	PR fortran/92996
+	* expr.c (simplify_parameter_variable): Call gfc_resolve_ref and
+	gfc_expression_rank; fix location info.
+	* gfortran.h (gfc_resolve_ref, gfc_expression_rank): Declare.
+	* match.c (gfc_match_stopcode): Remove redundant setting of
+	gfc_init_expr_flag; early return if gfc_simplify_expr has an error.
+	* resolve.c (gfc_expression_rank): Renamed from expression_rank;
+	minor cleanup.
+	(gfc_resolve_ref): Removed static and renamed from resolve_ref.
+	(resolve_variable, resolve_typebound_function,
+	resolve_typebound_subroutine, resolve_ppc_call, resolve_expr_ppc,
+	gfc_resolve_expr, resolve_procedure): Update calls.
+
+2019-12-20  Tobias Burnus  <tobias@codesourcery.com>
+
 	* openmp.c (resolve_omp_clauses): Move is-coindexed check from here ...
 	(gfc_match_omp_variable_list): ... to here.
 

gcc/fortran/expr.c

@@ -2044,6 +2044,15 @@ simplify_parameter_variable (gfc_expr *p, int type)
   gfc_expr *e;
   bool t;
 
+  /* Set rank and check array ref; as resolve_variable calls
+     gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead.  */
+  if (!gfc_resolve_ref (p))
+    {
+      gfc_error_check ();
+      return false;
+    }
+  gfc_expression_rank (p);
+
   if (gfc_is_size_zero_array (p))
     {
       if (p->expr_type == EXPR_ARRAY)
@@ -2073,6 +2082,7 @@ simplify_parameter_variable (gfc_expr *p, int type)
   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
     e->ref = gfc_copy_ref (p->ref);
   t = gfc_simplify_expr (e, type);
+  e->where = p->where;
 
   /* Only use the simplification if it eliminated all subobject references.  */
   if (t && !e->ref)

gcc/fortran/gfortran.h

@@ -3352,6 +3352,8 @@ void gfc_free_statements (gfc_code *);
 void gfc_free_association_list (gfc_association_list *);
 
 /* resolve.c */
+void gfc_expression_rank (gfc_expr *);
+bool gfc_resolve_ref (gfc_expr *);
 bool gfc_resolve_expr (gfc_expr *);
 void gfc_resolve (gfc_namespace *);
 void gfc_resolve_code (gfc_code *, gfc_namespace *);

gcc/fortran/match.c

@@ -3073,7 +3073,8 @@ gfc_match_stopcode (gfc_statement st)
 
   if (e != NULL)
     {
-      gfc_simplify_expr (e, 0);
+      if (!gfc_simplify_expr (e, 0))
+	goto cleanup;
 
       /* Test for F95 and F2003 style STOP stop-code.  */
       if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
@@ -3085,9 +3086,7 @@ gfc_match_stopcode (gfc_statement st)
 
       /* Use the machinery for an initialization expression to reduce the
 	 stop-code to a constant.  */
-      gfc_init_expr_flag = true;
       gfc_reduce_init_expr (e);
-      gfc_init_expr_flag = false;
 
       /* Test for F2008 style STOP stop-code.  */
       if (e->expr_type != EXPR_CONSTANT && f08)

gcc/fortran/resolve.c

@@ -5189,8 +5189,8 @@ gfc_resolve_substring_charlen (gfc_expr *e)
 
 /* Resolve subtype references.  */
 
-static bool
-resolve_ref (gfc_expr *expr)
+bool
+gfc_resolve_ref (gfc_expr *expr)
 {
   int current_part_dimension, n_components, seen_part_dimension;
   gfc_ref *ref, **prev;
@@ -5359,7 +5359,7 @@ fail:
    examining the base symbol and any reference structures it may have.  */
 
 void
-expression_rank (gfc_expr *e)
+gfc_expression_rank (gfc_expr *e)
 {
   gfc_ref *ref;
   int i, rank;
@@ -5374,14 +5374,8 @@ expression_rank (gfc_expr *e)
 	goto done;
       /* Constructors can have a rank different from one via RESHAPE().  */
 
-      if (e->symtree == NULL)
-	{
-	  e->rank = 0;
-	  goto done;
-	}
-
-      e->rank = (e->symtree->n.sym->as == NULL)
-		? 0 : e->symtree->n.sym->as->rank;
+      e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
+		 ? 0 : e->symtree->n.sym->as->rank);
       goto done;
     }
 
@@ -5406,7 +5400,7 @@ expression_rank (gfc_expr *e)
 	{
 	  /* Figure out the rank of the section.  */
 	  if (rank != 0)
-	    gfc_internal_error ("expression_rank(): Two array specs");
+	    gfc_internal_error ("gfc_expression_rank(): Two array specs");
 
 	  for (i = 0; i < ref->u.ar.dimen; i++)
 	    if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
@@ -5686,7 +5680,7 @@ resolve_variable (gfc_expr *e)
 	}
     }
 
-  if (e->ref && !resolve_ref (e))
+  if (e->ref && !gfc_resolve_ref (e))
     return false;
 
   if (sym->attr.flavor == FL_PROCEDURE
@@ -5848,7 +5842,7 @@ resolve_procedure:
     }
 
   if (t)
-    expression_rank (e);
+    gfc_expression_rank (e);
 
   if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
     add_caf_get_intrinsic (e);
@@ -6642,7 +6636,7 @@ resolve_typebound_function (gfc_expr* e)
   if (st == NULL)
     return resolve_compcall (e, NULL);
 
-  if (!resolve_ref (e))
+  if (!gfc_resolve_ref (e))
     return false;
 
   /* Get the CLASS declared type.  */
@@ -6775,7 +6769,7 @@ resolve_typebound_subroutine (gfc_code *code)
   if (st == NULL)
     return resolve_typebound_call (code, NULL, NULL);
 
-  if (!resolve_ref (code->expr1))
+  if (!gfc_resolve_ref (code->expr1))
     return false;
 
   /* Get the CLASS declared type.  */
@@ -6838,7 +6832,7 @@ resolve_ppc_call (gfc_code* c)
   if (!comp->attr.subroutine)
     gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
 
-  if (!resolve_ref (c->expr1))
+  if (!gfc_resolve_ref (c->expr1))
     return false;
 
   if (!update_ppc_arglist (c->expr1))
@@ -6881,7 +6875,7 @@ resolve_expr_ppc (gfc_expr* e)
   if (!comp->attr.function)
     gfc_add_function (&comp->attr, comp->name, &e->where);
 
-  if (!resolve_ref (e))
+  if (!gfc_resolve_ref (e))
     return false;
 
   if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
@@ -7011,7 +7005,7 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_SUBSTRING:
-      t = resolve_ref (e);
+      t = gfc_resolve_ref (e);
       break;
 
     case EXPR_CONSTANT:
@@ -7025,14 +7019,14 @@ gfc_resolve_expr (gfc_expr *e)
 
     case EXPR_ARRAY:
       t = false;
-      if (!resolve_ref (e))
+      if (!gfc_resolve_ref (e))
 	break;
 
       t = gfc_resolve_array_constructor (e);
       /* Also try to expand a constructor.  */
       if (t)
 	{
-	  expression_rank (e);
+	  gfc_expression_rank (e);
 	  if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
 	    gfc_expand_constructor (e, false);
 	}
@@ -7051,7 +7045,7 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_STRUCTURE:
-      t = resolve_ref (e);
+      t = gfc_resolve_ref (e);
       if (!t)
 	break;
 

gcc/testsuite/ChangeLog

 2019-12-20  Tobias Burnus  <tobias@codesourcery.com>
 
+	PR fortran/92996
+	* gfortran.dg/array_simplify_4.f90: New.
+	* gfortran.dg/pr91565.f90: Update dg-error.
+	* gfortran.dg/pr91801.f90: Likewise.
+
+2019-12-20  Tobias Burnus  <tobias@codesourcery.com>
+
 	* gfortran.dg/goacc/coindexed-1.f90: New.
 
 2019-12-20  Tobias Burnus  <tobias@codesourcery.com>

gcc/testsuite/gfortran.dg/array_simplify_4.f90

+! { dg-do compile }
+!
+! PR fortran/92996
+!
+! Contributed by G. Steinmetz
+!
+
+module m
+  integer, parameter :: d(2) = [0,0]
+end module m
+
+subroutine one
+use m
+print size([1,2],dim=d(1)) ! { dg-error "'dim' argument of 'size' intrinsic at .1. is not a valid dimension index" }
+end
+
+subroutine two
+complex, parameter :: x = 1
+
+stop x  ! { dg-error "STOP code at .1. must be either INTEGER or CHARACTER type" }
+end
+
+program p
+   integer, parameter :: a(2) = [1, 2]
+   stop a(1) ! OK
+   stop a ! { dg-error "STOP code at .1. must be scalar" }
+   stop a(1,1) ! { dg-error "Rank mismatch in array reference at .1. .2/1." }
+end

gcc/testsuite/gfortran.dg/pr91565.f90

@@ -2,16 +2,16 @@
 ! 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" }
+   integer, parameter :: a(2) = [2,2]
+   print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "ORDER at .1. is not a permutation of the size of SHAPE at .2." }
 end
 
 subroutine foo
-   integer, parameter :: a(1) = 1                  ! { dg-error "\(1\)" }
+   integer, parameter :: a(1) = 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\)" }
+   integer, parameter :: a(1,2) = 1
    print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" }
 end

gcc/testsuite/gfortran.dg/pr91801.f90

@@ -2,6 +2,6 @@
 ! PR fortran/91801
 ! Code contributed by Gerhard Steinmetz
 program p
-   integer, parameter :: a(2) = [2,0]              ! { dg-error "Element with a value of" }
-   print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "for the RESHAPE intrinsic near" }
+   integer, parameter :: a(2) = [2,0]
+   print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "Element with a value of 0 in ORDER at .1. must be in the range .1, ..., 2. for the RESHAPE intrinsic near .2." }
 end