/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "coretypes.h"
#include "tree.h"
#include "tree-dump.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "tm.h"
#include "function.h"
#include "flags.h"
#include "cgraph.h"
+#include "debug.h"
#include "gfortran.h"
+#include "pointer-set.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
static GTY(()) tree saved_function_decls;
static GTY(()) tree saved_parent_function_decls;
+static struct pointer_set_t *nonlocal_dummy_decl_pset;
+static GTY(()) tree nonlocal_dummy_decls;
/* 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_stop_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at;
+tree gfor_fndecl_runtime_warning_at;
tree gfor_fndecl_os_error;
tree gfor_fndecl_generate_error;
+tree gfor_fndecl_set_args;
tree gfor_fndecl_set_fpe;
tree gfor_fndecl_set_options;
tree gfor_fndecl_set_convert;
tree gfor_fndecl_size0;
tree gfor_fndecl_size1;
tree gfor_fndecl_iargc;
+tree gfor_fndecl_clz128;
+tree gfor_fndecl_ctz128;
/* Intrinsic functions implemented in Fortran. */
tree gfor_fndecl_sc_kind;
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
- return (get_identifier (sym->name));
+ if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+ return (get_identifier ("MAIN__"));
+ else
+ return (get_identifier (sym->name));
}
TYPE_DOMAIN (type) = range;
layout_type (type);
}
+
+ if (TYPE_NAME (type) != NULL_TREE
+ && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
+ && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
+ {
+ tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
+
+ for (dim = 0; dim < sym->as->rank - 1; dim++)
+ {
+ gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
+ gtype = TREE_TYPE (gtype);
+ }
+ gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
+ if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
+ TYPE_NAME (type) = NULL_TREE;
+ }
+
+ if (TYPE_NAME (type) == NULL_TREE)
+ {
+ tree gtype = TREE_TYPE (type), rtype, type_decl;
+
+ 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));
+ gtype = build_array_type (gtype, rtype);
+ /* Ensure the bound variables aren't optimized out at -O0. */
+ if (!optimize)
+ {
+ 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;
+ }
+ }
+ TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+ DECL_ORIGINAL_TYPE (type_decl) = gtype;
+ }
}
return decl;
}
+/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
+ function add a VAR_DECL to the current function with DECL_VALUE_EXPR
+ pointing to the artificial variable for debug info purposes. */
+
+static void
+gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
+{
+ tree decl, dummy;
+
+ if (! nonlocal_dummy_decl_pset)
+ nonlocal_dummy_decl_pset = pointer_set_create ();
+
+ if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
+ return;
+
+ dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+ decl = build_decl (VAR_DECL, DECL_NAME (dummy),
+ TREE_TYPE (sym->backend_decl));
+ DECL_ARTIFICIAL (decl) = 0;
+ TREE_USED (decl) = 1;
+ TREE_PUBLIC (decl) = 0;
+ TREE_STATIC (decl) = 0;
+ DECL_EXTERNAL (decl) = 0;
+ if (DECL_BY_REFERENCE (dummy))
+ DECL_BY_REFERENCE (decl) = 1;
+ DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
+ SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
+ DECL_HAS_VALUE_EXPR_P (decl) = 1;
+ DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
+ TREE_CHAIN (decl) = nonlocal_dummy_decls;
+ nonlocal_dummy_decls = decl;
+}
/* Return a constant or a variable to use as a string length. Does not
add the decl to the current scope. */
static tree
gfc_create_string_length (gfc_symbol * sym)
{
- tree length;
-
gcc_assert (sym->ts.cl);
gfc_conv_const_charlen (sym->ts.cl);
-
+
if (sym->ts.cl->backend_decl == NULL_TREE)
{
+ tree length;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
/* Also prefix the mangled name. */
TREE_USED (length) = 1;
if (sym->ns->proc_name->tlink != NULL)
gfc_defer_symbol_init (sym);
+
sym->ts.cl->backend_decl = length;
}
+ gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
return sym->ts.cl->backend_decl;
}
{
gfc_add_assign_aux_vars (sym);
}
+
+ if (sym->attr.dimension
+ && DECL_LANG_SPECIFIC (sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
+ && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
+ gfc_nonlocal_dummy_array_decl (sym);
+
return sym->backend_decl;
}
if (sym->backend_decl)
return sym->backend_decl;
- /* Catch function declarations. Only used for actual parameters. */
+ /* Catch function declarations. Only used for actual parameters and
+ procedure pointers. */
if (sym->attr.flavor == FL_PROCEDURE)
{
decl = gfc_get_extern_function_decl (sym);
+ gfc_set_decl_location (decl, &sym->declared_at);
return decl;
}
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));
+ {
+ SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
+ if (sym->attr.use_assoc)
+ DECL_IGNORED_P (decl) = 1;
+ }
if (sym->attr.dimension)
{
span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
gfc_array_index_type);
gfc_finish_var_decl (span, sym);
- TREE_STATIC (span) = 1;
- DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+ TREE_STATIC (span) = TREE_STATIC (decl);
+ DECL_ARTIFICIAL (span) = 1;
+ DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
GFC_DECL_SPAN (decl) = span;
+ GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
}
sym->backend_decl = decl;
sym->attr.pointer || sym->attr.allocatable);
}
+ if (!TREE_STATIC (decl)
+ && POINTER_TYPE_P (TREE_TYPE (decl))
+ && !sym->attr.pointer
+ && !sym->attr.allocatable
+ && !sym->attr.proc_pointer)
+ DECL_BY_REFERENCE (decl) = 1;
+
return decl;
}
decl = build_decl (VAR_DECL, get_identifier (sym->name),
build_pointer_type (gfc_get_function_type (sym)));
- if (sym->ns->proc_name->backend_decl == current_function_decl
+ if ((sym->ns->proc_name
+ && sym->ns->proc_name->backend_decl == current_function_decl)
|| sym->attr.contained)
gfc_add_decl_to_function (decl);
- else
+ else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
gfc_add_decl_to_parent_function (decl);
sym->backend_decl = decl;
+ /* If a variable is USE associated, it's always external. */
+ if (sym->attr.use_assoc)
+ {
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ }
+ else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ /* This is the declaration of a module variable. */
+ TREE_PUBLIC (decl) = 1;
+ TREE_STATIC (decl) = 1;
+ }
+
if (!sym->attr.use_assoc
&& (sym->attr.save != SAVE_NONE || sym->attr.data
|| (sym->value && sym->ns->proc_name->attr.is_main_program)))
char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
tree name;
tree mangled_name;
+ gfc_gsymbol *gsym;
if (sym->backend_decl)
return sym->backend_decl;
if (sym->attr.proc_pointer)
return get_proc_pointer_decl (sym);
+ /* See if this is an external procedure from the same file. If so,
+ return the backend_decl. */
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+
+ if (gfc_option.flag_whole_file
+ && !sym->backend_decl
+ && gsym && gsym->ns
+ && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+ && gsym->ns->proc_name->backend_decl)
+ {
+ /* If the namespace has entries, the proc_name is the
+ entry master. Find the entry and use its backend_decl.
+ otherwise, use the proc_name backend_decl. */
+ if (gsym->ns->entries)
+ {
+ gfc_entry_list *entry = gsym->ns->entries;
+
+ for (; entry; entry = entry->next)
+ {
+ if (strcmp (gsym->name, entry->sym->name) == 0)
+ {
+ sym->backend_decl = entry->sym->backend_decl;
+ break;
+ }
+ }
+ }
+ else
+ {
+ sym->backend_decl = gsym->ns->proc_name->backend_decl;
+ }
+
+ if (sym->backend_decl)
+ return sym->backend_decl;
+ }
+
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
/* Allow only one nesting level. Allow public declarations. */
gcc_assert (current_function_decl == NULL_TREE
- || DECL_CONTEXT (current_function_decl) == NULL_TREE);
+ || DECL_CONTEXT (current_function_decl) == NULL_TREE
+ || TREE_CODE (DECL_CONTEXT (current_function_decl))
+ == NAMESPACE_DECL);
type = gfc_get_function_type (sym);
fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
/* This specifies if a function is globally visible, i.e. it is
the opposite of declaring static in C. */
if (DECL_CONTEXT (fndecl) == NULL_TREE
- && !sym->attr.entry_master)
+ && !sym->attr.entry_master && !sym->attr.is_main_program)
TREE_PUBLIC (fndecl) = 1;
/* TREE_STATIC means the function body is defined here. */
TREE_SIDE_EFFECTS (fndecl) = 0;
}
- /* For -fwhole-program to work well, the main program needs to have the
- "externally_visible" attribute. */
- if (attr.is_main_program)
- DECL_ATTRIBUTES (fndecl)
- = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
-
/* Layout the function declaration and put it in the binding level
of the current function. */
pushdecl (fndecl);
TREE_READONLY (length) = 1;
gfc_finish_decl (length);
- /* TODO: Check string lengths when -fbounds-check. */
+ /* Remember the passed value. */
+ f->sym->ts.cl->passed_length = length;
/* Use the passed value for assumed length variables. */
if (!f->sym->ts.cl->length)
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
/* All implementation args are read-only. */
TREE_READONLY (parm) = 1;
+ if (POINTER_TYPE_P (type)
+ && (!f->sym->attr.proc_pointer
+ && f->sym->attr.flavor != FL_PROCEDURE))
+ DECL_BY_REFERENCE (parm) = 1;
gfc_finish_decl (parm);
thunk_fndecl = thunk_sym->backend_decl;
- gfc_start_block (&body);
+ gfc_init_block (&body);
/* Pass extra parameter identifying this entry point. */
tmp = build_int_cst (gfc_array_index_type, el->id);
/* Finish off this function and send it for code generation. */
DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
+ tmp = getdecls ();
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
+ DECL_SAVED_TREE (thunk_fndecl)
+ = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
+ DECL_INITIAL (thunk_fndecl));
/* Output the GENERIC tree. */
dump_function (TDI_original, thunk_fndecl);
gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
gfc_int4_type_node,
0);
+
+ if (gfc_type_for_size (128, true))
+ {
+ tree uint128 = gfc_type_for_size (128, true);
+
+ gfor_fndecl_clz128 =
+ gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
+ integer_type_node, 1, uint128);
+
+ gfor_fndecl_ctz128 =
+ gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
+ integer_type_node, 1, uint128);
+ }
}
/* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
+ gfor_fndecl_runtime_warning_at =
+ gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
+ void_type_node, -2, pchar_type_node,
+ pchar_type_node);
gfor_fndecl_generate_error =
gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
void_type_node, 3, pvoid_type_node,
/* The runtime_error function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
+ gfor_fndecl_set_args =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
+ void_type_node, 2, integer_type_node,
+ build_pointer_type (pchar_type_node));
+
gfor_fndecl_set_fpe =
gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
void_type_node, 1, integer_type_node);
gfor_fndecl_set_options =
gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
void_type_node, 2, integer_type_node,
- pvoid_type_node);
+ build_pointer_type (integer_type_node));
gfor_fndecl_set_convert =
gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (cl, &body);
+ gfc_conv_string_length (cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (sym->ts.cl, &body);
+ gfc_conv_string_length (sym->ts.cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
/* Set the initial value to length. See the comments in
function gfc_add_assign_aux_vars in this file. */
- gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
+ gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
build_int_cst (NULL_TREE, -2));
gfc_add_expr_to_block (&body, fnbody);
var = gfc_create_var_np (TREE_TYPE (t), NULL);
gfc_add_decl_to_function (var);
- gfc_add_modify_expr (body, var, val);
+ gfc_add_modify (body, var, val);
if (TREE_CODE (t) == SAVE_EXPR)
TREE_OPERAND (t, 0) = var;
*tp = var;
}
-/* Initialize INTENT(OUT) derived type dummies. */
+/* Initialize INTENT(OUT) derived type dummies. As well as giving
+ them their default initializer, if they do not have allocatable
+ components, they have their allocatable components deallocated. */
+
static tree
init_intent_out_dt (gfc_symbol * proc_sym, tree body)
{
stmtblock_t fnblock;
gfc_formal_arglist *f;
+ tree tmp;
+ tree present;
gfc_init_block (&fnblock);
for (f = proc_sym->formal; f; f = f->next)
if (f->sym && f->sym->attr.intent == INTENT_OUT
- && f->sym->ts.type == BT_DERIVED
- && !f->sym->ts.derived->attr.alloc_comp
- && f->sym->value)
- body = gfc_init_default_dt (f->sym, body);
+ && f->sym->ts.type == BT_DERIVED)
+ {
+ if (f->sym->ts.derived->attr.alloc_comp)
+ {
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.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 ());
+
+ 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);
+ }
gfc_add_expr_to_block (&fnblock, body);
return gfc_finish_block (&fnblock);
return gfc_finish_block (&body);
}
+static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
+
+/* Hash and equality functions for module_htab. */
+
+static hashval_t
+module_htab_do_hash (const void *x)
+{
+ return htab_hash_string (((const struct module_htab_entry *)x)->name);
+}
+
+static int
+module_htab_eq (const void *x1, const void *x2)
+{
+ return strcmp ((((const struct module_htab_entry *)x1)->name),
+ (const char *)x2) == 0;
+}
+
+/* Hash and equality functions for module_htab's decls. */
+
+static hashval_t
+module_htab_decls_hash (const void *x)
+{
+ const_tree t = (const_tree) x;
+ const_tree n = DECL_NAME (t);
+ if (n == NULL_TREE)
+ n = TYPE_NAME (TREE_TYPE (t));
+ return htab_hash_string (IDENTIFIER_POINTER (n));
+}
+
+static int
+module_htab_decls_eq (const void *x1, const void *x2)
+{
+ const_tree t1 = (const_tree) x1;
+ const_tree n1 = DECL_NAME (t1);
+ if (n1 == NULL_TREE)
+ n1 = TYPE_NAME (TREE_TYPE (t1));
+ return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
+}
+
+struct module_htab_entry *
+gfc_find_module (const char *name)
+{
+ void **slot;
+
+ if (! module_htab)
+ module_htab = htab_create_ggc (10, module_htab_do_hash,
+ module_htab_eq, NULL);
+
+ slot = htab_find_slot_with_hash (module_htab, name,
+ htab_hash_string (name), INSERT);
+ if (*slot == NULL)
+ {
+ struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
+
+ entry->name = gfc_get_string (name);
+ entry->decls = htab_create_ggc (10, module_htab_decls_hash,
+ module_htab_decls_eq, NULL);
+ *slot = (void *) entry;
+ }
+ return (struct module_htab_entry *) *slot;
+}
+
+void
+gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
+{
+ void **slot;
+ const char *name;
+
+ if (DECL_NAME (decl))
+ name = IDENTIFIER_POINTER (DECL_NAME (decl));
+ else
+ {
+ gcc_assert (TREE_CODE (decl) == TYPE_DECL);
+ name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
+ }
+ slot = htab_find_slot_with_hash (entry->decls, name,
+ htab_hash_string (name), INSERT);
+ if (*slot == NULL)
+ *slot = (void *) decl;
+}
+
+static struct module_htab_entry *cur_module;
/* Output an initialized decl for a module variable. */
&& sym->ts.type == BT_DERIVED)
sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
- /* Only output variables and array valued, or derived type,
- parameters. */
+ if (sym->attr.flavor == FL_DERIVED
+ && sym->backend_decl
+ && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
+ {
+ 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);
+ 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));
+ }
+
+ /* Only output variables, procedure pointers and array valued,
+ or derived type, parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& !(sym->attr.flavor == FL_PARAMETER
- && (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
+ && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
+ && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
return;
+ if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
+ {
+ decl = sym->backend_decl;
+ gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
+ gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+ gfc_module_add_decl (cur_module, decl);
+ }
+
/* Don't generate variables from other modules. Variables from
COMMONs will already have been generated. */
if (sym->attr.use_assoc || sym->attr.in_common)
/* Equivalenced variables arrive here after creation. */
if (sym->backend_decl
- && (sym->equiv_built || sym->attr.in_equivalence))
- return;
+ && (sym->equiv_built || sym->attr.in_equivalence))
+ return;
if (sym->backend_decl)
internal_error ("backend decl for module variable %s already exists",
/* Create the variable. */
pushdecl (decl);
+ gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
+ gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
rest_of_decl_compilation (decl, 1, 0);
+ gfc_module_add_decl (cur_module, decl);
/* Also add length of strings. */
if (sym->ts.type == BT_CHARACTER)
}
}
+/* Emit debug information for USE statements. */
+
+static void
+gfc_trans_use_stmts (gfc_namespace * ns)
+{
+ gfc_use_list *use_stmt;
+ for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
+ {
+ struct module_htab_entry *entry
+ = gfc_find_module (use_stmt->module_name);
+ gfc_use_rename *rent;
+
+ if (entry->namespace_decl == NULL)
+ {
+ entry->namespace_decl
+ = build_decl (NAMESPACE_DECL,
+ get_identifier (use_stmt->module_name),
+ void_type_node);
+ DECL_EXTERNAL (entry->namespace_decl) = 1;
+ }
+ gfc_set_backend_locus (&use_stmt->where);
+ if (!use_stmt->only_flag)
+ (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
+ NULL_TREE,
+ ns->proc_name->backend_decl,
+ false);
+ for (rent = use_stmt->rename; rent; rent = rent->next)
+ {
+ tree decl, local_name;
+ void **slot;
+
+ if (rent->op != INTRINSIC_NONE)
+ continue;
+
+ slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
+ htab_hash_string (rent->use_name),
+ INSERT);
+ if (*slot == NULL)
+ {
+ gfc_symtree *st;
+
+ 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);
+ if (st->n.sym->backend_decl
+ && DECL_P (st->n.sym->backend_decl)
+ && st->n.sym->module
+ && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
+ {
+ gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
+ || (TREE_CODE (st->n.sym->backend_decl)
+ != VAR_DECL));
+ decl = copy_node (st->n.sym->backend_decl);
+ DECL_CONTEXT (decl) = entry->namespace_decl;
+ DECL_EXTERNAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 0;
+ DECL_INITIAL (decl) = NULL_TREE;
+ }
+ else
+ {
+ *slot = error_mark_node;
+ htab_clear_slot (entry->decls, slot);
+ continue;
+ }
+ *slot = decl;
+ }
+ decl = (tree) *slot;
+ if (rent->local_name[0])
+ local_name = get_identifier (rent->local_name);
+ else
+ local_name = NULL_TREE;
+ gfc_set_backend_locus (&rent->where);
+ (*debug_hooks->imported_module_or_decl) (decl, local_name,
+ ns->proc_name->backend_decl,
+ !use_stmt->only_flag);
+ }
+ }
+}
+
+
+/* Return true if expr is a constant initializer that gfc_conv_initializer
+ will handle. */
+
+static bool
+check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
+ bool pointer)
+{
+ gfc_constructor *c;
+ gfc_component *cm;
+
+ if (pointer)
+ return true;
+ else if (array)
+ {
+ if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
+ return true;
+ else if (expr->expr_type == EXPR_STRUCTURE)
+ 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)
+ {
+ if (c->iterator)
+ return false;
+ if (c->expr->expr_type == EXPR_STRUCTURE)
+ {
+ if (!check_constant_initializer (c->expr, ts, false, false))
+ return false;
+ }
+ else if (c->expr->expr_type != EXPR_CONSTANT)
+ return false;
+ }
+ return true;
+ }
+ else switch (ts->type)
+ {
+ 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)
+ {
+ if (!c->expr || cm->attr.allocatable)
+ continue;
+ if (!check_constant_initializer (c->expr, &cm->ts,
+ cm->attr.dimension,
+ cm->attr.pointer))
+ return false;
+ }
+ return true;
+ default:
+ return expr->expr_type == EXPR_CONSTANT;
+ }
+}
+
+/* Emit debug info for parameters and unreferenced variables with
+ initializers. */
+
+static void
+gfc_emit_parameter_debug_info (gfc_symbol *sym)
+{
+ tree decl;
+
+ if (sym->attr.flavor != FL_PARAMETER
+ && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
+ return;
+
+ if (sym->backend_decl != NULL
+ || sym->value == NULL
+ || sym->attr.use_assoc
+ || sym->attr.dummy
+ || sym->attr.result
+ || sym->attr.function
+ || sym->attr.intrinsic
+ || sym->attr.pointer
+ || sym->attr.allocatable
+ || sym->attr.cray_pointee
+ || sym->attr.threadprivate
+ || sym->attr.is_bind_c
+ || sym->attr.subref_array_pointer
+ || sym->attr.assign)
+ return;
+
+ 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)
+ return;
+ }
+ else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ return;
+
+ if (sym->as)
+ {
+ int n;
+
+ if (sym->as->type != AS_EXPLICIT)
+ return;
+ for (n = 0; n < sym->as->rank; n++)
+ if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
+ || sym->as->upper[n] == NULL
+ || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
+ return;
+ }
+
+ if (!check_constant_initializer (sym->value, &sym->ts,
+ sym->attr.dimension, false))
+ return;
+
+ /* Create the decl for the variable or constant. */
+ decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
+ gfc_sym_identifier (sym), gfc_sym_type (sym));
+ if (sym->attr.flavor == FL_PARAMETER)
+ TREE_READONLY (decl) = 1;
+ gfc_set_decl_location (decl, &sym->declared_at);
+ if (sym->attr.dimension)
+ GFC_DECL_PACKED_ARRAY (decl) = 1;
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+ TREE_STATIC (decl) = 1;
+ TREE_USED (decl) = 1;
+ if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
+ TREE_PUBLIC (decl) = 1;
+ DECL_INITIAL (decl)
+ = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
+ sym->attr.dimension, 0);
+ debug_hooks->global_decl (decl);
+}
/* Generate all the required code for module variables. */
gfc_generate_module_vars (gfc_namespace * ns)
{
module_namespace = ns;
+ cur_module = gfc_find_module (ns->proc_name->name);
/* Check if the frontend left the namespace in a reasonable state. */
gcc_assert (ns->proc_name && !ns->proc_name->tlink);
/* Create decls for all the module variables. */
gfc_traverse_ns (ns, gfc_create_module_variable);
+
+ cur_module = NULL;
+
+ gfc_trans_use_stmts (ns);
+ gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
}
+
static void
gfc_generate_contained_functions (gfc_namespace * parent)
{
{
if (sym->attr.flavor == FL_VARIABLE)
{
- /* 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
- getting stuck in a circular dependency. */
- sym->mark = 1;
if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
- generate_dependency_declarations (sym);
+ generate_dependency_declarations (sym);
if (sym->attr.referenced)
- gfc_get_symbol_decl (sym);
+ gfc_get_symbol_decl (sym);
/* INTENT(out) dummy arguments are likely meant to be set. */
else if (warn_unused_variable
&& sym->attr.dummy
&& !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
gfc_warning ("Unused variable '%s' declared at %L", sym->name,
&sym->declared_at);
+
/* For variable length CHARACTER parameters, the PARM_DECL already
references the length variable, so force gfc_get_symbol_decl
even when not referenced. If optimize > 0, it will be optimized
away anyway. But do this only after emitting -Wunused-parameter
warning if requested. */
- if (sym->attr.dummy && ! sym->attr.referenced
- && sym->ts.type == BT_CHARACTER
- && sym->ts.cl->backend_decl != NULL
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+ if (sym->attr.dummy && !sym->attr.referenced
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->backend_decl != NULL
+ && TREE_CODE (sym->ts.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
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.alloc_comp
+ && sym->attr.intent == INTENT_OUT)
{
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
+ getting stuck in a circular dependency. */
+ sym->mark = 1;
+
/* We do not want the middle-end to warn about unused parameters
as this was already done above. */
if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
&sym->result->declared_at);
/* Prevents "Unused variable" warning for RESULT variables. */
- sym->mark = sym->result->mark = 1;
+ sym->result->mark = 1;
}
}
}
+/* Add code to string lengths of actual arguments passed to a function against
+ the expected lengths of the dummy arguments. */
+
+static void
+add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
+{
+ gfc_formal_arglist *formal;
+
+ for (formal = sym->formal; formal; formal = formal->next)
+ if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
+ {
+ enum tree_code comparison;
+ tree cond;
+ tree argname;
+ gfc_symbol *fsym;
+ gfc_charlen *cl;
+ const char *message;
+
+ fsym = formal->sym;
+ cl = fsym->ts.cl;
+
+ gcc_assert (cl);
+ gcc_assert (cl->passed_length != NULL_TREE);
+ gcc_assert (cl->backend_decl != NULL_TREE);
+
+ /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
+ string lengths must match exactly. Otherwise, it is only required
+ that the actual string length is *at least* the expected one. */
+ if (fsym->attr.pointer || fsym->attr.allocatable
+ || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+ {
+ comparison = NE_EXPR;
+ message = _("Actual string length does not match the declared one"
+ " for dummy argument '%s' (%ld/%ld)");
+ }
+ else
+ {
+ comparison = LT_EXPR;
+ message = _("Actual string length is shorter than the declared one"
+ " for dummy argument '%s' (%ld/%ld)");
+ }
+
+ /* Build the condition. For optional arguments, an actual length
+ of 0 is also acceptable if the associated string is NULL, which
+ means the argument was not passed. */
+ cond = fold_build2 (comparison, boolean_type_node,
+ cl->passed_length, cl->backend_decl);
+ if (fsym->attr.optional)
+ {
+ tree not_absent;
+ tree not_0length;
+ tree absent_failed;
+
+ not_0length = fold_build2 (NE_EXPR, boolean_type_node,
+ cl->passed_length,
+ fold_convert (gfc_charlen_type_node,
+ integer_zero_node));
+ not_absent = fold_build2 (NE_EXPR, boolean_type_node,
+ fsym->backend_decl, null_pointer_node);
+
+ absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
+ not_0length, not_absent);
+
+ cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ cond, absent_failed);
+ }
+
+ /* Build the runtime check. */
+ argname = gfc_build_cstring_const (fsym->name);
+ argname = gfc_build_addr_expr (pchar_type_node, argname);
+ gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
+ message, argname,
+ fold_convert (long_integer_type_node,
+ cl->passed_length),
+ fold_convert (long_integer_type_node,
+ cl->backend_decl));
+ }
+}
+
+
+static void
+create_main_function (tree fndecl)
+{
+ tree old_context;
+ tree ftn_main;
+ tree tmp, decl, result_decl, argc, argv, typelist, arglist;
+ stmtblock_t body;
+
+ old_context = current_function_decl;
+
+ if (old_context)
+ {
+ push_function_context ();
+ saved_parent_function_decls = saved_function_decls;
+ saved_function_decls = NULL_TREE;
+ }
+
+ /* main() function must be declared with global scope. */
+ gcc_assert (current_function_decl == NULL_TREE);
+
+ /* Declare the function. */
+ tmp = build_function_type_list (integer_type_node, integer_type_node,
+ build_pointer_type (pchar_type_node),
+ NULL_TREE);
+ main_identifier_node = get_identifier ("main");
+ ftn_main = build_decl (FUNCTION_DECL, main_identifier_node, tmp);
+ ftn_main = build_decl (FUNCTION_DECL, get_identifier ("main"), tmp);
+ DECL_EXTERNAL (ftn_main) = 0;
+ TREE_PUBLIC (ftn_main) = 1;
+ TREE_STATIC (ftn_main) = 1;
+ DECL_ATTRIBUTES (ftn_main)
+ = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
+
+ /* Setup the result declaration (for "return 0"). */
+ result_decl = build_decl (RESULT_DECL, NULL_TREE, integer_type_node);
+ DECL_ARTIFICIAL (result_decl) = 1;
+ DECL_IGNORED_P (result_decl) = 1;
+ DECL_CONTEXT (result_decl) = ftn_main;
+ DECL_RESULT (ftn_main) = result_decl;
+
+ pushdecl (ftn_main);
+
+ /* Get the arguments. */
+
+ arglist = NULL_TREE;
+ typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
+
+ tmp = TREE_VALUE (typelist);
+ argc = build_decl (PARM_DECL, get_identifier ("argc"), tmp);
+ DECL_CONTEXT (argc) = ftn_main;
+ DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
+ TREE_READONLY (argc) = 1;
+ gfc_finish_decl (argc);
+ arglist = chainon (arglist, argc);
+
+ typelist = TREE_CHAIN (typelist);
+ tmp = TREE_VALUE (typelist);
+ argv = build_decl (PARM_DECL, get_identifier ("argv"), tmp);
+ DECL_CONTEXT (argv) = ftn_main;
+ DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
+ TREE_READONLY (argv) = 1;
+ DECL_BY_REFERENCE (argv) = 1;
+ gfc_finish_decl (argv);
+ arglist = chainon (arglist, argv);
+
+ DECL_ARGUMENTS (ftn_main) = arglist;
+ current_function_decl = ftn_main;
+ announce_function (ftn_main);
+
+ rest_of_decl_compilation (ftn_main, 1, 0);
+ make_decl_rtl (ftn_main);
+ init_function_start (ftn_main);
+ pushlevel (0);
+
+ gfc_init_block (&body);
+
+ /* Call some libgfortran initialization routines, call then MAIN__(). */
+
+ /* Call _gfortran_set_args (argc, argv). */
+ TREE_USED (argc) = 1;
+ TREE_USED (argv) = 1;
+ tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Add a call to set_options to set up the runtime library Fortran
+ language standard parameters. */
+ {
+ tree array_type, array, var;
+
+ /* Passing a new option to the library requires four modifications:
+ + add it to the tree_cons list below
+ + change the array size in the call to build_array_type
+ + change the first argument to the library call
+ gfor_fndecl_set_options
+ + modify the library (runtime/compile_options.c)! */
+
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ gfc_option.warn_std), NULL_TREE);
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ gfc_option.allow_std), array);
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
+ array);
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ gfc_option.flag_dump_core), array);
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ gfc_option.flag_backtrace), array);
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ gfc_option.flag_sign_zero), array);
+
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
+
+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+ gfc_option.flag_range_check), array);
+
+ array_type = build_array_type (integer_type_node,
+ build_index_type (build_int_cst (NULL_TREE, 7)));
+ array = build_constructor_from_list (array_type, nreverse (array));
+ TREE_CONSTANT (array) = 1;
+ TREE_STATIC (array) = 1;
+
+ /* Create a static variable to hold the jump table. */
+ var = gfc_create_var (array_type, "options");
+ TREE_CONSTANT (var) = 1;
+ TREE_STATIC (var) = 1;
+ TREE_READONLY (var) = 1;
+ DECL_INITIAL (var) = array;
+ var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
+
+ tmp = build_call_expr (gfor_fndecl_set_options, 2,
+ build_int_cst (integer_type_node, 8), var);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* If -ffpe-trap option was provided, add a call to set_fpe so that
+ the library will raise a FPE when needed. */
+ if (gfc_option.fpe != 0)
+ {
+ tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.fpe));
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* If this is the main program and an -fconvert option was provided,
+ add a call to set_convert. */
+
+ if (gfc_option.convert != GFC_CONVERT_NATIVE)
+ {
+ tmp = build_call_expr (gfor_fndecl_set_convert, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.convert));
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* If this is the main program and an -frecord-marker option was provided,
+ add a call to set_record_marker. */
+
+ if (gfc_option.record_marker != 0)
+ {
+ tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.record_marker));
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ if (gfc_option.max_subrecord_length != 0)
+ {
+ tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.max_subrecord_length));
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* Call MAIN__(). */
+ tmp = build_call_expr (fndecl, 0);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Mark MAIN__ as used. */
+ TREE_USED (fndecl) = 1;
+
+ /* "return 0". */
+ tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
+ build_int_cst (integer_type_node, 0));
+ tmp = build1_v (RETURN_EXPR, tmp);
+ gfc_add_expr_to_block (&body, tmp);
+
+
+ DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
+ decl = getdecls ();
+
+ /* Finish off this function and send it for code generation. */
+ poplevel (1, 0, 1);
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
+
+ DECL_SAVED_TREE (ftn_main)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
+ DECL_INITIAL (ftn_main));
+
+ /* Output the GENERIC tree. */
+ dump_function (TDI_original, ftn_main);
+
+ gfc_gimplify_function (ftn_main);
+ cgraph_finalize_function (ftn_main, false);
+
+ if (old_context)
+ {
+ pop_function_context ();
+ saved_function_decls = saved_parent_function_decls;
+ }
+ current_function_decl = old_context;
+}
+
+
/* Generate code for a function. */
void
stmtblock_t block;
stmtblock_t body;
tree result;
+ tree recurcheckvar = NULL;
gfc_symbol *sym;
int rank;
+ bool is_recursive;
sym = ns->proc_name;
trans_function_start (sym);
- gfc_start_block (&block);
+ gfc_init_block (&block);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
gfc_generate_contained_functions (ns);
+ nonlocal_dummy_decls = NULL;
+ nonlocal_dummy_decl_pset = NULL;
+
generate_local_vars (ns);
/* Keep the parent fake result declaration in module functions
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
- /* If this is the main program, add a call to set_options to set up the
- runtime library Fortran language standard parameters. */
- if (sym->attr.is_main_program)
- {
- tree array_type, array, var;
-
- /* Passing a new option to the library requires four modifications:
- + add it to the tree_cons list below
- + change the array size in the call to build_array_type
- + change the first argument to the library call
- gfor_fndecl_set_options
- + modify the library (runtime/compile_options.c)! */
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.warn_std), NULL_TREE);
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.allow_std), array);
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node, pedantic), array);
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_dump_core), array);
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_backtrace), array);
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_sign_zero), array);
-
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- flag_bounds_check), array);
-
- array = tree_cons (NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_range_check), array);
-
- array_type = build_array_type (integer_type_node,
- build_index_type (build_int_cst (NULL_TREE,
- 7)));
- array = build_constructor_from_list (array_type, nreverse (array));
- TREE_CONSTANT (array) = 1;
- TREE_STATIC (array) = 1;
-
- /* Create a static variable to hold the jump table. */
- var = gfc_create_var (array_type, "options");
- TREE_CONSTANT (var) = 1;
- TREE_STATIC (var) = 1;
- TREE_READONLY (var) = 1;
- DECL_INITIAL (var) = array;
- var = gfc_build_addr_expr (pvoid_type_node, var);
-
- tmp = build_call_expr (gfor_fndecl_set_options, 2,
- build_int_cst (integer_type_node, 8), var);
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* If this is the main program and a -ffpe-trap option was provided,
- add a call to set_fpe so that the library will raise a FPE when
- needed. */
- if (sym->attr.is_main_program && gfc_option.fpe != 0)
- {
- tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
- build_int_cst (integer_type_node,
- gfc_option.fpe));
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* If this is the main program and an -fconvert option was provided,
- add a call to set_convert. */
-
- if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
- {
- tmp = build_call_expr (gfor_fndecl_set_convert, 1,
- build_int_cst (integer_type_node,
- gfc_option.convert));
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* If this is the main program and an -frecord-marker option was provided,
- add a call to set_record_marker. */
-
- if (sym->attr.is_main_program && gfc_option.record_marker != 0)
- {
- tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
- build_int_cst (integer_type_node,
- gfc_option.record_marker));
- gfc_add_expr_to_block (&body, tmp);
- }
-
- if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
- {
- tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
- 1,
- build_int_cst (integer_type_node,
- gfc_option.max_subrecord_length));
- gfc_add_expr_to_block (&body, tmp);
+ is_recursive = sym->attr.recursive
+ || (sym->attr.entry_master
+ && sym->ns->entries->sym->attr.recursive);
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
+ {
+ char * msg;
+
+ asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+ sym->name);
+ recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+ TREE_STATIC (recurcheckvar) = 1;
+ DECL_INITIAL (recurcheckvar) = boolean_false_node;
+ gfc_add_expr_to_block (&block, recurcheckvar);
+ gfc_trans_runtime_check (true, false, recurcheckvar, &block,
+ &sym->declared_at, msg);
+ gfc_add_modify (&block, recurcheckvar, boolean_true_node);
+ gfc_free (msg);
}
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym, 0);
- gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
+ gfc_add_modify (&body, alternate_return, integer_zero_node);
}
if (ns->entries)
gfc_add_expr_to_block (&body, tmp);
}
+ /* If bounds-checking is enabled, generate code to check passed in actual
+ arguments against the expected dummy argument attributes (e.g. string
+ lengths). */
+ if (flag_bounds_check)
+ add_argument_checking (&body, sym);
+
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
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 (result == NULL_TREE)
{
/* TODO: move to the appropriate place in resolve.c. */
}
}
else
- gfc_add_expr_to_block (&block, tmp);
+ {
+ gfc_add_expr_to_block (&block, tmp);
+ /* Reset recursion-check variable. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
+ }
+ }
/* Add all the decls we created during processing. */
saved_function_decls = NULL_TREE;
DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
+ decl = getdecls ();
/* Finish off this function and send it for code generation. */
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ DECL_SAVED_TREE (fndecl)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+ DECL_INITIAL (fndecl));
+
+ if (nonlocal_dummy_decls)
+ {
+ BLOCK_VARS (DECL_INITIAL (fndecl))
+ = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
+ pointer_set_destroy (nonlocal_dummy_decl_pset);
+ nonlocal_dummy_decls = NULL;
+ nonlocal_dummy_decl_pset = NULL;
+ }
+
/* Output the GENERIC tree. */
dump_function (TDI_original, fndecl);
gfc_gimplify_function (fndecl);
cgraph_finalize_function (fndecl, false);
}
+
+ gfc_trans_use_stmts (ns);
+ gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
+
+ if (sym->attr.is_main_program)
+ create_main_function (fndecl);
}
+
void
gfc_generate_constructors (void)
{
DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
}
+ decl = getdecls ();
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ DECL_SAVED_TREE (fndecl)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+ DECL_INITIAL (fndecl));
free_after_parsing (cfun);
free_after_compilation (cfun);
decl = build_decl (VAR_DECL, id, gfc_array_index_type);
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
+ DECL_IGNORED_P (decl) = 1;
pushdecl (decl);
rest_of_decl_compilation (decl, 1, 0);
OSDN Git Service
