re PR fortran/40011 (Problems with -fwhole-file)

2009-08-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40011
	* error.c : Add static flag 'warnings_not_errors'.
	(gfc_error): If 'warnings_not_errors' is set, branch to code
	from gfc_warning.
	(gfc_clear_error): Reset 'warnings_not_errors'.
	(gfc_errors_to_warnings): New function.
	* options.c (gfc_post_options): If pedantic and flag_whole_file
	change the latter to a value of 2.
	* parse.c (parse_module): Add module namespace to gsymbol.
	(resolve_all_program_units): New function.
	(clean_up_modules): New function.
	(translate_all_program_units): New function.
	(gfc_parse_file): If whole_file, do not clean up module right
	away and add derived types to namespace derived types. In
	addition, call the three new functions above.
	* resolve.c (not_in_recursive): New function.
	(not_entry_self_reference): New function.
	(resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN,
	procedure must not be in the course of being resolved and
	must return false for the two new functions. Pack away the
	current derived type list before calling gfc_resolve for the
	gsymbol namespace.  It is unconditionally an error if the ranks
	of the reference and ther procedure do not match. Convert
	errors to warnings during call to gfc_procedure_use if not
	pedantic or legacy.
	(gfc_resolve): Set namespace resolved flag to -1 during
	resolution and store current cs_base.
	* trans-decl.c (gfc_get_symbol_decl): If whole_file compilation
	substitute a use associated variable, if it is available in a
	gsymbolnamespace.
	(gfc_get_extern_function_decl): If the procedure is use assoc,
	do not attempt to find it in a gsymbol because it could be an
	interface. If the symbol exists in a module namespace, return
	its backend_decl.
	* trans-expr.c (gfc_trans_scalar_assign): If a derived type
	assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs.
	* trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a
	boolean argument. Copy component backend_decls directly if the
	components are derived types and from_gsym is true.
	(gfc_get_derived_type): If whole_file copy the derived type from
	the module if it is use associated, otherwise, if can be found
	in another gsymbol namespace, use the existing derived type as
	the TYPE_CANONICAL and build normally.
	* gfortran.h : Add derived_types and resolved fields to
	gfc_namespace. Include prototype for gfc_errors_to_warnings.

2009-08-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40011
	* gfortran.dg/whole_file_7.f90: New test.
	* gfortran.dg/whole_file_8.f90: New test.
	* gfortran.dg/whole_file_9.f90: New test.
	* gfortran.dg/whole_file_10.f90: New test.
	* gfortran.dg/whole_file_11.f90: New test.
	* gfortran.dg/whole_file_12.f90: New test.
	* gfortran.dg/whole_file_13.f90: New test.
	* gfortran.dg/whole_file_14.f90: New test.

From-SVN: r150333

gcc/fortran/ChangeLog

+2009-08-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40011
+	* error.c : Add static flag 'warnings_not_errors'.
+	(gfc_error): If 'warnings_not_errors' is set, branch to code
+	from gfc_warning.
+	(gfc_clear_error): Reset 'warnings_not_errors'.
+	(gfc_errors_to_warnings): New function.
+	* options.c (gfc_post_options): If pedantic and flag_whole_file
+	change the latter to a value of 2.
+	* parse.c (parse_module): Add module namespace to gsymbol.
+	(resolve_all_program_units): New function.
+	(clean_up_modules): New function.
+	(translate_all_program_units): New function.
+	(gfc_parse_file): If whole_file, do not clean up module right
+	away and add derived types to namespace derived types. In
+	addition, call the three new functions above.
+	* resolve.c (not_in_recursive): New function.
+	(not_entry_self_reference): New function.
+	(resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN,
+	procedure must not be in the course of being resolved and
+	must return false for the two new functions. Pack away the
+	current derived type list before calling gfc_resolve for the
+	gsymbol namespace.  It is unconditionally an error if the ranks
+	of the reference and ther procedure do not match. Convert
+	errors to warnings during call to gfc_procedure_use if not
+	pedantic or legacy.
+	(gfc_resolve): Set namespace resolved flag to -1 during
+	resolution and store current cs_base.
+	* trans-decl.c (gfc_get_symbol_decl): If whole_file compilation
+	substitute a use associated variable, if it is available in a
+	gsymbolnamespace.
+	(gfc_get_extern_function_decl): If the procedure is use assoc,
+	do not attempt to find it in a gsymbol because it could be an
+	interface. If the symbol exists in a module namespace, return
+	its backend_decl.
+	* trans-expr.c (gfc_trans_scalar_assign): If a derived type
+	assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs.
+	* trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a
+	boolean argument. Copy component backend_decls directly if the
+	components are derived types and from_gsym is true.
+	(gfc_get_derived_type): If whole_file copy the derived type from
+	the module if it is use associated, otherwise, if can be found
+	in another gsymbol namespace, use the existing derived type as
+	the TYPE_CANONICAL and build normally.
+	* gfortran.h : Add derived_types and resolved fields to
+	gfc_namespace. Include prototype for gfc_errors_to_warnings.
+
 2009-07-29  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40898

gcc/fortran/error.c

@@ -32,6 +32,8 @@ along with GCC; see the file COPYING3.  If not see
 
 static int suppress_errors = 0;
 
+static int warnings_not_errors = 0; 
+
 static int terminal_width, buffer_flag, errors, warnings;
 
 static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
@@ -863,6 +865,9 @@ gfc_error (const char *nocmsgid, ...)
 {
   va_list argp;
 
+  if (warnings_not_errors)
+    goto warning;
+
   if (suppress_errors)
     return;
 
@@ -878,6 +883,30 @@ gfc_error (const char *nocmsgid, ...)
 
   if (buffer_flag == 0)
     gfc_increment_error_count();
+
+  return;
+
+warning:
+
+  if (inhibit_warnings)
+    return;
+
+  warning_buffer.flag = 1;
+  warning_buffer.index = 0;
+  cur_error_buffer = &warning_buffer;
+
+  va_start (argp, nocmsgid);
+  error_print (_("Warning:"), _(nocmsgid), argp);
+  va_end (argp);
+
+  error_char ('\0');
+
+  if (buffer_flag == 0)
+  {
+    warnings++;
+    if (warnings_are_errors)
+      gfc_increment_error_count();
+  }
 }
 
 
@@ -955,6 +984,7 @@ void
 gfc_clear_error (void)
 {
   error_buffer.flag = 0;
+  warnings_not_errors = 0;
 }
 
 
@@ -1042,3 +1072,12 @@ gfc_get_errors (int *w, int *e)
   if (e != NULL)
     *e = errors;
 }
+
+
+/* Switch errors into warnings.  */
+
+void
+gfc_errors_to_warnings (int f)
+{
+  warnings_not_errors = (f == 1) ? 1 : 0;
+}

gcc/fortran/gfortran.h

@@ -1329,6 +1329,8 @@ typedef struct gfc_namespace
 
   gfc_charlen *cl_list, *old_cl_list;
 
+  gfc_dt_list *derived_types;
+
   int save_all, seen_save, seen_implicit_none;
 
   /* Normally we don't need to refcount namespaces.  However when we read
@@ -1350,6 +1352,9 @@ typedef struct gfc_namespace
 
   /* Set to 1 if resolved has been called for this namespace.  */
   int resolved;
+
+  /* Set to 1 if code has been generated for this namespace.  */
+  int translated;
 }
 gfc_namespace;
 
@@ -2288,6 +2293,7 @@ void gfc_pop_error (gfc_error_buf *);
 void gfc_free_error (gfc_error_buf *);
 
 void gfc_get_errors (int *, int *);
+void gfc_errors_to_warnings (int);
 
 /* arith.c */
 void gfc_arith_init_1 (void);

gcc/fortran/options.c

@@ -371,6 +371,9 @@ gfc_post_options (const char **pfilename)
       gfc_option.warn_tabs = 0;
     }
 
+  if (pedantic && gfc_option.flag_whole_file)
+    gfc_option.flag_whole_file = 2;
+
   gfc_cpp_post_options ();
 
 /* FIXME: return gfc_cpp_preprocess_only ();

gcc/fortran/parse.c

@@ -3760,6 +3760,8 @@ loop:
       st = next_statement ();
       goto loop;
     }
+
+  s->ns = gfc_current_ns;
 }
 
 
@@ -3809,6 +3811,76 @@ add_global_program (void)
 }
 
 
+/* Resolve all the program units when whole file scope option
+   is active. */
+static void
+resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+  gfc_free_dt_list ();
+  gfc_current_ns = gfc_global_ns_list;
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_resolve (gfc_current_ns);
+      gfc_current_ns->derived_types = gfc_derived_types;
+      gfc_derived_types = NULL;
+    }
+}
+
+
+static void
+clean_up_modules (gfc_gsymbol *gsym)
+{
+  if (gsym == NULL)
+    return;
+
+  clean_up_modules (gsym->left);
+  clean_up_modules (gsym->right);
+
+  if (gsym->type != GSYM_MODULE || !gsym->ns)
+    return;
+
+  gfc_current_ns = gsym->ns;
+  gfc_derived_types = gfc_current_ns->derived_types;
+  gfc_done_2 ();
+  gsym->ns = NULL;
+  return;
+}
+
+
+/* Translate all the program units when whole file scope option
+   is active. This could be in a different order to resolution if
+   there are forward references in the file.  */
+static void
+translate_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+  int errors;
+
+  gfc_current_ns = gfc_global_ns_list;
+  gfc_get_errors (NULL, &errors);
+
+  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_generate_code (gfc_current_ns);
+      gfc_current_ns->translated = 1;
+    }
+
+  /* Clean up all the namespaces after translation.  */
+  gfc_current_ns = gfc_global_ns_list;
+  for (;gfc_current_ns;)
+    {
+      gfc_namespace *ns = gfc_current_ns->sibling;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_done_2 ();
+      gfc_current_ns = ns;
+    }
+
+  clean_up_modules (gfc_gsym_root);
+}
+
+
 /* Top level parser.  */
 
 gfc_try
@@ -3933,15 +4005,24 @@ loop:
       gfc_dump_module (s.sym->name, errors_before == errors);
       if (errors == 0)
 	gfc_generate_module_code (gfc_current_ns);
+      pop_state ();
+      if (!gfc_option.flag_whole_file)
+	gfc_done_2 ();
+      else
+	{
+	  gfc_current_ns->derived_types = gfc_derived_types;
+	  gfc_derived_types = NULL;
+	  gfc_current_ns = NULL;
+	}
     }
   else
     {
       if (errors == 0)
 	gfc_generate_code (gfc_current_ns);
+      pop_state ();
+      gfc_done_2 ();
     }
 
-  pop_state ();
-  gfc_done_2 ();
   goto loop;
 
 prog_units:
@@ -3964,35 +4045,23 @@ prog_units:
   if (!gfc_option.flag_whole_file)
     goto termination;
 
-  /* Do the resolution.  */ 
-  gfc_current_ns = gfc_global_ns_list;
-  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
-    {
-      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
-      gfc_resolve (gfc_current_ns);
-    }
+  /* Do the resolution.  */
+  resolve_all_program_units (gfc_global_ns_list);
 
   /* Do the parse tree dump.  */ 
-  gfc_current_ns = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+  gfc_current_ns
+	= gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+
   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
     {
       gfc_dump_parse_tree (gfc_current_ns, stdout);
-      fputs ("-----------------------------------------\n\n", stdout);
+      fputs ("------------------------------------------\n\n", stdout);
     }
 
-  gfc_current_ns = gfc_global_ns_list;
-  gfc_get_errors (NULL, &errors);
-
-  /* Do the translation.  This could be in a different order to
-     resolution if there are forward references in the file.  */
-  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
-    {
-      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
-      gfc_generate_code (gfc_current_ns);
-    }
+  /* Do the translation.  */
+  translate_all_program_units (gfc_global_ns_list);
 
 termination:
-  gfc_free_dt_list ();
 
   gfc_end_source_files ();
   return SUCCESS;

gcc/fortran/resolve.c

@@ -1652,6 +1652,47 @@ find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
    The namespace of the gsymbol is resolved and then, once this is
    done the interface is checked.  */
 
+
+static bool
+not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+  if (!gsym_ns->proc_name->attr.recursive)
+    return true;
+
+  if (sym->ns == gsym_ns)
+    return false;
+
+  if (sym->ns->parent && sym->ns->parent == gsym_ns)
+    return false;
+
+  return true;
+}
+
+static bool
+not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+  if (gsym_ns->entries)
+    {
+      gfc_entry_list *entry = gsym_ns->entries;
+
+      for (; entry; entry = entry->next)
+	{
+	  if (strcmp (sym->name, entry->sym->name) == 0)
+	    {
+	      if (strcmp (gsym_ns->proc_name->name,
+			  sym->ns->proc_name->name) == 0)
+		return false;
+
+	      if (sym->ns->parent
+		  && strcmp (gsym_ns->proc_name->name,
+			     sym->ns->parent->proc_name->name) == 0)
+		return false;
+	    }
+	}
+    }
+  return true;
+}
+
 static void
 resolve_global_procedure (gfc_symbol *sym, locus *where,
 			  gfc_actual_arglist **actual, int sub)
@@ -1668,9 +1709,13 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
     gfc_global_used (gsym, where);
 
   if (gfc_option.flag_whole_file
+	&& sym->attr.if_source == IFSRC_UNKNOWN
 	&& gsym->type != GSYM_UNKNOWN
 	&& gsym->ns
-	&& gsym->ns->proc_name)
+	&& gsym->ns->resolved != -1
+	&& gsym->ns->proc_name
+	&& not_in_recursive (sym, gsym->ns)
+	&& not_entry_self_reference (sym, gsym->ns))
     {
       /* Make sure that translation for the gsymbol occurs before
 	 the procedure currently being resolved.  */
@@ -1687,9 +1732,41 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 	}
 
       if (!gsym->ns->resolved)
-	gfc_resolve (gsym->ns);
+	{
+	  gfc_dt_list *old_dt_list;
+
+	  /* Stash away derived types so that the backend_decls do not
+	     get mixed up.  */
+	  old_dt_list = gfc_derived_types;
+	  gfc_derived_types = NULL;
+
+	  gfc_resolve (gsym->ns);
+
+	  /* Store the new derived types with the global namespace.  */
+	  if (gfc_derived_types)
+	    gsym->ns->derived_types = gfc_derived_types;
+
+	  /* Restore the derived types of this namespace.  */
+	  gfc_derived_types = old_dt_list;
+	}
+
+      if (gsym->ns->proc_name->attr.function
+	    && gsym->ns->proc_name->as
+	    && gsym->ns->proc_name->as->rank
+	    && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
+	gfc_error ("The reference to function '%s' at %L either needs an "
+		   "explicit INTERFACE or the rank is incorrect", sym->name,
+		   where);
+
+      if (gfc_option.flag_whole_file == 1
+	    || ((gfc_option.warn_std & GFC_STD_LEGACY)
+		  &&
+	       !(gfc_option.warn_std & GFC_STD_GNU)))
+	gfc_errors_to_warnings (1);
 
       gfc_procedure_use (gsym->ns->proc_name, actual, where);
+
+      gfc_errors_to_warnings (0);
     }
 
   if (gsym->type == GSYM_UNKNOWN)
@@ -11134,15 +11211,19 @@ void
 gfc_resolve (gfc_namespace *ns)
 {
   gfc_namespace *old_ns;
+  code_stack *old_cs_base;
 
   if (ns->resolved)
     return;
 
+  ns->resolved = -1;
   old_ns = gfc_current_ns;
+  old_cs_base = cs_base;
 
   resolve_types (ns);
   resolve_codes (ns);
 
   gfc_current_ns = old_ns;
+  cs_base = old_cs_base;
   ns->resolved = 1;
 }

gcc/fortran/trans-decl.c

@@ -1098,6 +1098,32 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   if (sym->backend_decl)
     return sym->backend_decl;
 
+  /* If use associated and whole file compilation, use the module
+     declaration.  This is only needed for intrinsic types because
+     they are substituted for one another during optimization.  */
+  if (gfc_option.flag_whole_file
+	&& sym->attr.flavor == FL_VARIABLE
+	&& sym->ts.type != BT_DERIVED
+	&& sym->attr.use_assoc
+	&& sym->module)
+    {
+      gfc_gsymbol *gsym;
+
+      gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+      if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+	{
+	  gfc_symbol *s;
+	  s = NULL;
+	  gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+	  if (s && s->backend_decl)
+	    {
+	      if (sym->ts.type == BT_CHARACTER)
+		sym->ts.cl->backend_decl = s->ts.cl->backend_decl;
+	      return s->backend_decl;
+	    }
+	}
+    }
+
   /* Catch function declarations.  Only used for actual parameters and
      procedure pointers.  */
   if (sym->attr.flavor == FL_PROCEDURE)
@@ -1341,6 +1367,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
 
   if (gfc_option.flag_whole_file
+	&& !sym->attr.use_assoc
 	&& !sym->backend_decl
 	&& gsym && gsym->ns
 	&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
@@ -1371,6 +1398,26 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
 	return sym->backend_decl;
     }
 
+  /* See if this is a module procedure from the same file.  If so,
+     return the backend_decl.  */
+  if (sym->module)
+    gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+  if (gfc_option.flag_whole_file
+	&& gsym && gsym->ns
+	&& gsym->type == GSYM_MODULE)
+    {
+      gfc_symbol *s;
+
+      s = NULL;
+      gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+      if (s && s->backend_decl)
+	{
+	  sym->backend_decl = s->backend_decl;
+	  return sym->backend_decl;
+	}
+    }
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is

gcc/fortran/trans-expr.c

@@ -4436,8 +4436,24 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
 
+      /* TODO This is rather obviously the wrong place to do this.
+	 However, a number of testcases, such as function_kinds_1
+	 and function_types_2 fail without it, by ICEing at
+	 fold_const: 2710 (fold_convert_loc).  */
+      if (ts.type == BT_DERIVED
+	    && gfc_option.flag_whole_file
+	    && (TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr))
+		!= TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))))
+	{
+	  tmp = gfc_evaluate_now (rse->expr, &block);
+	  TYPE_MAIN_VARIANT (TREE_TYPE (tmp))
+		= TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr));
+	}
+      else
+	tmp = rse->expr;
+      
       gfc_add_modify (&block, lse->expr,
-			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
+			   fold_convert (TREE_TYPE (lse->expr), tmp));
     }
 
   gfc_add_block_to_block (&block, &lse->post);

gcc/fortran/trans-types.c

@@ -1853,7 +1853,8 @@ gfc_add_field_to_struct (tree *fieldlist, tree context,
    in 4.4.2 and resolved by gfc_compare_derived_types.  */
 
 static int
-copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
+		       bool from_gsym)
 {
   gfc_component *to_cm;
   gfc_component *from_cm;
@@ -1876,7 +1877,8 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
     {
       to_cm->backend_decl = from_cm->backend_decl;
-      if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED)
+      if ((!from_cm->attr.pointer || from_gsym)
+	      && from_cm->ts.type == BT_DERIVED)
 	gfc_get_derived_type (to_cm->ts.derived);
 
       else if (from_cm->ts.type == BT_CHARACTER)
@@ -1916,8 +1918,12 @@ static tree
 gfc_get_derived_type (gfc_symbol * derived)
 {
   tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
+  tree canonical = NULL_TREE;
+  bool got_canonical = false;
   gfc_component *c;
   gfc_dt_list *dt;
+  gfc_namespace *ns;
+  gfc_gsymbol *gsym;
 
   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
 
@@ -1949,7 +1955,59 @@ gfc_get_derived_type (gfc_symbol * derived)
       
       return derived->backend_decl;
     }
-  
+
+/* If use associated, use the module type for this one.  */
+  if (gfc_option.flag_whole_file
+	&& derived->backend_decl == NULL
+	&& derived->attr.use_assoc
+	&& derived->module)
+    {
+      gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
+      if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+	{
+	  gfc_symbol *s;
+	  s = NULL;
+	  gfc_find_symbol (derived->name, gsym->ns, 0, &s);
+	  if (s && s->backend_decl)
+	    {
+	      copy_dt_decls_ifequal (s, derived, true);
+	      goto copy_derived_types;
+	    }
+	}
+    }
+
+  /* If a whole file compilation, the derived types from an earlier
+     namespace can be used as the the canonical type.  */
+  if (gfc_option.flag_whole_file
+	&& derived->backend_decl == NULL
+	&& !derived->attr.use_assoc
+	&& gfc_global_ns_list)
+    {
+      for (ns = gfc_global_ns_list;
+	   ns->translated && !got_canonical;
+	   ns = ns->sibling)
+	{
+	  dt = ns->derived_types;
+	  for (; dt && !canonical; dt = dt->next)
+	    {
+	      copy_dt_decls_ifequal (dt->derived, derived, true);
+	      if (derived->backend_decl)
+		got_canonical = true;
+	    }
+	}
+    }
+
+  /* Store up the canonical type to be added to this one.  */
+  if (got_canonical)
+    {
+      if (TYPE_CANONICAL (derived->backend_decl))
+	canonical = TYPE_CANONICAL (derived->backend_decl);
+      else
+	canonical = derived->backend_decl;
+
+      derived->backend_decl = NULL_TREE;
+    }
+
   /* derived->backend_decl != 0 means we saw it before, but its
      components' backend_decl may have not been built.  */
   if (derived->backend_decl)
@@ -2065,6 +2123,7 @@ gfc_get_derived_type (gfc_symbol * derived)
   /* Now we have the final fieldlist.  Record it, then lay out the
      derived type, including the fields.  */
   TYPE_FIELDS (typenode) = fieldlist;
+  TYPE_CANONICAL (typenode) = canonical;
 
   gfc_finish_type (typenode);
   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
@@ -2083,9 +2142,10 @@ gfc_get_derived_type (gfc_symbol * derived)
 
   derived->backend_decl = typenode;
 
-  /* Add this backend_decl to all the other, equal derived types.  */
+copy_derived_types:
+
   for (dt = gfc_derived_types; dt; dt = dt->next)
-    copy_dt_decls_ifequal (derived, dt->derived);
+    copy_dt_decls_ifequal (derived, dt->derived, false);
 
   return derived->backend_decl;
 }

gcc/testsuite/ChangeLog

+2009-08-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40011
+	* gfortran.dg/whole_file_7.f90: New test.
+	* gfortran.dg/whole_file_8.f90: New test.
+	* gfortran.dg/whole_file_9.f90: New test.
+	* gfortran.dg/whole_file_10.f90: New test.
+	* gfortran.dg/whole_file_11.f90: New test.
+	* gfortran.dg/whole_file_12.f90: New test.
+	* gfortran.dg/whole_file_13.f90: New test.
+	* gfortran.dg/whole_file_14.f90: New test.
+
 2009-07-31  Jason Merrill  <jason@redhat.com>
 
 	* g++.dg/cpp0x/initlist22.C: Adjust for new rvalue reference

gcc/testsuite/gfortran.dg/whole_file_10.f90

+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the fifth problem in PR40011, where the
+! entries were not resolved, resulting in a segfault.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+recursive function fac(i) result (res)
+  integer :: i, j, k, res
+  k = 1
+  goto 100
+entry bifac(i,j) result (res)
+  k = j
+100 continue
+  if (i < k) then
+    res = 1
+  else
+    res = i * bifac(i-k,k)
+  end if
+end function
+
+program test
+  external fac
+  external bifac
+  integer :: fac, bifac
+  print *, fac(5)
+  print *, bifac(5,2)
+  print*, fac(6)
+  print *, bifac(6,2)
+  print*, fac(0)
+  print *, bifac(1,2)
+end program test

gcc/testsuite/gfortran.dg/whole_file_11.f90

+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+!
+! Tests the fix PR40011 comment 16 in which the derived type lists in
+! different program units were getting mixed up.
+!
+! Contributed by Daniel Franck  <dfranke@gcc.gnu.org>
+!
+MODULE module_foo
+  TYPE :: foo_node
+    TYPE(foo_node_private), POINTER :: p
+  END TYPE
+
+  TYPE :: foo_node_private
+    TYPE(foo_node), DIMENSION(-1:1) :: link
+  END TYPE
+
+  TYPE :: foo
+    TYPE(foo_node) :: root
+  END TYPE
+END MODULE
+
+FUNCTION foo_insert()
+  USE module_foo, ONLY: foo, foo_node
+
+  INTEGER :: foo_insert
+  TYPE(foo_node) :: parent, current
+  INTEGER :: cmp
+
+  parent  = current
+  current = current%p%link(cmp)
+END FUNCTION
+
+FUNCTION foo_count()
+  USE module_foo, ONLY: foo
+  INTEGER :: foo_count
+END FUNCTION

gcc/testsuite/gfortran.dg/whole_file_12.f90

+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+!
+! Tests the fix PR40011 comment 17 in which the explicit interface was
+! being ignored and the missing argument was not correctly handled, which
+! led to an ICE.
+!
+! Contributed by Dominique d'Humieres  <dominiq@lps.ens.fr
+!
+          Implicit None 
+          call sub(1,2) 
+          call sub(1,2,3)
+ 
+          contains
+
+          subroutine sub(i,j,k) 
+          Implicit None 
+          Integer, Intent( In )           :: i 
+          Integer, Intent( In )           :: j 
+          Integer, Intent( In ), Optional :: k 
+          intrinsic present 
+          write(*,*)' 3 presence flag ',present(k) 
+          write(*,*)' 1st arg ',i 
+          write(*,*)' 2nd arg ',j 
+          if (present(k)) then 
+            write(*,*)' 3rd arg ',k 
+          else 
+            write(*,*)' 3rd arg is absent' 
+          endif 
+          return 
+          end subroutine
+
+          end

gcc/testsuite/gfortran.dg/whole_file_13.f90

+! { dg-do run }
+! { dg-options "-fwhole-file -O3" }
+! Check that the TYPE_CANONICAL is being correctly set
+! for the derived types, when whole file compiling.
+! (based on import.f90)
+!
+subroutine test(x)
+  type myType3
+    sequence
+    integer :: i
+  end type myType3
+  type(myType3) :: x
+  if(x%i /= 7) call abort()
+  x%i = 1
+end subroutine test
+
+
+program foo
+  type myType3
+    sequence
+    integer :: i
+  end type myType3
+
+  type(myType3) :: z
+  z%i = 7
+  call test(z)
+  if(z%i /= 1) call abort
+end program foo

gcc/testsuite/gfortran.dg/whole_file_14.f90

+! { dg-do run }
+! { dg-options "-fwhole-file -O3" }
+! Check that the derived types are correctly substituted when
+! whole file compiling.
+!
+! Contributed by Dominique d'Humieres  <dominiq@lps.ens.fr
+!
+module global
+ type                                ::  mytype
+   type(mytype),pointer   ::  this
+ end type mytype
+ type(mytype),target        :: base
+end module global
+
+program test_equi
+  use global
+  call check()
+  print *, "base%this%this=>base?"  ,  associated(base%this%this,base)
+  print *, "base%this%this=>?" ,          associated(base%this%this)
+  print *, "base%this=>?" ,                   associated(base%this)
+contains
+  subroutine check()
+    type(mytype),target        :: j
+    base%this => j                      !have the variables point
+    j%this => base                      !to one another
+  end subroutine check                  !take j out of scope
+end program test_equi
+! { dg-final { cleanup-modules "global" } }

gcc/testsuite/gfortran.dg/whole_file_7.f90

+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fixes for the first two problems in PR40011
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+! This function would not compile because -fwhole-file would
+! try repeatedly to resolve the function because of the self
+! reference.
+RECURSIVE FUNCTION eval_args(q)  result (r)
+  INTEGER NNODE 
+  PARAMETER (NNODE  = 10) 
+  TYPE NODE 
+    SEQUENCE 
+    INTEGER car 
+    INTEGER cdr 
+  END TYPE NODE 
+  TYPE(NODE) heap(NNODE) 
+  INTEGER r, q 
+  r = eval_args(heap(q)%cdr) 
+END FUNCTION eval_args 
+
+function test(n)
+  real, dimension(2) :: test
+  integer            :: n
+  test = n
+  return
+end function test
+
+program arr     ! The error was not picked up causing an ICE
+  real, dimension(2) :: res
+  res = test(2) ! { dg-error "needs an explicit INTERFACE" }
+  print *, res
+end program

gcc/testsuite/gfortran.dg/whole_file_8.f90

+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the third problem in PR40011, where false
+! type/rank mismatches were found in the main program calls.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+subroutine test_d(fn, val, res)
+  double precision fn
+  double precision val, res
+
+  print *, fn(val), res
+end subroutine
+
+subroutine test_c(fn, val, res)
+  complex fn
+  complex val, res
+
+  print *, fn(val), res
+end subroutine
+
+program specifics
+
+  intrinsic dcos
+  intrinsic dcosh
+  intrinsic dexp
+
+  intrinsic conjg
+
+  call test_d (dcos, 1d0, dcos(1d0))
+  call test_d (dcosh, 1d0, dcosh(1d0))
+  call test_d (dexp, 1d0, dexp(1d0))
+
+  call test_c (conjg, (1.0,1.0) , conjg((1.0,1.0)))
+
+end program

gcc/testsuite/gfortran.dg/whole_file_9.f90

+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the fourth problem in PR40011, where the
+! entries were not resolved, resulting in a segfault.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+program test
+interface
+  function bad_stuff(n)
+    integer :: bad_stuff (2)
+    integer :: n(2)
+  end function bad_stuff
+   recursive function rec_stuff(n) result (tmp)
+    integer :: n(2), tmp(2)
+  end function rec_stuff
+end interface
+   integer :: res(2)
+  res = bad_stuff((/-19,-30/))
+
+end program test
+
+  recursive function bad_stuff(n)
+    integer :: bad_stuff (2)
+    integer :: n(2), tmp(2), ent = 0, sent = 0
+    save ent, sent
+    ent = -1
+   entry rec_stuff(n) result (tmp)
+    if (ent == -1) then
+      sent = ent
+      ent = 0
+    end if
+    ent = ent + 1
+    tmp = 1
+    if(maxval (n) < 5) then
+      tmp = tmp + rec_stuff (n+1)
+      ent = ent - 1
+    endif
+    if (ent == 1) then
+      if (sent == -1) then
+        bad_stuff = tmp + bad_stuff (1)
+      end if
+      ent = 0
+      sent = 0
+    end if
+  end function bad_stuff