re PR fortran/40873 (-fwhole-file -fwhole-program: Wrong decls cause too much to be optimized away)

2010-07-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40873
        * trans-decl.c (gfc_get_extern_function_decl): Fix generation
        for functions which are later in the same file.
        (gfc_create_function_decl, build_function_decl,
        build_entry_thunks): Add global argument.
        * trans.c (gfc_generate_module_code): Update
        gfc_create_function_decl call.
        * trans.h (gfc_create_function_decl): Update prototype.
        * resolve.c (resolve_global_procedure): Also resolve for
        IFSRC_IFBODY.

2010-07-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40873
        * gfortran.dg/whole_file_22.f90: New test.
        * gfortran.dg/whole_file_23.f90: New test.

From-SVN: r162557

8 files changed, 161 insertions, 23 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cd8e6e4..7700e0b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2010-07-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40873
+	* trans-decl.c (gfc_get_extern_function_decl): Fix generation
+	for functions which are later in the same file.
+	(gfc_create_function_decl, build_function_decl,
+	build_entry_thunks): Add global argument.
+	* trans.c (gfc_generate_module_code): Update
+	gfc_create_function_decl call.
+	* trans.h (gfc_create_function_decl): Update prototype.
+	* resolve.c (resolve_global_procedure): Also resolve for
+	IFSRC_IFBODY.
+
 2010-07-26  Richard Henderson  <rth@redhat.com>
 
 	PR target/44132
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fb9aadc..dab533d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1816,7 +1816,8 @@ 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
+	&& (sym->attr.if_source == IFSRC_UNKNOWN
+	    || sym->attr.if_source == IFSRC_IFBODY)
 	&& gsym->type != GSYM_UNKNOWN
 	&& gsym->ns
 	&& gsym->ns->resolved != -1
@@ -1902,7 +1903,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 		   sym->name, &sym->declared_at, gfc_typename (&sym->ts),
 		   gfc_typename (&def_sym->ts));
 
-      if (def_sym->formal)
+      if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
 	{
 	  gfc_formal_arglist *arg = def_sym->formal;
 	  for ( ; arg; arg = arg->next)
@@ -1969,14 +1970,19 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 		       where);
 
 	  /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
-	  if (def_sym->result->attr.pointer
-	      || def_sym->result->attr.allocatable)
+	  if ((def_sym->result->attr.pointer
+	       || def_sym->result->attr.allocatable)
+	       && (sym->attr.if_source != IFSRC_IFBODY
+		   || def_sym->result->attr.pointer
+			!= sym->result->attr.pointer
+		   || def_sym->result->attr.allocatable
+			!= sym->result->attr.allocatable))
 	    gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
 		       "result must have an explicit interface", sym->name,
 		       where);
 
 	  /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
-	  if (sym->ts.type == BT_CHARACTER
+	  if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
 	      && def_sym->ts.u.cl->length != NULL)
 	    {
 	      gfc_charlen *cl = sym->ts.u.cl;
@@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 	}
 
       /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
-      if (def_sym->attr.elemental)
+      if (def_sym->attr.elemental && !sym->attr.elemental)
 	{
 	  gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
 		     "interface", sym->name, &sym->declared_at);
 	}
 
       /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
-      if (def_sym->attr.is_bind_c)
+      if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
 	{
 	  gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
 		     "an explicit interface", sym->name, &sym->declared_at);
@@ -2010,7 +2016,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 	      && !(gfc_option.warn_std & GFC_STD_GNU)))
 	gfc_errors_to_warnings (1);
 
-      gfc_procedure_use (def_sym, actual, where);
+      if (sym->attr.if_source != IFSRC_IFBODY)  
+	gfc_procedure_use (def_sym, actual, where);
 
       gfc_errors_to_warnings (0);
     }
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4a3fcd8..5d6ea02 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1413,8 +1413,26 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
 	&& !sym->backend_decl
 	&& gsym && gsym->ns
 	&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
-	&& gsym->ns->proc_name->backend_decl)
+	&& (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
     {
+      if (!gsym->ns->proc_name->backend_decl)
+	{
+	  /* By construction, the external function cannot be
+	     a contained procedure.  */
+	  locus old_loc;
+	  tree save_fn_decl = current_function_decl;
+
+	  current_function_decl = NULL_TREE;
+	  gfc_get_backend_locus (&old_loc);
+	  push_cfun (cfun);
+
+	  gfc_create_function_decl (gsym->ns, true);
+
+	  pop_cfun ();
+	  gfc_set_backend_locus (&old_loc);
+	  current_function_decl = save_fn_decl;
+	}
+
       /* If the namespace has entries, the proc_name is the
 	 entry master.  Find the entry and use its backend_decl.
 	 otherwise, use the proc_name backend_decl.  */
@@ -1574,7 +1592,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
    a master function with alternate entry points.  */
 
 static void
-build_function_decl (gfc_symbol * sym)
+build_function_decl (gfc_symbol * sym, bool global)
 {
   tree fndecl, type, attributes;
   symbol_attribute attr;
@@ -1682,7 +1700,11 @@ build_function_decl (gfc_symbol * sym)
 
   /* Layout the function declaration and put it in the binding level
      of the current function.  */
-  pushdecl (fndecl);
+
+  if (global)
+    pushdecl_top_level (fndecl);
+  else
+    pushdecl (fndecl);
 
   sym->backend_decl = fndecl;
 }
@@ -1955,7 +1977,7 @@ trans_function_start (gfc_symbol * sym)
 /* Create thunks for alternate entry points.  */
 
 static void
-build_entry_thunks (gfc_namespace * ns)
+build_entry_thunks (gfc_namespace * ns, bool global)
 {
   gfc_formal_arglist *formal;
   gfc_formal_arglist *thunk_formal;
@@ -1977,7 +1999,7 @@ build_entry_thunks (gfc_namespace * ns)
 
       thunk_sym = el->sym;
       
-      build_function_decl (thunk_sym);
+      build_function_decl (thunk_sym, global);
       create_function_arglist (thunk_sym);
 
       trans_function_start (thunk_sym);
@@ -2137,17 +2159,18 @@ build_entry_thunks (gfc_namespace * ns)
 
 
 /* Create a decl for a function, and create any thunks for alternate entry
-   points.  */
+   points. If global is true, generate the function in the global binding
+   level, otherwise in the current binding level (which can be global).  */
 
 void
-gfc_create_function_decl (gfc_namespace * ns)
+gfc_create_function_decl (gfc_namespace * ns, bool global)
 {
   /* Create a declaration for the master function.  */
-  build_function_decl (ns->proc_name);
+  build_function_decl (ns->proc_name, global);
 
   /* Compile the entry thunks.  */
   if (ns->entries)
-    build_entry_thunks (ns);
+    build_entry_thunks (ns, global);
 
   /* Now create the read argument list.  */
   create_function_arglist (ns->proc_name);
@@ -3728,7 +3751,7 @@ gfc_generate_contained_functions (gfc_namespace * parent)
       if (ns->parent != parent)
 	continue;
 
-      gfc_create_function_decl (ns);
+      gfc_create_function_decl (ns, false);
     }
 
   for (ns = parent->contained; ns; ns = ns->sibling)
@@ -4364,7 +4387,7 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   /* Create the declaration for functions with global scope.  */
   if (!sym->backend_decl)
-    gfc_create_function_decl (ns);
+    gfc_create_function_decl (ns, false);
 
   fndecl = sym->backend_decl;
   old_context = current_function_decl;
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 003f609..4bd4f3b 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1388,7 +1388,7 @@ gfc_generate_module_code (gfc_namespace * ns)
       if (!n->proc_name)
         continue;
 
-      gfc_create_function_decl (n);
+      gfc_create_function_decl (n, false);
       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
       gfc_module_add_decl (entry, n->proc_name->backend_decl);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 9872e83..99f0dc0 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -449,7 +449,7 @@ void gfc_allocate_lang_decl (tree);
 tree gfc_advance_chain (tree, int);
 
 /* Create a decl for a function.  */
-void gfc_create_function_decl (gfc_namespace *);
+void gfc_create_function_decl (gfc_namespace *, bool);
 /* Generate the code for a function.  */
 void gfc_generate_function_code (gfc_namespace *);
 /* Output a BLOCK DATA program unit.  */
@@ -537,7 +537,7 @@ void gfc_process_block_locals (gfc_namespace*);
 /* Output initialization/clean-up code that was deferred.  */
 void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
 
-/* somewhere! */
+/* In f95-lang.c.  */
 tree pushdecl (tree);
 tree pushdecl_top_level (tree);
 void pushlevel (int);
@@ -545,6 +545,8 @@ tree poplevel (int, int, int);
 tree getdecls (void);
 tree gfc_truthvalue_conversion (tree);
 tree gfc_builtin_function (tree);
+
+/* In trans-types.c.  */
 struct array_descr_info;
 bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index de8eb35..9ce3878 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,4 +1,10 @@
-2010-07-19  Iain Sandoe  <iains@gcc.gnu.org>
+2010-07-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40873
+	* gfortran.dg/whole_file_22.f90: New test.
+	* gfortran.dg/whole_file_23.f90: New test.
+
+2010-07-26  Iain Sandoe  <iains@gcc.gnu.org>
 	    Jack Howarth  <howarth@bromo.med.uc.edu>
 	    Richard Henderson  <rth@redhat.com>
 
diff --git a/gcc/testsuite/gfortran.dg/whole_file_22.f90 b/gcc/testsuite/gfortran.dg/whole_file_22.f90
new file mode 100644
index 0000000..4e22920
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/whole_file_22.f90
@@ -0,0 +1,38 @@
+! { dg-do link }
+! { dg-options "-fwhole-program -O3 -g" }
+!
+! PR fortran/40873
+!
+      program prog
+        call one()
+        call two()
+        call test()
+      end program prog
+      subroutine one()
+        call three()
+      end subroutine one
+      subroutine two()
+        call three()
+      end subroutine two
+      subroutine three()
+      end subroutine three
+
+SUBROUTINE c()
+ CALL a()
+END SUBROUTINE c
+
+SUBROUTINE a()
+END SUBROUTINE a
+
+MODULE M
+CONTAINS
+ SUBROUTINE b()
+   CALL c()
+ END SUBROUTINE
+END MODULE
+
+subroutine test()
+USE M
+CALL b()
+END
+
diff --git a/gcc/testsuite/gfortran.dg/whole_file_23.f90 b/gcc/testsuite/gfortran.dg/whole_file_23.f90
new file mode 100644
index 0000000..c8f66e6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/whole_file_23.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+! 
+! PR fortran/40873
+!
+! Failed to compile (segfault) with -fwhole-file.
+! Cf. PR 40873 comment 24; test case taken from
+! PR fortran/31867 comment 6.
+!
+
+pure integer function lensum (words, sep)
+  character (len=*), intent(in)        :: words(:), sep
+  lensum = (size (words)-1) * len (sep) + sum (len_trim (words))
+end function
+
+module util_mod
+  implicit none
+  interface
+    pure integer function lensum (words, sep)
+      character (len=*), intent(in)        :: words(:), sep
+    end function
+  end interface
+  contains
+  function join (words, sep) result(str)
+! trim and concatenate a vector of character variables, 
+! inserting sep between them
+    character (len=*), intent(in)        :: words(:), sep
+    character (len=lensum (words, sep))  :: str
+    integer                              :: i, nw
+    nw  = size (words)
+    str = ""
+    if (nw < 1) then
+      return
+    else
+      str = words(1)
+    end if
+    do i=2,nw
+      str = trim (str) // sep // words(i)
+    end do
+  end function join
+end module util_mod
+!
+program xjoin
+  use util_mod, only: join
+  implicit none
+  character (len=5) :: words(2) = (/"two  ","three"/) 
+  write (*,"(1x,'words = ',a)") "'"//join (words, "&")//"'"
+end program xjoin
+
+! { dg-final { cleanup-modules "util_mod" } }