re PR fortran/36322 (ICE with PROCEDURE using a complicated interface)

2008-11-01  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36322
	PR fortran/36463
	* gfortran.h: New function gfc_expr_replace_symbols.
	* decl.c (match_procedure_decl): Increase reference count for interface.
	* expr.c: New functions replace_symbol and gfc_expr_replace_symbols.
	* resolve.c (resolve_symbol): Correctly copy array spec and char len
	of PROCEDURE declarations from their interface.
	* symbol.c (gfc_get_default_type): Enhanced error message.
	(copy_formal_args): Call copy_formal_args recursively for arguments.
	* trans-expr.c (gfc_conv_function_call): Bugfix.


2008-11-01  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36322
	PR fortran/36463
	* gfortran.dg/proc_decl_17.f90: New.
	* gfortran.dg/proc_decl_18.f90: New.

From-SVN: r141515

7 files changed, 63 insertions, 4 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8f0e58d..f4f82e2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2008-11-01  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36322
+	PR fortran/36463
+	* gfortran.h: New function gfc_expr_replace_symbols.
+	* decl.c (match_procedure_decl): Increase reference count for interface.
+	* expr.c: New functions replace_symbol and gfc_expr_replace_symbols.
+	* resolve.c (resolve_symbol): Correctly copy array spec and char len
+	of PROCEDURE declarations from their interface.
+	* symbol.c (gfc_get_default_type): Enhanced error message.
+	(copy_formal_args): Call copy_formal_args recursively for arguments.
+	* trans-expr.c (gfc_conv_function_call): Bugfix.
+
 2008-11-01  Dennis Wassel  <dennis.wassel@gmail.com>
 
 	PR fortran/37159
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 370ac10..fe044c7 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4125,6 +4125,7 @@ match_procedure_decl (void)
   /* Various interface checks.  */
   if (proc_if)
     {
+      proc_if->refs++;
       /* Resolve interface if possible. That way, attr.procedure is only set
 	 if it is declared by a later procedure-declaration-stmt, which is
 	 invalid per C1212.  */
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 1a5e6db..2cebb65 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3502,3 +3502,28 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
 
   return error_found ? FAILURE : SUCCESS;
 }
+
+/* Walk an expression tree and replace all symbols with a corresponding symbol
+   in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
+   statements. The boolean return value is required by gfc_traverse_expr.  */
+
+static bool
+replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+  if ((expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)
+      && expr->symtree->n.sym->ns != sym->formal_ns
+      && expr->symtree->n.sym->attr.dummy)
+    {
+      gfc_symtree *stree;
+      gfc_get_sym_tree (expr->symtree->name, sym->formal_ns, &stree);
+      stree->n.sym->attr.referenced = expr->symtree->n.sym->attr.referenced;
+      expr->symtree = stree;
+    }
+  return false;
+}
+
+void
+gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
+{
+  gfc_traverse_expr (expr, dest, &replace_symbol, 0);
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 42f5516..d2c415a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2448,8 +2448,8 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
 			bool (*)(gfc_expr *, gfc_symbol *, int*),
 			int);
 void gfc_expr_set_symbols_referenced (gfc_expr *);
-
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
+void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
 
 /* st.c */
 extern gfc_code new_st;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3cd6899..bccb46a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8917,8 +8917,26 @@ resolve_symbol (gfc_symbol *sym)
 	  sym->attr.dimension = ifc->attr.dimension;
 	  sym->attr.recursive = ifc->attr.recursive;
 	  sym->attr.always_explicit = ifc->attr.always_explicit;
-	  sym->as = gfc_copy_array_spec (ifc->as);
 	  copy_formal_args (sym, ifc);
+	  /* Copy array spec.  */
+	  sym->as = gfc_copy_array_spec (ifc->as);
+	  if (sym->as)
+	    {
+	      int i;
+	      for (i = 0; i < sym->as->rank; i++)
+		{
+		  gfc_expr_replace_symbols (sym->as->lower[i], sym);
+		  gfc_expr_replace_symbols (sym->as->upper[i], sym);
+		}
+	    }
+	  /* Copy char length.  */
+	  if (ifc->ts.cl)
+	    {
+	      sym->ts.cl = gfc_get_charlen();
+	      sym->ts.cl->resolved = ifc->ts.cl->resolved;
+	      sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
+	      gfc_expr_replace_symbols (sym->ts.cl->length, sym);
+	    }
 	}
       else if (sym->ts.interface->name[0] != '\0')
 	{
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 42df574..bf66ac8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -219,7 +219,7 @@ gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
 			"implicitly typed variables");
 
   if (letter < 'a' || letter > 'z')
-    gfc_internal_error ("gfc_get_default_type(): Bad symbol");
+    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name);
 
   if (ns == NULL)
     ns = gfc_current_ns;
@@ -3790,6 +3790,7 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
       formal_arg->sym->attr = curr_arg->sym->attr;
       formal_arg->sym->ts = curr_arg->sym->ts;
       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+      copy_formal_args (formal_arg->sym, curr_arg->sym);
 
       /* If this isn't the first arg, set up the next ptr.  For the
         last arg built, the formal_arg->next will never get set to
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e0f2f77..1c14ac1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2716,7 +2716,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      && parmse.string_length == NULL_TREE
 	      && e->ts.type == BT_PROCEDURE
 	      && e->symtree->n.sym->ts.type == BT_CHARACTER
-	      && e->symtree->n.sym->ts.cl->length != NULL)
+	      && e->symtree->n.sym->ts.cl->length != NULL
+	      && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
 	    {
 	      gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
 	      parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;