===================================================================
@@ -4265,10 +4265,11 @@ gfc_trans_array_bounds (tree type, gfc_s
/* 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 de
/* 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 de
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 de
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, t
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, t
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, t
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, t
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 *
/* 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 *
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 *
{
/* 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 *
}
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 *
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 *
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 *
{
/* 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 *
/* 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]);
- }
-
- /* 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,
+ 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,
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 *
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 *
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 *
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 * d
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 * s
"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 * s
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 * s
{
/* 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 * s
|| !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 * s
/* 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 * s
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 ******************/
===================================================================
@@ -37,11 +37,11 @@ tree gfc_trans_create_temp_array (stmtbl
/* 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 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 *);
===================================================================
@@ -977,31 +977,47 @@ gfc_call_realloc (stmtblock_t * block, t
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
}
}
+
+/* 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;
+}
===================================================================
@@ -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 *);
===================================================================
@@ -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 *sy
/* 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, t
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, t
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_sy
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 * pr
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 * pr
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 * pr
/* 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 * pr
{
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 * pr
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 * pr
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 * pr
/* 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 * pr
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 * pr
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 * pr
{
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 * pr
{
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;