/* 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;
/* 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);
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
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;
tree offset;
tree tmp;
tree stmt;
- stmtblock_t block;
+ stmtblock_t init;
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
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)
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);
}
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;
/* 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);
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. */
{
/* 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;
}
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;
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)
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));
{
/* 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);
/* 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);
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);
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. */
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);
}
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;
"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);
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);
{
/* 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. */
|| !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))
/* 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.
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 ******************/
/* 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
/* 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);
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);
}
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
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);
}
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)
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
/* 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)
{
{
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))
else
{
seen_trans_deferred_array = true;
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, &try_block);
}
}
else
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;
/* 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
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)
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)
{
{
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);
}
}
{
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;
OSDN Git Service
