re PR fortran/44709 (BLOCK and GOTO/EXIT/CYCLE)

2010-07-15  Daniel Kraft  <d@domob.eu>

	PR fortran/44709
	* trans.h (struct gfc_wrapped_block): New struct.
	(gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods.
	(gfc_finish_wrapped_block): New method.
	(gfc_init_default_dt): Add new init code to block rather than
	returning it.
	* trans-array.h (gfc_trans_auto_array_allocation): Use gfc_wrapped_block
	(gfc_trans_dummy_array_bias): Ditto.
	(gfc_trans_g77_array): Ditto.
	(gfc_trans_deferred_array): Ditto.
	* trans.c (gfc_add_expr_to_block): Call add_expr_to_chain.
	(add_expr_to_chain): New method based on old gfc_add_expr_to_block.
	(gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods.
	(gfc_finish_wrapped_block): New method.
	* trans-array.c (gfc_trans_auto_array_allocation): use gfc_wrapped_block
	(gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
	(gfc_trans_deferred_array): Ditto.
	* trans-decl.c (gfc_trans_dummy_character): Ditto.
	(gfc_trans_auto_character_variable), (gfc_trans_assign_aux_var): Ditto.
	(init_intent_out_dt): Ditto.
	(gfc_init_default_dt): Add new init code to block rather than
	returning it.
	(gfc_trans_deferred_vars): Use gfc_wrapped_block to collect all init
	and cleanup code and put it all together.

From-SVN: r162219

gcc/fortran/ChangeLog

+2010-07-15  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/44709
+	* trans.h (struct gfc_wrapped_block): New struct.
+	(gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods.
+	(gfc_finish_wrapped_block): New method.
+	(gfc_init_default_dt): Add new init code to block rather than
+	returning it.
+	* trans-array.h (gfc_trans_auto_array_allocation): Use gfc_wrapped_block
+	(gfc_trans_dummy_array_bias): Ditto.
+	(gfc_trans_g77_array): Ditto.
+	(gfc_trans_deferred_array): Ditto.
+	* trans.c (gfc_add_expr_to_block): Call add_expr_to_chain.
+	(add_expr_to_chain): New method based on old gfc_add_expr_to_block.
+	(gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods.
+	(gfc_finish_wrapped_block): New method.
+	* trans-array.c (gfc_trans_auto_array_allocation): use gfc_wrapped_block
+	(gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
+	(gfc_trans_deferred_array): Ditto.
+	* trans-decl.c (gfc_trans_dummy_character): Ditto.
+	(gfc_trans_auto_character_variable), (gfc_trans_assign_aux_var): Ditto.
+	(init_intent_out_dt): Ditto.
+	(gfc_init_default_dt): Add new init code to block rather than
+	returning it.
+	(gfc_trans_deferred_vars): Use gfc_wrapped_block to collect all init
+	and cleanup code and put it all together.
+
 2010-07-15  Jakub Jelinek  <jakub@redhat.com>
 
 	* trans.h (gfc_build_compare_string): Add CODE argument.

gcc/fortran/trans-array.c

@@ -4265,10 +4265,11 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 
 /* Generate code to initialize/allocate an array variable.  */
 
-tree
-gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
+void
+gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
+				 gfc_wrapped_block * block)
 {
-  stmtblock_t block;
+  stmtblock_t init;
   tree type;
   tree tmp;
   tree size;
@@ -4279,32 +4280,32 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
 
   /* Do nothing for USEd variables.  */
   if (sym->attr.use_assoc)
-    return fnbody;
+    return;
 
   type = TREE_TYPE (decl);
   gcc_assert (GFC_ARRAY_TYPE_P (type));
   onstack = TREE_CODE (type) != POINTER_TYPE;
 
-  gfc_start_block (&block);
+  gfc_start_block (&init);
 
   /* Evaluate character string length.  */
   if (sym->ts.type == BT_CHARACTER
       && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
     {
-      gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
+      gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
 
-      gfc_trans_vla_type_sizes (sym, &block);
+      gfc_trans_vla_type_sizes (sym, &init);
 
       /* Emit a DECL_EXPR for this variable, which will cause the
 	 gimplifier to allocate storage, and all that good stuff.  */
       tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
-      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_expr_to_block (&init, tmp);
     }
 
   if (onstack)
     {
-      gfc_add_expr_to_block (&block, fnbody);
-      return gfc_finish_block (&block);
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
     }
 
   type = TREE_TYPE (type);
@@ -4315,17 +4316,18 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
 
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
-    gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
 
-  size = gfc_trans_array_bounds (type, sym, &offset, &block);
+  size = gfc_trans_array_bounds (type, sym, &offset, &init);
 
   /* Don't actually allocate space for Cray Pointees.  */
   if (sym->attr.cray_pointee)
     {
       if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
-	gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
-      gfc_add_expr_to_block (&block, fnbody);
-      return gfc_finish_block (&block);
+	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
     }
 
   /* The size is the number of elements in the array, so multiply by the
@@ -4335,31 +4337,27 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
 		      fold_convert (gfc_array_index_type, tmp));
 
   /* Allocate memory to hold the data.  */
-  tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
-  gfc_add_modify (&block, decl, tmp);
+  tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
+  gfc_add_modify (&init, decl, tmp);
 
   /* Set offset of the array.  */
   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
-    gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
-
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
 
   /* Automatic arrays should not have initializers.  */
   gcc_assert (!sym->value);
 
-  gfc_add_expr_to_block (&block, fnbody);
-
   /* Free the temporary.  */
   tmp = gfc_call_free (convert (pvoid_type_node, decl));
-  gfc_add_expr_to_block (&block, tmp);
 
-  return gfc_finish_block (&block);
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
 }
 
 
 /* Generate entry and exit code for g77 calling convention arrays.  */
 
-tree
-gfc_trans_g77_array (gfc_symbol * sym, tree body)
+void
+gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
 {
   tree parm;
   tree type;
@@ -4367,7 +4365,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
   tree offset;
   tree tmp;
   tree stmt;  
-  stmtblock_t block;
+  stmtblock_t init;
 
   gfc_get_backend_locus (&loc);
   gfc_set_backend_locus (&sym->declared_at);
@@ -4377,31 +4375,29 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
   type = TREE_TYPE (parm);
   gcc_assert (GFC_ARRAY_TYPE_P (type));
 
-  gfc_start_block (&block);
+  gfc_start_block (&init);
 
   if (sym->ts.type == BT_CHARACTER
       && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
-    gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
 
   /* Evaluate the bounds of the array.  */
-  gfc_trans_array_bounds (type, sym, &offset, &block);
+  gfc_trans_array_bounds (type, sym, &offset, &init);
 
   /* Set the offset.  */
   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
-    gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
 
   /* Set the pointer itself if we aren't using the parameter directly.  */
   if (TREE_CODE (parm) != PARM_DECL)
     {
       tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
-      gfc_add_modify (&block, parm, tmp);
+      gfc_add_modify (&init, parm, tmp);
     }
-  stmt = gfc_finish_block (&block);
+  stmt = gfc_finish_block (&init);
 
   gfc_set_backend_locus (&loc);
 
-  gfc_start_block (&block);
-
   /* Add the initialization code to the start of the function.  */
 
   if (sym->attr.optional || sym->attr.not_always_present)
@@ -4410,10 +4406,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
       stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
     }
   
-  gfc_add_expr_to_block (&block, stmt);
-  gfc_add_expr_to_block (&block, body);
-
-  return gfc_finish_block (&block);
+  gfc_add_init_cleanup (block, stmt, NULL_TREE);
 }
 
 
@@ -4428,22 +4421,22 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
    Code is also added to copy the data back at the end of the function.
    */
 
-tree
-gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
+void
+gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
+			    gfc_wrapped_block * block)
 {
   tree size;
   tree type;
   tree offset;
   locus loc;
-  stmtblock_t block;
-  stmtblock_t cleanup;
+  stmtblock_t init;
+  tree stmtInit, stmtCleanup;
   tree lbound;
   tree ubound;
   tree dubound;
   tree dlbound;
   tree dumdesc;
   tree tmp;
-  tree stmt;
   tree stride, stride2;
   tree stmt_packed;
   tree stmt_unpacked;
@@ -4456,10 +4449,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 
   /* Do nothing for pointer and allocatable arrays.  */
   if (sym->attr.pointer || sym->attr.allocatable)
-    return body;
+    return;
 
   if (sym->attr.dummy && gfc_is_nodesc_array (sym))
-    return gfc_trans_g77_array (sym, body);
+    {
+      gfc_trans_g77_array (sym, block);
+      return;
+    }
 
   gfc_get_backend_locus (&loc);
   gfc_set_backend_locus (&sym->declared_at);
@@ -4468,35 +4464,32 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
   type = TREE_TYPE (tmpdesc);
   gcc_assert (GFC_ARRAY_TYPE_P (type));
   dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
-  dumdesc = build_fold_indirect_ref_loc (input_location,
-				     dumdesc);
-  gfc_start_block (&block);
+  dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+  gfc_start_block (&init);
 
   if (sym->ts.type == BT_CHARACTER
       && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
-    gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
 
   checkparm = (sym->as->type == AS_EXPLICIT
 	       && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
 
   no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
-                || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
+		|| GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
 
   if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
     {
       /* For non-constant shape arrays we only check if the first dimension
-         is contiguous.  Repacking higher dimensions wouldn't gain us
-         anything as we still don't know the array stride.  */
+	 is contiguous.  Repacking higher dimensions wouldn't gain us
+	 anything as we still don't know the array stride.  */
       partial = gfc_create_var (boolean_type_node, "partial");
       TREE_USED (partial) = 1;
       tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
       tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
-      gfc_add_modify (&block, partial, tmp);
+      gfc_add_modify (&init, partial, tmp);
     }
   else
-    {
-      partial = NULL_TREE;
-    }
+    partial = NULL_TREE;
 
   /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
      here, however I think it does the right thing.  */
@@ -4504,14 +4497,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
     {
       /* Set the first stride.  */
       stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
-      stride = gfc_evaluate_now (stride, &block);
+      stride = gfc_evaluate_now (stride, &init);
 
       tmp = fold_build2 (EQ_EXPR, boolean_type_node,
 			 stride, gfc_index_zero_node);
       tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
 			 gfc_index_one_node, stride);
       stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
-      gfc_add_modify (&block, stride, tmp);
+      gfc_add_modify (&init, stride, tmp);
 
       /* Allow the user to disable array repacking.  */
       stmt_unpacked = NULL_TREE;
@@ -4546,7 +4539,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
     }
   else
     tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
-  gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
+  gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
 
   offset = gfc_index_zero_node;
   size = gfc_index_one_node;
@@ -4561,34 +4554,34 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 	  dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
 	}
       else
-        {
+	{
 	  dubound = NULL_TREE;
 	  dlbound = NULL_TREE;
-        }
+	}
 
       lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
       if (!INTEGER_CST_P (lbound))
-        {
-          gfc_init_se (&se, NULL);
-          gfc_conv_expr_type (&se, sym->as->lower[n],
-                              gfc_array_index_type);
-          gfc_add_block_to_block (&block, &se.pre);
-          gfc_add_modify (&block, lbound, se.expr);
-        }
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, sym->as->lower[n],
+			      gfc_array_index_type);
+	  gfc_add_block_to_block (&init, &se.pre);
+	  gfc_add_modify (&init, lbound, se.expr);
+	}
 
       ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
       /* Set the desired upper bound.  */
       if (sym->as->upper[n])
 	{
 	  /* We know what we want the upper bound to be.  */
-          if (!INTEGER_CST_P (ubound))
-            {
+	  if (!INTEGER_CST_P (ubound))
+	    {
 	      gfc_init_se (&se, NULL);
 	      gfc_conv_expr_type (&se, sym->as->upper[n],
-                                  gfc_array_index_type);
-	      gfc_add_block_to_block (&block, &se.pre);
-              gfc_add_modify (&block, ubound, se.expr);
-            }
+				  gfc_array_index_type);
+	      gfc_add_block_to_block (&init, &se.pre);
+	      gfc_add_modify (&init, ubound, se.expr);
+	    }
 
 	  /* Check the sizes match.  */
 	  if (checkparm)
@@ -4607,11 +4600,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 	      stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
 				     gfc_index_one_node, stride2);
 
-              tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
+	      tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
 	      asprintf (&msg, "Dimension %d of array '%s' has extent "
-		        "%%ld instead of %%ld", n+1, sym->name);
+			"%%ld instead of %%ld", n+1, sym->name);
 
-	      gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, 
+	      gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, 
 			fold_convert (long_integer_type_node, temp),
 			fold_convert (long_integer_type_node, stride2));
 
@@ -4622,10 +4615,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 	{
 	  /* For assumed shape arrays move the upper bound by the same amount
 	     as the lower bound.  */
-          tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 			     dubound, dlbound);
-          tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
-          gfc_add_modify (&block, ubound, tmp);
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
+	  gfc_add_modify (&init, ubound, tmp);
 	}
       /* The offset of this dimension.  offset = offset - lbound * stride.  */
       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
@@ -4633,41 +4626,39 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 
       /* The size of this dimension, and the stride of the next.  */
       if (n + 1 < sym->as->rank)
-        {
-          stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
+	{
+	  stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
 
-          if (no_repack || partial != NULL_TREE)
-            {
-              stmt_unpacked =
-                gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
-            }
+	  if (no_repack || partial != NULL_TREE)
+	    stmt_unpacked =
+	      gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
 
-          /* Figure out the stride if not a known constant.  */
-          if (!INTEGER_CST_P (stride))
-            {
-              if (no_repack)
-                stmt_packed = NULL_TREE;
-              else
-                {
-                  /* Calculate stride = size * (ubound + 1 - lbound).  */
-                  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+	  /* Figure out the stride if not a known constant.  */
+	  if (!INTEGER_CST_P (stride))
+	    {
+	      if (no_repack)
+		stmt_packed = NULL_TREE;
+	      else
+		{
+		  /* Calculate stride = size * (ubound + 1 - lbound).  */
+		  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 				     gfc_index_one_node, lbound);
-                  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+		  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
 				     ubound, tmp);
-                  size = fold_build2 (MULT_EXPR, gfc_array_index_type,
+		  size = fold_build2 (MULT_EXPR, gfc_array_index_type,
 				      size, tmp);
-                  stmt_packed = size;
-                }
+		  stmt_packed = size;
+		}
 
-              /* Assign the stride.  */
-              if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
+	      /* Assign the stride.  */
+	      if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
 		tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
 				   stmt_unpacked, stmt_packed);
-              else
-                tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
-              gfc_add_modify (&block, stride, tmp);
-            }
-        }
+	      else
+		tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
+	      gfc_add_modify (&init, stride, tmp);
+	    }
+	}
       else
 	{
 	  stride = GFC_TYPE_ARRAY_SIZE (type);
@@ -4681,20 +4672,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 				 ubound, tmp);
 	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
 				 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
-	      gfc_add_modify (&block, stride, tmp);
+	      gfc_add_modify (&init, stride, tmp);
 	    }
 	}
     }
 
   /* Set the offset.  */
   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
-    gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
 
-  gfc_trans_vla_type_sizes (sym, &block);
+  gfc_trans_vla_type_sizes (sym, &init);
 
-  stmt = gfc_finish_block (&block);
-
-  gfc_start_block (&block);
+  stmtInit = gfc_finish_block (&init);
 
   /* Only do the entry/initialization code if the arg is present.  */
   dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
@@ -4704,18 +4693,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
   if (optional_arg)
     {
       tmp = gfc_conv_expr_present (sym);
-      stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+      stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
+			   build_empty_stmt (input_location));
     }
-  gfc_add_expr_to_block (&block, stmt);
-
-  /* Add the main function body.  */
-  gfc_add_expr_to_block (&block, body);
 
   /* Cleanup code.  */
-  if (!no_repack)
+  if (no_repack)
+    stmtCleanup = NULL_TREE;
+  else
     {
+      stmtblock_t cleanup;
       gfc_start_block (&cleanup);
-      
+
       if (sym->attr.intent != INTENT_IN)
 	{
 	  /* Copy the data back.  */
@@ -4728,26 +4717,26 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
       tmp = gfc_call_free (tmpdesc);
       gfc_add_expr_to_block (&cleanup, tmp);
 
-      stmt = gfc_finish_block (&cleanup);
+      stmtCleanup = gfc_finish_block (&cleanup);
 	
       /* Only do the cleanup if the array was repacked.  */
-      tmp = build_fold_indirect_ref_loc (input_location,
-				     dumdesc);
+      tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
       tmp = gfc_conv_descriptor_data_get (tmp);
       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
-      stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+      stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
+			      build_empty_stmt (input_location));
 
       if (optional_arg)
-        {
-          tmp = gfc_conv_expr_present (sym);
-          stmt = build3_v (COND_EXPR, tmp, stmt,
-			   build_empty_stmt (input_location));
-        }
-      gfc_add_expr_to_block (&block, stmt);
+	{
+	  tmp = gfc_conv_expr_present (sym);
+	  stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
+				  build_empty_stmt (input_location));
+	}
     }
+
   /* We don't need to free any memory allocated by internal_pack as it will
      be freed at the end of the function by pop_context.  */
-  return gfc_finish_block (&block);
+  gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
 }
 
 
@@ -6217,13 +6206,14 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
    Do likewise, recursively if necessary, with the allocatable components of
    derived types.  */
 
-tree
-gfc_trans_deferred_array (gfc_symbol * sym, tree body)
+void
+gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
 {
   tree type;
   tree tmp;
   tree descriptor;
-  stmtblock_t fnblock;
+  stmtblock_t init;
+  stmtblock_t cleanup;
   locus loc;
   int rank;
   bool sym_has_alloc_comp;
@@ -6237,7 +6227,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
 		 "allocatable attribute or derived type without allocatable "
 		 "components.");
 
-  gfc_init_block (&fnblock);
+  gfc_init_block (&init);
 
   gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
 		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
@@ -6245,16 +6235,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
     {
-      gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
-      gfc_trans_vla_type_sizes (sym, &fnblock);
+      gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+      gfc_trans_vla_type_sizes (sym, &init);
     }
 
   /* Dummy, use associated and result variables don't need anything special.  */
   if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
     {
-      gfc_add_expr_to_block (&fnblock, body);
-
-      return gfc_finish_block (&fnblock);
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
     }
 
   gfc_get_backend_locus (&loc);
@@ -6268,7 +6257,9 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
     {
       /* SAVEd variables are not freed on exit.  */
       gfc_trans_static_array_pointer (sym);
-      return body;
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
     }
 
   /* Get the descriptor type.  */
@@ -6283,14 +6274,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
 	      || !gfc_has_default_initializer (sym->ts.u.derived))
 	    {
 	      rank = sym->as ? sym->as->rank : 0;
-	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
-	      gfc_add_expr_to_block (&fnblock, tmp);
+	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
+					    descriptor, rank);
+	      gfc_add_expr_to_block (&init, tmp);
 	    }
 	  else
-	    {
-	      tmp = gfc_init_default_dt (sym, NULL, false);
-	      gfc_add_expr_to_block (&fnblock, tmp);
-	    }
+	    gfc_init_default_dt (sym, &init, false);
 	}
     }
   else if (!GFC_DESCRIPTOR_TYPE_P (type))
@@ -6298,16 +6287,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
       /* If the backend_decl is not a descriptor, we must have a pointer
 	 to one.  */
       descriptor = build_fold_indirect_ref_loc (input_location,
-					    sym->backend_decl);
+						sym->backend_decl);
       type = TREE_TYPE (descriptor);
     }
   
   /* NULLIFY the data pointer.  */
   if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
-    gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
-
-  gfc_add_expr_to_block (&fnblock, body);
+    gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
 
+  gfc_init_block (&cleanup);
   gfc_set_backend_locus (&loc);
 
   /* Allocatable arrays need to be freed when they go out of scope.
@@ -6318,17 +6306,18 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
       int rank;
       rank = sym->as ? sym->as->rank : 0;
       tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
-      gfc_add_expr_to_block (&fnblock, tmp);
+      gfc_add_expr_to_block (&cleanup, tmp);
     }
 
   if (sym->attr.allocatable && sym->attr.dimension
       && !sym->attr.save && !sym->attr.result)
     {
       tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
-      gfc_add_expr_to_block (&fnblock, tmp);
+      gfc_add_expr_to_block (&cleanup, tmp);
     }
 
-  return gfc_finish_block (&fnblock);
+  gfc_add_init_cleanup (block, gfc_finish_block (&init),
+			gfc_finish_block (&cleanup));
 }
 
 /************ Expression Walking Functions ******************/

gcc/fortran/trans-array.h

@@ -37,11 +37,11 @@ tree gfc_trans_create_temp_array (stmtblock_t *, stmtblock_t *, gfc_loopinfo *,
 
 /* Generate function entry code for allocation of compiler allocated array
    variables.  */
-tree gfc_trans_auto_array_allocation (tree, gfc_symbol *, tree);
+void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *);
 /* Generate entry and exit code for dummy array parameters.  */
-tree gfc_trans_dummy_array_bias (gfc_symbol *, tree, tree);
+void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
 /* Generate entry and exit code for g77 calling convention arrays.  */
-tree gfc_trans_g77_array (gfc_symbol *, tree);
+void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate code to deallocate an array, if it is allocated.  */
 tree gfc_trans_dealloc_allocated (tree);
 
@@ -58,7 +58,7 @@ tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
 tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
 
 /* Add initialization for deferred arrays.  */
-tree gfc_trans_deferred_array (gfc_symbol *, tree);
+void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate an initializer for a static pointer or allocatable array.  */
 void gfc_trans_static_array_pointer (gfc_symbol *);
 

gcc/fortran/trans-decl.c

@@ -2838,72 +2838,70 @@ gfc_build_builtin_function_decls (void)
 
 /* Evaluate the length of dummy character variables.  */
 
-static tree
-gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
+static void
+gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
+			   gfc_wrapped_block *block)
 {
-  stmtblock_t body;
+  stmtblock_t init;
 
   gfc_finish_decl (cl->backend_decl);
 
-  gfc_start_block (&body);
+  gfc_start_block (&init);
 
   /* Evaluate the string length expression.  */
-  gfc_conv_string_length (cl, NULL, &body);
+  gfc_conv_string_length (cl, NULL, &init);
 
-  gfc_trans_vla_type_sizes (sym, &body);
+  gfc_trans_vla_type_sizes (sym, &init);
 
-  gfc_add_expr_to_block (&body, fnbody);
-  return gfc_finish_block (&body);
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
 }
 
 
 /* Allocate and cleanup an automatic character variable.  */
 
-static tree
-gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
+static void
+gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
 {
-  stmtblock_t body;
+  stmtblock_t init;
   tree decl;
   tree tmp;
 
   gcc_assert (sym->backend_decl);
   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
 
-  gfc_start_block (&body);
+  gfc_start_block (&init);
 
   /* Evaluate the string length expression.  */
-  gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
+  gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
 
-  gfc_trans_vla_type_sizes (sym, &body);
+  gfc_trans_vla_type_sizes (sym, &init);
 
   decl = sym->backend_decl;
 
   /* Emit a DECL_EXPR for this variable, which will cause the
      gimplifier to allocate storage, and all that good stuff.  */
   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
-  gfc_add_expr_to_block (&body, tmp);
+  gfc_add_expr_to_block (&init, tmp);
 
-  gfc_add_expr_to_block (&body, fnbody);
-  return gfc_finish_block (&body);
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
 }
 
 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
 
-static tree
-gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
+static void
+gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
 {
-  stmtblock_t body;
+  stmtblock_t init;
 
   gcc_assert (sym->backend_decl);
-  gfc_start_block (&body);
+  gfc_start_block (&init);
 
   /* Set the initial value to length. See the comments in
      function gfc_add_assign_aux_vars in this file.  */
-  gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
-		       build_int_cst (NULL_TREE, -2));
+  gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
+		  build_int_cst (NULL_TREE, -2));
 
-  gfc_add_expr_to_block (&body, fnbody);
-  return gfc_finish_block (&body);
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
 }
 
 static void
@@ -3016,15 +3014,15 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
 /* Initialize a derived type by building an lvalue from the symbol
    and using trans_assignment to do the work. Set dealloc to false
    if no deallocation prior the assignment is needed.  */
-tree
-gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
+void
+gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
 {
-  stmtblock_t fnblock;
   gfc_expr *e;
   tree tmp;
   tree present;
 
-  gfc_init_block (&fnblock);
+  gcc_assert (block);
+
   gcc_assert (!sym->attr.allocatable);
   gfc_set_sym_referenced (sym);
   e = gfc_lval_expr_from_sym (sym);
@@ -3036,11 +3034,8 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
 		    tmp, build_empty_stmt (input_location));
     }
-  gfc_add_expr_to_block (&fnblock, tmp);
+  gfc_add_expr_to_block (block, tmp);
   gfc_free_expr (e);
-  if (body)
-    gfc_add_expr_to_block (&fnblock, body);
-  return gfc_finish_block (&fnblock);
 }
 
 
@@ -3048,15 +3043,15 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
    them their default initializer, if they do not have allocatable
    components, they have their allocatable components deallocated. */
 
-static tree
-init_intent_out_dt (gfc_symbol * proc_sym, tree body)
+static void
+init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 {
-  stmtblock_t fnblock;
+  stmtblock_t init;
   gfc_formal_arglist *f;
   tree tmp;
   tree present;
 
-  gfc_init_block (&fnblock);
+  gfc_init_block (&init);
   for (f = proc_sym->formal; f; f = f->next)
     if (f->sym && f->sym->attr.intent == INTENT_OUT
 	&& !f->sym->attr.pointer
@@ -3076,14 +3071,13 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
 			      tmp, build_empty_stmt (input_location));
 	      }
 
-	    gfc_add_expr_to_block (&fnblock, tmp);
+	    gfc_add_expr_to_block (&init, tmp);
 	  }
        else if (f->sym->value)
-	  body = gfc_init_default_dt (f->sym, body, true);
+	  gfc_init_default_dt (f->sym, &init, true);
       }
 
-  gfc_add_expr_to_block (&fnblock, body);
-  return gfc_finish_block (&fnblock);
+  gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
 }
 
 
@@ -3101,9 +3095,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
   locus loc;
   gfc_symbol *sym;
   gfc_formal_arglist *f;
-  stmtblock_t body;
+  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)
@@ -3125,19 +3122,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
       else if (proc_sym->as)
 	{
 	  tree result = TREE_VALUE (current_fake_result_decl);
-	  fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
+	  gfc_trans_dummy_array_bias (proc_sym, result, &try_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)
-	    fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
-						fnbody);
+	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block);
 	}
       else if (proc_sym->ts.type == BT_CHARACTER)
 	{
 	  if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
-	    fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
-						fnbody);
+	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block);
 	}
       else
 	gcc_assert (gfc_option.flag_f2c
@@ -3147,7 +3142,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
      should be done here so that the offsets and lbounds of arrays
      are available.  */
-  fnbody = init_intent_out_dt (proc_sym, fnbody);
+  init_intent_out_dt (proc_sym, &try_block);
 
   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
     {
@@ -3159,8 +3154,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	    {
 	    case AS_EXPLICIT:
 	      if (sym->attr.dummy || sym->attr.result)
-		fnbody =
-		  gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
+		gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block);
 	      else if (sym->attr.pointer || sym->attr.allocatable)
 		{
 		  if (TREE_STATIC (sym->backend_decl))
@@ -3168,7 +3162,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 		  else
 		    {
 		      seen_trans_deferred_array = true;
-		      fnbody = gfc_trans_deferred_array (sym, fnbody);
+		      gfc_trans_deferred_array (sym, &try_block);
 		    }
 		}
 	      else
@@ -3176,18 +3170,24 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 		  if (sym_has_alloc_comp)
 		    {
 		      seen_trans_deferred_array = true;
-		      fnbody = gfc_trans_deferred_array (sym, fnbody);
+		      gfc_trans_deferred_array (sym, &try_block);
 		    }
 		  else if (sym->ts.type == BT_DERIVED
 			     && sym->value
 			     && !sym->attr.data
 			     && sym->attr.save == SAVE_NONE)
-		    fnbody = gfc_init_default_dt (sym, fnbody, false);
+		    {
+		      gfc_start_block (&tmpblock);
+		      gfc_init_default_dt (sym, &tmpblock, false);
+		      gfc_add_init_cleanup (&try_block,
+					    gfc_finish_block (&tmpblock),
+					    NULL_TREE);
+		    }
 
 		  gfc_get_backend_locus (&loc);
 		  gfc_set_backend_locus (&sym->declared_at);
-		  fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
-		      sym, fnbody);
+		  gfc_trans_auto_array_allocation (sym->backend_decl,
+						   sym, &try_block);
 		  gfc_set_backend_locus (&loc);
 		}
 	      break;
@@ -3198,27 +3198,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 
 	      /* We should always pass assumed size arrays the g77 way.  */
 	      if (sym->attr.dummy)
-		fnbody = gfc_trans_g77_array (sym, fnbody);
-              break;
+		gfc_trans_g77_array (sym, &try_block);
+	      break;
 
 	    case AS_ASSUMED_SHAPE:
 	      /* Must be a dummy parameter.  */
 	      gcc_assert (sym->attr.dummy);
 
-	      fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
-						   fnbody);
+	      gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block);
 	      break;
 
 	    case AS_DEFERRED:
 	      seen_trans_deferred_array = true;
-	      fnbody = gfc_trans_deferred_array (sym, fnbody);
+	      gfc_trans_deferred_array (sym, &try_block);
 	      break;
 
 	    default:
 	      gcc_unreachable ();
 	    }
 	  if (sym_has_alloc_comp && !seen_trans_deferred_array)
-	    fnbody = gfc_trans_deferred_array (sym, fnbody);
+	    gfc_trans_deferred_array (sym, &try_block);
 	}
       else if (sym->attr.allocatable
 	       || (sym->ts.type == BT_CLASS
@@ -3231,7 +3230,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	      tree tmp;
 	      gfc_expr *e;
 	      gfc_se se;
-	      stmtblock_t block;
+	      stmtblock_t init;
 
 	      e = gfc_lval_expr_from_sym (sym);
 	      if (sym->ts.type == BT_CLASS)
@@ -3243,49 +3242,53 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	      gfc_free_expr (e);
 
 	      /* Nullify when entering the scope.  */
-	      gfc_start_block (&block);
-	      gfc_add_modify (&block, se.expr,
+	      gfc_start_block (&init);
+	      gfc_add_modify (&init, se.expr,
 			      fold_convert (TREE_TYPE (se.expr),
 					    null_pointer_node));
-	      gfc_add_expr_to_block (&block, fnbody);
 
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
 	      tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
 						NULL);
-	      gfc_add_expr_to_block (&block, tmp);
-	      fnbody = gfc_finish_block (&block);
+
+	      gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), tmp);
 	    }
 	}
       else if (sym_has_alloc_comp)
-	fnbody = gfc_trans_deferred_array (sym, fnbody);
+	gfc_trans_deferred_array (sym, &try_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)
-	    fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
+	    gfc_trans_dummy_character (sym, sym->ts.u.cl, &try_block);
 	  else
-	    fnbody = gfc_trans_auto_character_variable (sym, fnbody);
+	    gfc_trans_auto_character_variable (sym, &try_block);
 	  gfc_set_backend_locus (&loc);
 	}
       else if (sym->attr.assign)
 	{
 	  gfc_get_backend_locus (&loc);
 	  gfc_set_backend_locus (&sym->declared_at);
-	  fnbody = gfc_trans_assign_aux_var (sym, fnbody);
+	  gfc_trans_assign_aux_var (sym, &try_block);
 	  gfc_set_backend_locus (&loc);
 	}
       else if (sym->ts.type == BT_DERIVED
 		 && sym->value
 		 && !sym->attr.data
 		 && sym->attr.save == SAVE_NONE)
-	fnbody = gfc_init_default_dt (sym, fnbody, false);
+	{
+	  gfc_start_block (&tmpblock);
+	  gfc_init_default_dt (sym, &tmpblock, false);
+	  gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock),
+				NULL_TREE);
+	}
       else
 	gcc_unreachable ();
     }
 
-  gfc_init_block (&body);
+  gfc_init_block (&tmpblock);
 
   for (f = proc_sym->formal; f; f = f->next)
     {
@@ -3293,7 +3296,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	{
 	  gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
 	  if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
-	    gfc_trans_vla_type_sizes (f->sym, &body);
+	    gfc_trans_vla_type_sizes (f->sym, &tmpblock);
 	}
     }
 
@@ -3302,11 +3305,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
     {
       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
-	gfc_trans_vla_type_sizes (proc_sym, &body);
+	gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
     }
 
-  gfc_add_expr_to_block (&body, fnbody);
-  return gfc_finish_block (&body);
+  gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), NULL_TREE);
+
+  return gfc_finish_wrapped_block (&try_block);
 }
 
 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;

gcc/fortran/trans.c

@@ -977,31 +977,47 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
   return res;
 }
 
-/* Add a statement to a block.  */
 
-void
-gfc_add_expr_to_block (stmtblock_t * block, tree expr)
-{
-  gcc_assert (block);
+/* Add an expression to another one, either at the front or the back.  */
 
+static void
+add_expr_to_chain (tree* chain, tree expr, bool front)
+{
   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
     return;
 
-  if (block->head)
+  if (*chain)
     {
-      if (TREE_CODE (block->head) != STATEMENT_LIST)
+      if (TREE_CODE (*chain) != STATEMENT_LIST)
 	{
 	  tree tmp;
 
-	  tmp = block->head;
-	  block->head = NULL_TREE;
-	  append_to_statement_list (tmp, &block->head);
+	  tmp = *chain;
+	  *chain = NULL_TREE;
+	  append_to_statement_list (tmp, chain);
 	}
-      append_to_statement_list (expr, &block->head);
+
+      if (front)
+	{
+	  tree_stmt_iterator i;
+
+	  i = tsi_start (*chain);
+	  tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
+	}
+      else
+	append_to_statement_list (expr, chain);
     }
   else
-    /* Don't bother creating a list if we only have a single statement.  */
-    block->head = expr;
+    *chain = expr;
+}
+
+/* Add a statement to a block.  */
+
+void
+gfc_add_expr_to_block (stmtblock_t * block, tree expr)
+{
+  gcc_assert (block);
+  add_expr_to_chain (&block->head, expr, false);
 }
 
 
@@ -1393,3 +1409,55 @@ gfc_generate_module_code (gfc_namespace * ns)
     }
 }
 
+
+/* Initialize an init/cleanup block with existing code.  */
+
+void
+gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
+{
+  gcc_assert (block);
+
+  block->init = NULL_TREE;
+  block->code = code;
+  block->cleanup = NULL_TREE;
+}
+
+
+/* Add a new pair of initializers/clean-up code.  */
+
+void
+gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
+{
+  gcc_assert (block);
+
+  /* The new pair of init/cleanup should be "wrapped around" the existing
+     block of code, thus the initialization is added to the front and the
+     cleanup to the back.  */
+  add_expr_to_chain (&block->init, init, true);
+  add_expr_to_chain (&block->cleanup, cleanup, false);
+}
+
+
+/* Finish up a wrapped block by building a corresponding try-finally expr.  */
+
+tree
+gfc_finish_wrapped_block (gfc_wrapped_block* block)
+{
+  tree result;
+
+  gcc_assert (block);
+
+  /* Build the final expression.  For this, just add init and body together,
+     and put clean-up with that into a TRY_FINALLY_EXPR.  */
+  result = block->init;
+  add_expr_to_chain (&result, block->code, false);
+  if (block->cleanup)
+    result = build2 (TRY_FINALLY_EXPR, void_type_node, result, block->cleanup);
+  
+  /* Clear the block.  */
+  block->init = NULL_TREE;
+  block->code = NULL_TREE;
+  block->cleanup = NULL_TREE;
+
+  return result;
+}

gcc/fortran/trans.h

@@ -258,6 +258,29 @@ typedef struct
 gfc_saved_var;
 
 
+/* Store information about a block of code together with special
+   initialization and clean-up code.  This can be used to incrementally add
+   init and cleanup, and in the end put everything together to a
+   try-finally expression.  */
+typedef struct
+{
+  tree init;
+  tree cleanup;
+  tree code;
+}
+gfc_wrapped_block;
+
+
+/* Initialize an init/cleanup block.  */
+void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
+/* Add a pair of init/cleanup code to the block.  Each one might be a
+   NULL_TREE if not required.  */
+void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup);
+/* Finalize the block, that is, create a single expression encapsulating the
+   original code together with init and clean-up code.  */
+tree gfc_finish_wrapped_block (gfc_wrapped_block* block);
+
+
 /* Advance the SS chain to the next term.  */
 void gfc_advance_se_ss_chain (gfc_se *);
 
@@ -403,7 +426,7 @@ tree gfc_get_symbol_decl (gfc_symbol *);
 tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool);
 
 /* Assign a default initializer to a derived type.  */
-tree gfc_init_default_dt (gfc_symbol *, tree, bool);
+void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool);
 
 /* Substitute a temporary variable in place of the real one.  */
 void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);