/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook
#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"
#include "debug.h"
#include "gfortran.h"
#include "pointer-set.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
static GTY(()) tree current_fake_result_decl;
static GTY(()) tree parent_fake_result_decl;
-static GTY(()) tree current_function_return_label;
-
/* Holds the variable DECLs for the current function. */
static gfc_namespace *module_namespace;
+/* The currently processed procedure symbol. */
+static gfc_symbol* current_procedure_symbol = NULL;
+
/* List of static constructor functions. */
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;
tree gfor_fndecl_runtime_warning_at;
/* 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;
gcc_assert (decl);
DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
DECL_NONLOCAL (decl) = 1;
- TREE_CHAIN (decl) = saved_parent_function_decls;
+ DECL_CHAIN (decl) = saved_parent_function_decls;
saved_parent_function_decls = decl;
}
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
- TREE_CHAIN (decl) = saved_function_decls;
+ DECL_CHAIN (decl) = saved_function_decls;
saved_function_decls = decl;
}
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
- TREE_CHAIN (decl) = saved_local_decls;
+ DECL_CHAIN (decl) = saved_local_decls;
saved_local_decls = decl;
}
}
-/* Returns the return label for the current function. */
-
-tree
-gfc_get_return_label (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 10];
-
- if (current_function_return_label)
- return current_function_return_label;
-
- sprintf (name, "__return_%s",
- IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
-
- current_function_return_label =
- gfc_build_label_decl (get_identifier (name));
-
- DECL_ARTIFICIAL (current_function_return_label) = 1;
-
- return current_function_return_label;
-}
-
-
/* Set the backend source location of a decl. */
void
gfortran would typically put them in either the BSS or
initialized data segments, and only mark them as common if
they were part of common blocks. However, if they are not put
- into common space, then C cannot initialize global fortran
+ into common space, then C cannot initialize global Fortran
variables that it interoperates with and the draft says that
either Fortran or C should be able to initialize it (but not
both, of course.) (J3/04-007, section 15.3). */
if (!sym->attr.target
&& !sym->attr.pointer
+ && !sym->attr.cray_pointee
&& !sym->attr.proc_pointer)
DECL_RESTRICTED_P (decl) = 1;
}
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
tree type;
int dim;
int nest;
+ gfc_namespace* procns;
type = TREE_TYPE (decl);
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++)
{
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;
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 (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 (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 (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,
VAR_DECL, get_identifier (name), type);
DECL_ARTIFICIAL (decl) = 1;
+ DECL_NAMELESS (decl) = 1;
TREE_PUBLIC (decl) = 0;
TREE_STATIC (decl) = 0;
DECL_EXTERNAL (decl) = 0;
SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
DECL_HAS_VALUE_EXPR_P (decl) = 1;
DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
- TREE_CHAIN (decl) = nonlocal_dummy_decls;
+ DECL_CHAIN (decl) = nonlocal_dummy_decls;
nonlocal_dummy_decls = decl;
}
}
+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. */
tree length = NULL_TREE;
tree attributes;
int byref;
+ bool intrinsic_array_parameter = false;
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. */
/* For entry master function skip over the __entry
argument. */
if (sym->ns->proc_name->attr.entry_master)
- sym->backend_decl = TREE_CHAIN (sym->backend_decl);
+ sym->backend_decl = DECL_CHAIN (sym->backend_decl);
}
/* Dummy variables should already have been created. */
return sym->backend_decl;
/* If use associated and whole file compilation, use the module
- declaration. This is only needed for intrinsic types because
- they are substituted for one another during optimization. */
+ declaration. */
if (gfc_option.flag_whole_file
&& sym->attr.flavor == FL_VARIABLE
- && sym->ts.type != BT_DERIVED
&& sym->attr.use_assoc
&& sym->module)
{
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
if (s && s->backend_decl)
{
+ if (sym->ts.type == BT_DERIVED)
+ gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
+ true);
if (sym->ts.type == BT_CHARACTER)
sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
- return s->backend_decl;
+ 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;
}
if (sym->attr.intrinsic)
internal_error ("intrinsic variable which isn't a procedure");
+ /* Special case for array-valued named constants from intrinsic
+ procedures; those are inlined. */
+ if (sym->attr.use_assoc && sym->from_intmod && sym->attr.dimension
+ && sym->attr.flavor == FL_PARAMETER)
+ intrinsic_array_parameter = true;
+
/* Create string length decl first so that they can be used in the
type declaration. */
if (sym->ts.type == BT_CHARACTER)
if (sym->module)
{
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
- if (sym->attr.use_assoc)
+ if (sym->attr.use_assoc && !intrinsic_array_parameter)
DECL_IGNORED_P (decl) = 1;
}
/* 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
&& !sym->attr.data
&& !sym->attr.allocatable
&& (sym->value && !sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc))
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
if (sym->attr.assign)
gfc_add_assign_aux_vars (sym);
- if (TREE_STATIC (decl) && !sym->attr.use_assoc)
+ if (intrinsic_array_parameter)
{
- /* Add static initializer. */
+ TREE_STATIC (decl) = 1;
+ DECL_EXTERNAL (decl) = 0;
+ }
+
+ if (TREE_STATIC (decl)
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)
+ && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
+ || gfc_option.flag_max_stack_var_size == 0
+ || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
+ {
+ /* Add static initializer. For procedures, it is only needed if
+ SAVE is specified otherwise they need to be reinitialized
+ 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)
{
/* Add static initializer. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+ TREE_TYPE (decl),
+ sym->attr.dimension,
+ false, true);
}
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
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. */
}
}
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,
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);
/* 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;
}
/* 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;
gfc_symbol *thunk_sym;
stmtblock_t body;
tree thunk_fndecl;
- tree args;
- tree string_args;
tree tmp;
locus old_loc;
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);
/* 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));
}
}
{
/* 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;
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);
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);
/* 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);
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);
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)
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;
/* 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--)
{
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);
DECL_EXTERNAL (fndecl) = 1;
TREE_PUBLIC (fndecl) = 1;
- va_end (p);
-
pushdecl (fndecl);
rest_of_decl_compilation (fndecl, 1, 0);
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)
{
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. */
{
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;
}
}
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]);
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;
}
}
}
#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. */
{
}
/* 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;
}
{
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_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_runtime_error =
- gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
- void_type_node, -1, pchar_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_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_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 ();
/* 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
/* Initialize a derived type by building an lvalue from the symbol
- and using trans_assignment to do the work. */
-tree
-gfc_init_default_dt (gfc_symbol * sym, tree body)
+ and using trans_assignment to do the work. Set dealloc to false
+ if no deallocation prior the assignment is needed. */
+void
+gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
{
- stmtblock_t fnblock;
gfc_expr *e;
tree tmp;
tree present;
- gfc_init_block (&fnblock);
+ gcc_assert (block);
+
gcc_assert (!sym->attr.allocatable);
gfc_set_sym_referenced (sym);
e = gfc_lval_expr_from_sym (sym);
- tmp = gfc_trans_assignment (e, sym->value, false);
+ tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
if (sym->attr.dummy && (sym->attr.optional
|| 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);
}
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
|| 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);
+ 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);
+ }
}
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
else if (proc_sym->as)
{
tree result = TREE_VALUE (current_fake_result_decl);
- fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
+ gfc_trans_dummy_array_bias (proc_sym, result, block);
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
- fnbody);
+ gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
- fnbody);
+ gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else
gcc_assert (gfc_option.flag_f2c
/* Initialize the INTENT(OUT) derived type dummy arguments. This
should be done here so that the offsets and lbounds of arrays
are available. */
- fnbody = init_intent_out_dt (proc_sym, fnbody);
+ init_intent_out_dt (proc_sym, block);
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
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))
else
{
seen_trans_deferred_array = true;
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, block);
}
}
else
if (sym_has_alloc_comp)
{
seen_trans_deferred_array = true;
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, block);
}
else if (sym->ts.type == BT_DERIVED
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = gfc_init_default_dt (sym, fnbody);
+ {
+ 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;
case AS_ASSUMED_SIZE:
/* Must be a dummy parameter. */
- gcc_assert (sym->attr.dummy);
+ gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
/* We should always pass assumed size arrays the g77 way. */
- fnbody = gfc_trans_g77_array (sym, fnbody);
- break;
+ if (sym->attr.dummy)
+ 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))
{
- /* Nullify and automatic deallocatation of allocatable scalars. */
- tree tmp;
- gfc_expr *e;
- gfc_se se;
- stmtblock_t block;
-
- e = gfc_lval_expr_from_sym (sym);
- if (sym->ts.type == BT_CLASS)
- gfc_add_component_ref (e, "$data");
-
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
- gfc_free_expr (e);
-
- /* Nullify when entering the scope. */
- gfc_start_block (&block);
- gfc_add_modify (&block, 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);
+ if (!sym->attr.save)
+ {
+ /* Nullify and automatic deallocation of allocatable
+ scalars. */
+ tree tmp;
+ gfc_expr *e;
+ gfc_se se;
+ stmtblock_t init;
+
+ e = gfc_lval_expr_from_sym (sym);
+ if (sym->ts.type == BT_CLASS)
+ gfc_add_component_ref (e, "$data");
+
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc_free_expr (e);
+
+ /* Nullify when entering the scope. */
+ gfc_start_block (&init);
+ gfc_add_modify (&init, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+
+ /* Deallocate when leaving the scope. Nullifying is not
+ needed. */
+ 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);
+ {
+ gfc_start_block (&tmpblock);
+ gfc_init_default_dt (sym, &tmpblock, false);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
+ NULL_TREE);
+ }
else
gcc_unreachable ();
}
- gfc_init_block (&body);
+ gfc_init_block (&tmpblock);
for (f = proc_sym->formal; f; f = f->next)
{
{
gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
- gfc_trans_vla_type_sizes (f->sym, &body);
+ gfc_trans_vla_type_sizes (f->sym, &tmpblock);
}
}
{
gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
- gfc_trans_vla_type_sizes (proc_sym, &body);
+ gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
}
- gfc_add_expr_to_block (&body, fnbody);
- return gfc_finish_block (&body);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
}
static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
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,
{
decl = sym->backend_decl;
gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
- gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
- || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
- gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
- || DECL_CONTEXT (TYPE_STUB_DECL (decl))
- == sym->ns->proc_name->backend_decl);
+
+ /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
+ if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
+ {
+ gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
+ || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
+ gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
+ || DECL_CONTEXT (TYPE_STUB_DECL (decl))
+ == sym->ns->proc_name->backend_decl);
+ }
TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
&& (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);
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);
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;
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;
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);
}
if (ns->parent != parent)
continue;
- gfc_create_function_decl (ns);
+ gfc_create_function_decl (ns, false);
}
for (ns = parent->contained; ns; ns = ns->sibling)
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
/* 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_absent = fold_build2 (NE_EXPR, boolean_type_node,
- fsym->backend_decl, null_pointer_node);
-
- absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- not_0length, not_absent);
-
- cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- cond, absent_failed);
+ 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_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, not_0length,
+ not_absent);
+
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond, absent_failed);
}
/* Build the runtime check. */
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
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;
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);
}
+/* 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
tree old_context;
tree decl;
tree tmp;
- tree tmp2;
- stmtblock_t block;
+ stmtblock_t init, cleanup;
stmtblock_t body;
- tree result;
- tree recurcheckvar = NULL;
+ 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);
/* 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;
trans_function_start (sym);
- gfc_init_block (&block);
+ gfc_init_block (&init);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
else
current_fake_result_decl = NULL_TREE;
- current_function_return_label = NULL;
+ is_recursive = sym->attr.recursive
+ || (sym->attr.entry_master
+ && sym->ns->entries->sym->attr.recursive);
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_recursive)
+ {
+ char * msg;
+
+ asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+ sym->name);
+ recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+ TREE_STATIC (recurcheckvar) = 1;
+ DECL_INITIAL (recurcheckvar) = boolean_false_node;
+ gfc_add_expr_to_block (&init, recurcheckvar);
+ gfc_trans_runtime_check (true, false, recurcheckvar, &init,
+ &sym->declared_at, msg);
+ gfc_add_modify (&init, recurcheckvar, boolean_true_node);
+ gfc_free (msg);
+ }
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
- is_recursive = sym->attr.recursive
- || (sym->attr.entry_master
- && sym->ns->entries->sym->attr.recursive);
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
- && !gfc_option.flag_recursive)
- {
- char * msg;
-
- asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
- sym->name);
- recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
- TREE_STATIC (recurcheckvar) = 1;
- DECL_INITIAL (recurcheckvar) = boolean_false_node;
- gfc_add_expr_to_block (&block, recurcheckvar);
- gfc_trans_runtime_check (true, false, recurcheckvar, &block,
- &sym->declared_at, msg);
- gfc_add_modify (&block, recurcheckvar, boolean_true_node);
- gfc_free (msg);
- }
-
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
- && sym->attr.subroutine)
+ && sym->attr.subroutine)
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym, 0);
/* If bounds-checking is enabled, generate code to check passed in actual
arguments against the expected dummy argument attributes (e.g. string
lengths). */
- if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
add_argument_checking (&body, sym);
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
- /* Add a return label if needed. */
- if (current_function_return_label)
- {
- tmp = build1_v (LABEL_EXPR, current_function_return_label);
- gfc_add_expr_to_block (&body, tmp);
- }
-
- tmp = gfc_finish_block (&body);
- /* Add code to create and cleanup arrays. */
- tmp = gfc_trans_deferred_vars (sym, tmp);
-
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
- if (sym->attr.subroutine || sym == sym->result)
- {
- if (current_fake_result_decl != NULL)
- result = TREE_VALUE (current_fake_result_decl);
- else
- result = NULL_TREE;
- current_fake_result_decl = NULL_TREE;
- }
- else
- result = sym->result->backend_decl;
+ tree result = get_proc_result (sym);
- if (result != NULL_TREE && sym->attr.function
- && !sym->attr.pointer)
+ if (result != NULL_TREE
+ && sym->attr.function
+ && !sym->attr.pointer)
{
if (sym->ts.type == BT_DERIVED
&& 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)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
+ gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
+ null_pointer_node));
}
if (result == NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
else
- {
- /* Set the return value to the dummy result variable. The
- types may be different for scalar default REAL functions
- with -ff2c, therefore we have to convert. */
- tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
- tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
- DECL_RESULT (fndecl), tmp);
- tmp = build1_v (RETURN_EXPR, tmp);
- gfc_add_expr_to_block (&block, tmp);
- }
+ gfc_add_expr_to_block (&body, gfc_generate_return ());
}
- else
+
+ gfc_init_block (&cleanup);
+
+ /* Reset recursion-check variable. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_openmp
+ && recurcheckvar != NULL_TREE)
{
- gfc_add_expr_to_block (&block, tmp);
- /* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
- && !gfc_option.flag_openmp)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
- }
+ gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
}
+ /* Finish the function body and add init and cleanup code. */
+ tmp = gfc_finish_block (&body);
+ gfc_start_wrapped_block (&try_block, tmp);
+ /* Add code to create and cleanup arrays. */
+ gfc_trans_deferred_vars (sym, &try_block);
+ gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
+ gfc_finish_block (&cleanup));
/* Add all the decls we created during processing. */
decl = saved_function_decls;
{
tree next;
- next = TREE_CHAIN (decl);
- TREE_CHAIN (decl) = NULL_TREE;
+ next = DECL_CHAIN (decl);
+ DECL_CHAIN (decl) = NULL_TREE;
pushdecl (decl);
decl = next;
}
saved_function_decls = NULL_TREE;
- DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
+ DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
decl = getdecls ();
/* Finish off this function and send it for code generation. */
if (sym->attr.is_main_program)
create_main_function (fndecl);
+
+ current_procedure_symbol = previous_procedure_symbol;
}
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);
/* 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;
}
OSDN Git Service
