/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "cgraph.h"
#include "debug.h"
#include "gfortran.h"
+#include "pointer-set.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
static GTY(()) tree saved_function_decls;
static GTY(()) tree saved_parent_function_decls;
+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. */
tree gfor_fndecl_runtime_warning_at;
tree gfor_fndecl_os_error;
tree gfor_fndecl_generate_error;
+tree gfor_fndecl_set_args;
tree gfor_fndecl_set_fpe;
tree gfor_fndecl_set_options;
tree gfor_fndecl_set_convert;
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;
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;
+ TREE_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
label_name = NULL;
/* Build the LABEL_DECL node. Labels have no type. */
- label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
+ label_decl = build_decl (input_location,
+ LABEL_DECL, label_id, void_type_node);
DECL_CONTEXT (label_decl) = current_function_decl;
DECL_MODE (label_decl) = VOIDmode;
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
- return (get_identifier (sym->name));
+ if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+ return (get_identifier ("MAIN__"));
+ else
+ return (get_identifier (sym->name));
}
}
+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.proc_pointer)
+ DECL_RESTRICTED_P (decl) = 1;
}
layout_type (type);
}
- if (nest || write_symbols == NO_DEBUG)
- return;
-
if (TYPE_NAME (type) != NULL_TREE
&& GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
&& TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
}
}
- TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+ TYPE_NAME (type) = type_decl = build_decl (input_location,
+ TYPE_DECL, NULL, gtype);
DECL_ORIGINAL_TYPE (type_decl) = gtype;
}
}
/* 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
{
}
ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
- decl = build_decl (VAR_DECL, get_identifier (name), type);
+ decl = build_decl (input_location,
+ VAR_DECL, get_identifier (name), type);
DECL_ARTIFICIAL (decl) = 1;
TREE_PUBLIC (decl) = 0;
return decl;
}
+/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
+ function add a VAR_DECL to the current function with DECL_VALUE_EXPR
+ pointing to the artificial variable for debug info purposes. */
+
+static void
+gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
+{
+ tree decl, dummy;
+
+ if (! nonlocal_dummy_decl_pset)
+ nonlocal_dummy_decl_pset = pointer_set_create ();
+
+ if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
+ return;
+
+ dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+ decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
+ TREE_TYPE (sym->backend_decl));
+ DECL_ARTIFICIAL (decl) = 0;
+ TREE_USED (decl) = 1;
+ TREE_PUBLIC (decl) = 0;
+ TREE_STATIC (decl) = 0;
+ DECL_EXTERNAL (decl) = 0;
+ if (DECL_BY_REFERENCE (dummy))
+ DECL_BY_REFERENCE (decl) = 1;
+ DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
+ 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;
+ nonlocal_dummy_decls = decl;
+}
/* Return a constant or a variable to use as a string length. Does not
add the decl to the current scope. */
static tree
gfc_create_string_length (gfc_symbol * sym)
{
- tree length;
+ gcc_assert (sym->ts.u.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
- gcc_assert (sym->ts.cl);
- gfc_conv_const_charlen (sym->ts.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];
/* Also prefix the mangled name. */
strcpy (&name[1], sym->name);
name[0] = '.';
- length = build_decl (VAR_DECL, get_identifier (name),
+ length = build_decl (input_location,
+ VAR_DECL, get_identifier (name),
gfc_charlen_type_node);
DECL_ARTIFICIAL (length) = 1;
TREE_USED (length) = 1;
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;
}
- 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
decl = sym->backend_decl;
gfc_allocate_lang_decl (decl);
GFC_DECL_ASSIGN (decl) = 1;
- length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
+ length = build_decl (input_location,
+ VAR_DECL, create_tmp_var_name (sym->name),
gfc_charlen_type_node);
- addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
+ addr = build_decl (input_location,
+ VAR_DECL, create_tmp_var_name (sym->name),
pvoid_type_node);
gfc_finish_var_decl (length, sym);
gfc_finish_var_decl (addr, sym);
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;
+}
+
+
/* 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;
gcc_assert (sym->attr.referenced
|| sym->attr.use_assoc
|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
- 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;
/* 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)
{
{
gfc_add_assign_aux_vars (sym);
}
+
+ if (sym->attr.dimension
+ && DECL_LANG_SPECIFIC (sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
+ && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
+ gfc_nonlocal_dummy_array_decl (sym);
+
return sym->backend_decl;
}
if (sym->backend_decl)
return sym->backend_decl;
- /* Catch function declarations. Only used for actual parameters. */
+ /* If use associated and whole file compilation, use the module
+ declaration. This is only needed for intrinsic types because
+ they are substituted for one another during optimization. */
+ if (gfc_option.flag_whole_file
+ && sym->attr.flavor == FL_VARIABLE
+ && sym->ts.type != BT_DERIVED
+ && sym->attr.use_assoc
+ && 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_CHARACTER)
+ sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
+ return s->backend_decl;
+ }
+ }
+ }
+
+ /* Catch function declarations. Only used for actual parameters and
+ procedure pointers. */
if (sym->attr.flavor == FL_PROCEDURE)
{
decl = gfc_get_extern_function_decl (sym);
+ gfc_set_decl_location (decl, &sym->declared_at);
return decl;
}
length = gfc_create_string_length (sym);
/* Create the decl for the variable. */
- decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
+ decl = build_decl (sym->declared_at.lb->location,
+ VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
- gfc_set_decl_location (decl, &sym->declared_at);
+ /* 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));
+ gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.use_assoc)
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)
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 &&
+ (sym->ts.u.derived->components->attr.dimension
+ || sym->ts.u.derived->components->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))
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);
{
tree span;
GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
- span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
+ span = build_decl (input_location,
+ VAR_DECL, create_tmp_var_name ("span"),
gfc_array_index_type);
gfc_finish_var_decl (span, sym);
TREE_STATIC (span) = TREE_STATIC (decl);
sym->attr.pointer || sym->attr.allocatable);
}
+ if (!TREE_STATIC (decl)
+ && POINTER_TYPE_P (TREE_TYPE (decl))
+ && !sym->attr.pointer
+ && !sym->attr.allocatable
+ && !sym->attr.proc_pointer)
+ DECL_BY_REFERENCE (decl) = 1;
+
return decl;
}
get_proc_pointer_decl (gfc_symbol *sym)
{
tree decl;
+ tree attributes;
decl = sym->backend_decl;
if (decl)
return decl;
- decl = build_decl (VAR_DECL, get_identifier (sym->name),
+ decl = build_decl (input_location,
+ VAR_DECL, get_identifier (sym->name),
build_pointer_type (gfc_get_function_type (sym)));
if ((sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == current_function_decl)
|| sym->attr.contained)
gfc_add_decl_to_function (decl);
- else
+ else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
gfc_add_decl_to_parent_function (decl);
sym->backend_decl = decl;
+ /* If a variable is USE associated, it's always external. */
+ if (sym->attr.use_assoc)
+ {
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ }
+ else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ /* This is the declaration of a module variable. */
+ TREE_PUBLIC (decl) = 1;
+ TREE_STATIC (decl) = 1;
+ }
+
if (!sym->attr.use_assoc
&& (sym->attr.save != SAVE_NONE || sym->attr.data
|| (sym->value && sym->ns->proc_name->attr.is_main_program)))
{
/* 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.proc_pointer ? false : sym->attr.dimension,
+ sym->attr.proc_pointer);
}
+ 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;
char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
tree name;
tree mangled_name;
+ gfc_gsymbol *gsym;
if (sym->backend_decl)
return sym->backend_decl;
if (sym->attr.proc_pointer)
return get_proc_pointer_decl (sym);
+ /* See if this is an external procedure from the same file. If so,
+ return the backend_decl. */
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+
+ if (gfc_option.flag_whole_file
+ && !sym->attr.use_assoc
+ && !sym->backend_decl
+ && gsym && gsym->ns
+ && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+ && gsym->ns->proc_name->backend_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. */
+ if (gsym->ns->entries)
+ {
+ gfc_entry_list *entry = gsym->ns->entries;
+
+ for (; entry; entry = entry->next)
+ {
+ if (strcmp (gsym->name, entry->sym->name) == 0)
+ {
+ sym->backend_decl = entry->sym->backend_decl;
+ break;
+ }
+ }
+ }
+ else
+ {
+ sym->backend_decl = gsym->ns->proc_name->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)
{
/* Call the resolution function to get the actual name. This is
}
type = gfc_get_function_type (sym);
- fndecl = build_decl (FUNCTION_DECL, name, type);
+ 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)
static void
build_function_decl (gfc_symbol * sym)
{
- tree fndecl, type;
+ tree fndecl, type, attributes;
symbol_attribute attr;
tree result_decl;
gfc_formal_arglist *f;
== NAMESPACE_DECL);
type = gfc_get_function_type (sym);
- fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
+ 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)
type = void_type_node;
}
- result_decl = build_decl (RESULT_DECL, result_decl, type);
+ result_decl = build_decl (input_location,
+ RESULT_DECL, result_decl, type);
DECL_ARTIFICIAL (result_decl) = 1;
DECL_IGNORED_P (result_decl) = 1;
DECL_CONTEXT (result_decl) = fndecl;
/* 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;
/* This specifies if a function is globally visible, i.e. it is
the opposite of declaring static in C. */
if (DECL_CONTEXT (fndecl) == NULL_TREE
- && !sym->attr.entry_master)
+ && !sym->attr.entry_master && !sym->attr.is_main_program)
TREE_PUBLIC (fndecl) = 1;
/* TREE_STATIC means the function body is defined here. */
TREE_SIDE_EFFECTS (fndecl) = 0;
}
- /* For -fwhole-program to work well, the main program needs to have the
- "externally_visible" attribute. */
- if (attr.is_main_program)
- DECL_ATTRIBUTES (fndecl)
- = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
/* Layout the function declaration and put it in the binding level
of the current function. */
if (sym->attr.entry_master)
{
type = TREE_VALUE (typelist);
- parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
+ parm = build_decl (input_location,
+ PARM_DECL, get_identifier ("__entry"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
gcc_assert (len_type == gfc_charlen_type_node);
- length = build_decl (PARM_DECL,
+ length = build_decl (input_location,
+ 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 (VAR_DECL,
+ tree len = build_decl (input_location,
+ VAR_DECL,
get_identifier ("..__result"),
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. */
}
}
- parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
+ parm = build_decl (input_location,
+ PARM_DECL, get_identifier ("__result"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
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;
strcpy (&name[1], f->sym->name);
name[0] = '_';
- length = build_decl (PARM_DECL, get_identifier (name), len_type);
+ length = build_decl (input_location,
+ PARM_DECL, get_identifier (name), len_type);
hidden_arglist = chainon (hidden_arglist, length);
DECL_CONTEXT (length) = fndecl;
TREE_READONLY (length) = 1;
gfc_finish_decl (length);
- /* TODO: Check string lengths when -fbounds-check. */
+ /* Remember the passed value. */
+ 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. */
+ f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
+ }
+ 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. */
type = build_pointer_type (type);
/* Build the argument declaration. */
- parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
+ parm = build_decl (input_location,
+ PARM_DECL, gfc_sym_identifier (f->sym), type);
/* Fill in arg stuff. */
DECL_CONTEXT (parm) = fndecl;
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
thunk_fndecl = thunk_sym->backend_decl;
- gfc_start_block (&body);
+ gfc_init_block (&body);
/* Pass extra parameter identifying this entry point. */
tmp = build_int_cst (gfc_array_index_type, el->id);
args);
if (formal->sym->ts.type == BT_CHARACTER)
{
- tmp = thunk_formal->sym->ts.cl->backend_decl;
+ tmp = thunk_formal->sym->ts.u.cl->backend_decl;
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
args = nreverse (args);
args = chainon (args, nreverse (string_args));
tmp = ns->proc_name->backend_decl;
- tmp = build_function_call_expr (tmp, args);
+ tmp = build_function_call_expr (input_location, tmp, args);
if (ns->proc_name->attr.mixed_entry_master)
{
tree union_decl, field;
tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
- union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
+ union_decl = build_decl (input_location,
+ VAR_DECL, get_identifier ("__result"),
TREE_TYPE (master_type));
DECL_ARTIFICIAL (union_decl) = 1;
DECL_EXTERNAL (union_decl) = 0;
/* Finish off this function and send it for code generation. */
DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
+ tmp = getdecls ();
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
+ DECL_SAVED_TREE (thunk_fndecl)
+ = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
+ DECL_INITIAL (thunk_fndecl));
/* Output the GENERIC tree. */
dump_function (TDI_original, thunk_fndecl);
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;
}
}
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);
IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
if (!sym->attr.mixed_entry_master && sym->attr.function)
- decl = build_decl (VAR_DECL, get_identifier (name),
+ decl = build_decl (input_location,
+ VAR_DECL, get_identifier (name),
gfc_sym_type (sym));
else
- decl = build_decl (VAR_DECL, get_identifier (name),
+ decl = build_decl (input_location,
+ VAR_DECL, get_identifier (name),
TREE_TYPE (TREE_TYPE (this_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
/* Build the function type and decl. */
fntype = build_function_type (rettype, arglist);
- fndecl = build_decl (FUNCTION_DECL, name, fntype);
+ fndecl = build_decl (input_location,
+ FUNCTION_DECL, name, fntype);
/* Mark this decl as external. */
DECL_EXTERNAL (fndecl) = 1;
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);
+ }
}
/* 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_fpe =
gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
void_type_node, 1, integer_type_node);
gfor_fndecl_set_options =
gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
void_type_node, 2, integer_type_node,
- pvoid_type_node);
+ build_pointer_type (integer_type_node));
gfor_fndecl_set_convert =
gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
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);
/* Evaluate the string length expression. */
- gfc_conv_string_length (sym->ts.cl, NULL, &body);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
gfc_set_sym_referenced (sym);
e = gfc_lval_expr_from_sym (sym);
tmp = gfc_trans_assignment (e, sym->value, false);
- if (sym->attr.dummy)
+ 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 ());
+ tmp, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&fnblock, tmp);
gfc_free_expr (e);
}
-/* Initialize INTENT(OUT) derived type dummies. */
+/* Initialize INTENT(OUT) derived type dummies. As well as giving
+ 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)
{
stmtblock_t fnblock;
gfc_formal_arglist *f;
+ tree tmp;
+ tree present;
gfc_init_block (&fnblock);
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->ts.derived->attr.alloc_comp
- && f->sym->value)
- body = gfc_init_default_dt (f->sym, body);
+ && !f->sym->attr.pointer
+ && f->sym->ts.type == BT_DERIVED)
+ {
+ if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ {
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
+ f->sym->backend_decl,
+ f->sym->as ? f->sym->as->rank : 0);
+
+ if (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master)
+ {
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt (input_location));
+ }
+
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (f->sym->value)
+ body = gfc_init_default_dt (f->sym, body);
+ }
gfc_add_expr_to_block (&fnblock, body);
return gfc_finish_block (&fnblock);
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.
+ Automatic deallocation. */
-static tree
+tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
locus loc;
/* 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,
+ && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
fnbody);
}
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,
+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
fnbody);
}
else
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;
+ && sym->ts.u.derived->attr.alloc_comp;
if (sym->attr.dimension)
{
switch (sym->as->type)
}
else if (sym_has_alloc_comp)
fnbody = gfc_trans_deferred_array (sym, fnbody);
+ else if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.allocatable))
+ {
+ if (!sym->attr.save)
+ {
+ /* Nullify and automatic deallocation of allocatable
+ scalars. */
+ tree tmp;
+ gfc_expr *e;
+ gfc_se se;
+ stmtblock_t block;
+
+ e = gfc_lval_expr_from_sym (sym);
+ if (sym->ts.type == BT_CLASS)
+ gfc_add_component_ref (e, "$data");
+
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc_free_expr (e);
+
+ /* Nullify when entering the scope. */
+ gfc_start_block (&block);
+ gfc_add_modify (&block, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ gfc_add_expr_to_block (&block, fnbody);
+
+ /* Deallocate when leaving the scope. Nullifying is not
+ needed. */
+ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
+ NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ fnbody = gfc_finish_block (&block);
+ }
+ }
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);
+ fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
else
fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
{
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)
+ gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
+ if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (f->sym, &body);
}
}
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)
+ gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (proc_sym, &body);
}
gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
}
- /* Only output variables and array valued, or derived type,
- parameters. */
+ /* Only output variables, procedure pointers and array valued,
+ or derived type, parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& !(sym->attr.flavor == FL_PARAMETER
- && (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
+ && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
+ && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
return;
if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
- if (sym->backend_decl)
+ if (sym->backend_decl && !sym->attr.vtab)
internal_error ("backend decl for module variable %s already exists",
sym->name);
{
tree length;
- length = sym->ts.cl->backend_decl;
+ length = sym->ts.u.cl->backend_decl;
if (!INTEGER_CST_P (length))
{
pushdecl (length);
if (entry->namespace_decl == NULL)
{
entry->namespace_decl
- = build_decl (NAMESPACE_DECL,
+ = build_decl (input_location,
+ NAMESPACE_DECL,
get_identifier (use_stmt->module_name),
void_type_node);
DECL_EXTERNAL (entry->namespace_decl) = 1;
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
case BT_DERIVED:
if (expr->expr_type != EXPR_STRUCTURE)
return false;
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
if (!c->expr || cm->attr.allocatable)
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)
return;
/* Create the decl for the variable or constant. */
- decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
+ decl = build_decl (input_location,
+ sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
gfc_sym_identifier (sym), gfc_sym_type (sym));
if (sym->attr.flavor == FL_PARAMETER)
TREE_READONLY (decl) = 1;
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.flavor == FL_VARIABLE)
{
if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
- generate_dependency_declarations (sym);
+ generate_dependency_declarations (sym);
if (sym->attr.referenced)
- gfc_get_symbol_decl (sym);
+ 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);
+ {
+ if (!(sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->components->initializer))
+ gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
+ "but was not set", sym->name, &sym->declared_at);
+ }
/* 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->attr.in_common || sym->attr.use_assoc || sym->mark))
gfc_warning ("Unused variable '%s' declared at %L", sym->name,
&sym->declared_at);
+
/* For variable length CHARACTER parameters, the PARM_DECL already
references the length variable, so force gfc_get_symbol_decl
even when not referenced. If optimize > 0, it will be optimized
away anyway. But do this only after emitting -Wunused-parameter
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)
+ if (sym->attr.dummy && !sym->attr.referenced
+ && sym->ts.type == BT_CHARACTER
+ && 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 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.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);
}
+/* Add code to string lengths of actual arguments passed to a function against
+ the expected lengths of the dummy arguments. */
+
+static void
+add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
+{
+ gfc_formal_arglist *formal;
+
+ for (formal = sym->formal; formal; formal = formal->next)
+ if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
+ {
+ enum tree_code comparison;
+ tree cond;
+ tree argname;
+ gfc_symbol *fsym;
+ gfc_charlen *cl;
+ const char *message;
+
+ fsym = formal->sym;
+ cl = fsym->ts.u.cl;
+
+ gcc_assert (cl);
+ gcc_assert (cl->passed_length != NULL_TREE);
+ gcc_assert (cl->backend_decl != 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.
+ 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))
+ {
+ comparison = NE_EXPR;
+ 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;
+ message = _("Actual string length is shorter than the declared one"
+ " for dummy argument '%s' (%ld/%ld)");
+ }
+
+ /* 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);
+ 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);
+ }
+
+ /* Build the runtime check. */
+ argname = gfc_build_cstring_const (fsym->name);
+ argname = gfc_build_addr_expr (pchar_type_node, argname);
+ gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
+ message, argname,
+ fold_convert (long_integer_type_node,
+ cl->passed_length),
+ fold_convert (long_integer_type_node,
+ cl->backend_decl));
+ }
+}
+
+
+static void
+create_main_function (tree fndecl)
+{
+ tree old_context;
+ tree ftn_main;
+ tree tmp, decl, result_decl, argc, argv, typelist, arglist;
+ stmtblock_t body;
+
+ old_context = current_function_decl;
+
+ if (old_context)
+ {
+ push_function_context ();
+ saved_parent_function_decls = saved_function_decls;
+ saved_function_decls = NULL_TREE;
+ }
+
+ /* main() function must be declared with global scope. */
+ gcc_assert (current_function_decl == NULL_TREE);
+
+ /* Declare the function. */
+ tmp = build_function_type_list (integer_type_node, integer_type_node,
+ build_pointer_type (pchar_type_node),
+ NULL_TREE);
+ main_identifier_node = get_identifier ("main");
+ ftn_main = build_decl (input_location, FUNCTION_DECL,
+ main_identifier_node, tmp);
+ DECL_EXTERNAL (ftn_main) = 0;
+ TREE_PUBLIC (ftn_main) = 1;
+ TREE_STATIC (ftn_main) = 1;
+ DECL_ATTRIBUTES (ftn_main)
+ = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
+
+ /* Setup the result declaration (for "return 0"). */
+ result_decl = build_decl (input_location,
+ RESULT_DECL, NULL_TREE, integer_type_node);
+ DECL_ARTIFICIAL (result_decl) = 1;
+ DECL_IGNORED_P (result_decl) = 1;
+ DECL_CONTEXT (result_decl) = ftn_main;
+ DECL_RESULT (ftn_main) = result_decl;
+
+ pushdecl (ftn_main);
+
+ /* Get the arguments. */
+
+ arglist = NULL_TREE;
+ typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
+
+ tmp = TREE_VALUE (typelist);
+ argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
+ DECL_CONTEXT (argc) = ftn_main;
+ DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
+ TREE_READONLY (argc) = 1;
+ gfc_finish_decl (argc);
+ arglist = chainon (arglist, argc);
+
+ typelist = TREE_CHAIN (typelist);
+ tmp = TREE_VALUE (typelist);
+ argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
+ DECL_CONTEXT (argv) = ftn_main;
+ DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
+ TREE_READONLY (argv) = 1;
+ DECL_BY_REFERENCE (argv) = 1;
+ gfc_finish_decl (argv);
+ arglist = chainon (arglist, argv);
+
+ DECL_ARGUMENTS (ftn_main) = arglist;
+ current_function_decl = ftn_main;
+ announce_function (ftn_main);
+
+ rest_of_decl_compilation (ftn_main, 1, 0);
+ make_decl_rtl (ftn_main);
+ init_function_start (ftn_main);
+ pushlevel (0);
+
+ gfc_init_block (&body);
+
+ /* Call some libgfortran initialization routines, call then MAIN__(). */
+
+ /* Call _gfortran_set_args (argc, argv). */
+ TREE_USED (argc) = 1;
+ TREE_USED (argv) = 1;
+ 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;
+
+ /* Passing a new option to the library requires four modifications:
+ + add it to the tree_cons list below
+ + change the array size in the call to build_array_type
+ + change the first argument to the library call
+ 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);
+
+ 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));
+ TREE_CONSTANT (array) = 1;
+ TREE_STATIC (array) = 1;
+
+ /* Create a static variable to hold the jump table. */
+ var = gfc_create_var (array_type, "options");
+ TREE_CONSTANT (var) = 1;
+ TREE_STATIC (var) = 1;
+ TREE_READONLY (var) = 1;
+ DECL_INITIAL (var) = array;
+ var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
+
+ 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);
+ }
+
+ /* If -ffpe-trap option was provided, add a call to set_fpe so that
+ the library will raise a FPE when needed. */
+ if (gfc_option.fpe != 0)
+ {
+ 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 this is the main program and an -fconvert option was provided,
+ add a call to set_convert. */
+
+ if (gfc_option.convert != GFC_CONVERT_NATIVE)
+ {
+ 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 this is the main program and an -frecord-marker option was provided,
+ add a call to set_record_marker. */
+
+ if (gfc_option.record_marker != 0)
+ {
+ 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_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_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 = build1_v (RETURN_EXPR, tmp);
+ gfc_add_expr_to_block (&body, tmp);
+
+
+ DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
+ decl = getdecls ();
+
+ /* Finish off this function and send it for code generation. */
+ poplevel (1, 0, 1);
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
+
+ DECL_SAVED_TREE (ftn_main)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
+ DECL_INITIAL (ftn_main));
+
+ /* Output the GENERIC tree. */
+ dump_function (TDI_original, ftn_main);
+
+ cgraph_finalize_function (ftn_main, true);
+
+ if (old_context)
+ {
+ pop_function_context ();
+ saved_function_decls = saved_parent_function_decls;
+ }
+ current_function_decl = old_context;
+}
+
+
/* Generate code for a function. */
void
stmtblock_t block;
stmtblock_t body;
tree result;
+ tree recurcheckvar = NULL;
gfc_symbol *sym;
int rank;
+ bool is_recursive;
sym = ns->proc_name;
trans_function_start (sym);
- gfc_start_block (&block);
+ gfc_init_block (&block);
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. */
gfc_generate_contained_functions (ns);
+ nonlocal_dummy_decls = NULL;
+ nonlocal_dummy_decl_pset = NULL;
+
generate_local_vars (ns);
/* Keep the parent fake result declaration in module functions
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
- /* If this is the main program, add a call to set_options to set up the
- runtime library Fortran language standard parameters. */
- if (sym->attr.is_main_program)
- {
- tree array_type, array, var;
-
- /* Passing a new option to the library requires four modifications:
- + add it to the tree_cons list below
- + change the array size in the call to build_array_type
- + change the first argument to the library call
- 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,
- flag_bounds_check), array);
-
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_range_check), array);
-
- 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));
- TREE_CONSTANT (array) = 1;
- TREE_STATIC (array) = 1;
-
- /* Create a static variable to hold the jump table. */
- var = gfc_create_var (array_type, "options");
- TREE_CONSTANT (var) = 1;
- TREE_STATIC (var) = 1;
- TREE_READONLY (var) = 1;
- DECL_INITIAL (var) = array;
- var = gfc_build_addr_expr (pvoid_type_node, var);
-
- tmp = build_call_expr (gfor_fndecl_set_options, 2,
- build_int_cst (integer_type_node, 8), var);
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* If this is the main program and a -ffpe-trap option was provided,
- add a call to set_fpe so that the library will raise a FPE when
- needed. */
- if (sym->attr.is_main_program && gfc_option.fpe != 0)
- {
- tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
- build_int_cst (integer_type_node,
- gfc_option.fpe));
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* If this is the main program and an -fconvert option was provided,
- add a call to set_convert. */
-
- if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
- {
- tmp = build_call_expr (gfor_fndecl_set_convert, 1,
- build_int_cst (integer_type_node,
- gfc_option.convert));
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* If this is the main program and an -frecord-marker option was provided,
- add a call to set_record_marker. */
-
- if (sym->attr.is_main_program && gfc_option.record_marker != 0)
- {
- tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
- build_int_cst (integer_type_node,
- gfc_option.record_marker));
- gfc_add_expr_to_block (&body, tmp);
- }
-
- if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
- {
- tmp = build_call_expr (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);
+ is_recursive = sym->attr.recursive
+ || (sym->attr.entry_master
+ && sym->ns->entries->sym->attr.recursive);
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
+ && !gfc_option.flag_recursive)
+ {
+ char * msg;
+
+ asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+ sym->name);
+ recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+ TREE_STATIC (recurcheckvar) = 1;
+ DECL_INITIAL (recurcheckvar) = boolean_false_node;
+ gfc_add_expr_to_block (&block, recurcheckvar);
+ gfc_trans_runtime_check (true, false, recurcheckvar, &block,
+ &sym->declared_at, msg);
+ gfc_add_modify (&block, recurcheckvar, boolean_true_node);
+ gfc_free (msg);
}
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
gfc_add_expr_to_block (&body, tmp);
}
+ /* 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)
+ add_argument_checking (&body, sym);
+
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
result = sym->result->backend_decl;
if (result != NULL_TREE && sym->attr.function
- && sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp
- && !sym->attr.pointer)
+ && !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;
+ tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
+ gfc_add_expr_to_block (&block, tmp2);
+ }
+ else if (sym->attr.allocatable && sym->attr.dimension == 0)
+ gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
+ null_pointer_node));
}
gfc_add_expr_to_block (&block, tmp);
+ /* Reset recursion-check variable. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
+ && !gfc_option.flag_openmp)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
+ }
+
if (result == NULL_TREE)
{
/* TODO: move to the appropriate place in resolve.c. */
}
}
else
- gfc_add_expr_to_block (&block, tmp);
+ {
+ gfc_add_expr_to_block (&block, tmp);
+ /* Reset recursion-check variable. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
+ && !gfc_option.flag_openmp)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
+ }
+ }
/* Add all the decls we created during processing. */
saved_function_decls = NULL_TREE;
DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
+ decl = getdecls ();
/* Finish off this function and send it for code generation. */
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ DECL_SAVED_TREE (fndecl)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+ DECL_INITIAL (fndecl));
+
+ if (nonlocal_dummy_decls)
+ {
+ BLOCK_VARS (DECL_INITIAL (fndecl))
+ = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
+ pointer_set_destroy (nonlocal_dummy_decl_pset);
+ nonlocal_dummy_decls = NULL;
+ nonlocal_dummy_decl_pset = NULL;
+ }
+
/* Output the GENERIC tree. */
dump_function (TDI_original, fndecl);
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);
}
+
void
gfc_generate_constructors (void)
{
type = build_function_type (void_type_node,
gfc_chainon_list (NULL_TREE, void_type_node));
- fndecl = build_decl (FUNCTION_DECL, fnname, type);
+ fndecl = build_decl (input_location,
+ FUNCTION_DECL, fnname, type);
TREE_PUBLIC (fndecl) = 1;
- decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
+ decl = build_decl (input_location,
+ RESULT_DECL, NULL_TREE, void_type_node);
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
DECL_CONTEXT (decl) = fndecl;
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
- tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
- DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
+ tmp = build_call_expr_loc (input_location,
+ TREE_VALUE (gfc_static_ctors), 0);
+ DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
}
+ decl = getdecls ();
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ DECL_SAVED_TREE (fndecl)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+ DECL_INITIAL (fndecl));
free_after_parsing (cfun);
free_after_compilation (cfun);
else
id = get_identifier ("__BLOCK_DATA__");
- decl = build_decl (VAR_DECL, id, gfc_array_index_type);
+ decl = build_decl (input_location,
+ VAR_DECL, id, gfc_array_index_type);
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_IGNORED_P (decl) = 1;
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+ tree decl;
+
+ gcc_assert (saved_local_decls == NULL_TREE);
+ generate_local_vars (ns);
+
+ decl = saved_local_decls;
+ while (decl)
+ {
+ tree next;
+
+ next = TREE_CHAIN (decl);
+ TREE_CHAIN (decl) = NULL_TREE;
+ pushdecl (decl);
+ decl = next;
+ }
+ saved_local_decls = NULL_TREE;
+}
+
+
#include "gt-fortran-trans-decl.h"