/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook
static gfc_symbol* current_procedure_symbol = NULL;
+/* With -fcoarray=lib: For generating the registering call
+ of static coarrays. */
+static bool has_coarray_vars;
+static stmtblock_t caf_init_block;
+
+
/* List of static constructor functions. */
tree gfc_static_ctors;
tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
+tree gfor_fndecl_stop_numeric_f08;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_error_stop_numeric;
tree gfor_fndecl_error_stop_string;
tree gfor_fndecl_associated;
+/* Coarray run-time library function decls. */
+tree gfor_fndecl_caf_init;
+tree gfor_fndecl_caf_finalize;
+tree gfor_fndecl_caf_register;
+tree gfor_fndecl_caf_deregister;
+tree gfor_fndecl_caf_critical;
+tree gfor_fndecl_caf_end_critical;
+tree gfor_fndecl_caf_sync_all;
+tree gfor_fndecl_caf_sync_images;
+tree gfor_fndecl_caf_error_stop;
+tree gfor_fndecl_caf_error_stop_str;
+
+/* Coarray global variables for num_images/this_image. */
+
+tree gfort_gvar_caf_num_images;
+tree gfort_gvar_caf_this_image;
+
+
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */
/* If it wasn't used we wouldn't be getting it. */
TREE_USED (decl) = 1;
+ if (sym->attr.flavor == FL_PARAMETER
+ && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
+ TREE_READONLY (decl) = 1;
+
/* Chain this decl to the pending declarations. Don't do pushdecl()
because this would add them to the current scope rather than the
function scope. */
SAVE_EXPLICIT. */
if (!sym->attr.use_assoc
&& (sym->attr.save != SAVE_NONE || sym->attr.data
- || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+ || (sym->value && sym->ns->proc_name->attr.is_main_program)
+ || (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && sym->attr.codimension && !sym->attr.allocatable)))
TREE_STATIC (decl) = 1;
if (sym->attr.volatile_)
{
TREE_THIS_VOLATILE (decl) = 1;
+ TREE_SIDE_EFFECTS (decl) = 1;
new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
TREE_TYPE (decl) = new_type;
}
}
+/* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
+ backend_decl for a module symbol, if it all ready exists. If the
+ module gsymbol does not exist, it is created. If the symbol does
+ not exist, it is added to the gsymbol namespace. Returns true if
+ an existing backend_decl is found. */
+
+bool
+gfc_get_module_backend_decl (gfc_symbol *sym)
+{
+ gfc_gsymbol *gsym;
+ gfc_symbol *s;
+ gfc_symtree *st;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+ if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
+ {
+ st = NULL;
+ s = NULL;
+
+ if (gsym)
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+
+ if (!s)
+ {
+ if (!gsym)
+ {
+ gsym = gfc_get_gsymbol (sym->module);
+ gsym->type = GSYM_MODULE;
+ gsym->ns = gfc_get_namespace (NULL, 0);
+ }
+
+ st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
+ st->n.sym = sym;
+ sym->refs++;
+ }
+ else if (sym->attr.flavor == FL_DERIVED)
+ {
+ if (s && s->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_interface *intr;
+ gcc_assert (s->attr.generic);
+ for (intr = s->generic; intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ {
+ s = intr->sym;
+ break;
+ }
+ }
+
+ if (!s->backend_decl)
+ s->backend_decl = gfc_get_derived_type (s);
+ gfc_copy_dt_decls_ifequal (s, sym, true);
+ return true;
+ }
+ else if (s->backend_decl)
+ {
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
+ true);
+ else if (sym->ts.type == BT_CHARACTER)
+ sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
+ sym->backend_decl = s->backend_decl;
+ return true;
+ }
+ }
+ return false;
+}
+
+
/* Create an array index type variable with function scope. */
static tree
nest = (procns->proc_name->backend_decl != current_function_decl)
&& !sym->attr.contained;
+ if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
+ {
+ tree token;
+
+ token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
+ TYPE_QUAL_RESTRICT),
+ "caf_token");
+ GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
+ DECL_ARTIFICIAL (token) = 1;
+ TREE_STATIC (token) = 1;
+ gfc_add_decl_to_function (token);
+ }
+
for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
{
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
}
}
+ for (dim = GFC_TYPE_ARRAY_RANK (type);
+ dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
+ {
+ if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
+ {
+ GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+ }
+ /* Don't try to use the unknown ubound for the last coarray dimension. */
+ if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
+ && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
+ {
+ GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+ }
+ }
if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
target label's address. Otherwise, value is the length of a format string
and ASSIGN_ADDR is its address. */
if (TREE_STATIC (length))
- DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
+ DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
else
gfc_defer_symbol_init (sym);
tree length = NULL_TREE;
tree attributes;
int byref;
+ bool intrinsic_array_parameter = false;
gcc_assert (sym->attr.referenced
|| sym->attr.use_assoc
{
gfc_component *c = CLASS_DATA (sym);
if (!c->ts.u.derived->backend_decl)
- gfc_find_derived_vtab (c->ts.u.derived);
+ {
+ gfc_find_derived_vtab (c->ts.u.derived);
+ gfc_get_derived_type (sym->ts.u.derived);
+ }
+ }
+
+ /* All deferred character length procedures need to retain the backend
+ decl, which is a pointer to the character length in the caller's
+ namespace and to declare a local character length. */
+ if (!byref && sym->attr.function
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && sym->ts.u.cl->passed_length == NULL
+ && sym->ts.u.cl->backend_decl
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
+ {
+ sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+ sym->ts.u.cl->backend_decl = NULL_TREE;
+ length = gfc_create_string_length (sym);
}
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
/* Create a character length variable. */
if (sym->ts.type == BT_CHARACTER)
{
+ /* For a deferred dummy, make a new string length variable. */
+ if (sym->ts.deferred
+ &&
+ (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
+ && sym->ts.u.cl->passed_length == NULL
+ && sym->ts.u.cl->backend_decl)
+ {
+ sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+ sym->ts.u.cl->backend_decl = NULL_TREE;
+ }
+
if (sym->ts.u.cl->backend_decl == NULL_TREE)
length = gfc_create_string_length (sym);
else
length = sym->ts.u.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
- && DECL_CONTEXT (length) == NULL_TREE)
+ && DECL_FILE_SCOPE_P (length))
{
/* Add the string length to the same context as the symbol. */
if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
}
/* Use a copy of the descriptor for dummy arrays. */
- if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
+ if ((sym->attr.dimension || sym->attr.codimension)
+ && !TREE_USED (sym->backend_decl))
{
decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
/* Prevent the dummy from being detected as unused if it is copied. */
&& DECL_CONTEXT (sym->backend_decl) != current_function_decl)
gfc_nonlocal_dummy_array_decl (sym);
- return sym->backend_decl;
+ if (sym->ts.type == BT_CLASS && sym->backend_decl)
+ GFC_DECL_CLASS(sym->backend_decl) = 1;
+
+ if (sym->ts.type == BT_CLASS && sym->backend_decl)
+ GFC_DECL_CLASS(sym->backend_decl) = 1;
+ return sym->backend_decl;
}
if (sym->backend_decl)
return sym->backend_decl;
+ /* Special case for array-valued named constants from intrinsic
+ procedures; those are inlined. */
+ if (sym->attr.use_assoc && sym->from_intmod
+ && sym->attr.flavor == FL_PARAMETER)
+ intrinsic_array_parameter = true;
+
/* If use associated and whole file compilation, use the module
declaration. */
if (gfc_option.flag_whole_file
- && sym->attr.flavor == FL_VARIABLE
+ && (sym->attr.flavor == FL_VARIABLE
+ || sym->attr.flavor == FL_PARAMETER)
&& sym->attr.use_assoc
- && sym->module)
+ && !intrinsic_array_parameter
+ && sym->module
+ && gfc_get_module_backend_decl (sym))
{
- gfc_gsymbol *gsym;
-
- gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
- if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
- {
- gfc_symbol *s;
- s = NULL;
- gfc_find_symbol (sym->name, gsym->ns, 0, &s);
- if (s && s->backend_decl)
- {
- if (sym->ts.type == BT_DERIVED)
- gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
- true);
- if (sym->ts.type == BT_CHARACTER)
- sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
- sym->backend_decl = s->backend_decl;
- return sym->backend_decl;
- }
- }
+ if (sym->ts.type == BT_CLASS && sym->backend_decl)
+ GFC_DECL_CLASS(sym->backend_decl) = 1;
+ return sym->backend_decl;
}
if (sym->attr.flavor == FL_PROCEDURE)
if (sym->module)
{
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
- if (sym->attr.use_assoc)
+ if (sym->attr.use_assoc && !intrinsic_array_parameter)
DECL_IGNORED_P (decl) = 1;
}
- if (sym->attr.dimension)
+ if (sym->attr.dimension || sym->attr.codimension)
{
/* Create variables to hold the non-constant bits of array info. */
gfc_build_qualified_array (decl, sym);
}
/* Remember this variable for allocation/cleanup. */
- if (sym->attr.dimension || sym->attr.allocatable
+ if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
&& !sym->attr.data
&& !sym->attr.allocatable
&& (sym->value && !sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc))
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
gfc_finish_var_decl (span, sym);
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;
}
+ if (sym->ts.type == BT_CLASS)
+ GFC_DECL_CLASS(decl) = 1;
+
sym->backend_decl = decl;
if (sym->attr.assign)
gfc_add_assign_aux_vars (sym);
- if (TREE_STATIC (decl) && !sym->attr.use_assoc
+ if (intrinsic_array_parameter)
+ {
+ TREE_STATIC (decl) = 1;
+ DECL_EXTERNAL (decl) = 0;
+ }
+
+ if (TREE_STATIC (decl)
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)
&& (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))
+ || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
+ && (gfc_option.coarray != GFC_FCOARRAY_LIB
+ || !sym->attr.codimension || sym->attr.allocatable))
{
/* Add static initializer. For procedures, it is only needed if
SAVE is specified otherwise they need to be reinitialized
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.dimension
+ || (sym->attr.codimension
+ && sym->attr.allocatable),
sym->attr.pointer
|| sym->attr.allocatable,
sym->attr.proc_pointer);
&& !sym->attr.proc_pointer)
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;
+ }
+
return decl;
}
false, true);
}
+ /* Handle threadprivate procedure pointers. */
+ if (sym->attr.threadprivate
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
decl_attributes (&decl, attributes, 0);
tree save_fn_decl = current_function_decl;
current_function_decl = NULL_TREE;
- gfc_get_backend_locus (&old_loc);
+ gfc_save_backend_locus (&old_loc);
push_cfun (cfun);
gfc_create_function_decl (gsym->ns, true);
pop_cfun ();
- gfc_set_backend_locus (&old_loc);
+ gfc_restore_backend_locus (&old_loc);
current_function_decl = save_fn_decl;
}
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
if (s && s->backend_decl)
{
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
+ true);
+ else if (sym->ts.type == BT_CHARACTER)
+ sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
sym->backend_decl = s->backend_decl;
return sym->backend_decl;
}
fndecl = build_decl (input_location,
FUNCTION_DECL, name, type);
+ /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
+ TREE_PUBLIC specifies whether a function is globally addressable (i.e.
+ the opposite of declaring a function as static in C). */
+ DECL_EXTERNAL (fndecl) = 1;
+ TREE_PUBLIC (fndecl) = 1;
+
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
decl_attributes (&fndecl, attributes, 0);
DECL_CONTEXT (fndecl) = NULL_TREE;
}
- DECL_EXTERNAL (fndecl) = 1;
-
- /* This specifies if a function is globally addressable, i.e. it is
- the opposite of declaring static in C. */
- TREE_PUBLIC (fndecl) = 1;
-
/* Set attributes for PURE functions. A call to PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
/* Allow only one nesting level. Allow public declarations. */
gcc_assert (current_function_decl == NULL_TREE
- || DECL_CONTEXT (current_function_decl) == NULL_TREE
- || TREE_CODE (DECL_CONTEXT (current_function_decl))
- == NAMESPACE_DECL);
+ || DECL_FILE_SCOPE_P (current_function_decl)
+ || (TREE_CODE (DECL_CONTEXT (current_function_decl))
+ == NAMESPACE_DECL));
type = gfc_get_function_type (sym);
fndecl = build_decl (input_location,
attr = sym->attr;
+ /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
+ TREE_PUBLIC specifies whether a function is globally addressable (i.e.
+ the opposite of declaring a function as static in C). */
+ DECL_EXTERNAL (fndecl) = 0;
+
+ if (!current_function_decl
+ && !sym->attr.entry_master && !sym->attr.is_main_program)
+ TREE_PUBLIC (fndecl) = 1;
+
attributes = add_attributes_to_decl (attr, NULL_TREE);
decl_attributes (&fndecl, attributes, 0);
- /* Perform name mangling if this is a top level or module procedure. */
- if (current_function_decl == NULL_TREE)
- gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
-
/* Figure out the return type of the declared function, and build a
RESULT_DECL for it. If this is a subroutine with alternate
returns, build a RESULT_DECL for it. */
/* Don't call layout_decl for a RESULT_DECL.
layout_decl (result_decl, 0); */
- /* Set up all attributes for the function. */
- DECL_CONTEXT (fndecl) = current_function_decl;
- DECL_EXTERNAL (fndecl) = 0;
-
- /* 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.is_main_program)
- TREE_PUBLIC (fndecl) = 1;
-
/* TREE_STATIC means the function body is defined here. */
TREE_STATIC (fndecl) = 1;
/* Layout the function declaration and put it in the binding level
of the current function. */
- if (global)
+ if (global
+ || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0))
pushdecl_top_level (fndecl);
else
pushdecl (fndecl);
+ /* Perform name mangling if this is a top level or module procedure. */
+ if (current_function_decl == NULL_TREE)
+ gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
+
sym->backend_decl = fndecl;
}
{
/* Length of character result. */
tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
- gcc_assert (len_type == gfc_charlen_type_node);
length = build_decl (input_location,
PARM_DECL,
{
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
- gcc_assert (len_type == gfc_charlen_type_node);
+ if (!f->sym->ts.deferred)
+ gcc_assert (len_type == gfc_charlen_type_node);
+ else
+ gcc_assert (POINTER_TYPE_P (len_type));
strcpy (&name[1], f->sym->name);
name[0] = '_';
if (f->sym->attr.proc_pointer)
type = build_pointer_type (type);
+ if (f->sym->attr.volatile_)
+ type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
+
/* Build the argument declaration. */
parm = build_decl (input_location,
PARM_DECL, gfc_sym_identifier (f->sym), type);
+ if (f->sym->attr.volatile_)
+ {
+ TREE_THIS_VOLATILE (parm) = 1;
+ TREE_SIDE_EFFECTS (parm) = 1;
+ }
+
/* Fill in arg stuff. */
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
f->sym->backend_decl = parm;
+ /* Coarrays which are descriptorless or assumed-shape pass with
+ -fcoarray=lib the token and the offset as hidden arguments. */
+ if (f->sym->attr.codimension
+ && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && !f->sym->attr.allocatable)
+ {
+ tree caf_type;
+ tree token;
+ tree offset;
+
+ gcc_assert (f->sym->backend_decl != NULL_TREE
+ && !sym->attr.is_bind_c);
+ caf_type = TREE_TYPE (f->sym->backend_decl);
+
+ token = build_decl (input_location, PARM_DECL,
+ create_tmp_var_name ("caf_token"),
+ build_qualified_type (pvoid_type_node,
+ TYPE_QUAL_RESTRICT));
+ if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
+ || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
+ if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
+ gfc_allocate_lang_decl (f->sym->backend_decl);
+ GFC_DECL_TOKEN (f->sym->backend_decl) = token;
+ }
+ else
+ {
+ 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);
+ TREE_READONLY (token) = 1;
+ hidden_arglist = chainon (hidden_arglist, token);
+ gfc_finish_decl (token);
+
+ offset = build_decl (input_location, PARM_DECL,
+ create_tmp_var_name ("caf_offset"),
+ gfc_array_index_type);
+
+ if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
+ == NULL_TREE);
+ GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
+ }
+ else
+ {
+ gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
+ GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+ }
+ DECL_CONTEXT (offset) = fndecl;
+ DECL_ARTIFICIAL (offset) = 1;
+ DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
+ TREE_READONLY (offset) = 1;
+ hidden_arglist = chainon (hidden_arglist, offset);
+ gfc_finish_decl (offset);
+ }
+
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
/* Let the world know what we're about to do. */
announce_function (fndecl);
- if (DECL_CONTEXT (fndecl) == NULL_TREE)
+ if (DECL_FILE_SCOPE_P (fndecl))
{
/* Create RTL for function declaration. */
rest_of_decl_compilation (fndecl, 1, 0);
init_function_start (fndecl);
- /* Even though we're inside a function body, we still don't want to
- call expand_expr to calculate the size of a variable-sized array.
- We haven't necessarily assigned RTL to all variables yet, so it's
- not safe to try to expand expressions involving them. */
- cfun->dont_save_pending_sizes_p = 1;
-
/* function.c requires a push at the start of the function. */
pushlevel (0);
}
/* This should always be a toplevel function. */
gcc_assert (current_function_decl == NULL_TREE);
- gfc_get_backend_locus (&old_loc);
+ gfc_save_backend_locus (&old_loc);
for (el = ns->entries; el; el = el->next)
{
VEC(tree,gc) *args = NULL;
}
}
- gfc_set_backend_locus (&old_loc);
+ gfc_restore_backend_locus (&old_loc);
}
build_library_function_decl_1 (tree name, const char *spec,
tree rettype, int nargs, va_list p)
{
- tree arglist;
- tree argtype;
+ VEC(tree,gc) *arglist;
tree fntype;
tree fndecl;
int n;
gcc_assert (current_function_decl == NULL_TREE);
/* Create a list of the argument types. */
- for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
- {
- argtype = va_arg (p, tree);
- arglist = gfc_chainon_list (arglist, argtype);
- }
-
- if (nargs >= 0)
+ arglist = VEC_alloc (tree, gc, abs (nargs));
+ for (n = abs (nargs); n > 0; n--)
{
- /* Terminate the list. */
- arglist = chainon (arglist, void_list_node);
+ tree argtype = va_arg (p, tree);
+ VEC_quick_push (tree, arglist, argtype);
}
/* Build the function type and decl. */
- fntype = build_function_type (rettype, arglist);
+ if (nargs >= 0)
+ fntype = build_function_type_vec (rettype, arglist);
+ else
+ fntype = build_varargs_function_type_vec (rettype, arglist);
if (spec)
{
tree attr_args = build_tree_list (NULL_TREE,
/* STOP doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
+ gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
+ get_identifier (PREFIX("stop_numeric_f08")),
+ void_type_node, 1, gfc_int4_type_node);
+ /* STOP doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
+
gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("stop_string")), ".R.",
void_type_node, 2, pchar_type_node, gfc_int4_type_node);
DECL_PURE_P (gfor_fndecl_associated) = 1;
TREE_NOTHROW (gfor_fndecl_associated) = 1;
+ /* Coarray library calls. */
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree pint_type, pppchar_type;
+
+ pint_type = build_pointer_type (integer_type_node);
+ pppchar_type
+ = build_pointer_type (build_pointer_type (pchar_type_node));
+
+ gfor_fndecl_caf_init = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_init")), void_type_node,
+ 4, pint_type, pppchar_type, pint_type, pint_type);
+
+ gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
+
+ gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
+ size_type_node, integer_type_node, ppvoid_type_node, pint_type,
+ pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
+ ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_critical = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_critical")), void_type_node, 0);
+
+ gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
+
+ gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
+ 3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
+
+ gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
+ 5, integer_type_node, pint_type, pint_type,
+ build_pointer_type (pchar_type_node), integer_type_node);
+
+ gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_error_stop")),
+ void_type_node, 1, gfc_int4_type_node);
+ /* CAF's ERROR STOP doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
+
+ gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_error_stop_str")), ".R.",
+ void_type_node, 2, pchar_type_node, gfc_int4_type_node);
+ /* CAF's ERROR STOP doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
+ }
+
gfc_build_intrinsic_function_decls ();
gfc_build_intrinsic_lib_fndecls ();
gfc_build_io_library_fndecls ();
gcc_assert (sym->backend_decl);
gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
- gfc_start_block (&init);
+ gfc_init_block (&init);
/* Evaluate the string length expression. */
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
/* Set the initial value to length. See the comments in
function gfc_add_assign_aux_vars in this file. */
gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
- build_int_cst (NULL_TREE, -2));
+ build_int_cst (gfc_charlen_type_node, -2));
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
}
|| sym->ns->proc_name->attr.entry_master))
{
present = gfc_conv_expr_present (sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
- tmp, build_empty_stmt (input_location));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (block, tmp);
gfc_free_expr (e);
|| f->sym->ns->proc_name->attr.entry_master)
{
present = gfc_conv_expr_present (f->sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
- tmp, build_empty_stmt (input_location));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ present, tmp,
+ build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&init, tmp);
else if (f->sym->value)
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)
+ {
+ tree decl = build_fold_indirect_ref_loc (input_location,
+ f->sym->backend_decl);
+ tmp = CLASS_DATA (f->sym)->backend_decl;
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (tmp), decl, tmp, NULL_TREE);
+ 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);
+
+ 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));
+ }
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
-}
-
-
-/* Do proper initialization for ASSOCIATE names. */
-
-static void
-trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
-{
- gfc_expr* e;
- tree tmp;
-
- gcc_assert (sym->assoc);
- e = sym->assoc->target;
-
- /* Do a `pointer assignment' with updated descriptor (or assign descriptor
- to array temporary) for arrays with either unknown shape or if associating
- to a variable. */
- if (sym->attr.dimension
- && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
- {
- gfc_se se;
- gfc_ss* ss;
- tree desc;
-
- desc = sym->backend_decl;
-
- /* If association is to an expression, evaluate it and create temporary.
- Otherwise, get descriptor of target for pointer assignment. */
- gfc_init_se (&se, NULL);
- ss = gfc_walk_expr (e);
- if (sym->assoc->variable)
- {
- se.direct_byref = 1;
- se.expr = desc;
- }
- gfc_conv_expr_descriptor (&se, e, ss);
-
- /* If we didn't already do the pointer assignment, set associate-name
- descriptor to the one generated for the temporary. */
- if (!sym->assoc->variable)
- {
- int dim;
-
- gfc_add_modify (&se.pre, desc, se.expr);
-
- /* The generated descriptor has lower bound zero (as array
- temporary), shift bounds so we get lower bounds of 1. */
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
- }
-
- /* Done, register stuff as init / cleanup code. */
- gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
- gfc_finish_block (&se.post));
- }
-
- /* Do a scalar pointer assignment; this is for scalar variable targets. */
- else if (gfc_is_associate_pointer (sym))
- {
- gfc_se se;
-
- gcc_assert (!sym->attr.dimension);
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, e);
-
- tmp = TREE_TYPE (sym->backend_decl);
- tmp = gfc_build_addr_expr (tmp, se.expr);
- gfc_add_modify (&se.pre, sym->backend_decl, tmp);
-
- gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
- gfc_finish_block (&se.post));
- }
-
- /* Do a simple assignment. This is for scalar expressions, where we
- can simply use expression assignment. */
- else
- {
- gfc_expr* lhs;
+ gfc_add_expr_to_block (&init, tmp);
+ }
- lhs = gfc_lval_expr_from_sym (sym);
- tmp = gfc_trans_assignment (lhs, e, false, true);
- gfc_add_init_cleanup (block, tmp, NULL_TREE);
- }
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
}
gfc_formal_arglist *f;
stmtblock_t tmpblock;
bool seen_trans_deferred_array = false;
+ tree tmp = NULL;
+ gfc_expr *e;
+ gfc_se se;
+ stmtblock_t init;
/* Deal with implicit return variables. Explicit return variables will
already have been added. */
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
- if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ if (proc_sym->ts.deferred)
+ {
+ tmp = NULL;
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&proc_sym->declared_at);
+ gfc_start_block (&init);
+ /* Zero the string length on entry. */
+ gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
+ build_int_cst (gfc_charlen_type_node, 0));
+ /* Null the pointer. */
+ e = gfc_lval_expr_from_sym (proc_sym);
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc_free_expr (e);
+ tmp = se.expr;
+ gfc_add_modify (&init, tmp,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ gfc_restore_backend_locus (&loc);
+
+ /* Pass back the string length on exit. */
+ tmp = proc_sym->ts.u.cl->passed_length;
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node, tmp,
+ proc_sym->ts.u.cl->backend_decl);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+ }
+ else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else
/* Initialize the INTENT(OUT) derived type dummy arguments. This
should be done here so that the offsets and lbounds of arrays
are available. */
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&proc_sym->declared_at);
init_intent_out_dt (proc_sym, block);
+ gfc_restore_backend_locus (&loc);
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;
if (sym->assoc)
- trans_associate_var (sym, block);
- else if (sym->attr.dimension)
+ continue;
+
+ if (sym->attr.subref_array_pointer
+ && GFC_DECL_SPAN (sym->backend_decl)
+ && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
{
- switch (sym->as->type)
+ gfc_init_block (&tmpblock);
+ gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
+ build_int_cst (gfc_array_index_type, 0));
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
+ NULL_TREE);
+ }
+
+ if (sym->attr.dimension || sym->attr.codimension)
+ {
+ /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
+ array_type tmp = sym->as->type;
+ if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
+ tmp = AS_EXPLICIT;
+ switch (tmp)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
else if (sym->attr.pointer || sym->attr.allocatable)
{
if (TREE_STATIC (sym->backend_decl))
- gfc_trans_static_array_pointer (sym);
+ {
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&sym->declared_at);
+ gfc_trans_static_array_pointer (sym);
+ gfc_restore_backend_locus (&loc);
+ }
else
{
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
}
}
- else
+ else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
{
+ gfc_init_block (&tmpblock);
+ gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
+ &tmpblock, sym);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
+ NULL_TREE);
+ continue;
+ }
+ else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+ {
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&sym->declared_at);
+
if (sym_has_alloc_comp)
{
seen_trans_deferred_array = true;
NULL_TREE);
}
- gfc_get_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
gfc_trans_auto_array_allocation (sym->backend_decl,
sym, block);
- gfc_set_backend_locus (&loc);
+ gfc_restore_backend_locus (&loc);
}
break;
if (sym_has_alloc_comp && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block);
}
- else if (sym->attr.allocatable
- || (sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)->attr.allocatable))
+ else if ((!sym->attr.dummy || sym->ts.deferred)
+ && (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.class_pointer))
+ continue;
+ else if ((!sym->attr.dummy || sym->ts.deferred)
+ && (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.allocatable)))
{
if (!sym->attr.save)
{
+ tree descriptor = NULL_TREE;
+
/* Nullify and automatic deallocation of allocatable
scalars. */
- tree tmp;
- gfc_expr *e;
- gfc_se se;
- stmtblock_t init;
-
e = gfc_lval_expr_from_sym (sym);
if (sym->ts.type == BT_CLASS)
- gfc_add_component_ref (e, "$data");
+ gfc_add_data_component (e);
gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
+ if (sym->ts.type != BT_CLASS
+ || sym->ts.u.derived->attr.dimension
+ || sym->ts.u.derived->attr.codimension)
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ }
+ else if (sym->ts.type == BT_CLASS
+ && !CLASS_DATA (sym)->attr.dimension
+ && !CLASS_DATA (sym)->attr.codimension)
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ }
+ else
+ {
+ gfc_conv_expr (&se, e);
+ descriptor = se.expr;
+ se.expr = gfc_conv_descriptor_data_addr (se.expr);
+ se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ }
gfc_free_expr (e);
- /* Nullify when entering the scope. */
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&sym->declared_at);
gfc_start_block (&init);
- gfc_add_modify (&init, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- null_pointer_node));
+
+ 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));
+ }
+
+ if ((sym->attr.dummy ||sym->attr.result)
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred)
+ {
+ /* Character length passed by reference. */
+ tmp = sym->ts.u.cl->passed_length;
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
+
+ if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
+ /* Zero the string length when entering the scope. */
+ 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);
+
+ 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);
+ else
+ tmp = NULL_TREE;
+ }
+ else
+ gfc_restore_backend_locus (&loc);
/* Deallocate when leaving the scope. Nullifying is not
needed. */
- tmp = NULL;
- if (!sym->attr.result)
- tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
- true, NULL);
+ if (!sym->attr.result && !sym->attr.dummy)
+ {
+ if (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.codimension)
+ tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
+ NULL_TREE, NULL_TREE,
+ NULL_TREE, true, NULL,
+ true);
+ else
+ tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
+ true, NULL,
+ sym->ts);
+ }
+ if (sym->ts.type == BT_CLASS)
+ {
+ /* Initialize _vptr to declared type. */
+ gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ tree rhs;
+
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&sym->declared_at);
+ e = gfc_lval_expr_from_sym (sym);
+ gfc_add_vptr_component (e);
+ gfc_init_se (&se, NULL);
+ 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));
+ gfc_add_modify (&init, se.expr, rhs);
+ gfc_restore_backend_locus (&loc);
+ }
+
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
+ else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+ {
+ tree tmp = NULL;
+ stmtblock_t init;
+
+ /* If we get to here, all that should be left are pointers. */
+ gcc_assert (sym->attr.pointer);
+
+ if (sym->attr.dummy)
+ {
+ gfc_start_block (&init);
+
+ /* Character length passed by reference. */
+ tmp = sym->ts.u.cl->passed_length;
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
+ gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
+ /* 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);
+ else
+ tmp = NULL_TREE;
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+ }
+ }
+ else if (sym->ts.deferred)
+ gfc_fatal_error ("Deferred type parameter not yet supported");
else if (sym_has_alloc_comp)
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
- gfc_get_backend_locus (&loc);
+ gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
else
gfc_trans_auto_character_variable (sym, block);
- gfc_set_backend_locus (&loc);
+ gfc_restore_backend_locus (&loc);
}
else if (sym->attr.assign)
{
- gfc_get_backend_locus (&loc);
+ gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_trans_assign_aux_var (sym, block);
- gfc_set_backend_locus (&loc);
+ gfc_restore_backend_locus (&loc);
}
else if (sym->ts.type == BT_DERIVED
&& sym->value
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 (DECL_FILE_SCOPE_P (decl));
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);
/* 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);
rest_of_decl_compilation (length, 1, 0);
}
}
+
+ if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
+ && sym->attr.referenced && !sym->attr.use_assoc)
+ has_coarray_vars = true;
}
/* Emit debug information for USE statements. */
st = gfc_find_symtree (ns->sym_root,
rent->local_name[0]
? rent->local_name : rent->use_name);
- gcc_assert (st);
+
+ /* The following can happen if a derived type is renamed. */
+ if (!st)
+ {
+ char *name;
+ name = xstrdup (rent->local_name[0]
+ ? rent->local_name : rent->use_name);
+ name[0] = (char) TOUPPER ((unsigned char) name[0]);
+ st = gfc_find_symtree (ns->sym_root, name);
+ free (name);
+ gcc_assert (st);
+ }
/* Sometimes, generic interfaces wind up being over-ruled by a
local symbol (see PR41062). */
sym->attr.dimension, false))
return;
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+ return;
+
/* Create the decl for the variable or constant. */
decl = build_decl (input_location,
sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
debug_hooks->global_decl (decl);
}
+
+static void
+generate_coarray_sym_init (gfc_symbol *sym)
+{
+ tree tmp, size, decl, token;
+
+ if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
+ || sym->attr.use_assoc || !sym->attr.referenced)
+ return;
+
+ decl = sym->backend_decl;
+ TREE_USED(decl) = 1;
+ gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
+
+ /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
+ to make sure the variable is not optimized away. */
+ DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
+
+ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
+
+ /* 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));
+
+ if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
+ {
+ tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
+ size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, tmp), size);
+ }
+
+ gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
+ token = gfc_build_addr_expr (ppvoid_type_node,
+ GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_STATIC), /* type. */
+ 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));
+
+
+ /* Handle "static" initializer. */
+ if (sym->value)
+ {
+ sym->attr.pointer = 1;
+ tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
+ true, false);
+ sym->attr.pointer = 0;
+ gfc_add_expr_to_block (&caf_init_block, tmp);
+ }
+}
+
+
+/* Generate constructor function to initialize static, nonallocatable
+ coarrays. */
+
+static void
+generate_coarray_init (gfc_namespace * ns __attribute((unused)))
+{
+ tree fndecl, tmp, decl, save_fn_decl;
+
+ save_fn_decl = current_function_decl;
+ push_function_context ();
+
+ tmp = build_function_type_list (void_type_node, NULL_TREE);
+ fndecl = build_decl (input_location, FUNCTION_DECL,
+ create_tmp_var_name ("_caf_init"), tmp);
+
+ DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
+ SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
+
+ decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 1;
+ DECL_CONTEXT (decl) = fndecl;
+ DECL_RESULT (fndecl) = decl;
+
+ pushdecl (fndecl);
+ current_function_decl = fndecl;
+ announce_function (fndecl);
+
+ rest_of_decl_compilation (fndecl, 0, 0);
+ make_decl_rtl (fndecl);
+ init_function_start (fndecl);
+
+ pushlevel (0);
+ gfc_init_block (&caf_init_block);
+
+ gfc_traverse_ns (ns, generate_coarray_sym_init);
+
+ DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
+ 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));
+ dump_function (TDI_original, fndecl);
+
+ cfun->function_end_locus = input_location;
+ set_cfun (NULL);
+
+ if (decl_function_context (fndecl))
+ (void) cgraph_create_node (fndecl);
+ else
+ cgraph_finalize_function (fndecl, true);
+
+ pop_function_context ();
+ current_function_decl = save_fn_decl;
+}
+
+
/* Generate all the required code for module variables. */
void
/* Generate COMMON blocks. */
gfc_trans_common (ns);
+ has_coarray_vars = false;
+
/* Create decls for all the module variables. */
gfc_traverse_ns (ns, gfc_create_module_variable);
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+ generate_coarray_init (ns);
+
cur_module = NULL;
gfc_trans_use_stmts (ns);
{
if (sym->attr.flavor == FL_VARIABLE)
{
+ if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
+ && sym->attr.referenced && !sym->attr.use_assoc)
+ has_coarray_vars = true;
+
if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
generate_dependency_declarations (sym);
"declared INTENT(OUT) but was not set and "
"does not have a default initializer",
sym->name, &sym->declared_at);
+ if (sym->backend_decl != NULL_TREE)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
}
else if (gfc_option.warn_unused_dummy_argument)
- gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
+ {
+ gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
&sym->declared_at);
+ if (sym->backend_decl != NULL_TREE)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
+ }
}
/* Warn for unused variables, but not if they're inside a common
- block or are use-associated. */
+ block, a namelist, or are use-associated. */
else if (warn_unused_variable
- && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
- gfc_warning ("Unused variable '%s' declared at %L", sym->name,
- &sym->declared_at);
+ && !(sym->attr.in_common || sym->attr.use_assoc || 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;
+ }
/* For variable length CHARACTER parameters, the PARM_DECL already
references the length variable, so force gfc_get_symbol_decl
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)
- TREE_NO_WARNING(sym->backend_decl) = 1;
}
else if (sym->attr.flavor == FL_PARAMETER)
{
if (warn_unused_parameter
- && !sym->attr.referenced
- && !sym->attr.use_assoc)
- gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
- &sym->declared_at);
+ && !sym->attr.referenced)
+ {
+ if (!sym->attr.use_assoc)
+ gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
+ &sym->declared_at);
+ else if (sym->attr.use_only)
+ gfc_warning ("Unused parameter '%s' which has been explicitly "
+ "imported at %L", sym->name, &sym->declared_at);
+ }
}
else if (sym->attr.flavor == FL_PROCEDURE)
{
/* Add the case label. */
label = gfc_build_label_decl (NULL_TREE);
val = build_int_cst (gfc_array_index_type, el->id);
- tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
+ tmp = build_case_label (val, NULL_TREE, label);
gfc_add_expr_to_block (&block, tmp);
/* And jump to the actual entry point. */
gfc_formal_arglist *formal;
for (formal = sym->formal; formal; formal = formal->next)
- if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
+ if (formal->sym && formal->sym->ts.type == BT_CHARACTER
+ && !formal->sym->ts.deferred)
{
enum tree_code comparison;
tree cond;
not_0length = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
cl->passed_length,
- fold_convert (gfc_charlen_type_node,
- integer_zero_node));
+ build_zero_cst (gfc_charlen_type_node));
/* The symbol needs to be referenced for gfc_get_symbol_decl. */
fsym->attr.referenced = 1;
not_absent = gfc_conv_expr_present (fsym);
}
+/* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
+ global variables for -fcoarray=lib. They are placed into the translation
+ unit of the main program. Make sure that in one TU (the one of the main
+ program), the first call to gfc_init_coarray_decl is done with true.
+ Otherwise, expect link errors. */
+
+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
+ = build_decl (input_location, VAR_DECL,
+ get_identifier (PREFIX("caf_this_image")),
+ integer_type_node);
+ DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
+ TREE_USED (gfort_gvar_caf_this_image) = 1;
+ TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
+ TREE_READONLY (gfort_gvar_caf_this_image) = 0;
+
+ if (main_tu)
+ TREE_STATIC (gfort_gvar_caf_this_image) = 1;
+ else
+ DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
+
+ pushdecl_top_level (gfort_gvar_caf_this_image);
+
+ gfort_gvar_caf_num_images
+ = build_decl (input_location, VAR_DECL,
+ get_identifier (PREFIX("caf_num_images")),
+ integer_type_node);
+ DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
+ TREE_USED (gfort_gvar_caf_num_images) = 1;
+ TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
+ TREE_READONLY (gfort_gvar_caf_num_images) = 0;
+
+ if (main_tu)
+ TREE_STATIC (gfort_gvar_caf_num_images) = 1;
+ else
+ DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
+
+ pushdecl_top_level (gfort_gvar_caf_num_images);
+
+ pop_cfun ();
+ current_function_decl = save_fn_decl;
+}
+
+
static void
create_main_function (tree fndecl)
{
/* Call some libgfortran initialization routines, call then MAIN__(). */
+ /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree pint_type, pppchar_type;
+ pint_type = build_pointer_type (integer_type_node);
+ pppchar_type
+ = build_pointer_type (build_pointer_type (pchar_type_node));
+
+ gfc_init_coarray_decl (true);
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
+ gfc_build_addr_expr (pint_type, argc),
+ gfc_build_addr_expr (pppchar_type, argv),
+ gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
+ gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
/* Call _gfortran_set_args (argc, argv). */
TREE_USED (argc) = 1;
TREE_USED (argv) = 1;
gfc_option.allow_std));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node, pedantic));
+ /* TODO: This is the old -fdump-core option, which is unused but
+ passed due to ABI compatibility; remove when bumping the
+ library ABI. */
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node,
- gfc_option.flag_dump_core));
+ 0));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node,
gfc_option.flag_backtrace));
gfc_option.flag_range_check));
array_type = build_array_type (integer_type_node,
- build_index_type (build_int_cst (NULL_TREE, 7)));
+ build_index_type (size_int (7)));
array = build_constructor (array_type, v);
TREE_CONSTANT (array) = 1;
TREE_STATIC (array) = 1;
/* Mark MAIN__ as used. */
TREE_USED (fndecl) = 1;
+ /* 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. */
+ tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
+ tmp = build_call_expr_loc (input_location, tmp, 0);
+ gfc_add_expr_to_block (&body, tmp);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
/* "return 0". */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
DECL_RESULT (ftn_main),
nonlocal_dummy_decls = NULL;
nonlocal_dummy_decl_pset = NULL;
+ has_coarray_vars = false;
generate_local_vars (ns);
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+ generate_coarray_init (ns);
+
/* Keep the parent fake result declaration in module functions
or external procedures. */
if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
gfc_trans_runtime_check (true, false, recurcheckvar, &init,
&sym->declared_at, msg);
gfc_add_modify (&init, recurcheckvar, boolean_true_node);
- gfc_free (msg);
+ free (msg);
}
/* Now generate the code for the body of this function. */
{
tree result = get_proc_result (sym);
- 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)
+ if (sym->attr.allocatable && sym->attr.dimension == 0
+ && sym->result == sym)
+ gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
+ null_pointer_node));
+ else if (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.allocatable
+ && CLASS_DATA (sym)->attr.dimension == 0
+ && sym->result == sym)
+ {
+ tmp = CLASS_DATA (sym)->backend_decl;
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (tmp), result, tmp, NULL_TREE);
+ gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
+ else if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp
+ && !sym->attr.allocatable)
{
rank = sym->as ? sym->as->rank : 0;
tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
gfc_add_expr_to_block (&init, tmp);
}
- else if (sym->attr.allocatable && sym->attr.dimension == 0)
- gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
- null_pointer_node));
}
if (result == NULL_TREE)
{
/* TODO: move to the appropriate place in resolve.c. */
- if (warn_return_type && !sym->attr.referenced && sym == sym->result)
+ if (warn_return_type && sym == sym->result)
gfc_warning ("Return value of function '%s' at %L not set",
sym->name, &sym->declared_at);
-
- TREE_NO_WARNING(sym->backend_decl) = 1;
+ if (warn_return_type)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
}
else
gfc_add_expr_to_block (&body, gfc_generate_return ());
/* Reset recursion-check variable. */
if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
&& !is_recursive
- && !gfc_option.flag_openmp
+ && !gfc_option.gfc_flag_openmp
&& recurcheckvar != NULL_TREE)
{
gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
next = DECL_CHAIN (decl);
DECL_CHAIN (decl) = NULL_TREE;
- pushdecl (decl);
+ if (GFC_DECL_PUSH_TOPLEVEL (decl))
+ pushdecl_top_level (decl);
+ else
+ pushdecl (decl);
decl = next;
}
saved_function_decls = NULL_TREE;
}
current_function_decl = old_context;
- if (decl_function_context (fndecl))
+ 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. */
- (void) cgraph_node (fndecl);
+ 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);
else
cgraph_finalize_function (fndecl, true);
/* Process the local variables of a BLOCK construct. */
void
-gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
+gfc_process_block_locals (gfc_namespace* ns)
{
tree decl;
gcc_assert (saved_local_decls == NULL_TREE);
+ has_coarray_vars = false;
+
generate_local_vars (ns);
- /* Mark associate names to be initialized. The symbol's namespace may not
- be the BLOCK's, we have to force this so that the deferring
- works as expected. */
- for (; assoc; assoc = assoc->next)
- {
- assoc->st->n.sym->ns = ns;
- gfc_defer_symbol_init (assoc->st->n.sym);
- }
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+ generate_coarray_init (ns);
decl = saved_local_decls;
while (decl)
OSDN Git Service
