diff mbox

[Fortran] More clean-up with try-finally

Message ID 4C435709.9030007@domob.eu
State New
Headers show

Commit Message

Daniel Kraft July 18, 2010, 7:33 p.m. UTC 
Hi,

the attached patch takes my last one a step further.  In 
gfc_generate_function_code, there still was some init/clean-up code (for 
instance, for bounds/recursion checking but also other stuff); this is 
now also handled via gfc_wrapped_block and the clean-up done as try-finally.

As a side effect, I now got rid of the "return label" philosophy for 
procedures.  Instead, a RETURN statement actually returns; all follow-up 
code that needs to be executed is done so as part of try-finally.  I 
hope this makes the code structure clearer to the middle-end (and at 
least seems simpler and more intuitive to me).

I've marked two points in the patch with an XXX comment:  First, I 
created a new global variable in trans-decl that keeps track of the 
currently trans'ed procedure's gfc_symbol (instead of its return label). 
  I did not find any existing feature to get it, although I may well 
image there is one.  Did I miss it?

Second, in gfc_trans_return, se.post is added to the code after the exit 
jump -- maybe I did completely misunderstand something, but to me this 
makes no sense (as it will not be executed anyway); I guess that this 
just never really mattered.  But I may be wrong -- so can this line go? 
  And if so, why can we be sure that se.post needs never be handled? 
And if I'm wrong, why?

This patch passed the test-suite, but when I wanted to re-check with a 
fresh svn update, bootstrap failed (since) with

Comparing stages 2 and 3
warning: gcc/cc1-checksum.o differs
Bootstrap comparison failure!
gcc/dwarf2out.o differs
gcc/recog.o differs
gcc/reload.o differs
gcc/i386.o differs
gcc/reg-stack.o differs
libiberty/hashtab.o differs.

I can't image how this is related to my patch; is anyone else seeing 
this, too?

Ok for trunk once I can bootstrap again and there are no regressions?

Daniel

Comments

Jack Howarth July 18, 2010, 9:07 p.m. UTC | #1 
On Sun, Jul 18, 2010 at 09:33:29PM +0200, Daniel Kraft wrote:
> Hi,
>
> the attached patch takes my last one a step further.  In  
> gfc_generate_function_code, there still was some init/clean-up code (for  
> instance, for bounds/recursion checking but also other stuff); this is  
> now also handled via gfc_wrapped_block and the clean-up done as 
> try-finally.
>
> As a side effect, I now got rid of the "return label" philosophy for  
> procedures.  Instead, a RETURN statement actually returns; all follow-up  
> code that needs to be executed is done so as part of try-finally.  I  
> hope this makes the code structure clearer to the middle-end (and at  
> least seems simpler and more intuitive to me).
>
> I've marked two points in the patch with an XXX comment:  First, I  
> created a new global variable in trans-decl that keeps track of the  
> currently trans'ed procedure's gfc_symbol (instead of its return label).  
>  I did not find any existing feature to get it, although I may well  
> image there is one.  Did I miss it?
>
> Second, in gfc_trans_return, se.post is added to the code after the exit  
> jump -- maybe I did completely misunderstand something, but to me this  
> makes no sense (as it will not be executed anyway); I guess that this  
> just never really mattered.  But I may be wrong -- so can this line go?  
> And if so, why can we be sure that se.post needs never be handled? And if 
> I'm wrong, why?
>
> This patch passed the test-suite, but when I wanted to re-check with a  
> fresh svn update, bootstrap failed (since) with
>
> Comparing stages 2 and 3
> warning: gcc/cc1-checksum.o differs
> Bootstrap comparison failure!
> gcc/dwarf2out.o differs
> gcc/recog.o differs
> gcc/reload.o differs
> gcc/i386.o differs
> gcc/reg-stack.o differs
> libiberty/hashtab.o differs.
>
> I can't image how this is related to my patch; is anyone else seeing  
> this, too?

This is [Bug bootstrap/44970]. Try using gcc trunk with r162270 reverted
for now.
              Jack

>
> Ok for trunk once I can bootstrap again and there are no regressions?
>
> Daniel
>
> -- 
> http://www.pro-vegan.info/
> --
> Done:  Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
> To go: Hea-Kni-Mon-Pri
Daniel Kraft July 20, 2010, 8:35 a.m. UTC | #2 
Daniel Kraft wrote:
> This patch passed the test-suite, but when I wanted to re-check with a 
> fresh svn update, bootstrap failed (since) with
> 
> Comparing stages 2 and 3
> warning: gcc/cc1-checksum.o differs
> Bootstrap comparison failure!
> gcc/dwarf2out.o differs
> gcc/recog.o differs
> gcc/reload.o differs
> gcc/i386.o differs
> gcc/reg-stack.o differs
> libiberty/hashtab.o differs.
> 
> I can't image how this is related to my patch; is anyone else seeing 
> this, too?
> 
> Ok for trunk once I can bootstrap again and there are no regressions?

It finally worked yesterday and there were no failures left.

Daniel
Tobias Burnus July 20, 2010, 9:22 p.m. UTC | #3 
Daniel Kraft wrote:
> I've marked two points in the patch with an XXX comment:  First, I
> created a new global variable in trans-decl that keeps track of the
> currently trans'ed procedure's gfc_symbol (instead of its return
> label).  I did not find any existing feature to get it, although I may
> well image there is one.  Did I miss it?

I think there is not yet such a variable.

> Second, in gfc_trans_return, se.post is added to the code after the
> exit jump -- maybe I did completely misunderstand something, but to me
> this makes no sense (as it will not be executed anyway); I guess that
> this just never really mattered.  But I may be wrong -- so can this
> line go?  And if so, why can we be sure that se.post needs never be
> handled? And if I'm wrong, why?

I think this line can go.

> Ok for trunk once I can bootstrap again and there are no regressions?

OK. Thanks for the patch!

Tobias
Daniel Kraft July 21, 2010, 1:50 p.m. UTC | #4 
Tobias Burnus wrote:
> Daniel Kraft wrote:
>> I've marked two points in the patch with an XXX comment:  First, I
>> created a new global variable in trans-decl that keeps track of the
>> currently trans'ed procedure's gfc_symbol (instead of its return
>> label).  I did not find any existing feature to get it, although I may
>> well image there is one.  Did I miss it?
> 
> I think there is not yet such a variable.
> 
>> Second, in gfc_trans_return, se.post is added to the code after the
>> exit jump -- maybe I did completely misunderstand something, but to me
>> this makes no sense (as it will not be executed anyway); I guess that
>> this just never really mattered.  But I may be wrong -- so can this
>> line go?  And if so, why can we be sure that se.post needs never be
>> handled? And if I'm wrong, why?
> 
> I think this line can go.
> 
>> Ok for trunk once I can bootstrap again and there are no regressions?
> 
> OK. Thanks for the patch!

Committed as rev. 162373.  Removed the comments and line as suggested.

Thanks for the review!
Daniel
Paul Richard Thomas July 21, 2010, 8:35 p.m. UTC | #5 
Dear All,


>> Second, in gfc_trans_return, se.post is added to the code after the
>> exit jump -- maybe I did completely misunderstand something, but to me
>> this makes no sense (as it will not be executed anyway); I guess that
>> this just never really mattered.  But I may be wrong -- so can this
>> line go?  And if so, why can we be sure that se.post needs never be
>> handled? And if I'm wrong, why?
>
> I think this line can go.

I do not think that I agree.

I am hard put to do it right now but I rather think that it must be
possible to generate an integer-scalar-expression that generates a
post block.  It certainly does no harm to leave it in :-)

Cheers

Paul
Tobias Burnus July 21, 2010, 9:32 p.m. UTC | #6 
Dear Paul,

Paul Richard Thomas wrote:
>> I think this line can go.
>>     
> I do not think that I agree.
>
> I am hard put to do it right now but I rather think that it must be
> possible to generate an integer-scalar-expression that generates a
> post block.  It certainly does no harm to leave it in :-)
>   

Thinking about it again, I agree: One needs to take care of se.post.
However, if one simply adds the previous line, the result for the
example below is as follows. First, one returns and then one frees the
memory:

    return __result_bar;
    {
      void * D.1566;

      D.1566 = (void *) pstr.0;
      if (D.1566 != 0B)
        {
          __builtin_free (D.1566);
        }
    }

which doesn't make sense. (Ditto for the old code: The free came after
the "goto __return".) Thus, removing the line does neither harm nor
improve the situation. The real fix is to ensure that the clean up of
"se.post" comes before the "return".

Example program:

contains
function f(n)
  character(len=n) :: f
end function f
subroutine bar(k,*)
return len(f(k))
end subroutine bar
end

Tobias
Daniel Kraft July 22, 2010, 6:47 a.m. UTC | #7 
Tobias Burnus wrote:
> Dear Paul,
> 
> Paul Richard Thomas wrote:
>>> I think this line can go.
>>>     
>> I do not think that I agree.
>>
>> I am hard put to do it right now but I rather think that it must be
>> possible to generate an integer-scalar-expression that generates a
>> post block.  It certainly does no harm to leave it in :-)
>>   
> 
> Thinking about it again, I agree: One needs to take care of se.post.
> However, if one simply adds the previous line, the result for the
> example below is as follows. First, one returns and then one frees the
> memory:
> 
>     return __result_bar;
>     {
>       void * D.1566;
> 
>       D.1566 = (void *) pstr.0;
>       if (D.1566 != 0B)
>         {
>           __builtin_free (D.1566);
>         }
>     }
> 
> which doesn't make sense. (Ditto for the old code: The free came after
> the "goto __return".) Thus, removing the line does neither harm nor
> improve the situation. The real fix is to ensure that the clean up of
> "se.post" comes before the "return".

Yes, I also agree.  Of course, we could build another try-finally there 
to counter the problem, if se.post is not empty.  I can add this, if you 
agree that it's a reasonable solution.  But I've no idea what to do else.

BTW, I remember when doing other work at trans-*, that se.post was not 
used really symetricaly to se.pre at some places (e.g., also just ignored).

Daniel
Paul Richard Thomas July 22, 2010, 7:22 a.m. UTC | #8 
Dear All,

>> which doesn't make sense. (Ditto for the old code: The free came after
>> the "goto __return".) Thus, removing the line does neither harm nor
>> improve the situation. The real fix is to ensure that the clean up of
>> "se.post" comes before the "return".

       gfc_add_expr_to_block (&se.pre, tmp);  /* Add the return
MODIFY_EXPR to the block */
       gfc_add_block_to_block (&se.pre, &se.post);  /* Follow it with
the post block.  */
       tmp = gfc_generate_return ();  /* and return */
       gfc_add_expr_to_block (&se.pre, tmp);
       return gfc_finish_block (&se.pre);

> Yes, I also agree.  Of course, we could build another try-finally there to
> counter the problem, if se.post is not empty.  I can add this, if you agree
> that it's a reasonable solution.  But I've no idea what to do else.

I think that it's too weighty - the above will work since the return
value is evaluated and assigned to 'return'.  Most of the time the
post block is NULL in any case.

> BTW, I remember when doing other work at trans-*, that se.post was not used
> really symetricaly to se.pre at some places (e.g., also just ignored).
>

An asymmetric usage is fine, as long as the expression value is fixed.
 Ignoring the post block should only occur for variables or constants.

Cheers

Paul
Daniel Kraft July 22, 2010, 7:30 a.m. UTC | #9 
Paul Richard Thomas wrote:
> Dear All,
> 
>>> which doesn't make sense. (Ditto for the old code: The free came after
>>> the "goto __return".) Thus, removing the line does neither harm nor
>>> improve the situation. The real fix is to ensure that the clean up of
>>> "se.post" comes before the "return".
> 
>        gfc_add_expr_to_block (&se.pre, tmp);  /* Add the return
> MODIFY_EXPR to the block */
>        gfc_add_block_to_block (&se.pre, &se.post);  /* Follow it with
> the post block.  */
>        tmp = gfc_generate_return ();  /* and return */
>        gfc_add_expr_to_block (&se.pre, tmp);
>        return gfc_finish_block (&se.pre);

You're right (and Tobias also suggested the same), I overlooked that the 
return'ed expression can only be a "simple" one and so this works.

I'll add this line and commit (I guess this is obvious) later today.

Thanks for spotting this!

Daniel
diff mbox

Patch

Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 162282)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -491,7 +491,7 @@  gfc_trans_call (gfc_code * code, bool de
 /* Translate the RETURN statement.  */
 
 tree
-gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
+gfc_trans_return (gfc_code * code)
 {
   if (code->expr1)
     {
@@ -500,16 +500,16 @@  gfc_trans_return (gfc_code * code ATTRIB
       tree result;
 
       /* If code->expr is not NULL, this return statement must appear
-         in a subroutine and current_fake_result_decl has already
+	 in a subroutine and current_fake_result_decl has already
 	 been generated.  */
 
       result = gfc_get_fake_result_decl (NULL, 0);
       if (!result)
-        {
-          gfc_warning ("An alternate return at %L without a * dummy argument",
-                        &code->expr1->where);
-          return build1_v (GOTO_EXPR, gfc_get_return_label ());
-        }
+	{
+	  gfc_warning ("An alternate return at %L without a * dummy argument",
+			&code->expr1->where);
+	  return gfc_generate_return ();
+	}
 
       /* Start a new block for this statement.  */
       gfc_init_se (&se, NULL);
@@ -521,13 +521,14 @@  gfc_trans_return (gfc_code * code ATTRIB
 			 fold_convert (TREE_TYPE (result), se.expr));
       gfc_add_expr_to_block (&se.pre, tmp);
 
-      tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
+      tmp = gfc_generate_return ();
       gfc_add_expr_to_block (&se.pre, tmp);
+      /* XXX: Why this after the exit jump???  */
       gfc_add_block_to_block (&se.pre, &se.post);
       return gfc_finish_block (&se.pre);
     }
-  else
-    return build1_v (GOTO_EXPR, gfc_get_return_label ());
+
+  return gfc_generate_return ();
 }
 
 
@@ -847,8 +848,7 @@  gfc_trans_block_construct (gfc_code* cod
 {
   gfc_namespace* ns;
   gfc_symbol* sym;
-  stmtblock_t body;
-  tree tmp;
+  gfc_wrapped_block body;
 
   ns = code->ext.block.ns;
   gcc_assert (ns);
@@ -858,14 +858,12 @@  gfc_trans_block_construct (gfc_code* cod
   gcc_assert (!sym->tlink);
   sym->tlink = sym;
 
-  gfc_start_block (&body);
   gfc_process_block_locals (ns);
 
-  tmp = gfc_trans_code (ns->code);
-  tmp = gfc_trans_deferred_vars (sym, tmp);
+  gfc_start_wrapped_block (&body, gfc_trans_code (ns->code));
+  gfc_trans_deferred_vars (sym, &body);
 
-  gfc_add_expr_to_block (&body, tmp);
-  return gfc_finish_block (&body);
+  return gfc_finish_wrapped_block (&body);
 }
 
 
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 162282)
+++ gcc/fortran/trans.h	(working copy)
@@ -408,9 +408,6 @@  tree gfc_build_label_decl (tree);
    Do not use if the function has an explicit result variable.  */
 tree gfc_get_fake_result_decl (gfc_symbol *, int);
 
-/* Get the return label for the current function.  */
-tree gfc_get_return_label (void);
-
 /* Add a decl to the binding level for the current function.  */
 void gfc_add_decl_to_function (tree);
 
@@ -456,6 +453,8 @@  void gfc_generate_function_code (gfc_nam
 void gfc_generate_block_data (gfc_namespace *);
 /* Output a decl for a module variable.  */
 void gfc_generate_module_vars (gfc_namespace *);
+/* Get the appropriate return statement for a procedure.  */
+tree gfc_generate_return (void);
 
 struct GTY(()) module_htab_entry {
   const char *name;
@@ -533,7 +532,7 @@  tree gfc_build_library_function_decl_wit
 void gfc_process_block_locals (gfc_namespace*);
 
 /* Output initialization/clean-up code that was deferred.  */
-tree gfc_trans_deferred_vars (gfc_symbol*, tree);
+void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
 
 /* somewhere! */
 tree pushdecl (tree);
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 162282)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -55,8 +55,6 @@  along with GCC; see the file COPYING3.  
 static GTY(()) tree current_fake_result_decl;
 static GTY(()) tree parent_fake_result_decl;
 
-static GTY(()) tree current_function_return_label;
-
 
 /* Holds the variable DECLs for the current function.  */
 
@@ -75,6 +73,10 @@  static GTY(()) tree saved_local_decls;
 
 static gfc_namespace *module_namespace;
 
+/* The currently processed procedure symbol.  */
+/* XXX: Is there already something like this?  */
+static gfc_symbol* current_procedure_symbol = NULL;
+
 
 /* List of static constructor functions.  */
 
@@ -237,28 +239,6 @@  gfc_build_label_decl (tree label_id)
 }
 
 
-/* Returns the return label for the current function.  */
-
-tree
-gfc_get_return_label (void)
-{
-  char name[GFC_MAX_SYMBOL_LEN + 10];
-
-  if (current_function_return_label)
-    return current_function_return_label;
-
-  sprintf (name, "__return_%s",
-	   IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
-
-  current_function_return_label =
-    gfc_build_label_decl (get_identifier (name));
-
-  DECL_ARTIFICIAL (current_function_return_label) = 1;
-
-  return current_function_return_label;
-}
-
-
 /* Set the backend source location of a decl.  */
 
 void
@@ -3089,18 +3069,15 @@  init_intent_out_dt (gfc_symbol * proc_sy
     Initialization of ASSIGN statement auxiliary variable.
     Automatic deallocation.  */
 
-tree
-gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
+void
+gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 {
   locus loc;
   gfc_symbol *sym;
   gfc_formal_arglist *f;
   stmtblock_t tmpblock;
-  gfc_wrapped_block try_block;
   bool seen_trans_deferred_array = false;
 
-  gfc_start_wrapped_block (&try_block, fnbody);
-
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */
   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
@@ -3122,17 +3099,17 @@  gfc_trans_deferred_vars (gfc_symbol * pr
       else if (proc_sym->as)
 	{
 	  tree result = TREE_VALUE (current_fake_result_decl);
-	  gfc_trans_dummy_array_bias (proc_sym, result, &try_block);
+	  gfc_trans_dummy_array_bias (proc_sym, result, block);
 
 	  /* An automatic character length, pointer array result.  */
 	  if (proc_sym->ts.type == BT_CHARACTER
 		&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
-	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block);
+	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
 	}
       else if (proc_sym->ts.type == BT_CHARACTER)
 	{
 	  if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
-	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block);
+	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
 	}
       else
 	gcc_assert (gfc_option.flag_f2c
@@ -3142,7 +3119,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
      should be done here so that the offsets and lbounds of arrays
      are available.  */
-  init_intent_out_dt (proc_sym, &try_block);
+  init_intent_out_dt (proc_sym, block);
 
   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
     {
@@ -3154,7 +3131,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 	    {
 	    case AS_EXPLICIT:
 	      if (sym->attr.dummy || sym->attr.result)
-		gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block);
+		gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
 	      else if (sym->attr.pointer || sym->attr.allocatable)
 		{
 		  if (TREE_STATIC (sym->backend_decl))
@@ -3162,7 +3139,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 		  else
 		    {
 		      seen_trans_deferred_array = true;
-		      gfc_trans_deferred_array (sym, &try_block);
+		      gfc_trans_deferred_array (sym, block);
 		    }
 		}
 	      else
@@ -3170,7 +3147,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 		  if (sym_has_alloc_comp)
 		    {
 		      seen_trans_deferred_array = true;
-		      gfc_trans_deferred_array (sym, &try_block);
+		      gfc_trans_deferred_array (sym, block);
 		    }
 		  else if (sym->ts.type == BT_DERIVED
 			     && sym->value
@@ -3179,7 +3156,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 		    {
 		      gfc_start_block (&tmpblock);
 		      gfc_init_default_dt (sym, &tmpblock, false);
-		      gfc_add_init_cleanup (&try_block,
+		      gfc_add_init_cleanup (block,
 					    gfc_finish_block (&tmpblock),
 					    NULL_TREE);
 		    }
@@ -3187,7 +3164,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 		  gfc_get_backend_locus (&loc);
 		  gfc_set_backend_locus (&sym->declared_at);
 		  gfc_trans_auto_array_allocation (sym->backend_decl,
-						   sym, &try_block);
+						   sym, block);
 		  gfc_set_backend_locus (&loc);
 		}
 	      break;
@@ -3198,26 +3175,26 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 
 	      /* We should always pass assumed size arrays the g77 way.  */
 	      if (sym->attr.dummy)
-		gfc_trans_g77_array (sym, &try_block);
+		gfc_trans_g77_array (sym, block);
 	      break;
 
 	    case AS_ASSUMED_SHAPE:
 	      /* Must be a dummy parameter.  */
 	      gcc_assert (sym->attr.dummy);
 
-	      gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block);
+	      gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
 	      break;
 
 	    case AS_DEFERRED:
 	      seen_trans_deferred_array = true;
-	      gfc_trans_deferred_array (sym, &try_block);
+	      gfc_trans_deferred_array (sym, block);
 	      break;
 
 	    default:
 	      gcc_unreachable ();
 	    }
 	  if (sym_has_alloc_comp && !seen_trans_deferred_array)
-	    gfc_trans_deferred_array (sym, &try_block);
+	    gfc_trans_deferred_array (sym, block);
 	}
       else if (sym->attr.allocatable
 	       || (sym->ts.type == BT_CLASS
@@ -3252,26 +3229,26 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 	      tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
 						NULL);
 
-	      gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), tmp);
+	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
 	    }
 	}
       else if (sym_has_alloc_comp)
-	gfc_trans_deferred_array (sym, &try_block);
+	gfc_trans_deferred_array (sym, block);
       else if (sym->ts.type == BT_CHARACTER)
 	{
 	  gfc_get_backend_locus (&loc);
 	  gfc_set_backend_locus (&sym->declared_at);
 	  if (sym->attr.dummy || sym->attr.result)
-	    gfc_trans_dummy_character (sym, sym->ts.u.cl, &try_block);
+	    gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
 	  else
-	    gfc_trans_auto_character_variable (sym, &try_block);
+	    gfc_trans_auto_character_variable (sym, block);
 	  gfc_set_backend_locus (&loc);
 	}
       else if (sym->attr.assign)
 	{
 	  gfc_get_backend_locus (&loc);
 	  gfc_set_backend_locus (&sym->declared_at);
-	  gfc_trans_assign_aux_var (sym, &try_block);
+	  gfc_trans_assign_aux_var (sym, block);
 	  gfc_set_backend_locus (&loc);
 	}
       else if (sym->ts.type == BT_DERIVED
@@ -3281,7 +3258,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 	{
 	  gfc_start_block (&tmpblock);
 	  gfc_init_default_dt (sym, &tmpblock, false);
-	  gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock),
+	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
 				NULL_TREE);
 	}
       else
@@ -3308,9 +3285,7 @@  gfc_trans_deferred_vars (gfc_symbol * pr
 	gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
     }
 
-  gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), NULL_TREE);
-
-  return gfc_finish_wrapped_block (&try_block);
+  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
 }
 
 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
@@ -4308,6 +4283,56 @@  create_main_function (tree fndecl)
 }
 
 
+/* Get the result expression for a procedure.  */
+
+static tree
+get_proc_result (gfc_symbol* sym)
+{
+  if (sym->attr.subroutine || sym == sym->result)
+    {
+      if (current_fake_result_decl != NULL)
+	return TREE_VALUE (current_fake_result_decl);
+
+      return NULL_TREE;
+    }
+
+  return sym->result->backend_decl;
+}
+
+
+/* Generate an appropriate return-statement for a procedure.  */
+
+tree
+gfc_generate_return (void)
+{
+  gfc_symbol* sym;
+  tree result;
+  tree fndecl;
+
+  sym = current_procedure_symbol;
+  fndecl = sym->backend_decl;
+
+  if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
+    result = NULL_TREE;
+  else
+    {
+      result = get_proc_result (sym);
+
+      /* Set the return value to the dummy result variable.  The
+	 types may be different for scalar default REAL functions
+	 with -ff2c, therefore we have to convert.  */
+      if (result != NULL_TREE)
+	{
+	  result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
+	  result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
+				DECL_RESULT (fndecl), result);
+	}
+    }
+
+  return build1_v (RETURN_EXPR, result);
+}
+
+
 /* Generate code for a function.  */
 
 void
@@ -4317,16 +4342,18 @@  gfc_generate_function_code (gfc_namespac
   tree old_context;
   tree decl;
   tree tmp;
-  tree tmp2;
-  stmtblock_t block;
+  stmtblock_t init, cleanup;
   stmtblock_t body;
-  tree result;
+  gfc_wrapped_block try_block;
   tree recurcheckvar = NULL_TREE;
   gfc_symbol *sym;
+  gfc_symbol *previous_procedure_symbol;
   int rank;
   bool is_recursive;
 
   sym = ns->proc_name;
+  previous_procedure_symbol = current_procedure_symbol;
+  current_procedure_symbol = sym;
 
   /* Check that the frontend isn't still using this.  */
   gcc_assert (sym->tlink == NULL);
@@ -4348,7 +4375,7 @@  gfc_generate_function_code (gfc_namespac
 
   trans_function_start (sym);
 
-  gfc_init_block (&block);
+  gfc_init_block (&init);
 
   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
     {
@@ -4387,34 +4414,32 @@  gfc_generate_function_code (gfc_namespac
   else
     current_fake_result_decl = NULL_TREE;
 
-  current_function_return_label = NULL;
+  is_recursive = sym->attr.recursive
+		 || (sym->attr.entry_master
+		     && sym->ns->entries->sym->attr.recursive);
+  if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+	&& !is_recursive
+	&& !gfc_option.flag_recursive)
+    {
+      char * msg;
+
+      asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+		sym->name);
+      recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+      TREE_STATIC (recurcheckvar) = 1;
+      DECL_INITIAL (recurcheckvar) = boolean_false_node;
+      gfc_add_expr_to_block (&init, recurcheckvar);
+      gfc_trans_runtime_check (true, false, recurcheckvar, &init,
+			       &sym->declared_at, msg);
+      gfc_add_modify (&init, recurcheckvar, boolean_true_node);
+      gfc_free (msg);
+    }
 
   /* Now generate the code for the body of this function.  */
   gfc_init_block (&body);
 
-   is_recursive = sym->attr.recursive
-		  || (sym->attr.entry_master
-		      && sym->ns->entries->sym->attr.recursive);
-   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
-	  && !is_recursive
-	  && !gfc_option.flag_recursive)
-     {
-       char * msg;
-
-       asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
-		 sym->name);
-       recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
-       TREE_STATIC (recurcheckvar) = 1;
-       DECL_INITIAL (recurcheckvar) = boolean_false_node;
-       gfc_add_expr_to_block (&block, recurcheckvar);
-       gfc_trans_runtime_check (true, false, recurcheckvar, &block,
-				&sym->declared_at, msg);
-       gfc_add_modify (&block, recurcheckvar, boolean_true_node);
-       gfc_free (msg);
-    }
-
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
-        && sym->attr.subroutine)
+	&& sym->attr.subroutine)
     {
       tree alternate_return;
       alternate_return = gfc_get_fake_result_decl (sym, 0);
@@ -4437,29 +4462,9 @@  gfc_generate_function_code (gfc_namespac
   tmp = gfc_trans_code (ns->code);
   gfc_add_expr_to_block (&body, tmp);
 
-  /* Add a return label if needed.  */
-  if (current_function_return_label)
-    {
-      tmp = build1_v (LABEL_EXPR, current_function_return_label);
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  tmp = gfc_finish_block (&body);
-  /* Add code to create and cleanup arrays.  */
-  tmp = gfc_trans_deferred_vars (sym, tmp);
-
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
     {
-      if (sym->attr.subroutine || sym == sym->result)
-	{
-	  if (current_fake_result_decl != NULL)
-	    result = TREE_VALUE (current_fake_result_decl);
-	  else
-	    result = NULL_TREE;
-	  current_fake_result_decl = NULL_TREE;
-	}
-      else
-	result = sym->result->backend_decl;
+      tree result = get_proc_result (sym);
 
       if (result != NULL_TREE
 	    && sym->attr.function
@@ -4469,24 +4474,12 @@  gfc_generate_function_code (gfc_namespac
 	      && sym->ts.u.derived->attr.alloc_comp)
 	    {
 	      rank = sym->as ? sym->as->rank : 0;
-	      tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
-	      gfc_add_expr_to_block (&block, tmp2);
+	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
+	      gfc_add_expr_to_block (&init, tmp);
 	    }
 	  else if (sym->attr.allocatable && sym->attr.dimension == 0)
-	    gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
-							  null_pointer_node));
-	}
-
-      gfc_add_expr_to_block (&block, tmp);
-
-      /* Reset recursion-check variable.  */
-      if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
-	     && !is_recursive
-	     && !gfc_option.flag_openmp
-	     && recurcheckvar != NULL_TREE)
-	{
-	  gfc_add_modify (&block, recurcheckvar, boolean_false_node);
-	  recurcheckvar = NULL;
+	    gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
+							 null_pointer_node));
 	}
 
       if (result == NULL_TREE)
@@ -4499,31 +4492,28 @@  gfc_generate_function_code (gfc_namespac
 	  TREE_NO_WARNING(sym->backend_decl) = 1;
 	}
       else
-	{
-	  /* Set the return value to the dummy result variable.  The
-	     types may be different for scalar default REAL functions
-	     with -ff2c, therefore we have to convert.  */
-	  tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
-	  tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
-			     DECL_RESULT (fndecl), tmp);
-	  tmp = build1_v (RETURN_EXPR, tmp);
-	  gfc_add_expr_to_block (&block, tmp);
-	}
+	gfc_add_expr_to_block (&body, gfc_generate_return ());
     }
-  else
+
+  gfc_init_block (&cleanup);
+
+  /* Reset recursion-check variable.  */
+  if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+	 && !is_recursive
+	 && !gfc_option.flag_openmp
+	 && recurcheckvar != NULL_TREE)
     {
-      gfc_add_expr_to_block (&block, tmp);
-      /* Reset recursion-check variable.  */
-      if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
-	     && !is_recursive
-	     && !gfc_option.flag_openmp
-	     && recurcheckvar != NULL_TREE)
-	{
-	  gfc_add_modify (&block, recurcheckvar, boolean_false_node);
-	  recurcheckvar = NULL_TREE;
-	}
+      gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
+      recurcheckvar = NULL;
     }
 
+  /* Finish the function body and add init and cleanup code.  */
+  tmp = gfc_finish_block (&body);
+  gfc_start_wrapped_block (&try_block, tmp);
+  /* Add code to create and cleanup arrays.  */
+  gfc_trans_deferred_vars (sym, &try_block);
+  gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
+			gfc_finish_block (&cleanup));
 
   /* Add all the decls we created during processing.  */
   decl = saved_function_decls;
@@ -4538,7 +4528,7 @@  gfc_generate_function_code (gfc_namespac
     }
   saved_function_decls = NULL_TREE;
 
-  DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
+  DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
   decl = getdecls ();
 
   /* Finish off this function and send it for code generation.  */
@@ -4589,6 +4579,8 @@  gfc_generate_function_code (gfc_namespac
 
   if (sym->attr.is_main_program)
     create_main_function (fndecl);
+
+  current_procedure_symbol = previous_procedure_symbol;
 }