static GTY(()) tree current_fake_result_decl;
static GTY(()) tree parent_fake_result_decl;
-static GTY(()) tree current_function_return_label;
-
/* Holds the variable DECLs for the current function. */
static gfc_namespace *module_namespace;
+/* The currently processed procedure symbol. */
+static gfc_symbol* current_procedure_symbol = NULL;
+
/* List of static constructor functions. */
gcc_assert (decl);
DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
DECL_NONLOCAL (decl) = 1;
- TREE_CHAIN (decl) = saved_parent_function_decls;
+ DECL_CHAIN (decl) = saved_parent_function_decls;
saved_parent_function_decls = decl;
}
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
- TREE_CHAIN (decl) = saved_function_decls;
+ DECL_CHAIN (decl) = saved_function_decls;
saved_function_decls = decl;
}
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
- TREE_CHAIN (decl) = saved_local_decls;
+ DECL_CHAIN (decl) = saved_local_decls;
saved_local_decls = decl;
}
}
-/* Returns the return label for the current function. */
-
-tree
-gfc_get_return_label (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 10];
-
- if (current_function_return_label)
- return current_function_return_label;
-
- sprintf (name, "__return_%s",
- IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
-
- current_function_return_label =
- gfc_build_label_decl (get_identifier (name));
-
- DECL_ARTIFICIAL (current_function_return_label) = 1;
-
- return current_function_return_label;
-}
-
-
/* Set the backend source location of a decl. */
void
gtype = build_array_type (gtype, rtype);
/* Ensure the bound variables aren't optimized out at -O0.
For -O1 and above they often will be optimized out, but
- can be tracked by VTA. Also clear the artificial
- lbound.N or ubound.N DECL_NAME, so that it doesn't end up
- in debug info. */
+ can be tracked by VTA. Also set DECL_NAMELESS, so that
+ the artificial lbound.N or ubound.N DECL_NAME doesn't
+ end up in debug info. */
if (lbound && TREE_CODE (lbound) == VAR_DECL
&& DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
{
if (DECL_NAME (lbound)
&& strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
"lbound") != 0)
- DECL_NAME (lbound) = NULL_TREE;
+ DECL_NAMELESS (lbound) = 1;
DECL_IGNORED_P (lbound) = 0;
}
if (ubound && TREE_CODE (ubound) == VAR_DECL
if (DECL_NAME (ubound)
&& strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
"ubound") != 0)
- DECL_NAME (ubound) = NULL_TREE;
+ DECL_NAMELESS (ubound) = 1;
DECL_IGNORED_P (ubound) = 0;
}
}
VAR_DECL, get_identifier (name), type);
DECL_ARTIFICIAL (decl) = 1;
+ DECL_NAMELESS (decl) = 1;
TREE_PUBLIC (decl) = 0;
TREE_STATIC (decl) = 0;
DECL_EXTERNAL (decl) = 0;
SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
DECL_HAS_VALUE_EXPR_P (decl) = 1;
DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
- TREE_CHAIN (decl) = nonlocal_dummy_decls;
+ DECL_CHAIN (decl) = nonlocal_dummy_decls;
nonlocal_dummy_decls = decl;
}
/* For entry master function skip over the __entry
argument. */
if (sym->ns->proc_name->attr.entry_master)
- sym->backend_decl = TREE_CHAIN (sym->backend_decl);
+ sym->backend_decl = DECL_CHAIN (sym->backend_decl);
}
/* Dummy variables should already have been created. */
return sym->backend_decl;
/* If use associated and whole file compilation, use the module
- declaration. This is only needed for intrinsic types because
- they are substituted for one another during optimization. */
+ declaration. */
if (gfc_option.flag_whole_file
&& sym->attr.flavor == FL_VARIABLE
- && sym->ts.type != BT_DERIVED
&& sym->attr.use_assoc
&& sym->module)
{
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
if (s && s->backend_decl)
{
+ if (sym->ts.type == BT_DERIVED)
+ gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
+ true);
if (sym->ts.type == BT_CHARACTER)
sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
return s->backend_decl;
tree ref = DECL_ARGUMENTS (current_function_decl);
VEC_safe_push (tree, gc, args, ref);
if (ns->proc_name->ts.type == BT_CHARACTER)
- VEC_safe_push (tree, gc, args, TREE_CHAIN (ref));
+ VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
}
}
gfc_add_expr_to_block (&body, tmp);
for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
- field; field = TREE_CHAIN (field))
+ field; field = DECL_CHAIN (field))
if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
thunk_sym->result->name) == 0)
break;
tree field;
for (field = TYPE_FIELDS (TREE_TYPE (decl));
- field; field = TREE_CHAIN (field))
+ field; field = DECL_CHAIN (field))
if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
sym->name) == 0)
break;
if (sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master)
- decl = TREE_CHAIN (decl);
+ decl = DECL_CHAIN (decl);
TREE_USED (decl) = 1;
if (sym->as)
/* 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);
}
Initialization of ASSIGN statement auxiliary variable.
Automatic deallocation. */
-tree
-gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
+void
+gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
locus loc;
gfc_symbol *sym;
gfc_formal_arglist *f;
- stmtblock_t body;
+ stmtblock_t tmpblock;
bool seen_trans_deferred_array = false;
/* Deal with implicit return variables. Explicit return variables will
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, 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, 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, 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, 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, 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, block);
}
}
else
if (sym_has_alloc_comp)
{
seen_trans_deferred_array = true;
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, 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 (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, 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, 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, block);
break;
case AS_DEFERRED:
seen_trans_deferred_array = true;
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, 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, 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);
+ tmp = NULL;
+ if (!sym->attr.result)
+ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
+ true, NULL);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
else if (sym_has_alloc_comp)
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
- fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
+ gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
else
- fnbody = gfc_trans_auto_character_variable (sym, fnbody);
+ gfc_trans_auto_character_variable (sym, block);
gfc_set_backend_locus (&loc);
}
else if (sym->attr.assign)
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
- fnbody = gfc_trans_assign_aux_var (sym, fnbody);
+ gfc_trans_assign_aux_var (sym, 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 (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 (block, gfc_finish_block (&tmpblock), NULL_TREE);
}
static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
}
+/* Get the result expression for a procedure. */
+
+static tree
+get_proc_result (gfc_symbol* sym)
+{
+ if (sym->attr.subroutine || sym == sym->result)
+ {
+ if (current_fake_result_decl != NULL)
+ return TREE_VALUE (current_fake_result_decl);
+
+ return NULL_TREE;
+ }
+
+ return sym->result->backend_decl;
+}
+
+
+/* Generate an appropriate return-statement for a procedure. */
+
+tree
+gfc_generate_return (void)
+{
+ gfc_symbol* sym;
+ tree result;
+ tree fndecl;
+
+ sym = current_procedure_symbol;
+ fndecl = sym->backend_decl;
+
+ if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
+ result = NULL_TREE;
+ else
+ {
+ result = get_proc_result (sym);
+
+ /* Set the return value to the dummy result variable. The
+ types may be different for scalar default REAL functions
+ with -ff2c, therefore we have to convert. */
+ if (result != NULL_TREE)
+ {
+ result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
+ result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
+ DECL_RESULT (fndecl), result);
+ }
+ }
+
+ return build1_v (RETURN_EXPR, result);
+}
+
+
/* Generate code for a function. */
void
tree old_context;
tree decl;
tree tmp;
- tree tmp2;
- stmtblock_t block;
+ stmtblock_t init, cleanup;
stmtblock_t body;
- tree result;
+ gfc_wrapped_block try_block;
tree recurcheckvar = NULL_TREE;
gfc_symbol *sym;
+ gfc_symbol *previous_procedure_symbol;
int rank;
bool is_recursive;
sym = ns->proc_name;
+ previous_procedure_symbol = current_procedure_symbol;
+ current_procedure_symbol = sym;
/* Check that the frontend isn't still using this. */
gcc_assert (sym->tlink == NULL);
trans_function_start (sym);
- gfc_init_block (&block);
+ gfc_init_block (&init);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
else
current_fake_result_decl = NULL_TREE;
- current_function_return_label = NULL;
+ is_recursive = sym->attr.recursive
+ || (sym->attr.entry_master
+ && sym->ns->entries->sym->attr.recursive);
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_recursive)
+ {
+ char * msg;
+
+ asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+ sym->name);
+ recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+ TREE_STATIC (recurcheckvar) = 1;
+ DECL_INITIAL (recurcheckvar) = boolean_false_node;
+ gfc_add_expr_to_block (&init, recurcheckvar);
+ gfc_trans_runtime_check (true, false, recurcheckvar, &init,
+ &sym->declared_at, msg);
+ gfc_add_modify (&init, recurcheckvar, boolean_true_node);
+ gfc_free (msg);
+ }
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
- is_recursive = sym->attr.recursive
- || (sym->attr.entry_master
- && sym->ns->entries->sym->attr.recursive);
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
- && !is_recursive
- && !gfc_option.flag_recursive)
- {
- char * msg;
-
- asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
- sym->name);
- recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
- TREE_STATIC (recurcheckvar) = 1;
- DECL_INITIAL (recurcheckvar) = boolean_false_node;
- gfc_add_expr_to_block (&block, recurcheckvar);
- gfc_trans_runtime_check (true, false, recurcheckvar, &block,
- &sym->declared_at, msg);
- gfc_add_modify (&block, recurcheckvar, boolean_true_node);
- gfc_free (msg);
- }
-
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
- && sym->attr.subroutine)
+ && sym->attr.subroutine)
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym, 0);
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
- /* Add a return label if needed. */
- if (current_function_return_label)
- {
- tmp = build1_v (LABEL_EXPR, current_function_return_label);
- gfc_add_expr_to_block (&body, tmp);
- }
-
- tmp = gfc_finish_block (&body);
- /* Add code to create and cleanup arrays. */
- tmp = gfc_trans_deferred_vars (sym, tmp);
-
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
- if (sym->attr.subroutine || sym == sym->result)
- {
- if (current_fake_result_decl != NULL)
- result = TREE_VALUE (current_fake_result_decl);
- else
- result = NULL_TREE;
- current_fake_result_decl = NULL_TREE;
- }
- else
- result = sym->result->backend_decl;
+ tree result = get_proc_result (sym);
if (result != NULL_TREE
&& sym->attr.function
&& sym->ts.u.derived->attr.alloc_comp)
{
rank = sym->as ? sym->as->rank : 0;
- tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
- gfc_add_expr_to_block (&block, tmp2);
+ tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
+ gfc_add_expr_to_block (&init, tmp);
}
else if (sym->attr.allocatable && sym->attr.dimension == 0)
- gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
- null_pointer_node));
- }
-
- gfc_add_expr_to_block (&block, tmp);
-
- /* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
- && !is_recursive
- && !gfc_option.flag_openmp
- && recurcheckvar != NULL_TREE)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
+ gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
+ null_pointer_node));
}
if (result == NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
else
- {
- /* Set the return value to the dummy result variable. The
- types may be different for scalar default REAL functions
- with -ff2c, therefore we have to convert. */
- tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
- tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
- DECL_RESULT (fndecl), tmp);
- tmp = build1_v (RETURN_EXPR, tmp);
- gfc_add_expr_to_block (&block, tmp);
- }
+ gfc_add_expr_to_block (&body, gfc_generate_return ());
}
- else
+
+ gfc_init_block (&cleanup);
+
+ /* Reset recursion-check variable. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_openmp
+ && recurcheckvar != NULL_TREE)
{
- gfc_add_expr_to_block (&block, tmp);
- /* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
- && !is_recursive
- && !gfc_option.flag_openmp
- && recurcheckvar != NULL_TREE)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL_TREE;
- }
+ gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
}
+ /* Finish the function body and add init and cleanup code. */
+ tmp = gfc_finish_block (&body);
+ gfc_start_wrapped_block (&try_block, tmp);
+ /* Add code to create and cleanup arrays. */
+ gfc_trans_deferred_vars (sym, &try_block);
+ gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
+ gfc_finish_block (&cleanup));
/* Add all the decls we created during processing. */
decl = saved_function_decls;
{
tree next;
- next = TREE_CHAIN (decl);
- TREE_CHAIN (decl) = NULL_TREE;
+ next = DECL_CHAIN (decl);
+ DECL_CHAIN (decl) = NULL_TREE;
pushdecl (decl);
decl = next;
}
saved_function_decls = NULL_TREE;
- DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
+ DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
decl = getdecls ();
/* Finish off this function and send it for code generation. */
if (sym->attr.is_main_program)
create_main_function (fndecl);
+
+ current_procedure_symbol = previous_procedure_symbol;
}
{
tree next;
- next = TREE_CHAIN (decl);
- TREE_CHAIN (decl) = NULL_TREE;
+ next = DECL_CHAIN (decl);
+ DECL_CHAIN (decl) = NULL_TREE;
pushdecl (decl);
decl = next;
}