diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-09-19 18:19:39 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-09-19 18:19:39 +0000 |
| commit | e56043cd2c207982e812ce6fcecb7353dea58363 (patch) | |
| tree | 01a6f37ad5a9ae6b18bdc20f052b04e19b4255c0 /gcc/fortran/trans-decl.c | |
| parent | 2e02a1a4548f2ee1ea519c88e68b20621ad16fcc (diff) | |
| download | gcc-e56043cd2c207982e812ce6fcecb7353dea58363.tar.gz | |
2010-09-19 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 164348, with some improvements
in gcc/melt-runtime.[ch]
2010-09-19 Basile Starynkevitch <basile@starynkevitch.net>
[[merged with trunk rev.164348, so improved MELT runtime!]]
* gcc/melt-runtime.h: improved comments.
(melt_debug_garbcoll, melt_debuggc_eprintf): Moved from melt-runtime.c.
(melt_obmag_string): New declaration.
(struct meltobject_st, struct meltclosure_st, struct
meltroutine_st, struct meltmixbigint_st, struct meltstring_st):
using GTY variable_size and @@MELTGTY@@ comment.
(melt_mark_special): added debug print.
* gcc/melt-runtime.c: Improved comments.
Include bversion.h, realmpfr.h, gimple-pretty-print.h.
(ggc_force_collect) Declared external.
(melt_forward_counter): Added.
(melt_obmag_string): New function.
(melt_alptr_1, melt_alptr_2, melt_break_alptr_1_at)
(melt_break_alptr_2_at, melt_break_alptr_1,melt_break_alptr_1)
(melt_allocate_young_gc_zone, melt_free_young_gc_zone): New.
(delete_special, meltgc_make_special): Improved debug printf and
use melt_break_alptr_1...
(ggc_alloc_*) macros defined for backport to GCC 4.5
(melt_forwarded_copy): Don't clear the new destination zone in old
GGC heap.
(meltgc_add_out_raw_len): Use ggc_alloc_atomic.
(meltgc_raw_new_mappointers, meltgc_raw_put_mappointers)
(meltgc_raw_remove_mappointers): Corrected length argument to
ggc_alloc_cleared_vec_entrypointermelt_st.
(melt_really_initialize): Call melt_allocate_young_gc_zone.
(melt_initialize): Set flag_plugin_added.
(melt_val2passflag): TODO_verify_loops only in GCC 4.5
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@164424 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran/trans-decl.c')
| -rw-r--r-- | gcc/fortran/trans-decl.c | 1541 |
1 files changed, 875 insertions, 666 deletions
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 53c4b475add..0ff297f7e6b 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -24,13 +24,14 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tree.h" #include "tree-dump.h" -#include "gimple.h" +#include "gimple.h" /* For create_tmp_var_raw. */ #include "ggc.h" -#include "toplev.h" -#include "tm.h" -#include "rtl.h" +#include "diagnostic-core.h" /* For internal_error. */ +#include "toplev.h" /* For announce_function. */ +#include "output.h" /* For decl_default_tls_model. */ #include "target.h" #include "function.h" #include "flags.h" @@ -38,6 +39,7 @@ along with GCC; see the file COPYING3. If not see #include "debug.h" #include "gfortran.h" #include "pointer-set.h" +#include "constructor.h" #include "trans.h" #include "trans-types.h" #include "trans-array.h" @@ -53,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. */ @@ -73,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. */ @@ -85,6 +88,7 @@ tree gfor_fndecl_pause_numeric; tree gfor_fndecl_pause_string; tree gfor_fndecl_stop_numeric; tree gfor_fndecl_stop_string; +tree gfor_fndecl_error_stop_numeric; tree gfor_fndecl_error_stop_string; tree gfor_fndecl_runtime_error; tree gfor_fndecl_runtime_error_at; @@ -146,12 +150,9 @@ tree gfor_fndecl_convert_char4_to_char1; /* Other misc. runtime library functions. */ - tree gfor_fndecl_size0; tree gfor_fndecl_size1; tree gfor_fndecl_iargc; -tree gfor_fndecl_clz128; -tree gfor_fndecl_ctz128; /* Intrinsic functions implemented in Fortran. */ tree gfor_fndecl_sc_kind; @@ -171,7 +172,7 @@ gfc_add_decl_to_parent_function (tree decl) 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; } @@ -181,7 +182,7 @@ gfc_add_decl_to_function (tree 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; } @@ -191,7 +192,7 @@ add_decl_as_local (tree 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; } @@ -234,28 +235,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 @@ -610,8 +589,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) void gfc_allocate_lang_decl (tree decl) { - DECL_LANG_SPECIFIC (decl) = (struct lang_decl *) - ggc_alloc_cleared (sizeof (struct lang_decl)); + DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof + (struct lang_decl)); } /* Remember a symbol to generate initialization/cleanup code at function @@ -676,6 +655,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) tree type; int dim; int nest; + gfc_namespace* procns; type = TREE_TYPE (decl); @@ -684,7 +664,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) return; gcc_assert (GFC_ARRAY_TYPE_P (type)); - nest = (sym->ns->proc_name->backend_decl != current_function_decl) + procns = gfc_find_proc_namespace (sym->ns); + nest = (procns->proc_name->backend_decl != current_function_decl) && !sym->attr.contained; for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) @@ -740,8 +721,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) { tree size, range; - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); range = build_range_type (gfc_array_index_type, gfc_index_zero_node, size); TYPE_DOMAIN (type) = range; @@ -770,19 +751,33 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) for (dim = sym->as->rank - 1; dim >= 0; dim--) { - rtype = build_range_type (gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, dim), - GFC_TYPE_ARRAY_UBOUND (type, dim)); + tree lbound, ubound; + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + rtype = build_range_type (gfc_array_index_type, lbound, ubound); gtype = build_array_type (gtype, rtype); - /* Ensure the bound variables aren't optimized out at -O0. */ - if (!optimize) + /* 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 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 (GFC_TYPE_ARRAY_LBOUND (type, dim) - && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL) - DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0; - if (GFC_TYPE_ARRAY_UBOUND (type, dim) - && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL) - DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0; + if (DECL_NAME (lbound) + && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)), + "lbound") != 0) + DECL_NAMELESS (lbound) = 1; + DECL_IGNORED_P (lbound) = 0; + } + if (ubound && TREE_CODE (ubound) == VAR_DECL + && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound)) + { + if (DECL_NAME (ubound) + && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)), + "ubound") != 0) + DECL_NAMELESS (ubound) = 1; + DECL_IGNORED_P (ubound) = 0; } } TYPE_NAME (type) = type_decl = build_decl (input_location, @@ -883,6 +878,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) 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; @@ -943,7 +939,7 @@ gfc_nonlocal_dummy_array_decl (gfc_symbol *sym) 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; } @@ -1035,6 +1031,9 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list) } +static void build_function_decl (gfc_symbol * sym, bool global); + + /* Return the decl for a gfc_symbol, create it if it doesn't already exist. */ @@ -1048,13 +1047,23 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (sym->attr.referenced || sym->attr.use_assoc - || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY); + || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY + || (sym->module && sym->attr.if_source != IFSRC_DECL + && sym->backend_decl)); if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function) byref = gfc_return_by_reference (sym->ns->proc_name); else byref = 0; + /* Make sure that the vtab for the declared type is completed. */ + if (sym->ts.type == BT_CLASS) + { + gfc_component *c = CLASS_DATA (sym); + if (!c->ts.u.derived->backend_decl) + gfc_find_derived_vtab (c->ts.u.derived); + } + if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref)) { /* Return via extra parameter. */ @@ -1066,7 +1075,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* 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. */ @@ -1124,11 +1133,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) 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) { @@ -1142,19 +1149,32 @@ gfc_get_symbol_decl (gfc_symbol * sym) 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; + sym->backend_decl = s->backend_decl; + return sym->backend_decl; } } } - /* Catch function declarations. Only used for actual parameters and - procedure pointers. */ if (sym->attr.flavor == FL_PROCEDURE) { - decl = gfc_get_extern_function_decl (sym); - gfc_set_decl_location (decl, &sym->declared_at); + /* Catch function declarations. Only used for actual parameters, + procedure pointers and procptr initialization targets. */ + if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic) + { + decl = gfc_get_extern_function_decl (sym); + gfc_set_decl_location (decl, &sym->declared_at); + } + else + { + if (!sym->backend_decl) + build_function_decl (sym, false); + decl = sym->backend_decl; + } return decl; } @@ -1189,15 +1209,16 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create variables to hold the non-constant bits of array info. */ gfc_build_qualified_array (decl, sym); - if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer) + if (sym->attr.contiguous + || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) GFC_DECL_PACKED_ARRAY (decl) = 1; } /* Remember this variable for allocation/cleanup. */ if (sym->attr.dimension || sym->attr.allocatable || (sym->ts.type == BT_CLASS && - (sym->ts.u.derived->components->attr.dimension - || sym->ts.u.derived->components->attr.allocatable)) + (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.allocatable)) || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) /* This applies a derived type default initializer. */ || (sym->ts.type == BT_DERIVED @@ -1269,8 +1290,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) every time the procedure is entered. The TREE_STATIC is in this case due to -fmax-stack-var-size=. */ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), sym->attr.dimension, - sym->attr.pointer || sym->attr.allocatable); + TREE_TYPE (decl), + sym->attr.dimension, + sym->attr.pointer + || sym->attr.allocatable, + sym->attr.proc_pointer); } if (!TREE_STATIC (decl) @@ -1357,9 +1381,9 @@ get_proc_pointer_decl (gfc_symbol *sym) { /* Add static initializer. */ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), - sym->attr.proc_pointer ? false : sym->attr.dimension, - sym->attr.proc_pointer); + TREE_TYPE (decl), + sym->attr.dimension, + false, true); } attributes = add_attributes_to_decl (sym->attr, NULL_TREE); @@ -1401,12 +1425,30 @@ gfc_get_extern_function_decl (gfc_symbol * sym) gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); if (gfc_option.flag_whole_file - && !sym->attr.use_assoc + && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL) && !sym->backend_decl && gsym && gsym->ns && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) - && gsym->ns->proc_name->backend_decl) + && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) { + if (!gsym->ns->proc_name->backend_decl) + { + /* By construction, the external function cannot be + a contained procedure. */ + locus old_loc; + tree save_fn_decl = current_function_decl; + + current_function_decl = NULL_TREE; + gfc_get_backend_locus (&old_loc); + push_cfun (cfun); + + gfc_create_function_decl (gsym->ns, true); + + pop_cfun (); + gfc_set_backend_locus (&old_loc); + current_function_decl = save_fn_decl; + } + /* If the namespace has entries, the proc_name is the entry master. Find the entry and use its backend_decl. otherwise, use the proc_name backend_decl. */ @@ -1424,12 +1466,17 @@ gfc_get_extern_function_decl (gfc_symbol * sym) } } else - { - sym->backend_decl = gsym->ns->proc_name->backend_decl; - } + sym->backend_decl = gsym->ns->proc_name->backend_decl; if (sym->backend_decl) - return sym->backend_decl; + { + /* Avoid problems of double deallocation of the backend declaration + later in gfc_trans_use_stmts; cf. PR 45087. */ + if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc) + sym->attr.use_assoc = 0; + + return sym->backend_decl; + } } /* See if this is a module procedure from the same file. If so, @@ -1566,16 +1613,18 @@ gfc_get_extern_function_decl (gfc_symbol * sym) a master function with alternate entry points. */ static void -build_function_decl (gfc_symbol * sym) +build_function_decl (gfc_symbol * sym, bool global) { tree fndecl, type, attributes; symbol_attribute attr; tree result_decl; gfc_formal_arglist *f; - gcc_assert (!sym->backend_decl); gcc_assert (!sym->attr.external); + if (sym->backend_decl) + return; + /* Set the line and filename. sym->declared_at seems to point to the last statement for subroutines, but it'll do for now. */ gfc_set_backend_locus (&sym->declared_at); @@ -1674,7 +1723,11 @@ build_function_decl (gfc_symbol * sym) /* Layout the function declaration and put it in the binding level of the current function. */ - pushdecl (fndecl); + + if (global) + pushdecl_top_level (fndecl); + else + pushdecl (fndecl); sym->backend_decl = fndecl; } @@ -1947,7 +2000,7 @@ trans_function_start (gfc_symbol * sym) /* Create thunks for alternate entry points. */ static void -build_entry_thunks (gfc_namespace * ns) +build_entry_thunks (gfc_namespace * ns, bool global) { gfc_formal_arglist *formal; gfc_formal_arglist *thunk_formal; @@ -1955,8 +2008,6 @@ build_entry_thunks (gfc_namespace * ns) gfc_symbol *thunk_sym; stmtblock_t body; tree thunk_fndecl; - tree args; - tree string_args; tree tmp; locus old_loc; @@ -1966,9 +2017,12 @@ build_entry_thunks (gfc_namespace * ns) gfc_get_backend_locus (&old_loc); for (el = ns->entries; el; el = el->next) { + VEC(tree,gc) *args = NULL; + VEC(tree,gc) *string_args = NULL; + thunk_sym = el->sym; - build_function_decl (thunk_sym); + build_function_decl (thunk_sym, global); create_function_arglist (thunk_sym); trans_function_start (thunk_sym); @@ -1979,18 +2033,16 @@ build_entry_thunks (gfc_namespace * ns) /* Pass extra parameter identifying this entry point. */ tmp = build_int_cst (gfc_array_index_type, el->id); - args = tree_cons (NULL_TREE, tmp, NULL_TREE); - string_args = NULL_TREE; + VEC_safe_push (tree, gc, args, tmp); if (thunk_sym->attr.function) { if (gfc_return_by_reference (ns->proc_name)) { tree ref = DECL_ARGUMENTS (current_function_decl); - args = tree_cons (NULL_TREE, ref, args); + VEC_safe_push (tree, gc, args, ref); if (ns->proc_name->ts.type == BT_CHARACTER) - args = tree_cons (NULL_TREE, TREE_CHAIN (ref), - args); + VEC_safe_push (tree, gc, args, DECL_CHAIN (ref)); } } @@ -2014,31 +2066,29 @@ build_entry_thunks (gfc_namespace * ns) { /* Pass the argument. */ DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1; - args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl, - args); + VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl); if (formal->sym->ts.type == BT_CHARACTER) { tmp = thunk_formal->sym->ts.u.cl->backend_decl; - string_args = tree_cons (NULL_TREE, tmp, string_args); + VEC_safe_push (tree, gc, string_args, tmp); } } else { /* Pass NULL for a missing argument. */ - args = tree_cons (NULL_TREE, null_pointer_node, args); + VEC_safe_push (tree, gc, args, null_pointer_node); if (formal->sym->ts.type == BT_CHARACTER) { tmp = build_int_cst (gfc_charlen_type_node, 0); - string_args = tree_cons (NULL_TREE, tmp, string_args); + VEC_safe_push (tree, gc, string_args, tmp); } } } /* Call the master function. */ - args = nreverse (args); - args = chainon (args, nreverse (string_args)); + VEC_safe_splice (tree, gc, args, string_args); tmp = ns->proc_name->backend_decl; - tmp = build_function_call_expr (input_location, tmp, args); + tmp = build_call_expr_loc_vec (input_location, tmp, args); if (ns->proc_name->attr.mixed_entry_master) { tree union_decl, field; @@ -2055,19 +2105,20 @@ build_entry_thunks (gfc_namespace * ns) pushdecl (union_decl); DECL_CONTEXT (union_decl) = current_function_decl; - tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl), - union_decl, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (union_decl), union_decl, tmp); 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; gcc_assert (field != NULL_TREE); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - union_decl, field, NULL_TREE); - tmp = fold_build2 (MODIFY_EXPR, + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), union_decl, field, + NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (DECL_RESULT (current_function_decl)), DECL_RESULT (current_function_decl), tmp); tmp = build1_v (RETURN_EXPR, tmp); @@ -2075,7 +2126,7 @@ build_entry_thunks (gfc_namespace * ns) else if (TREE_TYPE (DECL_RESULT (current_function_decl)) != void_type_node) { - tmp = fold_build2 (MODIFY_EXPR, + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (DECL_RESULT (current_function_decl)), DECL_RESULT (current_function_decl), tmp); tmp = build1_v (RETURN_EXPR, tmp); @@ -2132,17 +2183,18 @@ build_entry_thunks (gfc_namespace * ns) /* Create a decl for a function, and create any thunks for alternate entry - points. */ + points. If global is true, generate the function in the global binding + level, otherwise in the current binding level (which can be global). */ void -gfc_create_function_decl (gfc_namespace * ns) +gfc_create_function_decl (gfc_namespace * ns, bool global) { /* Create a declaration for the master function. */ - build_function_decl (ns->proc_name); + build_function_decl (ns->proc_name, global); /* Compile the entry thunks. */ if (ns->entries) - build_entry_thunks (ns); + build_entry_thunks (ns, global); /* Now create the read argument list. */ create_function_arglist (ns->proc_name); @@ -2196,14 +2248,14 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) 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; gcc_assert (field != NULL_TREE); - decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - decl, field, NULL_TREE); + decl = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), decl, field, NULL_TREE); } var = create_tmp_var_raw (TREE_TYPE (decl), sym->name); @@ -2247,7 +2299,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) 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) @@ -2259,11 +2311,11 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) IDENTIFIER_POINTER (DECL_NAME (this_function_decl))); if (!sym->attr.mixed_entry_master && sym->attr.function) - decl = build_decl (input_location, + decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), VAR_DECL, get_identifier (name), gfc_sym_type (sym)); else - decl = build_decl (input_location, + decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), VAR_DECL, get_identifier (name), TREE_TYPE (TREE_TYPE (this_function_decl))); DECL_ARTIFICIAL (decl) = 1; @@ -2293,22 +2345,19 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) /* Builds a function decl. The remaining parameters are the types of the function arguments. Negative nargs indicates a varargs function. */ -tree -gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) +static tree +build_library_function_decl_1 (tree name, const char *spec, + tree rettype, int nargs, va_list p) { tree arglist; tree argtype; tree fntype; tree fndecl; - va_list p; int n; /* Library functions must be declared with global scope. */ gcc_assert (current_function_decl == NULL_TREE); - va_start (p, nargs); - - /* Create a list of the argument types. */ for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--) { @@ -2319,11 +2368,19 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) if (nargs >= 0) { /* Terminate the list. */ - arglist = gfc_chainon_list (arglist, void_type_node); + arglist = chainon (arglist, void_list_node); } /* Build the function type and decl. */ fntype = build_function_type (rettype, arglist); + if (spec) + { + tree attr_args = build_tree_list (NULL_TREE, + build_string (strlen (spec), spec)); + tree attrs = tree_cons (get_identifier ("fn spec"), + attr_args, TYPE_ATTRIBUTES (fntype)); + fntype = build_type_attribute_variant (fntype, attrs); + } fndecl = build_decl (input_location, FUNCTION_DECL, name, fntype); @@ -2331,8 +2388,6 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) DECL_EXTERNAL (fndecl) = 1; TREE_PUBLIC (fndecl) = 1; - va_end (p); - pushdecl (fndecl); rest_of_decl_compilation (fndecl, 1, 0); @@ -2340,6 +2395,37 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) return fndecl; } +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. */ + +tree +gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) +{ + tree ret; + va_list args; + va_start (args, nargs); + ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args); + va_end (args); + return ret; +} + +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. + The SPEC parameter specifies the function argument and return type + specification according to the fnspec function type attribute. */ + +tree +gfc_build_library_function_decl_with_spec (tree name, const char *spec, + tree rettype, int nargs, ...) +{ + tree ret; + va_list args; + va_start (args, nargs); + ret = build_library_function_decl_1 (name, spec, rettype, nargs, args); + va_end (args); + return ret; +} + static void gfc_build_intrinsic_function_decls (void) { @@ -2351,211 +2437,197 @@ gfc_build_intrinsic_function_decls (void) tree pchar4_type_node = gfc_get_pchar_type (4); /* String functions. */ - gfor_fndecl_compare_string = - gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")), - integer_type_node, 4, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_concat_string = - gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")), - void_type_node, 6, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_string_len_trim = - gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")), - gfc_int4_type_node, 2, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_string_index = - gfc_build_library_function_decl (get_identifier (PREFIX("string_index")), - gfc_int4_type_node, 5, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_scan = - gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")), - gfc_int4_type_node, 5, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_verify = - gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")), - gfc_int4_type_node, 5, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_trim = - gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")), - void_type_node, 4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar1_type_node), - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_string_minmax = - gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")), - void_type_node, -4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar1_type_node), - integer_type_node, integer_type_node); - - gfor_fndecl_adjustl = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), - void_type_node, 3, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_adjustr = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), - void_type_node, 3, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_select_string = - gfc_build_library_function_decl (get_identifier (PREFIX("select_string")), - integer_type_node, 4, pvoid_type_node, - integer_type_node, pchar1_type_node, - gfc_charlen_type_node); - - gfor_fndecl_compare_string_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("compare_string_char4")), - integer_type_node, 4, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_concat_string_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("concat_string_char4")), - void_type_node, 6, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_string_len_trim_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_len_trim_char4")), - gfc_charlen_type_node, 2, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_string_index_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_index_char4")), - gfc_charlen_type_node, 5, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_scan_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_scan_char4")), - gfc_charlen_type_node, 5, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_verify_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_verify_char4")), - gfc_charlen_type_node, 5, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_trim_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_trim_char4")), - void_type_node, 4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar4_type_node), - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_string_minmax_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_minmax_char4")), - void_type_node, -4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar4_type_node), - integer_type_node, integer_type_node); - - gfor_fndecl_adjustl_char4 = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")), - void_type_node, 3, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_adjustr_char4 = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")), - void_type_node, 3, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_select_string_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("select_string_char4")), - integer_type_node, 4, pvoid_type_node, - integer_type_node, pvoid_type_node, - gfc_charlen_type_node); + gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("compare_string")), "..R.R", + integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + DECL_PURE_P (gfor_fndecl_compare_string) = 1; + TREE_NOTHROW (gfor_fndecl_compare_string) = 1; + + gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("concat_string")), "..W.R.R", + void_type_node, 6, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + TREE_NOTHROW (gfor_fndecl_concat_string) = 1; + + gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_len_trim")), "..R", + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node); + DECL_PURE_P (gfor_fndecl_string_len_trim) = 1; + TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1; + + gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_index")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_index) = 1; + TREE_NOTHROW (gfor_fndecl_string_index) = 1; + + gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_scan")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_scan) = 1; + TREE_NOTHROW (gfor_fndecl_string_scan) = 1; + + gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_verify")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_verify) = 1; + TREE_NOTHROW (gfor_fndecl_string_verify) = 1; + + gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_trim")), ".Ww.R", + void_type_node, 4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), gfc_charlen_type_node, + pchar1_type_node); + + gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_minmax")), ".Ww.R", + void_type_node, -4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), integer_type_node, + integer_type_node); + + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustl")), ".W.R", + void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, + pchar1_type_node); + TREE_NOTHROW (gfor_fndecl_adjustl) = 1; + + gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustr")), ".W.R", + void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, + pchar1_type_node); + TREE_NOTHROW (gfor_fndecl_adjustr) = 1; + + gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("select_string")), ".R.R.", + integer_type_node, 4, pvoid_type_node, integer_type_node, + pchar1_type_node, gfc_charlen_type_node); + DECL_PURE_P (gfor_fndecl_select_string) = 1; + TREE_NOTHROW (gfor_fndecl_select_string) = 1; + + gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("compare_string_char4")), "..R.R", + integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1; + TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1; + + gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("concat_string_char4")), "..W.R.R", + void_type_node, 6, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1; + + gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_len_trim_char4")), "..R", + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node); + DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1; + + gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_index_char4")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_index_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1; + + gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_scan_char4")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1; + + gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_verify_char4")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1; + + gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_trim_char4")), ".Ww.R", + void_type_node, 4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), gfc_charlen_type_node, + pchar4_type_node); + + gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_minmax_char4")), ".Ww.R", + void_type_node, -4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), integer_type_node, + integer_type_node); + + gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustl_char4")), ".W.R", + void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1; + + gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustr_char4")), ".W.R", + void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1; + + gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("select_string_char4")), ".R.R.", + integer_type_node, 4, pvoid_type_node, integer_type_node, + pvoid_type_node, gfc_charlen_type_node); + DECL_PURE_P (gfor_fndecl_select_string_char4) = 1; + TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1; /* Conversion between character kinds. */ - gfor_fndecl_convert_char1_to_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("convert_char1_to_char4")), - void_type_node, 3, - build_pointer_type (pchar4_type_node), - gfc_charlen_type_node, pchar1_type_node); + gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("convert_char1_to_char4")), ".w.R", + void_type_node, 3, build_pointer_type (pchar4_type_node), + gfc_charlen_type_node, pchar1_type_node); - gfor_fndecl_convert_char4_to_char1 = - gfc_build_library_function_decl (get_identifier - (PREFIX("convert_char4_to_char1")), - void_type_node, 3, - build_pointer_type (pchar1_type_node), - gfc_charlen_type_node, pchar4_type_node); + gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("convert_char4_to_char1")), ".w.R", + void_type_node, 3, build_pointer_type (pchar1_type_node), + gfc_charlen_type_node, pchar4_type_node); /* Misc. functions. */ - gfor_fndecl_ttynam = - gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, - integer_type_node); - - gfor_fndecl_fdate = - gfc_build_library_function_decl (get_identifier (PREFIX("fdate")), - void_type_node, - 2, - pchar_type_node, - gfc_charlen_type_node); - - gfor_fndecl_ctime = - gfc_build_library_function_decl (get_identifier (PREFIX("ctime")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, - gfc_int8_type_node); - - gfor_fndecl_sc_kind = - gfc_build_library_function_decl (get_identifier - (PREFIX("selected_char_kind")), - gfc_int4_type_node, 2, - gfc_charlen_type_node, pchar_type_node); - - gfor_fndecl_si_kind = - gfc_build_library_function_decl (get_identifier - (PREFIX("selected_int_kind")), - gfc_int4_type_node, 1, pvoid_type_node); - - gfor_fndecl_sr_kind = - gfc_build_library_function_decl (get_identifier - (PREFIX("selected_real_kind")), - gfc_int4_type_node, 2, - pvoid_type_node, pvoid_type_node); + gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("ttynam")), ".W", + void_type_node, 3, pchar_type_node, gfc_charlen_type_node, + integer_type_node); + + gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("fdate")), ".W", + void_type_node, 2, pchar_type_node, gfc_charlen_type_node); + + gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("ctime")), ".W", + void_type_node, 3, pchar_type_node, gfc_charlen_type_node, + gfc_int8_type_node); + + gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_char_kind")), "..R", + gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); + DECL_PURE_P (gfor_fndecl_sc_kind) = 1; + TREE_NOTHROW (gfor_fndecl_sc_kind) = 1; + + gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_int_kind")), ".R", + gfc_int4_type_node, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_si_kind) = 1; + TREE_NOTHROW (gfor_fndecl_si_kind) = 1; + + gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_real_kind2008")), ".RR", + gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node, + pvoid_type_node); + DECL_PURE_P (gfor_fndecl_sr_kind) = 1; + TREE_NOTHROW (gfor_fndecl_sr_kind) = 1; /* Power functions. */ { @@ -2582,6 +2654,7 @@ gfc_build_intrinsic_function_decls (void) gfc_build_library_function_decl (get_identifier (name), jtype, 2, jtype, itype); TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; } } @@ -2596,6 +2669,7 @@ gfc_build_intrinsic_function_decls (void) gfc_build_library_function_decl (get_identifier (name), rtype, 2, rtype, itype); TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1; } ctype = gfc_get_complex_type (rkinds[rkind]); @@ -2607,6 +2681,7 @@ gfc_build_intrinsic_function_decls (void) gfc_build_library_function_decl (get_identifier (name), ctype, 2,ctype, itype); TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; } } } @@ -2614,23 +2689,29 @@ gfc_build_intrinsic_function_decls (void) #undef NRKINDS } - gfor_fndecl_math_ishftc4 = - gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")), - gfc_int4_type_node, - 3, gfc_int4_type_node, - gfc_int4_type_node, gfc_int4_type_node); - gfor_fndecl_math_ishftc8 = - gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")), - gfc_int8_type_node, - 3, gfc_int8_type_node, - gfc_int4_type_node, gfc_int4_type_node); + gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc4")), + gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node, + gfc_int4_type_node); + TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; + + gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc8")), + gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, + gfc_int4_type_node); + TREE_READONLY (gfor_fndecl_math_ishftc8) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1; + if (gfc_int16_type_node) - gfor_fndecl_math_ishftc16 = - gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")), - gfc_int16_type_node, 3, - gfc_int16_type_node, - gfc_int4_type_node, - gfc_int4_type_node); + { + gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc16")), + gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node, + gfc_int4_type_node); + TREE_READONLY (gfor_fndecl_math_ishftc16) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1; + } /* BLAS functions. */ { @@ -2676,33 +2757,21 @@ gfc_build_intrinsic_function_decls (void) } /* Other functions. */ - gfor_fndecl_size0 = - gfc_build_library_function_decl (get_identifier (PREFIX("size0")), - gfc_array_index_type, - 1, pvoid_type_node); - gfor_fndecl_size1 = - gfc_build_library_function_decl (get_identifier (PREFIX("size1")), - gfc_array_index_type, - 2, pvoid_type_node, - gfc_array_index_type); - - gfor_fndecl_iargc = - gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")), - gfc_int4_type_node, - 0); - - if (gfc_type_for_size (128, true)) - { - tree uint128 = gfc_type_for_size (128, true); - - gfor_fndecl_clz128 = - gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")), - integer_type_node, 1, uint128); - - gfor_fndecl_ctz128 = - gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")), - integer_type_node, 1, uint128); - } + gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("size0")), ".R", + gfc_array_index_type, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_size0) = 1; + TREE_NOTHROW (gfor_fndecl_size0) = 1; + + gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("size1")), ".R", + gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type); + DECL_PURE_P (gfor_fndecl_size1) = 1; + TREE_NOTHROW (gfor_fndecl_size1) = 1; + + gfor_fndecl_iargc = gfc_build_library_function_decl ( + get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); + TREE_NOTHROW (gfor_fndecl_iargc) = 1; } @@ -2713,103 +2782,105 @@ gfc_build_builtin_function_decls (void) { tree gfc_int4_type_node = gfc_get_int_type (4); - gfor_fndecl_stop_numeric = - gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")), - void_type_node, 1, gfc_int4_type_node); - /* Stop doesn't return. */ + gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("stop_numeric")), + void_type_node, 1, gfc_int4_type_node); + /* STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; - gfor_fndecl_stop_string = - gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")), - void_type_node, 2, pchar_type_node, - gfc_int4_type_node); - /* Stop doesn't return. */ + gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("stop_string")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); + /* STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; - gfor_fndecl_error_stop_string = - gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")), - void_type_node, 2, pchar_type_node, - gfc_int4_type_node); + gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("error_stop_numeric")), + void_type_node, 1, gfc_int4_type_node); + /* ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; + + gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("error_stop_string")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); /* ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; - gfor_fndecl_pause_numeric = - gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")), - void_type_node, 1, gfc_int4_type_node); + gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("pause_numeric")), + void_type_node, 1, gfc_int4_type_node); - gfor_fndecl_pause_string = - gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")), - void_type_node, 2, pchar_type_node, - gfc_int4_type_node); + gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("pause_string")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); - gfor_fndecl_runtime_error = - gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), - void_type_node, -1, pchar_type_node); + gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_error")), ".R", + void_type_node, -1, pchar_type_node); /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; - gfor_fndecl_runtime_error_at = - gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")), - void_type_node, -2, pchar_type_node, - pchar_type_node); + gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_error_at")), ".RR", + void_type_node, -2, pchar_type_node, pchar_type_node); /* The runtime_error_at function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; - gfor_fndecl_runtime_warning_at = - gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")), - void_type_node, -2, pchar_type_node, - pchar_type_node); - gfor_fndecl_generate_error = - gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")), - void_type_node, 3, pvoid_type_node, - integer_type_node, pchar_type_node); - - gfor_fndecl_os_error = - gfc_build_library_function_decl (get_identifier (PREFIX("os_error")), - void_type_node, 1, pchar_type_node); + gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_warning_at")), ".RR", + void_type_node, -2, pchar_type_node, pchar_type_node); + + gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("generate_error")), ".R.R", + void_type_node, 3, pvoid_type_node, integer_type_node, + pchar_type_node); + + gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("os_error")), ".R", + void_type_node, 1, pchar_type_node); /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1; - gfor_fndecl_set_args = - gfc_build_library_function_decl (get_identifier (PREFIX("set_args")), - void_type_node, 2, integer_type_node, - build_pointer_type (pchar_type_node)); + gfor_fndecl_set_args = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_args")), + void_type_node, 2, integer_type_node, + build_pointer_type (pchar_type_node)); - gfor_fndecl_set_fpe = - gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_fpe = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_fpe")), + void_type_node, 1, integer_type_node); /* Keep the array dimension in sync with the call, later in this file. */ - gfor_fndecl_set_options = - gfc_build_library_function_decl (get_identifier (PREFIX("set_options")), - void_type_node, 2, integer_type_node, - build_pointer_type (integer_type_node)); + gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("set_options")), "..R", + void_type_node, 2, integer_type_node, + build_pointer_type (integer_type_node)); - gfor_fndecl_set_convert = - gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_convert = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_convert")), + void_type_node, 1, integer_type_node); - gfor_fndecl_set_record_marker = - gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_record_marker = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_record_marker")), + void_type_node, 1, integer_type_node); - gfor_fndecl_set_max_subrecord_length = - gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_max_subrecord_length")), + void_type_node, 1, integer_type_node); - gfor_fndecl_in_pack = gfc_build_library_function_decl ( - get_identifier (PREFIX("internal_pack")), - pvoid_type_node, 1, pvoid_type_node); + gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("internal_pack")), ".r", + pvoid_type_node, 1, pvoid_type_node); - gfor_fndecl_in_unpack = gfc_build_library_function_decl ( - get_identifier (PREFIX("internal_unpack")), - void_type_node, 2, pvoid_type_node, pvoid_type_node); + gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("internal_unpack")), ".wR", + void_type_node, 2, pvoid_type_node, pvoid_type_node); - gfor_fndecl_associated = - gfc_build_library_function_decl ( - get_identifier (PREFIX("associated")), - integer_type_node, 2, ppvoid_type_node, - ppvoid_type_node); + gfor_fndecl_associated = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("associated")), ".RR", + integer_type_node, 2, ppvoid_type_node, ppvoid_type_node); + DECL_PURE_P (gfor_fndecl_associated) = 1; + TREE_NOTHROW (gfor_fndecl_associated) = 1; gfc_build_intrinsic_function_decls (); gfc_build_intrinsic_lib_fndecls (); @@ -2819,72 +2890,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); + tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); + 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 @@ -2997,15 +3066,15 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) /* 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); @@ -3014,14 +3083,11 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) || sym->ns->proc_name->attr.entry_master)) { present = gfc_conv_expr_present (sym); - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, - tmp, build_empty_stmt (input_location)); + tmp = build3_loc (input_location, 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); } @@ -3029,15 +3095,15 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) 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 @@ -3053,18 +3119,103 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) || f->sym->ns->proc_name->attr.entry_master) { present = gfc_conv_expr_present (f->sym); - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, - tmp, build_empty_stmt (input_location)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, 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); +} + + +/* Do proper initialization for ASSOCIATE names. */ + +static void +trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block) +{ + gfc_expr* e; + tree tmp; + + gcc_assert (sym->assoc); + e = sym->assoc->target; + + /* Do a `pointer assignment' with updated descriptor (or assign descriptor + to array temporary) for arrays with either unknown shape or if associating + to a variable. */ + if (sym->attr.dimension + && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) + { + gfc_se se; + gfc_ss* ss; + tree desc; + + desc = sym->backend_decl; + + /* If association is to an expression, evaluate it and create temporary. + Otherwise, get descriptor of target for pointer assignment. */ + gfc_init_se (&se, NULL); + ss = gfc_walk_expr (e); + if (sym->assoc->variable) + { + se.direct_byref = 1; + se.expr = desc; + } + gfc_conv_expr_descriptor (&se, e, ss); + + /* If we didn't already do the pointer assignment, set associate-name + descriptor to the one generated for the temporary. */ + if (!sym->assoc->variable) + { + int dim; + + gfc_add_modify (&se.pre, desc, se.expr); + + /* The generated descriptor has lower bound zero (as array + temporary), shift bounds so we get lower bounds of 1. */ + for (dim = 0; dim < e->rank; ++dim) + gfc_conv_shift_descriptor_lbound (&se.pre, desc, + dim, gfc_index_one_node); + } + + /* Done, register stuff as init / cleanup code. */ + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a scalar pointer assignment; this is for scalar variable targets. */ + else if (gfc_is_associate_pointer (sym)) + { + gfc_se se; + + gcc_assert (!sym->attr.dimension); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e); + + tmp = TREE_TYPE (sym->backend_decl); + tmp = gfc_build_addr_expr (tmp, se.expr); + gfc_add_modify (&se.pre, sym->backend_decl, tmp); + + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a simple assignment. This is for scalar expressions, where we + can simply use expression assignment. */ + else + { + gfc_expr* lhs; + + lhs = gfc_lval_expr_from_sym (sym); + tmp = gfc_trans_assignment (lhs, e, false, true); + gfc_add_init_cleanup (block, tmp, NULL_TREE); + } } @@ -3074,15 +3225,16 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) Allocation of character string variables. Initialization and possibly repacking of dummy arrays. Initialization of ASSIGN statement auxiliary variable. + Initialization of ASSOCIATE names. 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 @@ -3106,19 +3258,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) 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 @@ -3128,20 +3278,21 @@ 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. */ - 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) { bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) && sym->ts.u.derived->attr.alloc_comp; - if (sym->attr.dimension) + if (sym->assoc) + trans_associate_var (sym, block); + else if (sym->attr.dimension) { switch (sym->as->type) { 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)) @@ -3149,7 +3300,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) else { seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, block); } } else @@ -3157,18 +3308,24 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) 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; @@ -3179,33 +3336,30 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) /* 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_has_alloc_comp) - fnbody = gfc_trans_deferred_array (sym, fnbody); else if (sym->attr.allocatable || (sym->ts.type == BT_CLASS - && sym->ts.u.derived->components->attr.allocatable)) + && CLASS_DATA (sym)->attr.allocatable)) { if (!sym->attr.save) { @@ -3214,7 +3368,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) 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) @@ -3226,47 +3380,54 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) 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) + 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) { @@ -3274,7 +3435,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) { 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); } } @@ -3283,11 +3444,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) { 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; @@ -3342,7 +3502,7 @@ gfc_find_module (const char *name) htab_hash_string (name), INSERT); if (*slot == NULL) { - struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry); + struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry (); entry->name = gfc_get_string (name); entry->decls = htab_create_ggc (10, module_htab_decls_hash, @@ -3439,7 +3599,7 @@ gfc_create_module_variable (gfc_symbol * sym) && (sym->equiv_built || sym->attr.in_equivalence)) return; - if (sym->backend_decl && !sym->attr.vtab) + if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target) internal_error ("backend decl for module variable %s already exists", sym->name); @@ -3462,7 +3622,8 @@ gfc_create_module_variable (gfc_symbol * sym) tree length; length = sym->ts.u.cl->backend_decl; - if (!INTEGER_CST_P (length)) + gcc_assert (length || sym->attr.proc_pointer); + if (length && !INTEGER_CST_P (length)) { pushdecl (length); rest_of_decl_compilation (length, 1, 0); @@ -3578,7 +3739,8 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, return check_constant_initializer (expr, ts, false, false); else if (expr->expr_type != EXPR_ARRAY) return false; - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (c->iterator) return false; @@ -3598,7 +3760,8 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, if (expr->expr_type != EXPR_STRUCTURE) return false; cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { if (!c->expr || cm->attr.allocatable) continue; @@ -3682,9 +3845,10 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym) TREE_USED (decl) = 1; if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL) TREE_PUBLIC (decl) = 1; - DECL_INITIAL (decl) - = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl), - sym->attr.dimension, 0); + DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, + TREE_TYPE (decl), + sym->attr.dimension, + false, false); debug_hooks->global_decl (decl); } @@ -3724,7 +3888,7 @@ gfc_generate_contained_functions (gfc_namespace * parent) if (ns->parent != parent) continue; - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); } for (ns = parent->contained; ns; ns = ns->sibling) @@ -3806,20 +3970,29 @@ generate_local_decl (gfc_symbol * sym) if (sym->attr.referenced) gfc_get_symbol_decl (sym); - /* INTENT(out) dummy arguments are likely meant to be set. */ - else if (warn_unused_variable - && sym->attr.dummy - && sym->attr.intent == INTENT_OUT) + + /* Warnings for unused dummy arguments. */ + else if (sym->attr.dummy) { - if (!(sym->ts.type == BT_DERIVED - && sym->ts.u.derived->components->initializer)) - gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) " - "but was not set", sym->name, &sym->declared_at); + /* INTENT(out) dummy arguments are likely meant to be set. */ + if (gfc_option.warn_unused_dummy_argument + && sym->attr.intent == INTENT_OUT) + { + if (sym->ts.type != BT_DERIVED) + gfc_warning ("Dummy argument '%s' at %L was declared " + "INTENT(OUT) but was not set", sym->name, + &sym->declared_at); + else if (!gfc_has_default_initializer (sym->ts.u.derived)) + gfc_warning ("Derived-type dummy argument '%s' at %L was " + "declared INTENT(OUT) but was not set and " + "does not have a default initializer", + sym->name, &sym->declared_at); + } + else if (gfc_option.warn_unused_dummy_argument) + gfc_warning ("Unused dummy argument '%s' at %L", sym->name, + &sym->declared_at); } - /* Specific warning for unused dummy arguments. */ - else if (warn_unused_variable && sym->attr.dummy) - gfc_warning ("Unused dummy argument '%s' at %L", sym->name, - &sym->declared_at); + /* Warn for unused variables, but not if they're inside a common block or are use-associated. */ else if (warn_unused_variable @@ -4009,27 +4182,29 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) /* Build the condition. For optional arguments, an actual length of 0 is also acceptable if the associated string is NULL, which means the argument was not passed. */ - cond = fold_build2 (comparison, boolean_type_node, - cl->passed_length, cl->backend_decl); + cond = fold_build2_loc (input_location, comparison, boolean_type_node, + cl->passed_length, cl->backend_decl); if (fsym->attr.optional) { tree not_absent; tree not_0length; tree absent_failed; - not_0length = fold_build2 (NE_EXPR, boolean_type_node, - cl->passed_length, - fold_convert (gfc_charlen_type_node, - integer_zero_node)); + not_0length = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + cl->passed_length, + fold_convert (gfc_charlen_type_node, + integer_zero_node)); /* The symbol needs to be referenced for gfc_get_symbol_decl. */ fsym->attr.referenced = 1; not_absent = gfc_conv_expr_present (fsym); - absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, - not_0length, not_absent); + absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, not_0length, + not_absent); - cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - cond, absent_failed); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, absent_failed); } /* Build the runtime check. */ @@ -4135,6 +4310,7 @@ create_main_function (tree fndecl) language standard parameters. */ { tree array_type, array, var; + VEC(constructor_elt,gc) *v = NULL; /* Passing a new option to the library requires four modifications: + add it to the tree_cons list below @@ -4143,28 +4319,34 @@ create_main_function (tree fndecl) gfor_fndecl_set_options + modify the library (runtime/compile_options.c)! */ - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.warn_std), NULL_TREE); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.allow_std), array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic), - array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_dump_core), array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_backtrace), array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_sign_zero), array); - - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array); - - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_range_check), array); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.warn_std)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.allow_std)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, pedantic)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_dump_core)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_backtrace)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_sign_zero)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + (gfc_option.rtcheck + & GFC_RTCHECK_BOUNDS))); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_range_check)); array_type = build_array_type (integer_type_node, build_index_type (build_int_cst (NULL_TREE, 7))); - array = build_constructor_from_list (array_type, nreverse (array)); + array = build_constructor (array_type, v); TREE_CONSTANT (array) = 1; TREE_STATIC (array) = 1; @@ -4235,8 +4417,9 @@ create_main_function (tree fndecl) TREE_USED (fndecl) = 1; /* "return 0". */ - tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main), - build_int_cst (integer_type_node, 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node, + DECL_RESULT (ftn_main), + build_int_cst (integer_type_node, 0)); tmp = build1_v (RETURN_EXPR, tmp); gfc_add_expr_to_block (&body, tmp); @@ -4266,6 +4449,57 @@ 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_loc (input_location, MODIFY_EXPR, + TREE_TYPE (result), DECL_RESULT (fndecl), + result); + } + } + + return build1_v (RETURN_EXPR, result); +} + + /* Generate code for a function. */ void @@ -4275,16 +4509,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); @@ -4292,7 +4528,7 @@ gfc_generate_function_code (gfc_namespace * ns) /* Create the declaration for functions with global scope. */ if (!sym->backend_decl) - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); fndecl = sym->backend_decl; old_context = current_function_decl; @@ -4306,7 +4542,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) { @@ -4345,34 +4581,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); @@ -4395,29 +4629,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 @@ -4427,24 +4641,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) @@ -4457,31 +4659,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; @@ -4489,14 +4688,14 @@ gfc_generate_function_code (gfc_namespace * ns) { 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. */ @@ -4547,6 +4746,8 @@ gfc_generate_function_code (gfc_namespace * ns) if (sym->attr.is_main_program) create_main_function (fndecl); + + current_procedure_symbol = previous_procedure_symbol; } @@ -4565,8 +4766,7 @@ gfc_generate_constructors (void) return; fnname = get_file_function_name ("I"); - type = build_function_type (void_type_node, - gfc_chainon_list (NULL_TREE, void_type_node)); + type = build_function_type_list (void_type_node, NULL_TREE); fndecl = build_decl (input_location, FUNCTION_DECL, fnname, type); @@ -4657,20 +4857,29 @@ gfc_generate_block_data (gfc_namespace * ns) /* Process the local variables of a BLOCK construct. */ void -gfc_process_block_locals (gfc_namespace* ns) +gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc) { tree decl; gcc_assert (saved_local_decls == NULL_TREE); generate_local_vars (ns); + /* Mark associate names to be initialized. The symbol's namespace may not + be the BLOCK's, we have to force this so that the deferring + works as expected. */ + for (; assoc; assoc = assoc->next) + { + assoc->st->n.sym->ns = ns; + gfc_defer_symbol_init (assoc->st->n.sym); + } + decl = saved_local_decls; while (decl) { tree next; - next = TREE_CHAIN (decl); - TREE_CHAIN (decl) = NULL_TREE; + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; pushdecl (decl); decl = next; } |