Patchwork [Fortran] PR 40873 - -fwhole-program decl fixes

login
register
mail settings
Submitter Tobias Burnus
Date July 26, 2010, 8:32 p.m.
Message ID <4C4DF0D7.2020001@net-b.de>
Download mbox | patch
Permalink /patch/59948/
State New
Headers show

Comments

Tobias Burnus - July 26, 2010, 8:32 p.m.
Dear all,

the attached patch is rather obvious - after one has found the right spots.

a) If Fortran tried first to resolve "call proc()" and then only
generated the code for "subroutine proc()", two separate declarations
where created - thus the decl of "subroutine proc()" was never called --
and therefore, with -fwhole-program, "subroutine proc()" was optimized
away - causing linker errors.

The solution is simple: When obtaining the external decl, first generate
the decl for the real procedure - and place it at the global binding level.

b) gfortran did not properly resolve procedures if they were declared
with INTERFACE, causing crashes for assumed-shape dummies. For those,
one needs to change the dummy from AS_DEFERRED to AS_ASSUMED_SHAPE, but
this was not be done for the real global symbol. Well, as consequence,
one got an ICE in trans*.c when treating it as AS_DEFERRED array.

The solution was to also handle INTERFACE; afterwards, I had to adapt
(and to conditionally disable) some checks.


Build and and currently regtesting on x86-64-linux. If there is no failure:
OK for the trunk?

Tobias

PS: While now most of the -fwhole-file/-fwhole-program bugs are now
fixed, there are still a couple of ice-on-valid-code and wrong-code bugs
left to fix, e.g. PR 45087 (-fwhole-file issues of 2 polyhedron tests),
PR 44945 (no gsym created for symbols of external-file modules), PR
45077 (ICE).
Mikael Morin - July 26, 2010, 11:15 p.m.
Le 26.07.2010 22:32, Tobias Burnus a écrit :
> Dear all,
>
> the attached patch is rather obvious - after one has found the right spots.
>
> a) If Fortran tried first to resolve "call proc()" and then only
> generated the code for "subroutine proc()", two separate declarations
> where created - thus the decl of "subroutine proc()" was never called --
> and therefore, with -fwhole-program, "subroutine proc()" was optimized
> away - causing linker errors.
>
> The solution is simple: When obtaining the external decl, first generate
> the decl for the real procedure - and place it at the global binding level.
>
> b) gfortran did not properly resolve procedures if they were declared
> with INTERFACE, causing crashes for assumed-shape dummies. For those,
> one needs to change the dummy from AS_DEFERRED to AS_ASSUMED_SHAPE, but
> this was not be done for the real global symbol. Well, as consequence,
> one got an ICE in trans*.c when treating it as AS_DEFERRED array.
>
> The solution was to also handle INTERFACE; afterwards, I had to adapt
> (and to conditionally disable) some checks.
>
>
> Build and and currently regtesting on x86-64-linux. If there is no failure:
> OK for the trunk?
The extra expr.c hunk (pr45081 fix) which slipped through, is ok (and 
obvious).
The function decl changes are OK.
For the interface thing see below.

> Index: gcc/fortran/resolve.c
> ===================================================================
> --- gcc/fortran/resolve.c	(Revision 162542)
> +++ gcc/fortran/resolve.c	(Arbeitskopie)
> @@ -1816,7 +1816,8 @@ resolve_global_procedure (gfc_symbol *sy
>      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 *sy
>  		   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 *sy
>  		       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
The above makes sense, but the 4 following lines are odd.

If I understand it correctly if there is a function definition/interface 
mismatch (between pointer or allocatable attributes), we generate an 
error asking for explicit interface (even if the symbol comes from an 
interface block which _is_ an explicit interface).
Well, maybe it's better than nothing after all.
> +		   || def_sym->result->attr.pointer
> +			!= sym->result->attr.pointer)
There is an extra parenthesis here

> +		   || (def_sym->result->attr.allocatable
And another one here


> +			!= 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
This is going past the 80th character (OK, very minor ;) )

>  	      && def_sym->ts.u.cl->length != NULL)
>  	    {
>  	      gfc_charlen *cl = sym->ts.u.cl;
> @@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sy
>  	}
>
>        /* 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)
Same as above, I would put
if (def_sym->attr.elemental && sym->attr.if_source != IFSRC_IFBODY) like 
in the previous cases.
It is odd to guess interface explicitness out of symbol elementalness.

>  	{
>  	  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)
Same here.
>  	{
>  	  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 *sy
>  	      && !(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);
>      }

The comments above are about cases where procedure definitions don't 
match the corresponding interfaces, which makes them invalid.
As the previous status (without -fwhole-file) was not to check at all 
and the patch doesn't seem to error on valid testcases, OK if it passes 
the testsuite.
I may try to find testcases for my comments above tomorrow.

Mikael
Tobias Burnus - July 27, 2010, 5:54 a.m.
Mikael Morin wrote:
> Le 26.07.2010 22:32, Tobias Burnus a écrit :
>> Build and and currently regtesting on x86-64-linux. If there is no
>> failure:
>> OK for the trunk?
> The extra expr.c hunk (pr45081 fix) which slipped through, is ok (and
> obvious).
But regresses in terms of diagnostics - I will leave it out and have a
separate look later.

> For the interface thing see below.        /* 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
> The above makes sense, but the 4 following lines are odd.
>
> If I understand it correctly if there is a function
> definition/interface mismatch (between pointer or allocatable
> attributes), we generate an error asking for explicit interface (even
> if the symbol comes from an interface block which _is_ an explicit
> interface).
> Well, maybe it's better than nothing after all.

That was my idea - I think interface mismatches are rare enough that one
does not need to replicate all the messages - and the error might be
slightly odd, but should give a good hint.

>> +           || def_sym->result->attr.pointer
>> +            != sym->result->attr.pointer)
> There is an extra parenthesis here
I concur.

>> +           || (def_sym->result->attr.allocatable
> And another one here

I concur. With those changes - which I spotted after I had send the
email (but did not want to send a reply before testing finished),
regtesting succeeded.


>>            && def_sym->ts.u.cl->length != NULL)
>>          {
>>            gfc_charlen *cl = sym->ts.u.cl;
>> @@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sy
>>      }
>>
>>        /* 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)
> Same as above, I would put
> if (def_sym->attr.elemental && sym->attr.if_source != IFSRC_IFBODY)
> like in the previous cases.
> It is odd to guess interface explicitness out of symbol elementalness.

Well, I want to print also an error if the INTERFACE has no ELEMENTAL -
I could split the message in one for IFSRC_IFBODY and one for wrong
interfaces, if you think it makes sense.

>> -      if (def_sym->attr.is_bind_c)
>> +      if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
> Same here.

Ditto.

Thanks for the review!

Tobias
Tobias Burnus - July 27, 2010, 8:45 a.m.
On 07/27/2010 01:15 AM, Mikael Morin wrote:
> Le 26.07.2010 22:32, Tobias Burnus a écrit :
>> Build and and currently regtesting on x86-64-linux. If there is no
>> failure:
>> OK for the trunk?
> The extra expr.c hunk (pr45081 fix) which slipped through, is ok (and
> obvious).
> The function decl changes are OK.
> [...]
> As the previous status (without -fwhole-file) was not to check at all
> and the patch doesn't seem to error on valid testcases, OK if it
> passes the testsuite.

Committed as Rev. 162557 with the parentheses fixes in resolve.c (for
allocatable/pointer) and without the expr.c patch.
http://gcc.gnu.org/ml/gcc-cvs/2010-07/msg00911.html

Regarding the resolve.c checks: You can also consider adding a comment
to PR 45086 - there I track the external vs. INTERFACE checking for
-fwhole-file.

Tobias
Mikael Morin - July 27, 2010, 9:14 a.m.
Le 27.07.2010 07:54, Tobias Burnus a écrit :
>
> Mikael Morin wrote:
>> Le 26.07.2010 22:32, Tobias Burnus a écrit :
>>> Build and and currently regtesting on x86-64-linux. If there is no
>>> failure:
>>> OK for the trunk?
>> The extra expr.c hunk (pr45081 fix) which slipped through, is ok (and
>> obvious).
> But regresses in terms of diagnostics - I will leave it out and have a
> separate look later.
>
>> For the interface thing see below.        /* 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
>> The above makes sense, but the 4 following lines are odd.
>>
>> If I understand it correctly if there is a function
>> definition/interface mismatch (between pointer or allocatable
>> attributes), we generate an error asking for explicit interface (even
>> if the symbol comes from an interface block which _is_ an explicit
>> interface).
>> Well, maybe it's better than nothing after all.
>
> That was my idea - I think interface mismatches are rare enough that one
> does not need to replicate all the messages - and the error might be
> slightly odd, but should give a good hint.
OK, we can wait for someone to open a PR(if any) to decide to do 
something here.

>
>>> +           || def_sym->result->attr.pointer
>>> +            != sym->result->attr.pointer)
>> There is an extra parenthesis here
> I concur.
>
>>> +           || (def_sym->result->attr.allocatable
>> And another one here
>
> I concur. With those changes - which I spotted after I had send the
> email (but did not want to send a reply before testing finished),
> regtesting succeeded.
>
>
>>>             &&  def_sym->ts.u.cl->length != NULL)
>>>           {
>>>             gfc_charlen *cl = sym->ts.u.cl;
>>> @@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sy
>>>       }
>>>
>>>         /* 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)
>> Same as above, I would put
>> if (def_sym->attr.elemental&&  sym->attr.if_source != IFSRC_IFBODY)
>> like in the previous cases.
>> It is odd to guess interface explicitness out of symbol elementalness.
>
> Well, I want to print also an error if the INTERFACE has no ELEMENTAL -
> I could split the message in one for IFSRC_IFBODY and one for wrong
> interfaces, if you think it makes sense.
I was afraid that one could come up with a case where both def_sym and 
sym were declared as elemental (without interface body), thus skipping 
the check. I can't produce one, however, so it's probably fine as is.
>
>>> -      if (def_sym->attr.is_bind_c)
>>> +      if (def_sym->attr.is_bind_c&&  !sym->attr.is_bind_c)
>> Same here.
>
> Ditto.
Same here. No failing testcase.
>
> Thanks for the review!
>
> Tobias
>
Thanks for all your whole-file work.
Mikael

Patch

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.

Index: gcc/testsuite/gfortran.dg/whole_file_23.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_23.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_23.f90	(Revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/whole_file_22.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_22.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_22.f90	(Revision 0)
@@ -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
+
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 162542)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -913,7 +913,7 @@  gfc_is_constant_expr (gfc_expr *e)
 		  || gfc_is_constant_expr (e->value.op.op2)));
 
     case EXPR_VARIABLE:
-      return 0;
+      return (e->symtree->n.sym->attr.flavour == FL_PARAMETER);
 
     case EXPR_FUNCTION:
     case EXPR_PPC:
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(Revision 162542)
+++ gcc/fortran/trans.c	(Arbeitskopie)
@@ -1388,7 +1388,7 @@  gfc_generate_module_code (gfc_namespace
       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);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(Revision 162542)
+++ gcc/fortran/trans.h	(Arbeitskopie)
@@ -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_names
 /* 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 *);
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 162542)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -1816,7 +1816,8 @@  resolve_global_procedure (gfc_symbol *sy
     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 *sy
 		   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 *sy
 		       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 *sy
 	}
 
       /* 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 *sy
 	      && !(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);
     }
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(Revision 162542)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -1413,8 +1413,26 @@  gfc_get_extern_function_decl (gfc_symbol
 	&& !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
    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_na
       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_namespac
 
   /* 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;