/* 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 struct pointer_set_t *nonlocal_dummy_decl_pset;
static GTY(()) tree nonlocal_dummy_decls;
+/* Holds the variable DECLs that are locals. */
+
+static GTY(()) tree saved_local_decls;
+
/* The namespace of the module we're currently generating. Only used while
outputting decls for module variables. Do not rely on this being set. */
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;
}
+static void
+add_decl_as_local (tree decl)
+{
+ gcc_assert (decl);
+ TREE_USED (decl) = 1;
+ DECL_CONTEXT (decl) = current_function_decl;
+ DECL_CHAIN (decl) = saved_local_decls;
+ saved_local_decls = decl;
+}
+
/* Build a backend label declaration. Set TREE_USED for named labels.
The context of the label is always the current_function_decl. All
}
-/* 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
}
+void
+gfc_set_decl_assembler_name (tree decl, tree name)
+{
+ tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
+ SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
+}
+
+
/* Returns true if a variable of specified size should go on the stack. */
int
/* Parameters need to be dereferenced. */
if (sym->cp_pointer->attr.dummy)
- ptr_decl = build_fold_indirect_ref (ptr_decl);
+ ptr_decl = build_fold_indirect_ref_loc (input_location,
+ ptr_decl);
/* Check to see if we're dealing with a variable-sized array. */
if (sym->attr.dimension
{
ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
ptr_decl);
- value = build_fold_indirect_ref (ptr_decl);
+ value = build_fold_indirect_ref_loc (input_location,
+ ptr_decl);
}
SET_DECL_VALUE_EXPR (decl, value);
if (current_function_decl != NULL_TREE)
{
if (sym->ns->proc_name->backend_decl == current_function_decl
- || sym->result == sym)
+ || sym->result == sym)
gfc_add_decl_to_function (decl);
+ else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+ /* This is a BLOCK construct. */
+ add_decl_as_local (decl);
else
gfc_add_decl_to_parent_function (decl);
}
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.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+ 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,
/* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER
- || INTEGER_CST_P (sym->ts.cl->backend_decl);
+ || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{
}
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ !sym->attr.target);
}
else
{
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 tree
gfc_create_string_length (gfc_symbol * sym)
{
- gcc_assert (sym->ts.cl);
- gfc_conv_const_charlen (sym->ts.cl);
+ gcc_assert (sym->ts.u.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
- if (sym->ts.cl->backend_decl == NULL_TREE)
+ if (sym->ts.u.cl->backend_decl == NULL_TREE)
{
tree length;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
if (sym->ns->proc_name->tlink != NULL)
gfc_defer_symbol_init (sym);
- sym->ts.cl->backend_decl = length;
+ sym->ts.u.cl->backend_decl = length;
}
- gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
- return sym->ts.cl->backend_decl;
+ gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
+ return sym->ts.u.cl->backend_decl;
}
/* If a variable is assigned a label, we add another two auxiliary
GFC_DECL_ASSIGN_ADDR (decl) = addr;
}
+
+static tree
+add_attributes_to_decl (symbol_attribute sym_attr, tree list)
+{
+ unsigned id;
+ tree attr;
+
+ for (id = 0; id < EXT_ATTR_NUM; id++)
+ if (sym_attr.ext_attr & (1 << id))
+ {
+ attr = build_tree_list (
+ get_identifier (ext_attr_list[id].middle_end_name),
+ NULL_TREE);
+ list = chainon (list, attr);
+ }
+
+ return 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. */
{
tree decl;
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->attr.function)
+ 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. */
/* Create a character length variable. */
if (sym->ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->backend_decl == NULL_TREE)
+ if (sym->ts.u.cl->backend_decl == NULL_TREE)
length = gfc_create_string_length (sym);
else
- length = sym->ts.cl->backend_decl;
+ length = sym->ts.u.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
{
if (sym->backend_decl)
return sym->backend_decl;
- /* Catch function declarations. Only used for actual parameters and
- procedure pointers. */
+ /* Special case for array-valued named constants from intrinsic
+ procedures; those are inlined. */
+ if (sym->attr.use_assoc && sym->from_intmod
+ && sym->attr.flavor == FL_PARAMETER)
+ intrinsic_array_parameter = true;
+
+ /* If use associated and whole file compilation, use the module
+ declaration. */
+ if (gfc_option.flag_whole_file
+ && (sym->attr.flavor == FL_VARIABLE
+ || sym->attr.flavor == FL_PARAMETER)
+ && sym->attr.use_assoc && !intrinsic_array_parameter
+ && sym->module)
+ {
+ gfc_gsymbol *gsym;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
+ if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+ {
+ gfc_symbol *s;
+ s = NULL;
+ 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;
+ sym->backend_decl = s->backend_decl;
+ return sym->backend_decl;
+ }
+ }
+ }
+
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;
}
decl = build_decl (sym->declared_at.lb->location,
VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
+ /* Add attributes to variables. Functions are handled elsewhere. */
+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+ decl_attributes (&decl, attributes, 0);
+
/* Symbols from modules should have their assembler names mangled.
This is done here rather than in gfc_finish_var_decl because it
is different for string length variables. */
if (sym->module)
{
- SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
- if (sym->attr.use_assoc)
+ gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
+ 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);
- /* Remember this variable for allocation/cleanup. */
- gfc_defer_symbol_init (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;
}
- if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
- gfc_defer_symbol_init (sym);
- /* This applies a derived type default initializer. */
- else if (sym->ts.type == BT_DERIVED
- && sym->attr.save == SAVE_NONE
- && !sym->attr.data
- && !sym->attr.allocatable
- && (sym->value && !sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
+ /* Remember this variable for allocation/cleanup. */
+ if (sym->attr.dimension || sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS &&
+ (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.save == SAVE_NONE
+ && !sym->attr.data
+ && !sym->attr.allocatable
+ && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
name[0] = '.';
strcpy (&name[1],
IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
- SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
+ gfc_set_decl_assembler_name (decl, get_identifier (name));
}
gfc_finish_var_decl (length, sym);
gcc_assert (!sym->value);
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)
get_proc_pointer_decl (gfc_symbol *sym)
{
tree decl;
+ tree attributes;
decl = sym->backend_decl;
if (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);
+ decl_attributes (&decl, attributes, 0);
+
return decl;
}
{
tree type;
tree fndecl;
+ tree attributes;
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
if (gfc_option.flag_whole_file
+ && (!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;
+
+ if (sym->backend_decl)
{
- sym->backend_decl = gsym->ns->proc_name->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;
}
+ }
- if (sym->backend_decl)
- return sym->backend_decl;
+ /* See if this is a module procedure from the same file. If so,
+ return the backend_decl. */
+ if (sym->module)
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+ if (gfc_option.flag_whole_file
+ && gsym && gsym->ns
+ && gsym->type == GSYM_MODULE)
+ {
+ gfc_symbol *s;
+
+ s = NULL;
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ {
+ sym->backend_decl = s->backend_decl;
+ return sym->backend_decl;
+ }
}
if (sym->attr.intrinsic)
fndecl = build_decl (input_location,
FUNCTION_DECL, name, type);
- SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
- /* If the return type is a pointer, avoid alias issues by setting
- DECL_IS_MALLOC to nonzero. This means that the function should be
- treated as if it were a malloc, meaning it returns a pointer that
- is not an alias. */
- if (POINTER_TYPE_P (type))
- DECL_IS_MALLOC (fndecl) = 1;
+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+ decl_attributes (&fndecl, attributes, 0);
+
+ gfc_set_decl_assembler_name (fndecl, mangled_name);
/* Set the context of this decl. */
if (0 && sym->ns && sym->ns->proc_name)
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;
+ 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);
fndecl = build_decl (input_location,
FUNCTION_DECL, gfc_sym_identifier (sym), type);
+ attr = sym->attr;
+
+ attributes = add_attributes_to_decl (attr, NULL_TREE);
+ decl_attributes (&fndecl, attributes, 0);
+
/* Perform name mangling if this is a top level or module procedure. */
if (current_function_decl == NULL_TREE)
- SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
+ gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
/* Figure out the return type of the declared function, and build a
RESULT_DECL for it. If this is a subroutine with alternate
returns, build a RESULT_DECL for it. */
- attr = sym->attr;
-
result_decl = NULL_TREE;
/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
if (attr.function)
/* Don't call layout_decl for a RESULT_DECL.
layout_decl (result_decl, 0); */
- /* If the return type is a pointer, avoid alias issues by setting
- DECL_IS_MALLOC to nonzero. This means that the function should be
- treated as if it were a malloc, meaning it returns a pointer that
- is not an alias. */
- if (POINTER_TYPE_P (type))
- DECL_IS_MALLOC (fndecl) = 1;
-
/* Set up all attributes for the function. */
DECL_CONTEXT (fndecl) = current_function_decl;
DECL_EXTERNAL (fndecl) = 0;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
+
/* 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;
}
PARM_DECL,
get_identifier (".__result"),
len_type);
- if (!sym->ts.cl->length)
+ if (!sym->ts.u.cl->length)
{
- sym->ts.cl->backend_decl = length;
+ sym->ts.u.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length);
- if (sym->ts.cl->backend_decl == NULL
- || sym->ts.cl->backend_decl == length)
+ if (sym->ts.u.cl->backend_decl == NULL
+ || sym->ts.u.cl->backend_decl == length)
{
gfc_symbol *arg;
tree backend_decl;
- if (sym->ts.cl->backend_decl == NULL)
+ if (sym->ts.u.cl->backend_decl == NULL)
{
tree len = build_decl (input_location,
VAR_DECL,
gfc_charlen_type_node);
DECL_ARTIFICIAL (len) = 1;
TREE_USED (len) = 1;
- sym->ts.cl->backend_decl = len;
+ sym->ts.u.cl->backend_decl = len;
}
/* Make sure PARM_DECL type doesn't point to incomplete type. */
type = TREE_VALUE (typelist);
- if (f->sym->ts.type == BT_CHARACTER)
+ if (f->sym->ts.type == BT_CHARACTER
+ && (!sym->attr.is_bind_c || sym->attr.entry_master))
{
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
gfc_finish_decl (length);
/* Remember the passed value. */
- if (f->sym->ts.cl->passed_length != NULL)
+ if (f->sym->ts.u.cl->passed_length != NULL)
{
/* This can happen if the same type is used for multiple
arguments. We need to copy cl as otherwise
cl->passed_length gets overwritten. */
- gfc_charlen *cl, *cl2;
- cl = f->sym->ts.cl;
- f->sym->ts.cl = gfc_get_charlen();
- f->sym->ts.cl->length = cl->length;
- f->sym->ts.cl->backend_decl = cl->backend_decl;
- f->sym->ts.cl->length_from_typespec = cl->length_from_typespec;
- f->sym->ts.cl->resolved = cl->resolved;
- cl2 = f->sym->ts.cl->next;
- f->sym->ts.cl->next = cl;
- cl->next = cl2;
+ f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
}
- f->sym->ts.cl->passed_length = length;
+ f->sym->ts.u.cl->passed_length = length;
/* Use the passed value for assumed length variables. */
- if (!f->sym->ts.cl->length)
+ if (!f->sym->ts.u.cl->length)
{
TREE_USED (length) = 1;
- gcc_assert (!f->sym->ts.cl->backend_decl);
- f->sym->ts.cl->backend_decl = length;
+ gcc_assert (!f->sym->ts.u.cl->backend_decl);
+ f->sym->ts.u.cl->backend_decl = length;
}
hidden_typelist = TREE_CHAIN (hidden_typelist);
- if (f->sym->ts.cl->backend_decl == NULL
- || f->sym->ts.cl->backend_decl == length)
+ if (f->sym->ts.u.cl->backend_decl == NULL
+ || f->sym->ts.u.cl->backend_decl == length)
{
- if (f->sym->ts.cl->backend_decl == NULL)
+ if (f->sym->ts.u.cl->backend_decl == NULL)
gfc_create_string_length (f->sym);
/* Make sure PARM_DECL type doesn't point to incomplete type. */
DECL_ARGUMENTS (fndecl) = arglist;
}
-/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
-
-static void
-gfc_gimplify_function (tree fndecl)
-{
- struct cgraph_node *cgn;
-
- gimplify_function_tree (fndecl);
- dump_function (TDI_generic, fndecl);
-
- /* Generate errors for structured block violations. */
- /* ??? Could be done as part of resolve_labels. */
- if (flag_openmp)
- diagnose_omp_structured_block_errors (fndecl);
-
- /* Convert all nested functions to GIMPLE now. We do things in this order
- so that items like VLA sizes are expanded properly in the context of the
- correct function. */
- cgn = cgraph_node (fndecl);
- for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
- gfc_gimplify_function (cgn->decl);
-}
-
-
/* Do the setup necessary before generating the body of a function. */
static void
/* 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.cl->backend_decl;
- string_args = tree_cons (NULL_TREE, tmp, string_args);
+ tmp = thunk_formal->sym->ts.u.cl->backend_decl;
+ 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 (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);
current_function_decl = NULL_TREE;
- gfc_gimplify_function (thunk_fndecl);
- cgraph_finalize_function (thunk_fndecl, false);
+ cgraph_finalize_function (thunk_fndecl, true);
/* We share the symbols in the formal argument list with other entry
points and the master function. Clear them so that they are
{
formal->sym->backend_decl = NULL_TREE;
if (formal->sym->ts.type == BT_CHARACTER)
- formal->sym->ts.cl->backend_decl = NULL_TREE;
+ formal->sym->ts.u.cl->backend_decl = NULL_TREE;
}
if (thunk_sym->attr.function)
{
if (thunk_sym->ts.type == BT_CHARACTER)
- thunk_sym->ts.cl->backend_decl = NULL_TREE;
+ thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
if (thunk_sym->result->ts.type == BT_CHARACTER)
- thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
+ thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
}
}
/* 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->ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->backend_decl == NULL_TREE)
+ if (sym->ts.u.cl->backend_decl == NULL_TREE)
length = gfc_create_string_length (sym);
else
- length = sym->ts.cl->backend_decl;
+ length = sym->ts.u.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
gfc_add_decl_to_function (length);
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.cl && sym->ts.cl->length);
+ 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.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);
- if (sym->attr.dummy)
+ 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->ts.type == BT_DERIVED)
+ && !f->sym->attr.pointer
+ && f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.derived->attr.alloc_comp)
+ if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
f->sym->backend_decl,
f->sym->as ? f->sym->as->rank : 0);
- present = gfc_conv_expr_present (f->sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
- tmp, build_empty_stmt (input_location));
+ if (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master)
+ {
+ present = gfc_conv_expr_present (f->sym);
+ 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);
}
-
- if (!f->sym->ts.derived->attr.alloc_comp
- && f->sym->value)
- body = gfc_init_default_dt (f->sym, body);
+ else if (f->sym->value)
+ 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 and initialization of array variables.
Allocation of character string variables.
Initialization and possibly repacking of dummy arrays.
- Initialization of ASSIGN statement auxiliary variable. */
+ Initialization of ASSIGN statement auxiliary variable.
+ Initialization of ASSOCIATE names.
+ Automatic deallocation. */
-static 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.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
- fnbody);
+ && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ 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.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
- fnbody);
+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ 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.derived->attr.alloc_comp;
- if (sym->attr.dimension)
+ && sym->ts.u.derived->attr.alloc_comp;
+ 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->attr.allocatable
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.allocatable))
+ {
+ 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)
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
- fnbody = gfc_trans_dummy_character (sym, sym->ts.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)
{
if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
{
- gcc_assert (f->sym->ts.cl->backend_decl != NULL);
- if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
- gfc_trans_vla_type_sizes (f->sym, &body);
+ 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, &tmpblock);
}
}
if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
&& current_fake_result_decl != NULL)
{
- gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
- if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
- gfc_trans_vla_type_sizes (proc_sym, &body);
+ 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, &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)
+ 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.cl->backend_decl;
- if (!INTEGER_CST_P (length))
+ length = sym->ts.u.cl->backend_decl;
+ gcc_assert (length || sym->attr.proc_pointer);
+ if (length && !INTEGER_CST_P (length))
{
pushdecl (length);
rest_of_decl_compilation (length, 1, 0);
st = gfc_find_symtree (ns->sym_root,
rent->local_name[0]
? rent->local_name : rent->use_name);
- gcc_assert (st && st->n.sym->attr.use_assoc);
+ gcc_assert (st);
+
+ /* Sometimes, generic interfaces wind up being over-ruled by a
+ local symbol (see PR41062). */
+ if (!st->n.sym->attr.use_assoc)
+ continue;
+
if (st->n.sym->backend_decl
&& DECL_P (st->n.sym->backend_decl)
&& st->n.sym->module
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;
case BT_DERIVED:
if (expr->expr_type != EXPR_STRUCTURE)
return false;
- cm = expr->ts.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ cm = expr->ts.u.derived->components;
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
if (!c->expr || cm->attr.allocatable)
continue;
if (sym->ts.type == BT_CHARACTER)
{
- gfc_conv_const_charlen (sym->ts.cl);
- if (sym->ts.cl->backend_decl == NULL
- || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
+ gfc_conv_const_charlen (sym->ts.u.cl);
+ if (sym->ts.u.cl->backend_decl == NULL
+ || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
return;
}
- else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
return;
if (sym->as)
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)
int i;
if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && sym->ts.cl->length
- && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
- generate_expr_decls (sym, sym->ts.cl->length);
+ && sym->ts.u.cl
+ && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ generate_expr_decls (sym, sym->ts.u.cl->length);
if (sym->as && sym->as->rank)
{
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)
- gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
- 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);
+
+ /* Warnings for unused dummy arguments. */
+ else if (sym->attr.dummy)
+ {
+ /* 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);
+ }
+
/* Warn for unused variables, but not if they're inside a common
block or are use-associated. */
else if (warn_unused_variable
warning if requested. */
if (sym->attr.dummy && !sym->attr.referenced
&& sym->ts.type == BT_CHARACTER
- && sym->ts.cl->backend_decl != NULL
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+ && sym->ts.u.cl->backend_decl != NULL
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
{
sym->attr.referenced = 1;
gfc_get_symbol_decl (sym);
}
- /* INTENT(out) dummy arguments with allocatable components are reset
- by default and need to be set referenced to generate the code for
- automatic lengths. */
- if (sym->attr.dummy && !sym->attr.referenced
+ /* INTENT(out) dummy arguments and result variables with allocatable
+ components are reset by default and need to be set referenced to
+ generate the code for nullification and automatic lengths. */
+ if (!sym->attr.referenced
&& sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp
- && sym->attr.intent == INTENT_OUT)
+ && sym->ts.u.derived->attr.alloc_comp
+ && !sym->attr.pointer
+ && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+ ||
+ (sym->attr.result && sym != sym->result)))
{
sym->attr.referenced = 1;
gfc_get_symbol_decl (sym);
}
-
/* Check for dependencies in the array specification and string
length, adding the necessary declarations to the function. We
mark the symbol now, as well as in traverse_ns, to prevent
const char *message;
fsym = formal->sym;
- cl = fsym->ts.cl;
+ cl = fsym->ts.u.cl;
gcc_assert (cl);
gcc_assert (cl->passed_length != NULL_TREE);
/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
string lengths must match exactly. Otherwise, it is only required
- that the actual string length is *at least* the expected one. */
+ that the actual string length is *at least* the expected one.
+ Sequence association allows for a mismatch of the string length
+ if the actual argument is (part of) an array, but only if the
+ dummy argument is an array. (See "Sequence association" in
+ Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
if (fsym->attr.pointer || fsym->attr.allocatable
|| (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
{
message = _("Actual string length does not match the declared one"
" for dummy argument '%s' (%ld/%ld)");
}
+ else if (fsym->as && fsym->as->rank != 0)
+ continue;
else
{
comparison = LT_EXPR;
/* 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. */
/* Call _gfortran_set_args (argc, argv). */
TREE_USED (argc) = 1;
TREE_USED (argv) = 1;
- tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_set_args, 2, argc, argv);
gfc_add_expr_to_block (&body, tmp);
/* Add a call to set_options to set up the runtime library Fortran
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;
DECL_INITIAL (var) = array;
var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
- tmp = build_call_expr (gfor_fndecl_set_options, 2,
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_set_options, 2,
build_int_cst (integer_type_node, 8), var);
gfc_add_expr_to_block (&body, tmp);
}
the library will raise a FPE when needed. */
if (gfc_option.fpe != 0)
{
- tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_set_fpe, 1,
build_int_cst (integer_type_node,
gfc_option.fpe));
gfc_add_expr_to_block (&body, tmp);
if (gfc_option.convert != GFC_CONVERT_NATIVE)
{
- tmp = build_call_expr (gfor_fndecl_set_convert, 1,
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_set_convert, 1,
build_int_cst (integer_type_node,
gfc_option.convert));
gfc_add_expr_to_block (&body, tmp);
if (gfc_option.record_marker != 0)
{
- tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_set_record_marker, 1,
build_int_cst (integer_type_node,
gfc_option.record_marker));
gfc_add_expr_to_block (&body, tmp);
if (gfc_option.max_subrecord_length != 0)
{
- tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_set_max_subrecord_length, 1,
build_int_cst (integer_type_node,
gfc_option.max_subrecord_length));
gfc_add_expr_to_block (&body, tmp);
}
/* Call MAIN__(). */
- tmp = build_call_expr (fndecl, 0);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 0);
gfc_add_expr_to_block (&body, tmp);
/* Mark MAIN__ as used. */
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);
/* Output the GENERIC tree. */
dump_function (TDI_original, ftn_main);
- gfc_gimplify_function (ftn_main);
- cgraph_finalize_function (ftn_main, false);
+ cgraph_finalize_function (ftn_main, true);
if (old_context)
{
}
+/* 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)
{
gfc_entry_list *el;
tree backend_decl;
- gfc_conv_const_charlen (ns->proc_name->ts.cl);
- backend_decl = ns->proc_name->result->ts.cl->backend_decl;
+ gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
+ backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
for (el = ns->entries; el; el = el->next)
- el->sym->result->ts.cl->backend_decl = backend_decl;
+ el->sym->result->ts.u.cl->backend_decl = backend_decl;
}
/* Translate COMMON blocks. */
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)
- {
- 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->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp
+ if (result != NULL_TREE
+ && sym->attr.function
&& !sym->attr.pointer)
{
- rank = sym->as ? sym->as->rank : 0;
- tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
- gfc_add_expr_to_block (&block, tmp2);
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp)
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ 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 (&init, 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_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
- }
-
if (result == NULL_TREE)
{
/* TODO: move to the appropriate place in resolve.c. */
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_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. */
added to our parent's nested function list. */
(void) cgraph_node (fndecl);
else
- {
- gfc_gimplify_function (fndecl);
- cgraph_finalize_function (fndecl, false);
- }
+ cgraph_finalize_function (fndecl, true);
gfc_trans_use_stmts (ns);
gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
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);
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
- tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
+ tmp = build_call_expr_loc (input_location,
+ TREE_VALUE (gfc_static_ctors), 0);
DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
}
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+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 = DECL_CHAIN (decl);
+ DECL_CHAIN (decl) = NULL_TREE;
+ pushdecl (decl);
+ decl = next;
+ }
+ saved_local_decls = NULL_TREE;
+}
+
+
#include "gt-fortran-trans-decl.h"
OSDN Git Service
