re PR fortran/22571 (Reject derived types for dummy arguments declared in the subroutine unless they are SEQUENCE)

2009-03-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22571
	PR fortran/26227
	PR fortran/24886
	* symbol.c : Add gfc_global_ns_list.
	* decl.c (add_global_entry): Set the namespace ('ns') field.
	* gfortran.h : Add the resolved field to gfc_namespace. Add the
	namespace ('ns') field to gfc_gsymbol.  Add flag_whole_file to
	gfc_option_t.  Add the prototype for gfc_free_dt_list.
	* lang.opt : Add the whole-file option.
	* invoke.texi : Document the whole-file option.
	* resolve.c (resolve_global_procedure): If the fwhole-file
	option is set, reorder gsymbols to ensure that translation is
	in the right order.  Resolve the gsymbol's namespace if that
	has not occurred and then check interfaces.
	(resolve_function): Move call to resolve_global_procedure.
	(resolve_call): The same.
	(resolve_codes): Store the current labels_obstack.
	(gfc_resolve) : Return if the namespace is already resolved.
	trans-decl.c (gfc_get_extern_function_decl): If the whole_file
	option is selected, use the backend_decl of a gsymbol, if it is
	available.
	parse.c (add_global_procedure, add_global_program): If the flag
	whole-file is set, add the namespace to the gsymbol.
	(gfc_parse_file): On -fwhole-file, put procedure namespaces on
	the global namespace list.  Rearrange to do resolution of all
	the procedures in a file, followed by their translation.
	* options.c (gfc_init_options): Add -fwhole-file.
	(gfc_handle_option): The same.

2009-03-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22571
	* gfortran.dg/whole_file_1.f90: New test.
	PR fortran/26227
	* gfortran.dg/whole_file_2.f90: New test.
	* gfortran.dg/whole_file_3.f90: New test.
	PR fortran/24886
	* gfortran.dg/whole_file_4.f90: New test.

From-SVN: r145314

1 files changed, 53 insertions, 10 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b79e485..81d5ed8 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1582,12 +1582,19 @@ find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
    reference being resolved must correspond to the type of gsymbol.
    Otherwise, the new symbol is equipped with the attributes of the
    reference.  The corresponding code that is called in creating
-   global entities is parse.c.  */
+   global entities is parse.c.
+
+   In addition, for all but -std=legacy, the gsymbols are used to
+   check the interfaces of external procedures from the same file.
+   The namespace of the gsymbol is resolved and then, once this is
+   done the interface is checked.  */
 
 static void
-resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
+resolve_global_procedure (gfc_symbol *sym, locus *where,
+			  gfc_actual_arglist **actual, int sub)
 {
   gfc_gsymbol * gsym;
+  gfc_namespace *ns;
   unsigned int type;
 
   type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
@@ -1597,6 +1604,32 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
   if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
     gfc_global_used (gsym, where);
 
+  if (gfc_option.flag_whole_file
+	&& gsym->type != GSYM_UNKNOWN
+	&& gsym->ns
+	&& gsym->ns->proc_name
+	&& gsym->ns->proc_name->formal)
+    {
+      /* Make sure that translation for the gsymbol occurs before
+	 the procedure currently being resolved.  */
+      ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
+      for (; ns && ns != gsym->ns; ns = ns->sibling)
+	{
+	  if (ns->sibling == gsym->ns)
+	    {
+	      ns->sibling = gsym->ns->sibling;
+	      gsym->ns->sibling = gfc_global_ns_list;
+	      gfc_global_ns_list = gsym->ns;
+	      break;
+	    }
+	}
+
+      if (!gsym->ns->resolved)
+	gfc_resolve (gsym->ns);
+
+      gfc_procedure_use (gsym->ns->proc_name, actual, where);
+    }
+
   if (gsym->type == GSYM_UNKNOWN)
     {
       gsym->type = type;
@@ -2310,10 +2343,6 @@ resolve_function (gfc_expr *expr)
       return FAILURE;
     }
 
-  /* If the procedure is external, check for usage.  */
-  if (sym && is_external_proc (sym))
-    resolve_global_procedure (sym, &expr->where, 0);
-
   /* Switch off assumed size checking and do this again for certain kinds
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
@@ -2342,6 +2371,11 @@ resolve_function (gfc_expr *expr)
   /* Resume assumed_size checking.  */
   need_full_assumed_size--;
 
+  /* If the procedure is external, check for usage.  */
+  if (sym && is_external_proc (sym))
+    resolve_global_procedure (sym, &expr->where,
+			      &expr->value.function.actual, 0);
+
   if (sym && sym->ts.type == BT_CHARACTER
       && sym->ts.cl
       && sym->ts.cl->length == NULL
@@ -2931,10 +2965,6 @@ resolve_call (gfc_code *c)
 	}
     }
 
-  /* If external, check for usage.  */
-  if (csym && is_external_proc (csym))
-    resolve_global_procedure (csym, &c->loc, 1);
-
   /* Subroutines without the RECURSIVE attribution are not allowed to
    * call themselves.  */
   if (csym && is_illegal_recursion (csym, gfc_current_ns))
@@ -2965,6 +2995,10 @@ resolve_call (gfc_code *c)
   /* Resume assumed_size checking.  */
   need_full_assumed_size--;
 
+  /* If external, check for usage.  */
+  if (csym && is_external_proc (csym))
+    resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+
   t = SUCCESS;
   if (c->resolved_sym == NULL)
     {
@@ -10559,6 +10593,7 @@ static void
 resolve_codes (gfc_namespace *ns)
 {
   gfc_namespace *n;
+  bitmap_obstack old_obstack;
 
   for (n = ns->contained; n; n = n->sibling)
     resolve_codes (n);
@@ -10568,9 +10603,13 @@ resolve_codes (gfc_namespace *ns)
   /* Set to an out of range value.  */
   current_entry_id = -1;
 
+  old_obstack = labels_obstack;
   bitmap_obstack_initialize (&labels_obstack);
+
   resolve_code (ns->code, ns);
+
   bitmap_obstack_release (&labels_obstack);
+  labels_obstack = old_obstack;
 }
 
 
@@ -10585,10 +10624,14 @@ gfc_resolve (gfc_namespace *ns)
 {
   gfc_namespace *old_ns;
 
+  if (ns->resolved)
+    return;
+
   old_ns = gfc_current_ns;
 
   resolve_types (ns);
   resolve_codes (ns);
 
   gfc_current_ns = old_ns;
+  ns->resolved = 1;
 }