OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

trans.h (gfc_get_return_label): Removed.

Browse Source 
2010-07-21  Daniel Kraft  <d@domob.eu>

	* trans.h (gfc_get_return_label): Removed.
	(gfc_generate_return): New method.
	(gfc_trans_deferred_vars): Update gfc_wrapped_block rather than
	returning a tree directly.
	* trans-stmt.c (gfc_trans_return): Use `gfc_generate_return'.
	(gfc_trans_block_construct): Update for new interface to
	`gfc_trans_deferred_vars'.
	* trans-decl.c (current_function_return_label): Removed.
	(current_procedure_symbol): New variable.
	(gfc_get_return_label): Removed.
	(gfc_trans_deferred_vars): Update gfc_wrapped_block rather than
	returning a tree directly.
	(get_proc_result), (gfc_generate_return): New methods.
	(gfc_generate_function_code): Clean up and do init/cleanup here
	also with gfc_wrapped_block.  Remove return-label but rather
	return directly.

From-SVN: r162373
This commit is contained in:
Daniel Kraft 2010-07-21 15:44:38 +02:00 committed by Daniel Kraft
parent 426797b226
commit d74d8807cc
4 changed files with 166 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/fortran/ChangeLog
View File

@ -1,3 +1,22 @@
2010-07-21 Daniel Kraft <d@domob.eu>
* trans.h (gfc_get_return_label): Removed.
(gfc_generate_return): New method.
(gfc_trans_deferred_vars): Update gfc_wrapped_block rather than
returning a tree directly.
* trans-stmt.c (gfc_trans_return): Use `gfc_generate_return'.
(gfc_trans_block_construct): Update for new interface to
`gfc_trans_deferred_vars'.
* trans-decl.c (current_function_return_label): Removed.
(current_procedure_symbol): New variable.
(gfc_get_return_label): Removed.
(gfc_trans_deferred_vars): Update gfc_wrapped_block rather than
returning a tree directly.
(get_proc_result), (gfc_generate_return): New methods.
(gfc_generate_function_code): Clean up and do init/cleanup here
also with gfc_wrapped_block. Remove return-label but rather
return directly.
2010-07-19 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/44929

269
gcc/fortran/trans-decl.c
View File

@ -55,8 +55,6 @@ along with GCC; see the file COPYING3. If not see
static GTY(()) tree current_fake_result_decl;
static GTY(()) tree parent_fake_result_decl;
static GTY(()) tree current_function_return_label;
/* Holds the variable DECLs for the current function. */
@ -75,6 +73,9 @@ static GTY(()) tree saved_local_decls;
static gfc_namespace *module_namespace;
/* The currently processed procedure symbol. */
static gfc_symbol* current_procedure_symbol = NULL;
/* List of static constructor functions. */
@ -237,28 +238,6 @@ gfc_build_label_decl (tree label_id)
}
/* Returns the return label for the current function. */
tree
gfc_get_return_label (void)
{
char name[GFC_MAX_SYMBOL_LEN + 10];
if (current_function_return_label)
return current_function_return_label;
sprintf (name, "__return_%s",
IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
current_function_return_label =
gfc_build_label_decl (get_identifier (name));
DECL_ARTIFICIAL (current_function_return_label) = 1;
return current_function_return_label;
}
/* Set the backend source location of a decl. */
void
@ -3089,18 +3068,15 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
Initialization of ASSIGN statement auxiliary variable.
Automatic deallocation. */
tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
void
gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
locus loc;
gfc_symbol *sym;
gfc_formal_arglist *f;
stmtblock_t tmpblock;
gfc_wrapped_block try_block;
bool seen_trans_deferred_array = false;
gfc_start_wrapped_block (&try_block, fnbody);
/* Deal with implicit return variables. Explicit return variables will
already have been added. */
if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
@ -3122,17 +3098,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
else if (proc_sym->as)
{
tree result = TREE_VALUE (current_fake_result_decl);
gfc_trans_dummy_array_bias (proc_sym, result, &try_block);
gfc_trans_dummy_array_bias (proc_sym, result, block);
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block);
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block);
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else
gcc_assert (gfc_option.flag_f2c
@ -3142,7 +3118,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. */
init_intent_out_dt (proc_sym, &try_block);
init_intent_out_dt (proc_sym, block);
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
@ -3154,7 +3130,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block);
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
else if (sym->attr.pointer || sym->attr.allocatable)
{
if (TREE_STATIC (sym->backend_decl))
@ -3162,7 +3138,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
else
{
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, &try_block);
gfc_trans_deferred_array (sym, block);
}
}
else
@ -3170,7 +3146,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
if (sym_has_alloc_comp)
{
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, &try_block);
gfc_trans_deferred_array (sym, block);
}
else if (sym->ts.type == BT_DERIVED
&& sym->value
@ -3179,7 +3155,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
gfc_start_block (&tmpblock);
gfc_init_default_dt (sym, &tmpblock, false);
gfc_add_init_cleanup (&try_block,
gfc_add_init_cleanup (block,
gfc_finish_block (&tmpblock),
NULL_TREE);
}
@ -3187,7 +3163,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_trans_auto_array_allocation (sym->backend_decl,
sym, &try_block);
sym, block);
gfc_set_backend_locus (&loc);
}
break;
@ -3198,26 +3174,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)
gfc_trans_g77_array (sym, &try_block);
gfc_trans_g77_array (sym, block);
break;
case AS_ASSUMED_SHAPE:
/* Must be a dummy parameter. */
gcc_assert (sym->attr.dummy);
gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block);
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
break;
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, &try_block);
gfc_trans_deferred_array (sym, block);
break;
default:
gcc_unreachable ();
}
if (sym_has_alloc_comp && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, &try_block);
gfc_trans_deferred_array (sym, block);
}
else if (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS
@ -3253,26 +3229,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
if (!sym->attr.result)
tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
true, NULL);
gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), tmp);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
else if (sym_has_alloc_comp)
gfc_trans_deferred_array (sym, &try_block);
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_character (sym, sym->ts.u.cl, &try_block);
gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
else
gfc_trans_auto_character_variable (sym, &try_block);
gfc_trans_auto_character_variable (sym, block);
gfc_set_backend_locus (&loc);
}
else if (sym->attr.assign)
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_trans_assign_aux_var (sym, &try_block);
gfc_trans_assign_aux_var (sym, block);
gfc_set_backend_locus (&loc);
}
else if (sym->ts.type == BT_DERIVED
@ -3282,7 +3258,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
gfc_start_block (&tmpblock);
gfc_init_default_dt (sym, &tmpblock, false);
gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock),
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
else
@ -3309,9 +3285,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
}
gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), NULL_TREE);
return gfc_finish_wrapped_block (&try_block);
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
}
static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
@ -4309,6 +4283,56 @@ create_main_function (tree fndecl)
}
/* Get the result expression for a procedure. */
static tree
get_proc_result (gfc_symbol* sym)
{
if (sym->attr.subroutine || sym == sym->result)
{
if (current_fake_result_decl != NULL)
return TREE_VALUE (current_fake_result_decl);
return NULL_TREE;
}
return sym->result->backend_decl;
}
/* Generate an appropriate return-statement for a procedure. */
tree
gfc_generate_return (void)
{
gfc_symbol* sym;
tree result;
tree fndecl;
sym = current_procedure_symbol;
fndecl = sym->backend_decl;
if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
result = NULL_TREE;
else
{
result = get_proc_result (sym);
/* Set the return value to the dummy result variable. The
types may be different for scalar default REAL functions
with -ff2c, therefore we have to convert. */
if (result != NULL_TREE)
{
result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
DECL_RESULT (fndecl), result);
}
}
return build1_v (RETURN_EXPR, result);
}
/* Generate code for a function. */
void
@ -4318,16 +4342,18 @@ gfc_generate_function_code (gfc_namespace * ns)
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);
@ -4349,7 +4375,7 @@ gfc_generate_function_code (gfc_namespace * ns)
trans_function_start (sym);
gfc_init_block (&block);
gfc_init_block (&init);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
@ -4388,34 +4414,32 @@ gfc_generate_function_code (gfc_namespace * ns)
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);
@ -4438,29 +4462,9 @@ gfc_generate_function_code (gfc_namespace * ns)
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
@ -4470,24 +4474,12 @@ gfc_generate_function_code (gfc_namespace * ns)
&& 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)
@ -4500,31 +4492,28 @@ gfc_generate_function_code (gfc_namespace * ns)
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);
}
}
else
{
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_expr_to_block (&body, gfc_generate_return ());
}
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_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;
@ -4539,7 +4528,7 @@ gfc_generate_function_code (gfc_namespace * ns)
}
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. */
@ -4590,6 +4579,8 @@ gfc_generate_function_code (gfc_namespace * ns)
if (sym->attr.is_main_program)
create_main_function (fndecl);
current_procedure_symbol = previous_procedure_symbol;
}

32
gcc/fortran/trans-stmt.c
View File

@ -491,7 +491,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
/* Translate the RETURN statement. */
tree
gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
gfc_trans_return (gfc_code * code)
{
if (code->expr1)
{
@ -500,16 +500,16 @@ gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
tree result;
/* If code->expr is not NULL, this return statement must appear
in a subroutine and current_fake_result_decl has already
in a subroutine and current_fake_result_decl has already
been generated. */
result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
&code->expr1->where);
return build1_v (GOTO_EXPR, gfc_get_return_label ());
}
{
gfc_warning ("An alternate return at %L without a * dummy argument",
&code->expr1->where);
return gfc_generate_return ();
}
/* Start a new block for this statement. */
gfc_init_se (&se, NULL);
@ -521,13 +521,12 @@ gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
fold_convert (TREE_TYPE (result), se.expr));
gfc_add_expr_to_block (&se.pre, tmp);
tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
tmp = gfc_generate_return ();
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
else
return build1_v (GOTO_EXPR, gfc_get_return_label ());
return gfc_generate_return ();
}
@ -847,8 +846,7 @@ gfc_trans_block_construct (gfc_code* code)
{
gfc_namespace* ns;
gfc_symbol* sym;
stmtblock_t body;
tree tmp;
gfc_wrapped_block body;
ns = code->ext.block.ns;
gcc_assert (ns);
@ -858,14 +856,12 @@ gfc_trans_block_construct (gfc_code* code)
gcc_assert (!sym->tlink);
sym->tlink = sym;
gfc_start_block (&body);
gfc_process_block_locals (ns);
tmp = gfc_trans_code (ns->code);
tmp = gfc_trans_deferred_vars (sym, tmp);
gfc_start_wrapped_block (&body, gfc_trans_code (ns->code));
gfc_trans_deferred_vars (sym, &body);
gfc_add_expr_to_block (&body, tmp);
return gfc_finish_block (&body);
return gfc_finish_wrapped_block (&body);
}

7
gcc/fortran/trans.h
View File

@ -408,9 +408,6 @@ tree gfc_build_label_decl (tree);
Do not use if the function has an explicit result variable. */
tree gfc_get_fake_result_decl (gfc_symbol *, int);
/* Get the return label for the current function. */
tree gfc_get_return_label (void);
/* Add a decl to the binding level for the current function. */
void gfc_add_decl_to_function (tree);
@ -456,6 +453,8 @@ void gfc_generate_function_code (gfc_namespace *);
void gfc_generate_block_data (gfc_namespace *);
/* Output a decl for a module variable. */
void gfc_generate_module_vars (gfc_namespace *);
/* Get the appropriate return statement for a procedure. */
tree gfc_generate_return (void);
struct GTY(()) module_htab_entry {
const char *name;
@ -533,7 +532,7 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
void gfc_process_block_locals (gfc_namespace*);
/* Output initialization/clean-up code that was deferred. */
tree gfc_trans_deferred_vars (gfc_symbol*, tree);
void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
/* somewhere! */
tree pushdecl (tree);