/* 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
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. */
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
}
+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
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;
}
/* 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
{
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
/* 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;
+ /* 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 = 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));
+ 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);
&& !sym->attr.proc_pointer)
DECL_BY_REFERENCE (decl) = 1;
- /* Add attributes to variables. Functions are handled elsewhere. */
- attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
- decl_attributes (&decl, attributes, 0);
-
return 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.proc_pointer ? false : sym->attr.dimension,
+ sym->attr.proc_pointer);
}
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
if (gfc_option.flag_whole_file
+ && !sym->attr.use_assoc
&& !sym->backend_decl
&& gsym && gsym->ns
&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
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
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)
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
- attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
- decl_attributes (&fndecl, attributes, 0);
-
return fndecl;
}
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;
}
- attributes = add_attributes_to_decl (attr, NULL_TREE);
- decl_attributes (&fndecl, attributes, 0);
/* Layout the function declaration and put it in the binding level
of the current function. */
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
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);
}
}
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);
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,
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->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 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt (input_location));
+ }
gfc_add_expr_to_block (&fnblock, tmp);
}
-
- if (!f->sym->ts.derived->attr.alloc_comp
- && f->sym->value)
+ else if (f->sym->value)
body = gfc_init_default_dt (f->sym, body);
}
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)
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);
+ if (sym->attr.dummy)
+ fnbody = gfc_trans_g77_array (sym, fnbody);
break;
case AS_ASSUMED_SHAPE:
}
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);
}
&& (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);
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)
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)
{
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,
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);
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);
+ /* The symbol needs to be referenced for gfc_get_symbol_decl. */
+ fsym->attr.referenced = 1;
+ not_absent = gfc_conv_expr_present (fsym);
absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
not_0length, not_absent);
/* 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)
{
stmtblock_t block;
stmtblock_t body;
tree result;
- tree recurcheckvar = NULL;
+ tree recurcheckvar = NULL_TREE;
gfc_symbol *sym;
int rank;
bool is_recursive;
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. */
is_recursive = sym->attr.recursive
|| (sym->attr.entry_master
&& sym->ns->entries->sym->attr.recursive);
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_recursive)
{
char * 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);
else
result = sym->result->backend_decl;
- 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;
+ 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_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
- }
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_openmp
+ && recurcheckvar != NULL_TREE)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
+ }
if (result == 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;
- }
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_openmp
+ && recurcheckvar != NULL_TREE)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL_TREE;
+ }
}
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);
}
+/* 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"