/* 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 "coretypes.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 "tm.h" /* For rtl.h. */
+#include "rtl.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 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_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;
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
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;
}
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 clear the artificial
+ lbound.N or ubound.N DECL_NAME, so that it doesn't end up
+ in debug info. */
+ if (lbound && TREE_CODE (lbound) == VAR_DECL
+ && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
{
- if (GFC_TYPE_ARRAY_LBOUND (type, dim)
- && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
- DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
- if (GFC_TYPE_ARRAY_UBOUND (type, dim)
- && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
- DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
+ if (DECL_NAME (lbound)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
+ "lbound") != 0)
+ DECL_NAME (lbound) = NULL_TREE;
+ DECL_IGNORED_P (lbound) = 0;
+ }
+ if (ubound && TREE_CODE (ubound) == VAR_DECL
+ && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
+ {
+ if (DECL_NAME (ubound)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
+ "ubound") != 0)
+ DECL_NAME (ubound) = NULL_TREE;
+ 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
{
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
else
byref = 0;
+ /* Make sure that the vtab for the declared type is completed. */
+ if (sym->ts.type == BT_CLASS)
+ {
+ gfc_component *c = gfc_find_component (sym->ts.u.derived,
+ "$data", true, true);
+ if (!c->ts.u.derived->backend_decl)
+ gfc_find_derived_vtab (c->ts.u.derived, true);
+ }
+
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
{
/* Return via extra parameter. */
/* 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)
/* 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);
if (sym->attr.assign)
gfc_add_assign_aux_vars (sym);
- if (TREE_STATIC (decl) && !sym->attr.use_assoc)
+ if (TREE_STATIC (decl) && !sym->attr.use_assoc
+ && (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. */
+ /* 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);
{
/* 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
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. */
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;
- 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 (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--)
{
/* 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. */
+
+static 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)
{
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. */
+ /* 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. */
+ gfc_int4_type_node);
+ /* STOP doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
+
+ 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 (get_identifier (PREFIX("error_stop_string")),
+ 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 (get_identifier (PREFIX("pause_string")),
void_type_node, 2, pchar_type_node,
- gfc_int4_type_node);
+ gfc_int4_type_node);
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
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")),
+ 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")),
+ 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 =
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);
/* Initialize a derived type by building an lvalue from the symbol
- and using trans_assignment to do the work. */
+ and using trans_assignment to do the work. Set dealloc to false
+ if no deallocation prior the assignment is needed. */
tree
-gfc_init_default_dt (gfc_symbol * sym, tree body)
+gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
{
stmtblock_t fnblock;
gfc_expr *e;
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,
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)
- body = gfc_init_default_dt (f->sym, body);
+ else if (f->sym->value)
+ body = gfc_init_default_dt (f->sym, body, true);
}
gfc_add_expr_to_block (&fnblock, 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)
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = gfc_init_default_dt (sym, fnbody);
+ fnbody = gfc_init_default_dt (sym, fnbody, false);
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
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:
if (sym_has_alloc_comp && !seen_trans_deferred_array)
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_has_alloc_comp)
fnbody = gfc_trans_deferred_array (sym, fnbody);
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);
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = gfc_init_default_dt (sym, fnbody);
+ fnbody = gfc_init_default_dt (sym, fnbody, false);
else
gcc_unreachable ();
}
{
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);
}
{
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)
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)
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)
+ 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);
+ }
/* 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);
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;
/* Output the GENERIC tree. */
dump_function (TDI_original, 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
- cgraph_finalize_function (fndecl, false);
+ cgraph_finalize_function (fndecl, true);
gfc_trans_use_stmts (ns);
gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
return;
fnname = get_file_function_name ("I");
- type = build_function_type (void_type_node,
- gfc_chainon_list (NULL_TREE, void_type_node));
+ type = build_function_type_list (void_type_node, NULL_TREE);
fndecl = build_decl (input_location,
FUNCTION_DECL, fnname, type);
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+ 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"