/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
+#include "stringpool.h"
+#include "stor-layout.h"
+#include "varasm.h"
+#include "attribs.h"
#include "tree-dump.h"
-#include "gimple.h" /* For create_tmp_var_raw. */
+#include "gimple-expr.h" /* For create_tmp_var_raw. */
#include "ggc.h"
#include "diagnostic-core.h" /* For internal_error. */
#include "toplev.h" /* For announce_function. */
binding label (mainly those that are bind(c)). */
if (sym->attr.is_bind_c == 1 && sym->binding_label)
return get_identifier (sym->binding_label);
-
+
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
if (gfc_option.flag_max_stack_var_size < 0)
return 1;
- if (TREE_INT_CST_HIGH (size) != 0)
+ if (!cst_fits_uhwi_p (size))
return 0;
low = TREE_INT_CST_LOW (size);
tree value;
/* Parameters need to be dereferenced. */
- if (sym->cp_pointer->attr.dummy)
+ if (sym->cp_pointer->attr.dummy)
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
- && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
- {
+ && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
+ {
/* These decls will be dereferenced later, so we don't dereference
them here. */
value = convert (TREE_TYPE (decl), ptr_decl);
/* We should know the storage size. */
gcc_assert (DECL_SIZE (decl) != NULL_TREE
- || (TREE_STATIC (decl)
+ || (TREE_STATIC (decl)
? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
: DECL_EXTERNAL (decl)));
TREE_PUBLIC(decl) = 1;
DECL_COMMON(decl) = 1;
}
-
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
{
/* TODO: Don't set sym->module for result or dummy variables. */
gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
- /* This is the declaration of a module variable. */
- if (sym->attr.access == ACCESS_UNKNOWN
- && (sym->ns->default_access == ACCESS_PRIVATE
- || (sym->ns->default_access == ACCESS_UNKNOWN
- && gfc_option.flag_module_private)))
- sym->attr.access = ACCESS_PRIVATE;
if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)
TREE_PUBLIC (decl) = 1;
TREE_SIDE_EFFECTS (decl) = 1;
new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
TREE_TYPE (decl) = new_type;
- }
+ }
/* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive
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.u.cl->backend_decl);
-
+
if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{
/* For descriptorless arrays with known element size the actual
&& as->lower[n]
&& as->upper[n]->expr_type == EXPR_CONSTANT
&& as->lower[n]->expr_type == EXPR_CONSTANT))
- packed = PACKED_PARTIAL;
+ {
+ packed = PACKED_PARTIAL;
+ break;
+ }
}
}
else
tree length;
const char *name;
- /* Also prefix the mangled name. */
- if (sym->module)
+ /* The string length variable shall be in static memory if it is either
+ explicitly SAVED, a module variable or with -fno-automatic. Only
+ relevant is "len=:" - otherwise, it is either a constant length or
+ it is an automatic variable. */
+ bool static_length = sym->attr.save
+ || sym->ns->proc_name->attr.flavor == FL_MODULE
+ || (gfc_option.flag_max_stack_var_size == 0
+ && sym->ts.deferred && !sym->attr.dummy
+ && !sym->attr.result && !sym->attr.function);
+
+ /* Also prefix the mangled name. We need to call GFC_PREFIX for static
+ variables as some systems do not support the "." in the assembler name.
+ For nonstatic variables, the "." does not appear in assembler. */
+ if (static_length)
+ {
+ if (sym->module)
+ name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
+ sym->name);
+ else
+ name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
+ }
+ else if (sym->module)
name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
else
name = gfc_get_string (".%s", sym->name);
sym->ts.u.cl->backend_decl = length;
- if (sym->attr.save || sym->ns->proc_name->attr.flavor == FL_MODULE)
+ if (static_length)
TREE_STATIC (length) = 1;
if (sym->ns->proc_name->attr.flavor == FL_MODULE
tree attributes;
int byref;
bool intrinsic_array_parameter = false;
+ bool fun_or_res;
gcc_assert (sym->attr.referenced
- || sym->attr.use_assoc
- || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
- || (sym->module && sym->attr.if_source != IFSRC_DECL
- && sym->backend_decl));
+ || sym->attr.flavor == FL_PROCEDURE
+ || sym->attr.use_assoc
+ || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
+ || (sym->module && sym->attr.if_source != IFSRC_DECL
+ && sym->backend_decl));
if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
length = gfc_create_string_length (sym);
}
- if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
+ fun_or_res = byref && (sym->attr.result
+ || (sym->attr.function && sym->ts.deferred));
+ if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
{
/* Return via extra parameter. */
if (sym->attr.result && byref
(sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
sym->ts.u.cl->backend_decl = NULL_TREE;
- if (sym->ts.deferred && sym->attr.result
+ if (sym->ts.deferred && fun_or_res
&& sym->ts.u.cl->passed_length == NULL
&& sym->ts.u.cl->backend_decl)
{
&& sym->attr.flavor == FL_PARAMETER)
intrinsic_array_parameter = true;
- /* If use associated and whole file compilation, use the module
+ /* If use associated compilation, use the module
declaration. */
- if (gfc_option.flag_whole_file
- && (sym->attr.flavor == FL_VARIABLE
- || sym->attr.flavor == FL_PARAMETER)
- && sym->attr.use_assoc
- && !intrinsic_array_parameter
- && sym->module
- && gfc_get_module_backend_decl (sym))
+ if ((sym->attr.flavor == FL_VARIABLE
+ || sym->attr.flavor == FL_PARAMETER)
+ && sym->attr.use_assoc
+ && !intrinsic_array_parameter
+ && sym->module
+ && gfc_get_module_backend_decl (sym))
{
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
DECL_IGNORED_P (decl) = 1;
}
+ if (sym->attr.select_type_temporary)
+ {
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 1;
+ }
+
if (sym->attr.dimension || sym->attr.codimension)
{
/* Create variables to hold the non-constant bits of array info. */
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
- || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+ || (sym->ts.type == BT_DERIVED
+ && (sym->ts.u.derived->attr.alloc_comp
+ || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
+ && !sym->ns->proc_name->attr.is_main_program
+ && gfc_is_finalizable (sym->ts.u.derived, NULL))))
/* This applies a derived type default initializer. */
|| (sym->ts.type == BT_DERIVED
&& sym->attr.save == SAVE_NONE
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.codimension
- && sym->attr.allocatable),
- sym->attr.pointer
- || sym->attr.allocatable,
- sym->attr.proc_pointer);
+ TREE_TYPE (decl), sym->attr.dimension
+ || (sym->attr.codimension
+ && sym->attr.allocatable),
+ sym->attr.pointer || sym->attr.allocatable
+ || sym->ts.type == BT_CLASS,
+ sym->attr.proc_pointer);
}
if (!TREE_STATIC (decl)
&& POINTER_TYPE_P (TREE_TYPE (decl))
&& !sym->attr.pointer
&& !sym->attr.allocatable
- && !sym->attr.proc_pointer)
+ && !sym->attr.proc_pointer
+ && !sym->attr.select_type_temporary)
DECL_BY_REFERENCE (decl) = 1;
if (sym->attr.vtab
|| (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
- {
- TREE_READONLY (decl) = 1;
- GFC_DECL_PUSH_TOPLEVEL (decl) = 1;
- }
+ TREE_READONLY (decl) = 1;
return decl;
}
VAR_DECL, get_identifier (sym->name),
build_pointer_type (gfc_get_function_type (sym)));
+ if (sym->module)
+ {
+ /* Apply name mangling. */
+ gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
+ if (sym->attr.use_assoc)
+ DECL_IGNORED_P (decl) = 1;
+ }
+
if ((sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == current_function_decl)
|| sym->attr.contained)
/* 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->attr.if_source != IFSRC_DECL)
- && !sym->backend_decl
- && gsym && gsym->ns
- && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
- && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
+ ? sym->binding_label : sym->name);
+
+ if (gsym && !gsym->defined)
+ gsym = NULL;
+
+ /* This can happen because of C binding. */
+ if (gsym && gsym->ns && gsym->ns->proc_name
+ && gsym->ns->proc_name->attr.flavor == FL_MODULE)
+ goto module_sym;
+
+ if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
+ && !sym->backend_decl
+ && gsym && gsym->ns
+ && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+ && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
{
if (!gsym->ns->proc_name->backend_decl)
{
/* By construction, the external function cannot be
a contained procedure. */
locus old_loc;
- tree save_fn_decl = current_function_decl;
- current_function_decl = NULL_TREE;
gfc_save_backend_locus (&old_loc);
- push_cfun (cfun);
+ push_cfun (NULL);
gfc_create_function_decl (gsym->ns, true);
pop_cfun ();
gfc_restore_backend_locus (&old_loc);
- current_function_decl = save_fn_decl;
}
/* If the namespace has entries, the proc_name is the
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)
+module_sym:
+ if (gsym && gsym->ns
+ && (gsym->type == GSYM_MODULE
+ || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
{
gfc_symbol *s;
s = NULL;
- gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (gsym->type == GSYM_MODULE)
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ else
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
+
if (s && s->backend_decl)
{
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
|| sym->attr.public_used))
TREE_PUBLIC (fndecl) = 1;
+ if (sym->attr.referenced || sym->attr.entry_master)
+ TREE_USED (fndecl) = 1;
+
attributes = add_attributes_to_decl (attr, NULL_TREE);
decl_attributes (&fndecl, attributes, 0);
{
/* Look for alternate return placeholders. */
int has_alternate_returns = 0;
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
if (f->sym == NULL)
{
/* Layout the function declaration and put it in the binding level
of the current function. */
- if (global
- || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0))
+ if (global)
pushdecl_top_level (fndecl);
else
pushdecl (fndecl);
type = TREE_VALUE (typelist);
parm = build_decl (input_location,
PARM_DECL, get_identifier ("__entry"), type);
-
+
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
}
hidden_typelist = typelist;
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
if (f->sym != NULL) /* Ignore alternate returns. */
hidden_typelist = TREE_CHAIN (hidden_typelist);
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
gfc_finish_decl (length);
/* Remember the passed value. */
- if (f->sym->ts.u.cl->passed_length != NULL)
+ if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
{
/* This can happen if the same type is used for multiple
arguments. We need to copy cl as otherwise
type = gfc_sym_type (f->sym);
}
}
+ /* For noncharacter scalar intrinsic types, VALUE passes the value,
+ hence, the optional status cannot be transferred via a NULL pointer.
+ Thus, we will use a hidden argument in that case. */
+ else if (f->sym->attr.optional && f->sym->attr.value
+ && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
+ && f->sym->ts.type != BT_DERIVED)
+ {
+ tree tmp;
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ tmp = build_decl (input_location,
+ PARM_DECL, get_identifier (name),
+ boolean_type_node);
+
+ hidden_arglist = chainon (hidden_arglist, tmp);
+ DECL_CONTEXT (tmp) = fndecl;
+ DECL_ARTIFICIAL (tmp) = 1;
+ DECL_ARG_TYPE (tmp) = boolean_type_node;
+ TREE_READONLY (tmp) = 1;
+ gfc_finish_decl (tmp);
+ }
/* For non-constant length array arguments, make sure they use
a different type node from TYPE_ARG_TYPES type. */
gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
}
-
+
DECL_CONTEXT (token) = fndecl;
DECL_ARTIFICIAL (token) = 1;
DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
gfc_save_backend_locus (&old_loc);
for (el = ns->entries; el; el = el->next)
{
- VEC(tree,gc) *args = NULL;
- VEC(tree,gc) *string_args = NULL;
+ vec<tree, va_gc> *args = NULL;
+ vec<tree, va_gc> *string_args = NULL;
thunk_sym = el->sym;
-
+
build_function_decl (thunk_sym, global);
create_function_arglist (thunk_sym);
/* Pass extra parameter identifying this entry point. */
tmp = build_int_cst (gfc_array_index_type, el->id);
- VEC_safe_push (tree, gc, args, tmp);
+ vec_safe_push (args, tmp);
if (thunk_sym->attr.function)
{
if (gfc_return_by_reference (ns->proc_name))
{
tree ref = DECL_ARGUMENTS (current_function_decl);
- VEC_safe_push (tree, gc, args, ref);
+ vec_safe_push (args, ref);
if (ns->proc_name->ts.type == BT_CHARACTER)
- VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
+ vec_safe_push (args, DECL_CHAIN (ref));
}
}
- for (formal = ns->proc_name->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
+ formal = formal->next)
{
/* Ignore alternate returns. */
if (formal->sym == NULL)
/* We don't have a clever way of identifying arguments, so resort to
a brute-force search. */
- for (thunk_formal = thunk_sym->formal;
+ for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
thunk_formal;
thunk_formal = thunk_formal->next)
{
{
/* Pass the argument. */
DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
- VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
+ vec_safe_push (args, thunk_formal->sym->backend_decl);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = thunk_formal->sym->ts.u.cl->backend_decl;
- VEC_safe_push (tree, gc, string_args, tmp);
+ vec_safe_push (string_args, tmp);
}
}
else
{
/* Pass NULL for a missing argument. */
- VEC_safe_push (tree, gc, args, null_pointer_node);
+ vec_safe_push (args, null_pointer_node);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = build_int_cst (gfc_charlen_type_node, 0);
- VEC_safe_push (tree, gc, string_args, tmp);
+ vec_safe_push (string_args, tmp);
}
}
}
/* Call the master function. */
- VEC_safe_splice (tree, gc, args, string_args);
+ vec_safe_splice (args, string_args);
tmp = ns->proc_name->backend_decl;
tmp = build_call_expr_loc_vec (input_location, tmp, args);
if (ns->proc_name->attr.mixed_entry_master)
tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), union_decl, field,
NULL_TREE);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
/* We share the symbols in the formal argument list with other entry
points and the master function. Clear them so that they are
recreated for each function. */
- for (formal = thunk_sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
+ formal = formal->next)
if (formal->sym != NULL) /* Ignore alternate returns. */
{
formal->sym->backend_decl = NULL_TREE;
build_library_function_decl_1 (tree name, const char *spec,
tree rettype, int nargs, va_list p)
{
- VEC(tree,gc) *arglist;
+ vec<tree, va_gc> *arglist;
tree fntype;
tree fndecl;
int n;
gcc_assert (current_function_decl == NULL_TREE);
/* Create a list of the argument types. */
- arglist = VEC_alloc (tree, gc, abs (nargs));
+ vec_alloc (arglist, abs (nargs));
for (n = abs (nargs); n > 0; n--)
{
tree argtype = va_arg (p, tree);
- VEC_quick_push (tree, arglist, argtype);
+ arglist->quick_push (argtype);
}
/* Build the function type and decl. */
gfc_int4_type_node);
TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
-
+
gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
get_identifier (PREFIX("ishftc8")),
gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
void_type_node, -2, pchar_type_node, pchar_type_node);
/* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
-
+
gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("runtime_warning_at")), ".RR",
void_type_node, -2, pchar_type_node, pchar_type_node);
tree present;
gfc_init_block (&init);
- for (f = proc_sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
if (f->sym && f->sym->attr.intent == INTENT_OUT
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = NULL_TREE;
+
+ /* Note: Allocatables are excluded as they are already handled
+ by the caller. */
+ if (!f->sym->attr.allocatable
+ && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
+ }
- if (f->sym->attr.optional
- || f->sym->ns->proc_name->attr.entry_master)
- {
- present = gfc_conv_expr_present (f->sym);
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- present, tmp,
- build_empty_stmt (input_location));
- }
+ if (tmp == NULL_TREE && !f->sym->attr.allocatable
+ && 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);
- gfc_add_expr_to_block (&init, tmp);
+ if (tmp != NULL_TREE && (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master))
+ {
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ present, tmp, build_empty_stmt (input_location));
}
- else if (f->sym->value)
+
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&init, tmp);
+ else if (f->sym->value && !f->sym->attr.allocatable)
gfc_init_default_dt (f->sym, &init, true);
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
&& !CLASS_DATA (f->sym)->attr.class_pointer
- && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+ && !CLASS_DATA (f->sym)->attr.allocatable)
{
- tmp = gfc_class_data_get (f->sym->backend_decl);
- if (CLASS_DATA (f->sym)->as == NULL)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
- tmp,
- CLASS_DATA (f->sym)->as ?
- CLASS_DATA (f->sym)->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
{
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
- bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
- && sym->ts.u.derived->attr.alloc_comp;
+ bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
+ && (sym->ts.u.derived->attr.alloc_comp
+ || gfc_is_finalizable (sym->ts.u.derived,
+ NULL));
if (sym->assoc)
continue;
NULL_TREE);
}
- if (sym->attr.dimension || sym->attr.codimension)
+ if (sym->ts.type == BT_CLASS
+ && (sym->attr.save || gfc_option.flag_max_stack_var_size == 0)
+ && CLASS_DATA (sym)->attr.allocatable)
+ {
+ tree vptr;
+
+ if (UNLIMITED_POLY (sym))
+ vptr = null_pointer_node;
+ else
+ {
+ gfc_symbol *vsym;
+ vsym = gfc_find_derived_vtab (sym->ts.u.derived);
+ vptr = gfc_get_symbol_decl (vsym);
+ vptr = gfc_build_addr_expr (NULL, vptr);
+ }
+
+ if (CLASS_DATA (sym)->attr.dimension
+ || (CLASS_DATA (sym)->attr.codimension
+ && gfc_option.coarray != GFC_FCOARRAY_LIB))
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
+ }
+ else
+ tmp = null_pointer_node;
+
+ DECL_INITIAL (sym->backend_decl)
+ = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
+ TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
+ }
+ else if (sym->attr.dimension || sym->attr.codimension)
{
/* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
array_type tmp = sym->as->type;
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
- if (sym_has_alloc_comp)
+ if (alloc_comp_or_fini)
{
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
default:
gcc_unreachable ();
}
- if (sym_has_alloc_comp && !seen_trans_deferred_array)
+ if (alloc_comp_or_fini && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block);
}
else if ((!sym->attr.dummy || sym->ts.deferred)
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable)))
{
- if (!sym->attr.save)
+ if (!sym->attr.save && gfc_option.flag_max_stack_var_size != 0)
{
tree descriptor = NULL_TREE;
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
/* Nullify when entering the scope. */
- gfc_add_modify (&init, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- null_pointer_node));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (se.expr), se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&init, tmp);
}
- if ((sym->attr.dummy ||sym->attr.result)
+ if ((sym->attr.dummy || sym->attr.result)
&& sym->ts.type == BT_CHARACTER
&& sym->ts.deferred)
{
gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
build_int_cst (gfc_charlen_type_node, 0));
else
- gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
+ {
+ tree tmp2;
+
+ tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node,
+ sym->ts.u.cl->backend_decl, tmp);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp2 = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp2,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&init, tmp2);
+ }
gfc_restore_backend_locus (&loc);
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- gfc_charlen_type_node, tmp,
- sym->ts.u.cl->backend_decl);
+ {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node, tmp,
+ sym->ts.u.cl->backend_decl);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ }
else
tmp = NULL_TREE;
}
/* Deallocate when leaving the scope. Nullifying is not
needed. */
- if (!sym->attr.result && !sym->attr.dummy)
+ if (!sym->attr.result && !sym->attr.dummy
+ && !sym->ns->proc_name->attr.is_main_program)
{
if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.codimension)
NULL_TREE, true, NULL,
true);
else
- tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
- true, NULL,
- sym->ts);
+ {
+ gfc_expr *expr = gfc_lval_expr_from_sym (sym);
+ tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
+ true, expr, sym->ts);
+ gfc_free_expr (expr);
+ }
}
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
- gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ gfc_symbol *vtab;
tree rhs;
gfc_save_backend_locus (&loc);
se.want_pointer = 1;
gfc_conv_expr (&se, e);
gfc_free_expr (e);
- rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
- gfc_get_symbol_decl (vtab));
+ if (UNLIMITED_POLY (sym))
+ rhs = build_int_cst (TREE_TYPE (se.expr), 0);
+ else
+ {
+ vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
+ gfc_get_symbol_decl (vtab));
+ }
gfc_add_modify (&init, se.expr, rhs);
gfc_restore_backend_locus (&loc);
}
}
else if (sym->ts.deferred)
gfc_fatal_error ("Deferred type parameter not yet supported");
- else if (sym_has_alloc_comp)
+ else if (alloc_comp_or_fini)
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
- else
+ else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
gfc_init_block (&tmpblock);
- for (f = proc_sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
{
if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
{
decl = sym->backend_decl;
gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
- /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
- if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
+ if (!sym->attr.use_assoc)
{
gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
|| TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
internal_error ("backend decl for module variable %s already exists",
sym->name);
+ if (sym->module && !sym->attr.result && !sym->attr.dummy
+ && (sym->attr.access == ACCESS_UNKNOWN
+ && (sym->ns->default_access == ACCESS_PRIVATE
+ || (sym->ns->default_access == ACCESS_UNKNOWN
+ && gfc_option.flag_module_private))))
+ sym->attr.access = ACCESS_PRIVATE;
+
+ if (warn_unused_variable && !sym->attr.referenced
+ && sym->attr.access == ACCESS_PRIVATE)
+ gfc_warning ("Unused PRIVATE module variable '%s' declared at %L",
+ sym->name, &sym->declared_at);
+
/* We always want module variables to be created. */
sym->attr.referenced = 1;
/* Create the decl. */
tree tmp, size, decl, token;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
- || sym->attr.use_assoc || !sym->attr.referenced)
+ || sym->attr.use_assoc || !sym->attr.referenced)
return;
decl = sym->backend_decl;
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
- /* Ensure that we do not have size=0 for zero-sized arrays. */
+ /* Ensure that we do not have size=0 for zero-sized arrays. */
size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
fold_convert (size_type_node, size),
build_int_cst (size_type_node, 1));
token, null_pointer_node, /* token, stat. */
null_pointer_node, /* errgmsg, errmsg_len. */
build_int_cst (integer_type_node, 0));
-
+
gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
gfc_get_symbol_decl (sym);
/* Warnings for unused dummy arguments. */
- else if (sym->attr.dummy)
+ else if (sym->attr.dummy && !sym->attr.in_namelist)
{
/* INTENT(out) dummy arguments are likely meant to be set. */
if (gfc_option.warn_unused_dummy_argument
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))
+ else if (!gfc_has_default_initializer (sym->ts.u.derived)
+ && !sym->ts.u.derived->attr.zero_comp)
gfc_warning ("Derived-type dummy argument '%s' at %L was "
"declared INTENT(OUT) but was not set and "
"does not have a default initializer",
}
/* Warn for unused variables, but not if they're inside a common
- block, a namelist, or are use-associated. */
+ block or a namelist. */
else if (warn_unused_variable
- && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
- || sym->attr.in_namelist))
+ && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
{
- gfc_warning ("Unused variable '%s' declared at %L", sym->name,
- &sym->declared_at);
- if (sym->backend_decl != NULL_TREE)
- TREE_NO_WARNING(sym->backend_decl) = 1;
- }
- else if (warn_unused_variable && sym->attr.use_only)
- {
- gfc_warning ("Unused module variable '%s' which has been explicitly "
- "imported at %L", sym->name, &sym->declared_at);
- if (sym->backend_decl != NULL_TREE)
- TREE_NO_WARNING(sym->backend_decl) = 1;
+ if (sym->attr.use_only)
+ {
+ gfc_warning ("Unused module variable '%s' which has been "
+ "explicitly imported at %L", sym->name,
+ &sym->declared_at);
+ if (sym->backend_decl != NULL_TREE)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
+ }
+ else if (!sym->attr.use_assoc)
+ {
+ gfc_warning ("Unused variable '%s' declared at %L",
+ sym->name, &sym->declared_at);
+ if (sym->backend_decl != NULL_TREE)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
+ }
}
/* For variable length CHARACTER parameters, the PARM_DECL already
{
if (gfc_option.warn_unused_dummy_argument)
gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
- &sym->declared_at);
+ &sym->declared_at);
}
/* Silence bogus "unused parameter" warnings from the
{
gfc_formal_arglist *formal;
- for (formal = sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
if (formal->sym && formal->sym->ts.type == BT_CHARACTER
&& !formal->sym->ts.deferred)
{
void
gfc_init_coarray_decl (bool main_tu)
{
- tree save_fn_decl;
-
if (gfc_option.coarray != GFC_FCOARRAY_LIB)
return;
if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
return;
- save_fn_decl = current_function_decl;
- current_function_decl = NULL_TREE;
push_cfun (cfun);
gfort_gvar_caf_this_image
pushdecl_top_level (gfort_gvar_caf_num_images);
pop_cfun ();
- current_function_decl = save_fn_decl;
}
language standard parameters. */
{
tree array_type, array, var;
- VEC(constructor_elt,gc) *v = NULL;
+ vec<constructor_elt, va_gc> *v = NULL;
/* Passing a new option to the library requires four modifications:
+ add it to the tree_cons list below
/* TODO: This is the -frange-check option, which no longer affects
library behavior; when bumping the library ABI this slot can be
reused for something else. As it is the last element in the
- array, we can instead leave it out altogether.
+ array, we can instead leave it out altogether. */
+ CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+ build_int_cst (integer_type_node, 0));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node,
- gfc_option.flag_range_check));
- */
+ gfc_option.fpe_summary));
array_type = build_array_type (integer_type_node,
- build_index_type (size_int (6)));
+ build_index_type (size_int (8)));
array = build_constructor (array_type, v);
TREE_CONSTANT (array) = 1;
TREE_STATIC (array) = 1;
tmp = build_call_expr_loc (input_location,
gfor_fndecl_set_options, 2,
- build_int_cst (integer_type_node, 7), var);
+ build_int_cst (integer_type_node, 9), var);
gfc_add_expr_to_block (&body, tmp);
}
/* Coarray: Call _gfortran_caf_finalize(void). */
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
- {
+ {
/* Per F2008, 8.5.1 END of the main program implies a
- SYNC MEMORY. */
+ SYNC MEMORY. */
tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
tmp = build_call_expr_loc (input_location, tmp, 0);
gfc_add_expr_to_block (&body, tmp);
next = DECL_CHAIN (decl);
DECL_CHAIN (decl) = NULL_TREE;
- if (GFC_DECL_PUSH_TOPLEVEL (decl))
- pushdecl_top_level (decl);
- else
- pushdecl (decl);
+ pushdecl (decl);
decl = next;
}
saved_function_decls = NULL_TREE;
}
current_function_decl = old_context;
- if (decl_function_context (fndecl) && gfc_option.coarray != GFC_FCOARRAY_LIB
- && has_coarray_vars)
- /* Register this function with cgraph just far enough to get it
- added to our parent's nested function list.
- If there are static coarrays in this function, the nested _caf_init
- function has already called cgraph_create_node, which also created
- the cgraph node for this function. */
- (void) cgraph_create_node (fndecl);
+ if (decl_function_context (fndecl))
+ {
+ /* Register this function with cgraph just far enough to get it
+ added to our parent's nested function list.
+ If there are static coarrays in this function, the nested _caf_init
+ function has already called cgraph_create_node, which also created
+ the cgraph node for this function. */
+ if (!has_coarray_vars || gfc_option.coarray != GFC_FCOARRAY_LIB)
+ (void) cgraph_create_node (fndecl);
+ }
else
cgraph_finalize_function (fndecl, true);
projects / thirdparty / gcc.git / blobdiff