re PR fortran/23446 (Valid internal subprogram array argument declaration is not accepted.)

2005-10-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23446
	* gfortran.h: Primitive for gfc_is_formal_arg.
	* resolve.c(gfc_is_formal_arg): New function to signal across
	several function calls that formal argument lists are being
	processed.
	(resolve_formal_arglist): Set/reset the flag for gfc_is_formal_arg.
	*expr.c(check_restricted): Add check, via gfc_is_formal_arg, if
	symbol is part of an formal argument declaration.

	PR fortran/21459
	* decl.c (add_init_expr_to_sym): Make a new character
	length for each variable, when the expression is NULL
	and link to cl_list.

	PR fortran/20866
	* match.c (recursive_stmt_fcn): New function that tests if
	a statement function resurses through itself or other other
	statement functions.
	(gfc_match_st_function): Call recursive_stmt_fcn to check
	if this is recursive and to raise error if so.

	PR fortran/20849
	PR fortran/20853
	* resolve.c (resolve_symbol): Errors for assumed size arrays
	with default initializer and for external objects with an
	initializer.

	PR fortran/20837
	* decl.c (match_attr_spec): Prevent PUBLIC from being used
	outside a module.

2005-10-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23446
	* gfortran.dg/host_dummy_index_1.f90: New test.

	PR fortran/21459
	gfortran.dg/automatic_char_len_2.f90: New test.

	PR fortran/20866
	gfortran.dg/recursive_statement_functions.f90: New test.

	PR fortran/20853
	gfortran.dg/assumed_size_dt_dummy.f90: New test.

	PR fortran/20849
	gfortran.dg/external_initializer.f90: New test.

	PR fortran/20837
	non_module_public.f90: New test.

From-SVN: r105518

1 files changed, 89 insertions, 0 deletions

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3f94874..eac5697 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2700,6 +2700,88 @@ cleanup:
   return MATCH_ERROR;
 }
 
+/* Check that a statement function is not recursive. This is done by looking
+   for the statement function symbol(sym) by looking recursively through its
+   expression(e).  If a reference to sym is found, true is returned.  */
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+{
+  gfc_actual_arglist *arg;
+  gfc_ref *ref;
+  int i;
+
+  if (e == NULL)
+    return false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+	{
+	  if (sym->name == arg->name
+		|| recursive_stmt_fcn (arg->expr, sym))
+	    return true;
+	}
+
+      /* Check the name before testing for nested recursion!  */
+      if (sym->name == e->symtree->n.sym->name)
+	return true;
+
+      /* Catch recursion via other statement functions.  */
+      if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
+	    && e->symtree->n.sym->value
+	    && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
+	return true;
+
+      break;
+
+    case EXPR_VARIABLE:
+      if (sym->name == e->symtree->n.sym->name)
+	return true;
+      break;
+
+    case EXPR_OP:
+      if (recursive_stmt_fcn (e->value.op.op1, sym)
+	    || recursive_stmt_fcn (e->value.op.op2, sym))
+	return true;
+      break;
+
+    default:
+      break;
+    }
+
+  /* Component references do not need to be checked.  */
+  if (e->ref)
+    {
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_ARRAY:
+	      for (i = 0; i < ref->u.ar.dimen; i++)
+		{
+		  if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
+			|| recursive_stmt_fcn (ref->u.ar.end[i], sym)
+			|| recursive_stmt_fcn (ref->u.ar.stride[i], sym))
+		    return true;
+		}
+	      break;
+
+	    case REF_SUBSTRING:
+	      if (recursive_stmt_fcn (ref->u.ss.start, sym)
+		    || recursive_stmt_fcn (ref->u.ss.end, sym))
+		return true;
+
+	      break;
+
+	    default:
+	      break;
+	    }
+	}
+    }
+  return false;
+}
+
 
 /* Match a statement function declaration.  It is so easy to match
    non-statement function statements with a MATCH_ERROR as opposed to
@@ -2734,6 +2816,13 @@ gfc_match_st_function (void)
   if (m == MATCH_ERROR)
     return m;
 
+  if (recursive_stmt_fcn (expr, sym))
+    {
+      gfc_error ("Statement function at %L is recursive",
+		 &expr->where);
+      return MATCH_ERROR;
+    }
+
   sym->value = expr;
 
   return MATCH_YES;