/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook
#include "debug.h"
#include "gfortran.h"
#include "pointer-set.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string;
+tree gfor_fndecl_error_stop_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at;
tree gfor_fndecl_runtime_warning_at;
if (!sym->attr.target
&& !sym->attr.pointer
+ && !sym->attr.cray_pointee
&& !sym->attr.proc_pointer)
DECL_RESTRICTED_P (decl) = 1;
}
for (dim = sym->as->rank - 1; dim >= 0; dim--)
{
- rtype = build_range_type (gfc_array_index_type,
- GFC_TYPE_ARRAY_LBOUND (type, dim),
- GFC_TYPE_ARRAY_UBOUND (type, dim));
+ tree lbound, ubound;
+ lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+ ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+ rtype = build_range_type (gfc_array_index_type, lbound, ubound);
gtype = build_array_type (gtype, rtype);
- /* Ensure the bound variables aren't optimized out at -O0. */
- if (!optimize)
+ /* Ensure the bound variables aren't optimized out at -O0.
+ For -O1 and above they often will be optimized out, but
+ can be tracked by VTA. Also clear the artificial
+ lbound.N or ubound.N DECL_NAME, so that it doesn't end up
+ in debug info. */
+ if (lbound && TREE_CODE (lbound) == VAR_DECL
+ && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
{
- if (GFC_TYPE_ARRAY_LBOUND (type, dim)
- && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
- DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
- if (GFC_TYPE_ARRAY_UBOUND (type, dim)
- && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
- DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
+ if (DECL_NAME (lbound)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
+ "lbound") != 0)
+ DECL_NAME (lbound) = NULL_TREE;
+ DECL_IGNORED_P (lbound) = 0;
+ }
+ if (ubound && TREE_CODE (ubound) == VAR_DECL
+ && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
+ {
+ if (DECL_NAME (ubound)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
+ "ubound") != 0)
+ DECL_NAME (ubound) = NULL_TREE;
+ DECL_IGNORED_P (ubound) = 0;
}
}
TYPE_NAME (type) = type_decl = build_decl (input_location,
else
byref = 0;
+ /* Make sure that the vtab for the declared type is completed. */
+ if (sym->ts.type == BT_CLASS)
+ {
+ gfc_component *c = gfc_find_component (sym->ts.u.derived,
+ "$data", true, true);
+ if (!c->ts.u.derived->backend_decl)
+ gfc_find_derived_vtab (c->ts.u.derived, true);
+ }
+
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
{
/* Return via extra parameter. */
if (sym->attr.assign)
gfc_add_assign_aux_vars (sym);
- if (TREE_STATIC (decl) && !sym->attr.use_assoc)
+ if (TREE_STATIC (decl) && !sym->attr.use_assoc
+ && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
+ || gfc_option.flag_max_stack_var_size == 0
+ || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
{
- /* Add static initializer. */
+ /* Add static initializer. For procedures, it is only needed if
+ SAVE is specified otherwise they need to be reinitialized
+ every time the procedure is entered. The TREE_STATIC is
+ in this case due to -fmax-stack-var-size=. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
TREE_TYPE (decl), sym->attr.dimension,
sym->attr.pointer || sym->attr.allocatable);
{
/* Add static initializer. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+ TREE_TYPE (decl),
+ sym->attr.proc_pointer ? false : sym->attr.dimension,
+ sym->attr.proc_pointer);
}
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
if (!sym->attr.mixed_entry_master && sym->attr.function)
- decl = build_decl (input_location,
+ decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
VAR_DECL, get_identifier (name),
gfc_sym_type (sym));
else
- decl = build_decl (input_location,
+ decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
VAR_DECL, get_identifier (name),
TREE_TYPE (TREE_TYPE (this_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
/* Builds a function decl. The remaining parameters are the types of the
function arguments. Negative nargs indicates a varargs function. */
-tree
-gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
+static tree
+build_library_function_decl_1 (tree name, const char *spec,
+ tree rettype, int nargs, va_list p)
{
tree arglist;
tree argtype;
tree fntype;
tree fndecl;
- va_list p;
int n;
/* Library functions must be declared with global scope. */
gcc_assert (current_function_decl == NULL_TREE);
- va_start (p, nargs);
-
-
/* Create a list of the argument types. */
for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
{
/* Build the function type and decl. */
fntype = build_function_type (rettype, arglist);
+ if (spec)
+ {
+ tree attr_args = build_tree_list (NULL_TREE,
+ build_string (strlen (spec), spec));
+ tree attrs = tree_cons (get_identifier ("fn spec"),
+ attr_args, TYPE_ATTRIBUTES (fntype));
+ fntype = build_type_attribute_variant (fntype, attrs);
+ }
fndecl = build_decl (input_location,
FUNCTION_DECL, name, fntype);
DECL_EXTERNAL (fndecl) = 1;
TREE_PUBLIC (fndecl) = 1;
- va_end (p);
-
pushdecl (fndecl);
rest_of_decl_compilation (fndecl, 1, 0);
return fndecl;
}
+/* Builds a function decl. The remaining parameters are the types of the
+ function arguments. Negative nargs indicates a varargs function. */
+
+tree
+gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
+{
+ tree ret;
+ va_list args;
+ va_start (args, nargs);
+ ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
+ va_end (args);
+ return ret;
+}
+
+/* Builds a function decl. The remaining parameters are the types of the
+ function arguments. Negative nargs indicates a varargs function.
+ The SPEC parameter specifies the function argument and return type
+ specification according to the fnspec function type attribute. */
+
+static tree
+gfc_build_library_function_decl_with_spec (tree name, const char *spec,
+ tree rettype, int nargs, ...)
+{
+ tree ret;
+ va_list args;
+ va_start (args, nargs);
+ ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
+ va_end (args);
+ return ret;
+}
+
static void
gfc_build_intrinsic_function_decls (void)
{
/* Stop doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
+ gfor_fndecl_error_stop_string =
+ gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
+ void_type_node, 2, pchar_type_node,
+ gfc_int4_type_node);
+ /* ERROR STOP doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
+
gfor_fndecl_pause_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
void_type_node, 1, gfc_int4_type_node);
gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
void_type_node, 1, integer_type_node);
- gfor_fndecl_in_pack = gfc_build_library_function_decl (
- get_identifier (PREFIX("internal_pack")),
+ gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("internal_pack")), ".r",
pvoid_type_node, 1, pvoid_type_node);
- gfor_fndecl_in_unpack = gfc_build_library_function_decl (
- get_identifier (PREFIX("internal_unpack")),
+ gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("internal_unpack")), ".wR",
void_type_node, 2, pvoid_type_node, pvoid_type_node);
gfor_fndecl_associated =
/* Initialize a derived type by building an lvalue from the symbol
- and using trans_assignment to do the work. */
+ and using trans_assignment to do the work. Set dealloc to false
+ if no deallocation prior the assignment is needed. */
tree
-gfc_init_default_dt (gfc_symbol * sym, tree body)
+gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
{
stmtblock_t fnblock;
gfc_expr *e;
gcc_assert (!sym->attr.allocatable);
gfc_set_sym_referenced (sym);
e = gfc_lval_expr_from_sym (sym);
- tmp = gfc_trans_assignment (e, sym->value, false);
+ tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
if (sym->attr.dummy && (sym->attr.optional
|| sym->ns->proc_name->attr.entry_master))
{
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (f->sym->value)
- body = gfc_init_default_dt (f->sym, body);
+ body = gfc_init_default_dt (f->sym, body, true);
}
gfc_add_expr_to_block (&fnblock, body);
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = gfc_init_default_dt (sym, fnbody);
+ fnbody = gfc_init_default_dt (sym, fnbody, false);
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
case AS_ASSUMED_SIZE:
/* Must be a dummy parameter. */
- gcc_assert (sym->attr.dummy);
+ gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
/* We should always pass assumed size arrays the g77 way. */
- fnbody = gfc_trans_g77_array (sym, fnbody);
+ if (sym->attr.dummy)
+ fnbody = gfc_trans_g77_array (sym, fnbody);
break;
case AS_ASSUMED_SHAPE:
|| (sym->ts.type == BT_CLASS
&& sym->ts.u.derived->components->attr.allocatable))
{
- /* Nullify and automatic deallocation of allocatable scalars. */
- tree tmp;
- gfc_expr *e;
- gfc_se se;
- stmtblock_t block;
-
- e = gfc_lval_expr_from_sym (sym);
- if (sym->ts.type == BT_CLASS)
- gfc_add_component_ref (e, "$data");
-
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
- gfc_free_expr (e);
-
- /* Nullify when entering the scope. */
- gfc_start_block (&block);
- gfc_add_modify (&block, se.expr, fold_convert (TREE_TYPE (se.expr),
- null_pointer_node));
- gfc_add_expr_to_block (&block, fnbody);
-
- /* Deallocate when leaving the scope. Nullifying is not needed. */
- tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL);
- gfc_add_expr_to_block (&block, tmp);
- fnbody = gfc_finish_block (&block);
+ if (!sym->attr.save)
+ {
+ /* Nullify and automatic deallocation of allocatable
+ scalars. */
+ tree tmp;
+ gfc_expr *e;
+ gfc_se se;
+ stmtblock_t block;
+
+ e = gfc_lval_expr_from_sym (sym);
+ if (sym->ts.type == BT_CLASS)
+ gfc_add_component_ref (e, "$data");
+
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc_free_expr (e);
+
+ /* Nullify when entering the scope. */
+ gfc_start_block (&block);
+ gfc_add_modify (&block, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ gfc_add_expr_to_block (&block, fnbody);
+
+ /* Deallocate when leaving the scope. Nullifying is not
+ needed. */
+ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
+ NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ fnbody = gfc_finish_block (&block);
+ }
}
else if (sym->ts.type == BT_CHARACTER)
{
&& sym->value
&& !sym->attr.data
&& sym->attr.save == SAVE_NONE)
- fnbody = gfc_init_default_dt (sym, fnbody);
+ fnbody = gfc_init_default_dt (sym, fnbody, false);
else
gcc_unreachable ();
}
{
decl = sym->backend_decl;
gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
- gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
- || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
- gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
- || DECL_CONTEXT (TYPE_STUB_DECL (decl))
- == sym->ns->proc_name->backend_decl);
+
+ /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
+ if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
+ {
+ gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
+ || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
+ gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
+ || DECL_CONTEXT (TYPE_STUB_DECL (decl))
+ == sym->ns->proc_name->backend_decl);
+ }
TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
tree length;
length = sym->ts.u.cl->backend_decl;
- if (!INTEGER_CST_P (length))
+ gcc_assert (length || sym->attr.proc_pointer);
+ if (length && !INTEGER_CST_P (length))
{
pushdecl (length);
rest_of_decl_compilation (length, 1, 0);
return check_constant_initializer (expr, ts, false, false);
else if (expr->expr_type != EXPR_ARRAY)
return false;
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (c->iterator)
return false;
if (expr->expr_type != EXPR_STRUCTURE)
return false;
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
if (!c->expr || cm->attr.allocatable)
continue;
cl->passed_length,
fold_convert (gfc_charlen_type_node,
integer_zero_node));
- not_absent = fold_build2 (NE_EXPR, boolean_type_node,
- fsym->backend_decl, null_pointer_node);
+ /* The symbol needs to be referenced for gfc_get_symbol_decl. */
+ fsym->attr.referenced = 1;
+ not_absent = gfc_conv_expr_present (fsym);
absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
not_0length, not_absent);
stmtblock_t block;
stmtblock_t body;
tree result;
- tree recurcheckvar = NULL;
+ tree recurcheckvar = NULL_TREE;
gfc_symbol *sym;
int rank;
bool is_recursive;
is_recursive = sym->attr.recursive
|| (sym->attr.entry_master
&& sym->ns->entries->sym->attr.recursive);
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
- && !gfc_option.flag_recursive)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_recursive)
{
char * msg;
}
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
- && sym->attr.subroutine)
+ && sym->attr.subroutine)
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym, 0);
/* If bounds-checking is enabled, generate code to check passed in actual
arguments against the expected dummy argument attributes (e.g. string
lengths). */
- if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
add_argument_checking (&body, sym);
tmp = gfc_trans_code (ns->code);
else
result = sym->result->backend_decl;
- if (result != NULL_TREE && sym->attr.function
- && !sym->attr.pointer)
+ if (result != NULL_TREE
+ && sym->attr.function
+ && !sym->attr.pointer)
{
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.alloc_comp)
gfc_add_expr_to_block (&block, tmp);
/* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
- && !gfc_option.flag_openmp)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_openmp
+ && recurcheckvar != NULL_TREE)
{
gfc_add_modify (&block, recurcheckvar, boolean_false_node);
recurcheckvar = NULL;
{
gfc_add_expr_to_block (&block, tmp);
/* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
- && !gfc_option.flag_openmp)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
- }
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+ && !is_recursive
+ && !gfc_option.flag_openmp
+ && recurcheckvar != NULL_TREE)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL_TREE;
+ }
}