From: domob Date: Wed, 21 Jul 2010 13:44:38 +0000 (+0000) Subject: 2010-07-21 Daniel Kraft X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=89ac8ba1010f80f10f55ffe9d9445a25163266af 2010-07-21 Daniel Kraft * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162373 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0c70c2b95ea..fa32e0bfa98 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,22 @@ +2010-07-21 Daniel Kraft + + * 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 PR fortran/44929 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 5932695a587..326afd76e18 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); - } + 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; @@ -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; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 0f34e617dff..8abdd885c2c 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index db782c0a0ff..cbed52b5f87 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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);