re PR fortran/23091 (ICE in gfc_trans_auto_array_allocation)

2006-06-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23091
	* resolve.c (resolve_fl_variable): Error if an automatic
	object has the SAVE attribute.

	PR fortran/24168
	* expr.c (simplify_intrinsic_op): Transfer the rank and
	the locus to the simplified expression.

	PR fortran/25090
	PR fortran/25058
	* gfortran.h : Add int entry_id to gfc_symbol.
	* resolve.c : Add static variables current_entry_id and
	specification_expr.
	(resolve_variable): During code resolution, check if a
	reference to a dummy variable in an executable expression
	is preceded by its appearance as a parameter in an entry.
	Likewise check its specification expressions.
	(resolve_code): Update current_entry_id on EXEC_ENTRY.
	(resolve_charlen, resolve_fl_variable): Set and reset
	specifiaction_expr.
	(is_non_constant_shape_array): Do not return on detection
	of a variable but continue to resolve all the expressions.
	(resolve_codes): set current_entry_id to an out of range
	value.

2006-06-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23091
	* gfortran.dg/saved_automatic_1.f90: New test.

	PR fortran/24168
	* gfortran.dg/array_simplify_1.f90: New test.

	PR fortran/25090
	* gfortran.dg/entry_dummy_ref_1.f90: New test.

	PR fortran/25058
	* gfortran.dg/entry_dummy_ref_2.f90: New test.

From-SVN: r114461

9 files changed, 243 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a2cd96e..23e50d1 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+2006-06-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23091
+	* resolve.c (resolve_fl_variable): Error if an automatic
+	object has the SAVE attribute.
+
+	PR fortran/24168
+	* expr.c (simplify_intrinsic_op): Transfer the rank and
+	the locus to the simplified expression.
+
+	PR fortran/25090
+	PR fortran/25058
+	* gfortran.h : Add int entry_id to gfc_symbol.
+	* resolve.c : Add static variables current_entry_id and
+	specification_expr.
+	(resolve_variable): During code resolution, check if a
+	reference to a dummy variable in an executable expression
+	is preceded by its appearance as a parameter in an entry.
+	Likewise check its specification expressions.
+	(resolve_code): Update current_entry_id on EXEC_ENTRY.
+	(resolve_charlen, resolve_fl_variable): Set and reset
+	specifiaction_expr.
+	(is_non_constant_shape_array): Do not return on detection
+	of a variable but continue to resolve all the expressions.
+	(resolve_codes): set current_entry_id to an out of range
+	value.
+
 2006-06-06  Mike Stump  <mrs@apple.com>
 
 	* Make-lang.in: Rename to htmldir to build_htmldir to avoid
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 84dcf68..a163151 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -869,6 +869,8 @@ simplify_intrinsic_op (gfc_expr * p, int type)
       return FAILURE;
     }
 
+  result->rank = p->rank;
+  result->where = p->where;
   gfc_replace_expr (p, result);
 
   return SUCCESS;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d5b3411..6cfd934 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -838,6 +838,8 @@ typedef struct gfc_symbol
      order.  */
   int dummy_order;
 
+  int entry_id;
+
   gfc_namelist *namelist, *namelist_tail;
 
   /* Change management fields.  Symbols that might be modified by the
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8e54d3c..33e21df 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -60,6 +60,12 @@ static int omp_workshare_flag;
    resets the flag each time that it is read.  */
 static int formal_arg_flag = 0;
 
+/* True if we are resolving a specification expression.  */
+static int specification_expr = 0;
+
+/* The id of the last entry seen.  */
+static int current_entry_id;
+
 int
 gfc_is_formal_arg (void)
 {
@@ -2763,6 +2769,9 @@ static try
 resolve_variable (gfc_expr * e)
 {
   gfc_symbol *sym;
+  try t;
+
+  t = SUCCESS;
 
   if (e->ref && resolve_ref (e) == FAILURE)
     return FAILURE;
@@ -2790,7 +2799,73 @@ resolve_variable (gfc_expr * e)
   if (check_assumed_size_reference (sym, e))
     return FAILURE;
 
-  return SUCCESS;
+  /* Deal with forward references to entries during resolve_code, to
+     satisfy, at least partially, 12.5.2.5.  */
+  if (gfc_current_ns->entries
+	&& current_entry_id == sym->entry_id
+	&& cs_base
+	&& cs_base->current
+	&& cs_base->current->op != EXEC_ENTRY)
+    {
+      gfc_entry_list *entry;
+      gfc_formal_arglist *formal;
+      int n;
+      bool seen;
+
+      /* If the symbol is a dummy...  */
+      if (sym->attr.dummy)
+	{
+	  entry = gfc_current_ns->entries;
+	  seen = false;
+
+	  /* ...test if the symbol is a parameter of previous entries.  */
+	  for (; entry && entry->id <= current_entry_id; entry = entry->next)
+	    for (formal = entry->sym->formal; formal; formal = formal->next)
+	      {
+		if (formal->sym && sym->name == formal->sym->name)
+		  seen = true;
+	      }
+
+	  /*  If it has not been seen as a dummy, this is an error.  */
+	  if (!seen)
+	    {
+	      if (specification_expr)
+		gfc_error ("Variable '%s',used in a specification expression, "
+			   "is referenced at %L before the ENTRY statement "
+			   "in which it is a parameter",
+			   sym->name, &cs_base->current->loc);
+	      else
+		gfc_error ("Variable '%s' is used at %L before the ENTRY "
+			   "statement in which it is a parameter",
+			   sym->name, &cs_base->current->loc);
+	      t = FAILURE;
+	    }
+	}
+
+      /* Now do the same check on the specification expressions.  */
+      specification_expr = 1;
+      if (sym->ts.type == BT_CHARACTER
+	    && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
+	t = FAILURE;
+
+      if (sym->as)
+	for (n = 0; n < sym->as->rank; n++)
+	  {
+	     specification_expr = 1;
+	     if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
+	       t = FAILURE;
+	     specification_expr = 1;
+	     if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
+	       t = FAILURE;
+	  }
+      specification_expr = 0;
+
+      if (t == SUCCESS)
+	/* Update the symbol's entry level.  */
+	sym->entry_id = current_entry_id + 1;
+    }
+
+  return t;
 }
 
 
@@ -4490,7 +4565,11 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
 	case EXEC_EXIT:
 	case EXEC_CONTINUE:
 	case EXEC_DT_END:
+	  break;
+
 	case EXEC_ENTRY:
+	  /* Keep track of which entry we are up to.  */
+	  current_entry_id = code->ext.entry->id;
 	  break;
 
 	case EXEC_WHERE:
@@ -4769,7 +4848,6 @@ resolve_values (gfc_symbol * sym)
 static try
 resolve_index_expr (gfc_expr * e)
 {
-
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
@@ -4792,8 +4870,13 @@ resolve_charlen (gfc_charlen *cl)
 
   cl->resolved = 1;
 
+  specification_expr = 1;
+
   if (resolve_index_expr (cl->length) == FAILURE)
-    return FAILURE;
+    {
+      specification_expr = 0;
+      return FAILURE;
+    }
 
   return SUCCESS;
 }
@@ -4806,7 +4889,9 @@ is_non_constant_shape_array (gfc_symbol *sym)
 {
   gfc_expr *e;
   int i;
+  bool not_constant;
 
+  not_constant = false;
   if (sym->as != NULL)
     {
       /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
@@ -4817,15 +4902,15 @@ is_non_constant_shape_array (gfc_symbol *sym)
 	  e = sym->as->lower[i];
 	  if (e && (resolve_index_expr (e) == FAILURE
 		|| !gfc_is_constant_expr (e)))
-	    return true;
+	    not_constant = true;
 
 	  e = sym->as->upper[i];
 	  if (e && (resolve_index_expr (e) == FAILURE
 		|| !gfc_is_constant_expr (e)))
-	    return true;
+	    not_constant = true;
 	}
     }
-  return false;
+  return not_constant;
 }
 
 /* Resolution of common features of flavors variable and procedure. */
@@ -4877,22 +4962,34 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
   int i;
   gfc_expr *e;
   gfc_expr *constructor_expr;
+  const char * auto_save_msg;
+
+  auto_save_msg = "automatic object '%s' at %L cannot have the "
+		  "SAVE attribute";
 
   if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
     return FAILURE;
 
-  /* The shape of a main program or module array needs to be constant.  */
-  if (sym->ns->proc_name
-	&& (sym->ns->proc_name->attr.flavor == FL_MODULE
-	     || sym->ns->proc_name->attr.is_main_program)
-	&& !sym->attr.use_assoc
+  /* Set this flag to check that variables are parameters of all entries.
+     This check is effected by the call to gfc_resolve_expr through
+     is_non_constant_shape_array.  */
+  specification_expr = 1;
+
+  if (!sym->attr.use_assoc
 	&& !sym->attr.allocatable
 	&& !sym->attr.pointer
 	&& is_non_constant_shape_array (sym))
     {
-       gfc_error ("The module or main program array '%s' at %L must "
-		     "have constant shape", sym->name, &sym->declared_at);
-	  return FAILURE;
+	/* The shape of a main program or module array needs to be constant.  */
+	if (sym->ns->proc_name
+	      && (sym->ns->proc_name->attr.flavor == FL_MODULE
+		    || sym->ns->proc_name->attr.is_main_program))
+	  {
+	    gfc_error ("The module or main program array '%s' at %L must "
+		       "have constant shape", sym->name, &sym->declared_at);
+	    specification_expr = 0;
+	    return FAILURE;
+	  }
     }
 
   if (sym->ts.type == BT_CHARACTER)
@@ -4907,6 +5004,12 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	  return FAILURE;
 	}
 
+      if (e && sym->attr.save && !gfc_is_constant_expr (e))
+	{
+	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
       if (!gfc_is_constant_expr (e)
 	    && !(e->expr_type == EXPR_VARIABLE
 	    && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
@@ -4940,6 +5043,13 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	      break;
 	    }
 	}
+
+      /* Also, they must not have the SAVE attribute.  */
+      if (flag && sym->attr.save)
+	{
+	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
   }
 
   /* Reject illegal initializers.  */
@@ -6416,6 +6526,8 @@ resolve_codes (gfc_namespace * ns)
 
   gfc_current_ns = ns;
   cs_base = NULL;
+  /* Set to an out of range value.  */
+  current_entry_id = -1;
   resolve_code (ns->code, ns);
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0f42204..b93f912 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,17 @@
+2006-06-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23091
+	* gfortran.dg/saved_automatic_1.f90: New test.
+
+	PR fortran/24168
+	* gfortran.dg/array_simplify_1.f90: New test.
+
+	PR fortran/25090
+	* gfortran.dg/entry_dummy_ref_1.f90: New test.
+
+	PR fortran/25058
+	* gfortran.dg/entry_dummy_ref_2.f90: New test.
+
 2006-06-06  Mark Mitchell  <mark@codesourcery.com>
 
 	PR c++/27177
diff --git a/gcc/testsuite/gfortran.dg/array_simplify_1.f90 b/gcc/testsuite/gfortran.dg/array_simplify_1.f90
new file mode 100644
index 0000000..c638dee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_simplify_1.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! Tests the fix for PR24168, in which line   would return
+! Error: Incompatible ranks 2 and 1 in assignment at (1)
+! This came about because the simplification of the binary
+! operation, in the first actual argument of spread, was not
+! returning the rank of the result.  Thus the error could
+! be generated with any operator and other intrinsics than
+! cshift.
+!
+! Contributed by Steve Kargl  <kargl@gcc.gnu.org>
+!
+ integer, parameter :: nx=2, ny=2
+ real, dimension(nx, ny) :: f
+ f = spread(2 * cshift((/ 1, 2 /), nx/2), 2, ny)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90 b/gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90
new file mode 100644
index 0000000..8985b93
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Tests fix for PR25090 in which references in specification
+! expressions to variables that were not entry formal arguments
+! would be missed.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+   SUBROUTINE S1(I)
+   CHARACTER(LEN=I+J) :: a
+   real :: x(i:j), z
+   a = ""  ! { dg-error "before the ENTRY statement in which it is a parameter" }
+   x = 0.0 ! { dg-error "before the ENTRY statement in which it is a parameter" }
+   ENTRY E1(J)
+   END SUBROUTINE S1
+   END
diff --git a/gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90 b/gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90
new file mode 100644
index 0000000..46dbdf6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! Tests fix for PR25058 in which references to dummy
+! parameters before the entry would be missed.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+MODULE M1
+CONTAINS
+FUNCTION F1(I) RESULT(RF1)
+ INTEGER :: I,K,RE1,RF1
+ RE1=K ! { dg-error "before the ENTRY statement" }
+ RETURN
+ ENTRY E1(K) RESULT(RE1)
+ RE1=-I
+ RETURN
+END FUNCTION F1
+END  MODULE M1
+END
+
+! { dg-final { cleanup-modules "M1" } }
diff --git a/gcc/testsuite/gfortran.dg/saved_automatic_1.f90 b/gcc/testsuite/gfortran.dg/saved_automatic_1.f90
new file mode 100644
index 0000000..53e7dce
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/saved_automatic_1.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! Tests patch for PR23091, in which autmatic objects caused
+! an ICE if they were given the SAVE attribute.
+!
+! Contributed by Valera Veryazov  <valera.veryazov@teokem.lu.se>
+!
+Subroutine My(n1)
+  integer :: myArray(n1)
+  character(n1) :: ch
+  save      ! OK because only allowed objects are saved globally.
+  call xxx(myArray, ch)
+  return
+  end
+
+Subroutine Thy(n1)
+  integer, save :: myArray(n1) ! { dg-error "SAVE attribute" }
+  character(n1), save :: ch ! { dg-error "SAVE attribute" }
+  call xxx(myArray, ch)
+  return
+  end
+