#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. */
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);
{
/* 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;
&& 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 attributes;
int byref;
bool intrinsic_array_parameter = false;
+ bool fun_or_res;
gcc_assert (sym->attr.referenced
|| sym->attr.flavor == FL_PROCEDURE
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;
|| (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)
/* 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)
{
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)
{
/* 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)
{
}
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];
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. */
}
}
- 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)
{
/* 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;
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)
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_TREE,
- true,
- gfc_lval_expr_from_sym (sym),
- 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)
{
}
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_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. */
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",
{
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)
{
/* 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);
}
}
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