blob: 7da1d2ebdcf14172e880b7b15d97416cd7f64a51 [file] [log] [blame]
/* Backend function setup
Copyright (C) 2002-2021 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* trans-decl.c -- Handling of backend function and variable decls, etc */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "target.h"
#include "function.h"
#include "tree.h"
#include "gfortran.h"
#include "gimple-expr.h" /* For create_tmp_var_raw. */
#include "trans.h"
#include "stringpool.h"
#include "cgraph.h"
#include "fold-const.h"
#include "stor-layout.h"
#include "varasm.h"
#include "attribs.h"
#include "dumpfile.h"
#include "toplev.h" /* For announce_function. */
#include "debug.h"
#include "constructor.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "intrinsic.h" /* For gfc_resolve_index_func. */
/* Only for gfc_trans_code. Shouldn't need to include this. */
#include "trans-stmt.h"
#include "gomp-constants.h"
#include "gimplify.h"
#include "omp-general.h"
#include "attr-fnspec.h"
#define MAX_LABEL_VALUE 99999
/* Holds the result of the function if no result variable specified. */
static GTY(()) tree current_fake_result_decl;
static GTY(()) tree parent_fake_result_decl;
/* Holds the variable DECLs for the current function. */
static GTY(()) tree saved_function_decls;
static GTY(()) tree saved_parent_function_decls;
/* Holds the variable DECLs that are locals. */
static GTY(()) tree saved_local_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. */
static gfc_namespace *module_namespace;
/* The currently processed procedure symbol. */
static gfc_symbol* current_procedure_symbol = NULL;
/* The currently processed module. */
static struct module_htab_entry *cur_module;
/* 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;
/* Whether we've seen a symbol from an IEEE module in the namespace. */
static int seen_ieee_symbol;
/* Function declarations for builtin library functions. */
tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_error_stop_numeric;
tree gfor_fndecl_error_stop_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at;
tree gfor_fndecl_runtime_warning_at;
tree gfor_fndecl_os_error_at;
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_set_record_marker;
tree gfor_fndecl_set_max_subrecord_length;
tree gfor_fndecl_ctime;
tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
tree gfor_fndecl_cfi_to_gfc;
tree gfor_fndecl_gfc_to_cfi;
tree gfor_fndecl_associated;
tree gfor_fndecl_system_clock4;
tree gfor_fndecl_system_clock8;
tree gfor_fndecl_ieee_procedure_entry;
tree gfor_fndecl_ieee_procedure_exit;
/* Coarray run-time library function decls. */
tree gfor_fndecl_caf_init;
tree gfor_fndecl_caf_finalize;
tree gfor_fndecl_caf_this_image;
tree gfor_fndecl_caf_num_images;
tree gfor_fndecl_caf_register;
tree gfor_fndecl_caf_deregister;
tree gfor_fndecl_caf_get;
tree gfor_fndecl_caf_send;
tree gfor_fndecl_caf_sendget;
tree gfor_fndecl_caf_get_by_ref;
tree gfor_fndecl_caf_send_by_ref;
tree gfor_fndecl_caf_sendget_by_ref;
tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_memory;
tree gfor_fndecl_caf_sync_images;
tree gfor_fndecl_caf_stop_str;
tree gfor_fndecl_caf_stop_numeric;
tree gfor_fndecl_caf_error_stop;
tree gfor_fndecl_caf_error_stop_str;
tree gfor_fndecl_caf_atomic_def;
tree gfor_fndecl_caf_atomic_ref;
tree gfor_fndecl_caf_atomic_cas;
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_caf_lock;
tree gfor_fndecl_caf_unlock;
tree gfor_fndecl_caf_event_post;
tree gfor_fndecl_caf_event_wait;
tree gfor_fndecl_caf_event_query;
tree gfor_fndecl_caf_fail_image;
tree gfor_fndecl_caf_failed_images;
tree gfor_fndecl_caf_image_status;
tree gfor_fndecl_caf_stopped_images;
tree gfor_fndecl_caf_form_team;
tree gfor_fndecl_caf_change_team;
tree gfor_fndecl_caf_end_team;
tree gfor_fndecl_caf_sync_team;
tree gfor_fndecl_caf_get_team;
tree gfor_fndecl_caf_team_number;
tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
tree gfor_fndecl_co_reduce;
tree gfor_fndecl_co_sum;
tree gfor_fndecl_caf_is_present;
tree gfor_fndecl_caf_random_init;
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */
gfc_powdecl_list gfor_fndecl_math_powi[4][3];
tree gfor_fndecl_math_ishftc4;
tree gfor_fndecl_math_ishftc8;
tree gfor_fndecl_math_ishftc16;
/* String functions. */
tree gfor_fndecl_compare_string;
tree gfor_fndecl_concat_string;
tree gfor_fndecl_string_len_trim;
tree gfor_fndecl_string_index;
tree gfor_fndecl_string_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
tree gfor_fndecl_string_minmax;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
tree gfor_fndecl_select_string;
tree gfor_fndecl_compare_string_char4;
tree gfor_fndecl_concat_string_char4;
tree gfor_fndecl_string_len_trim_char4;
tree gfor_fndecl_string_index_char4;
tree gfor_fndecl_string_scan_char4;
tree gfor_fndecl_string_verify_char4;
tree gfor_fndecl_string_trim_char4;
tree gfor_fndecl_string_minmax_char4;
tree gfor_fndecl_adjustl_char4;
tree gfor_fndecl_adjustr_char4;
tree gfor_fndecl_select_string_char4;
/* Conversion between character kinds. */
tree gfor_fndecl_convert_char1_to_char4;
tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
tree gfor_fndecl_iargc;
tree gfor_fndecl_kill;
tree gfor_fndecl_kill_sub;
tree gfor_fndecl_is_contiguous0;
/* Intrinsic functions implemented in Fortran. */
tree gfor_fndecl_sc_kind;
tree gfor_fndecl_si_kind;
tree gfor_fndecl_sr_kind;
/* BLAS gemm functions. */
tree gfor_fndecl_sgemm;
tree gfor_fndecl_dgemm;
tree gfor_fndecl_cgemm;
tree gfor_fndecl_zgemm;
/* RANDOM_INIT function. */
tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */
static void
gfc_add_decl_to_parent_function (tree decl)
{
gcc_assert (decl);
DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
DECL_NONLOCAL (decl) = 1;
DECL_CHAIN (decl) = saved_parent_function_decls;
saved_parent_function_decls = decl;
}
void
gfc_add_decl_to_function (tree decl)
{
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
DECL_CHAIN (decl) = saved_function_decls;
saved_function_decls = decl;
}
static void
add_decl_as_local (tree decl)
{
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
DECL_CHAIN (decl) = saved_local_decls;
saved_local_decls = decl;
}
/* Build a backend label declaration. Set TREE_USED for named labels.
The context of the label is always the current_function_decl. All
labels are marked artificial. */
tree
gfc_build_label_decl (tree label_id)
{
/* 2^32 temporaries should be enough. */
static unsigned int tmp_num = 1;
tree label_decl;
char *label_name;
if (label_id == NULL_TREE)
{
/* Build an internal label name. */
ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
label_id = get_identifier (label_name);
}
else
label_name = NULL;
/* Build the LABEL_DECL node. Labels have no type. */
label_decl = build_decl (input_location,
LABEL_DECL, label_id, void_type_node);
DECL_CONTEXT (label_decl) = current_function_decl;
SET_DECL_MODE (label_decl, VOIDmode);
/* We always define the label as used, even if the original source
file never references the label. We don't want all kinds of
spurious warnings for old-style Fortran code with too many
labels. */
TREE_USED (label_decl) = 1;
DECL_ARTIFICIAL (label_decl) = 1;
return label_decl;
}
/* Set the backend source location of a decl. */
void
gfc_set_decl_location (tree decl, locus * loc)
{
DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc);
}
/* Return the backend label declaration for a given label structure,
or create it if it doesn't exist yet. */
tree
gfc_get_label_decl (gfc_st_label * lp)
{
if (lp->backend_decl)
return lp->backend_decl;
else
{
char label_name[GFC_MAX_SYMBOL_LEN + 1];
tree label_decl;
/* Validate the label declaration from the front end. */
gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
/* Build a mangled name for the label. */
sprintf (label_name, "__label_%.6d", lp->value);
/* Build the LABEL_DECL node. */
label_decl = gfc_build_label_decl (get_identifier (label_name));
/* Tell the debugger where the label came from. */
if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
gfc_set_decl_location (label_decl, &lp->where);
else
DECL_ARTIFICIAL (label_decl) = 1;
/* Store the label in the label list and return the LABEL_DECL. */
lp->backend_decl = label_decl;
return label_decl;
}
}
/* Return the name of an identifier. */
static const char *
sym_identifier (gfc_symbol *sym)
{
if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
return "MAIN__";
else
return sym->name;
}
/* Convert a gfc_symbol to an identifier of the same name. */
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
return get_identifier (sym_identifier (sym));
}
/* Construct mangled name from symbol name. */
static const char *
mangled_identifier (gfc_symbol *sym)
{
gfc_symbol *proc = sym->ns->proc_name;
static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14];
/* Prevent the mangling of identifiers that have an assigned
binding label (mainly those that are bind(c)). */
if (sym->attr.is_bind_c == 1 && sym->binding_label)
return sym->binding_label;
if (!sym->fn_result_spec
|| (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE)))
{
if (sym->module == NULL)
return sym_identifier (sym);
else
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
}
else
{
/* This is an entity that is actually local to a module procedure
that appears in the result specification expression. Since
sym->module will be a zero length string, we use ns->proc_name
to provide the module name instead. */
if (proc && proc->module)
snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s",
proc->module, proc->name, sym->name);
else
snprintf (name, sizeof name, "__%s_PROC_%s",
proc->name, sym->name);
}
return name;
}
/* Get mangled identifier, adding the symbol to the global table if
it is not yet already there. */
static tree
gfc_sym_mangled_identifier (gfc_symbol * sym)
{
tree result;
gfc_gsymbol *gsym;
const char *name;
name = mangled_identifier (sym);
result = get_identifier (name);
gsym = gfc_find_gsymbol (gfc_gsym_root, name);
if (gsym == NULL)
{
gsym = gfc_get_gsymbol (name, false);
gsym->ns = sym->ns;
gsym->sym_name = sym->name;
}
return result;
}
/* Construct mangled function name from symbol name. */
static tree
gfc_sym_mangled_function_id (gfc_symbol * sym)
{
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
/* It may be possible to simply use the binding label if it's
provided, and remove the other checks. Then we could use it
for other things if we wished. */
if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
sym->binding_label)
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
&& !sym->attr.module_procedure)
{
/* Main program is mangled into MAIN__. */
if (sym->attr.is_main_program)
return get_identifier ("MAIN__");
/* Intrinsic procedures are never mangled. */
if (sym->attr.proc == PROC_INTRINSIC)
return get_identifier (sym->name);
if (flag_underscoring)
{
has_underscore = strchr (sym->name, '_') != 0;
if (flag_second_underscore && has_underscore)
snprintf (name, sizeof name, "%s__", sym->name);
else
snprintf (name, sizeof name, "%s_", sym->name);
return get_identifier (name);
}
else
return get_identifier (sym->name);
}
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
return get_identifier (name);
}
}
void
gfc_set_decl_assembler_name (tree decl, tree name)
{
tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
}
/* Returns true if a variable of specified size should go on the stack. */
int
gfc_can_put_var_on_stack (tree size)
{
unsigned HOST_WIDE_INT low;
if (!INTEGER_CST_P (size))
return 0;
if (flag_max_stack_var_size < 0)
return 1;
if (!tree_fits_uhwi_p (size))
return 0;
low = TREE_INT_CST_LOW (size);
if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size)
return 0;
/* TODO: Set a per-function stack size limit. */
return 1;
}
/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
an expression involving its corresponding pointer. There are
2 cases; one for variable size arrays, and one for everything else,
because variable-sized arrays require one fewer level of
indirection. */
static void
gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
{
tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
tree value;
/* Parameters need to be dereferenced. */
if (sym->cp_pointer->attr.dummy)
ptr_decl = build_fold_indirect_ref_loc (input_location,
ptr_decl);
/* Check to see if we're dealing with a variable-sized array. */
if (sym->attr.dimension
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
{
/* These decls will be dereferenced later, so we don't dereference
them here. */
value = convert (TREE_TYPE (decl), ptr_decl);
}
else
{
ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
ptr_decl);
value = build_fold_indirect_ref_loc (input_location,
ptr_decl);
}
SET_DECL_VALUE_EXPR (decl, value);
DECL_HAS_VALUE_EXPR_P (decl) = 1;
GFC_DECL_CRAY_POINTEE (decl) = 1;
}
/* Finish processing of a declaration without an initial value. */
static void
gfc_finish_decl (tree decl)
{
gcc_assert (TREE_CODE (decl) == PARM_DECL
|| DECL_INITIAL (decl) == NULL_TREE);
if (!VAR_P (decl))
return;
if (DECL_SIZE (decl) == NULL_TREE
&& TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
layout_decl (decl, 0);
/* A few consistency checks. */
/* A static variable with an incomplete type is an error if it is
initialized. Also if it is not file scope. Otherwise, let it
through, but if it is not `extern' then it may cause an error
message later. */
/* An automatic variable with an incomplete type is an error. */
/* We should know the storage size. */
gcc_assert (DECL_SIZE (decl) != NULL_TREE
|| (TREE_STATIC (decl)
? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
: DECL_EXTERNAL (decl)));
/* The storage size should be constant. */
gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
|| !DECL_SIZE (decl)
|| TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
}
/* Handle setting of GFC_DECL_SCALAR* on DECL. */
void
gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
{
if (!attr->dimension && !attr->codimension)
{
/* Handle scalar allocatable variables. */
if (attr->allocatable)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
}
/* Handle scalar pointer variables. */
if (attr->pointer)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_SCALAR_POINTER (decl) = 1;
}
if (attr->target)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_SCALAR_TARGET (decl) = 1;
}
}
}
/* Apply symbol attributes to a variable, and add it to the function scope. */
static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
tree new_type;
/* Set DECL_VALUE_EXPR for Cray Pointees. */
if (sym->attr.cray_pointee)
gfc_finish_cray_pointee (decl, sym);
/* TREE_ADDRESSABLE means the address of this variable is actually needed.
This is the equivalent of the TARGET variables.
We also need to set this if the variable is passed by reference in a
CALL statement. */
if (sym->attr.target)
TREE_ADDRESSABLE (decl) = 1;
/* 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. */
if (current_function_decl != NULL_TREE)
{
if (sym->ns->proc_name
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| sym->result == sym))
gfc_add_decl_to_function (decl);
else if (sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_LABEL)
/* This is a BLOCK construct. */
add_decl_as_local (decl);
else
gfc_add_decl_to_parent_function (decl);
}
if (sym->attr.cray_pointee)
return;
if(sym->attr.is_bind_c == 1 && sym->binding_label)
{
/* We need to put variables that are bind(c) into the common
segment of the object file, because this is what C would do.
gfortran would typically put them in either the BSS or
initialized data segments, and only mark them as common if
they were part of common blocks. However, if they are not put
into common space, then C cannot initialize global Fortran
variables that it interoperates with and the draft says that
either Fortran or C should be able to initialize it (but not
both, of course.) (J3/04-007, section 15.3). */
TREE_PUBLIC(decl) = 1;
DECL_COMMON(decl) = 1;
if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
{
DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
DECL_VISIBILITY_SPECIFIED (decl) = true;
}
}
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc || sym->attr.used_in_submodule)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
}
else if (sym->fn_result_spec && !sym->ns->proc_name->module)
{
if (sym->ns->proc_name->attr.if_source != IFSRC_DECL)
DECL_EXTERNAL (decl) = 1;
else
TREE_STATIC (decl) = 1;
TREE_PUBLIC (decl) = 1;
}
else if (sym->module && !sym->attr.result && !sym->attr.dummy)
{
/* TODO: Don't set sym->module for result or dummy variables. */
gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
{
DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
DECL_VISIBILITY_SPECIFIED (decl) = true;
}
}
/* Derived types are a bit peculiar because of the possibility of
a default initializer; this must be applied each time the variable
comes into scope it therefore need not be static. These variables
are SAVE_NONE but have an initializer. Otherwise explicitly
initialized variables are SAVE_IMPLICIT and explicitly saved are
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)
|| (flag_coarray == GFC_FCOARRAY_LIB
&& sym->attr.codimension && !sym->attr.allocatable)))
TREE_STATIC (decl) = 1;
/* If derived-type variables with DTIO procedures are not made static
some bits of code referencing them get optimized away.
TODO Understand why this is so and fix it. */
if (!sym->attr.use_assoc
&& ((sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.has_dtio_procs)
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
/* Treat asynchronous variables the same as volatile, for now. */
if (sym->attr.volatile_ || sym->attr.asynchronous)
{
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;
}
/* Keep variables larger than max-stack-var-size off stack. */
if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive)
&& !sym->attr.automatic
&& sym->attr.save != SAVE_EXPLICIT
&& sym->attr.save != SAVE_IMPLICIT
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
/* Put variable length auto array pointers always into stack. */
&& (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
|| sym->attr.dimension == 0
|| sym->as->type != AS_EXPLICIT
|| sym->attr.pointer
|| sym->attr.allocatable)
&& !DECL_ARTIFICIAL (decl))
{
if (flag_max_stack_var_size > 0
&& !(sym->ns->proc_name
&& sym->ns->proc_name->attr.is_main_program))
gfc_warning (OPT_Wsurprising,
"Array %qs at %L is larger than limit set by "
"%<-fmax-stack-var-size=%>, moved from stack to static "
"storage. This makes the procedure unsafe when called "
"recursively, or concurrently from multiple threads. "
"Consider increasing the %<-fmax-stack-var-size=%> "
"limit (or use %<-frecursive%>, which implies "
"unlimited %<-fmax-stack-var-size%>) - or change the "
"code to use an ALLOCATABLE array. If the variable is "
"never accessed concurrently, this warning can be "
"ignored, and the variable could also be declared with "
"the SAVE attribute.",
sym->name, &sym->declared_at);
TREE_STATIC (decl) = 1;
/* Because the size of this variable isn't known until now, we may have
greedily added an initializer to this variable (in build_init_assign)
even though the max-stack-var-size indicates the variable should be
static. Therefore we rip out the automatic initializer here and
replace it with a static one. */
gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
gfc_code *prev = NULL;
gfc_code *code = sym->ns->code;
while (code && code->op == EXEC_INIT_ASSIGN)
{
/* Look for an initializer meant for this symbol. */
if (code->expr1->symtree == st)
{
if (prev)
prev->next = code->next;
else
sym->ns->code = code->next;
break;
}
prev = code;
code = code->next;
}
if (code && code->op == EXEC_INIT_ASSIGN)
{
/* Keep the init expression for a static initializer. */
sym->value = code->expr2;
/* Cleanup the defunct code object, without freeing the init expr. */
code->expr2 = NULL;
gfc_free_statement (code);
free (code);
}
}
/* Handle threadprivate variables. */
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
set_decl_tls_model (decl, decl_default_tls_model (decl));
gfc_finish_decl_attrs (decl, &sym->attr);
}
/* Allocate the lang-specific part of a decl. */
void
gfc_allocate_lang_decl (tree decl)
{
if (DECL_LANG_SPECIFIC (decl) == NULL)
DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
}
/* Remember a symbol to generate initialization/cleanup code at function
entry/exit. */
static void
gfc_defer_symbol_init (gfc_symbol * sym)
{
gfc_symbol *p;
gfc_symbol *last;
gfc_symbol *head;
/* Don't add a symbol twice. */
if (sym->tlink)
return;
last = head = sym->ns->proc_name;
p = last->tlink;
/* Make sure that setup code for dummy variables which are used in the
setup of other variables is generated first. */
if (sym->attr.dummy)
{
/* Find the first dummy arg seen after us, or the first non-dummy arg.
This is a circular list, so don't go past the head. */
while (p != head
&& (!p->attr.dummy || p->dummy_order > sym->dummy_order))
{
last = p;
p = p->tlink;
}
}
/* Insert in between last and p. */
last->tlink = sym;
sym->tlink = p;
}
/* 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;
/* Check for a symbol with the same name. */
if (gsym)
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
if (!s)
{
if (!gsym)
{
gsym = gfc_get_gsymbol (sym->module, false);
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 (gfc_fl_struct (sym->attr.flavor))
{
if (s && s->attr.flavor == FL_PROCEDURE)
{
gfc_interface *intr;
gcc_assert (s->attr.generic);
for (intr = s->generic; intr; intr = intr->next)
if (gfc_fl_struct (intr->sym->attr.flavor))
{
s = intr->sym;
break;
}
}
/* Normally we can assume that s is a derived-type symbol since it
shares a name with the derived-type sym. However if sym is a
STRUCTURE, it may in fact share a name with any other basic type
variable. If s is in fact of derived type then we can continue
looking for a duplicate type declaration. */
if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED)
{
s = s->ts.u.derived;
}
if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl)
{
if (s->attr.flavor == FL_UNION)
s->backend_decl = gfc_get_union_type (s);
else
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
create_index_var (const char * pfx, int nest)
{
tree decl;
decl = gfc_create_var_np (gfc_array_index_type, pfx);
if (nest)
gfc_add_decl_to_parent_function (decl);
else
gfc_add_decl_to_function (decl);
return decl;
}
/* Create variables to hold all the non-constant bits of info for a
descriptorless array. Remember these in the lang-specific part of the
type. */
static void
gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
tree type;
int dim;
int nest;
gfc_namespace* procns;
symbol_attribute *array_attr;
gfc_array_spec *as;
bool is_classarray = IS_CLASS_ARRAY (sym);
type = TREE_TYPE (decl);
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
/* We just use the descriptor, if there is one. */
if (GFC_DESCRIPTOR_TYPE_P (type))
return;
gcc_assert (GFC_ARRAY_TYPE_P (type));
procns = gfc_find_proc_namespace (sym->ns);
nest = (procns->proc_name->backend_decl != current_function_decl)
&& !sym->attr.contained;
if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
&& as->type != AS_ASSUMED_SHAPE
&& GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
{
tree token;
tree token_type = build_qualified_type (pvoid_type_node,
TYPE_QUAL_RESTRICT);
if (sym->module && (sym->attr.use_assoc
|| sym->ns->proc_name->attr.flavor == FL_MODULE))
{
tree token_name
= get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym))));
token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name,
token_type);
if (sym->attr.use_assoc)
DECL_EXTERNAL (token) = 1;
else
TREE_STATIC (token) = 1;
TREE_PUBLIC (token) = 1;
if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
{
DECL_VISIBILITY (token) = VISIBILITY_HIDDEN;
DECL_VISIBILITY_SPECIFIED (token) = true;
}
}
else
{
token = gfc_create_var_np (token_type, "caf_token");
TREE_STATIC (token) = 1;
}
GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
DECL_ARTIFICIAL (token) = 1;
DECL_NONALIASED (token) = 1;
if (sym->module && !sym->attr.use_assoc)
{
pushdecl (token);
DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl;
gfc_module_add_decl (cur_module, token);
}
else if (sym->attr.host_assoc
&& TREE_CODE (DECL_CONTEXT (current_function_decl))
!= TRANSLATION_UNIT_DECL)
gfc_add_decl_to_parent_function (token);
else
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)
{
GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
}
/* Don't try to use the unknown bound for assumed shape arrays. */
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
&& (as->type != AS_ASSUMED_SIZE
|| dim < GFC_TYPE_ARRAY_RANK (type) - 1))
{
GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
}
if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
{
GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim));
}
}
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);
suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
}
/* 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);
suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
}
}
if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
"offset");
suppress_warning (GFC_TYPE_ARRAY_OFFSET (type));
if (nest)
gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
else
gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
}
if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
&& as->type != AS_ASSUMED_SIZE)
{
GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
suppress_warning (GFC_TYPE_ARRAY_SIZE (type));
}
if (POINTER_TYPE_P (type))
{
gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
gcc_assert (TYPE_LANG_SPECIFIC (type)
== TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
type = TREE_TYPE (type);
}
if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
{
tree size, range;
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
size);
TYPE_DOMAIN (type) = range;
layout_type (type);
}
if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
&& GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
&& VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
{
tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
for (dim = 0; dim < 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 = as->rank - 1; dim >= 0; 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.
For -O1 and above they often will be optimized out, but
can be tracked by VTA. Also set DECL_NAMELESS, so that
the artificial lbound.N or ubound.N DECL_NAME doesn't
end up in debug info. */
if (lbound
&& VAR_P (lbound)
&& DECL_ARTIFICIAL (lbound)
&& DECL_IGNORED_P (lbound))
{
if (DECL_NAME (lbound)
&& strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
"lbound") != 0)
DECL_NAMELESS (lbound) = 1;
DECL_IGNORED_P (lbound) = 0;
}
if (ubound
&& VAR_P (ubound)
&& DECL_ARTIFICIAL (ubound)
&& DECL_IGNORED_P (ubound))
{
if (DECL_NAME (ubound)
&& strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
"ubound") != 0)
DECL_NAMELESS (ubound) = 1;
DECL_IGNORED_P (ubound) = 0;
}
}
TYPE_NAME (type) = type_decl = build_decl (input_location,
TYPE_DECL, NULL, gtype);
DECL_ORIGINAL_TYPE (type_decl) = gtype;
}
}
/* For some dummy arguments we don't use the actual argument directly.
Instead we create a local decl and use that. This allows us to perform
initialization, and construct full type information. */
static tree
gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
{
tree decl;
tree type;
gfc_array_spec *as;
symbol_attribute *array_attr;
char *name;
gfc_packed packed;
int n;
bool known_size;
bool is_classarray = IS_CLASS_ARRAY (sym);
/* Use the array as and attr. */
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
/* The dummy is returned for pointer, allocatable or assumed rank arrays.
For class arrays the information if sym is an allocatable or pointer
object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
too many reasons to be of use here). */
if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
|| array_attr->allocatable
|| (as && as->type == AS_ASSUMED_RANK))
return dummy;
/* Add to list of variables if not a fake result variable.
These symbols are set on the symbol only, not on the class component. */
if (sym->attr.result || sym->attr.dummy)
gfc_defer_symbol_init (sym);
/* For a class array the array descriptor is in the _data component, while
for a regular array the TREE_TYPE of the dummy is a pointer to the
descriptor. */
type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy)
: TREE_TYPE (dummy));
/* type now is the array descriptor w/o any indirection. */
gcc_assert (TREE_CODE (dummy) == PARM_DECL
&& POINTER_TYPE_P (TREE_TYPE (dummy)));
/* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER
|| INTEGER_CST_P (sym->ts.u.cl->backend_decl);
if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
{
/* For descriptorless arrays with known element size the actual
argument is sufficient. */
gfc_build_qualified_array (dummy, sym);
return dummy;
}
if (GFC_DESCRIPTOR_TYPE_P (type))
{
/* Create a descriptorless array pointer. */
packed = PACKED_NO;
/* Even when -frepack-arrays is used, symbols with TARGET attribute
are not repacked. */
if (!flag_repack_arrays || sym->attr.target)
{
if (as->type == AS_ASSUMED_SIZE)
packed = PACKED_FULL;
}
else
{
if (as->type == AS_EXPLICIT)
{
packed = PACKED_FULL;
for (n = 0; n < as->rank; n++)
{
if (!(as->upper[n]
&& as->lower[n]
&& as->upper[n]->expr_type == EXPR_CONSTANT
&& as->lower[n]->expr_type == EXPR_CONSTANT))
{
packed = PACKED_PARTIAL;
break;
}
}
}
else
packed = PACKED_PARTIAL;
}
/* For classarrays the element type is required, but
gfc_typenode_for_spec () returns the array descriptor. */
type = is_classarray ? gfc_get_element_type (type)
: gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, as, packed,
!sym->attr.target);
}
else
{
/* We now have an expression for the element size, so create a fully
qualified type. Reset sym->backend decl or this will just return the
old type. */
DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym);
packed = PACKED_FULL;
}
ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
decl = build_decl (input_location,
VAR_DECL, get_identifier (name), type);
DECL_ARTIFICIAL (decl) = 1;
DECL_NAMELESS (decl) = 1;
TREE_PUBLIC (decl) = 0;
TREE_STATIC (decl) = 0;
DECL_EXTERNAL (decl) = 0;
/* Avoid uninitialized warnings for optional dummy arguments. */
if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
|| sym->attr.optional)
suppress_warning (decl);
/* We should never get deferred shape arrays here. We used to because of
frontend bugs. */
gcc_assert (as->type != AS_DEFERRED);
if (packed == PACKED_PARTIAL)
GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
else if (packed == PACKED_FULL)
GFC_DECL_PACKED_ARRAY (decl) = 1;
gfc_build_qualified_array (decl, sym);
if (DECL_LANG_SPECIFIC (dummy))
DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
else
gfc_allocate_lang_decl (decl);
GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
if (sym->ns->proc_name->backend_decl == current_function_decl
|| sym->attr.contained)
gfc_add_decl_to_function (decl);
else
gfc_add_decl_to_parent_function (decl);
return 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)
{
gcc_assert (sym->ts.u.cl);
gfc_conv_const_charlen (sym->ts.u.cl);
if (sym->ts.u.cl->backend_decl == NULL_TREE)
{
tree length;
const char *name;
/* The string length variable shall be in static memory if it is either
explicitly SAVED, a module variable or with -fno-automatic. Only
relevant is "len=:" - otherwise, it is either a constant length or
it is an automatic variable. */
bool static_length = sym->attr.save
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| (flag_max_stack_var_size == 0
&& sym->ts.deferred && !sym->attr.dummy
&& !sym->attr.result && !sym->attr.function);
/* Also prefix the mangled name. We need to call GFC_PREFIX for static
variables as some systems do not support the "." in the assembler name.
For nonstatic variables, the "." does not appear in assembler. */
if (static_length)
{
if (sym->module)
name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
sym->name);
else
name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
}
else if (sym->module)
name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
else
name = gfc_get_string (".%s", sym->name);
length = build_decl (input_location,
VAR_DECL, get_identifier (name),
gfc_charlen_type_node);
DECL_ARTIFICIAL (length) = 1;
TREE_USED (length) = 1;
if (sym->ns->proc_name->tlink != NULL)
gfc_defer_symbol_init (sym);
sym->ts.u.cl->backend_decl = length;
if (static_length)
TREE_STATIC (length) = 1;
if (sym->ns->proc_name->attr.flavor == FL_MODULE
&& (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
TREE_PUBLIC (length) = 1;
}
gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
return sym->ts.u.cl->backend_decl;
}
/* If a variable is assigned a label, we add another two auxiliary
variables. */
static void
gfc_add_assign_aux_vars (gfc_symbol * sym)
{
tree addr;
tree length;
tree decl;
gcc_assert (sym->backend_decl);
decl = sym->backend_decl;
gfc_allocate_lang_decl (decl);
GFC_DECL_ASSIGN (decl) = 1;
length = build_decl (input_location,
VAR_DECL, create_tmp_var_name (sym->name),
gfc_charlen_type_node);
addr = build_decl (input_location,
VAR_DECL, create_tmp_var_name (sym->name),
pvoid_type_node);
gfc_finish_var_decl (length, sym);
gfc_finish_var_decl (addr, sym);
/* STRING_LENGTH is also used as flag. Less than -1 means that
ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the
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 (gfc_charlen_type_node, -2);
else
gfc_defer_symbol_init (sym);
GFC_DECL_STRING_LEN (decl) = length;
GFC_DECL_ASSIGN_ADDR (decl) = addr;
}
static tree
add_attributes_to_decl (symbol_attribute sym_attr, tree list)
{
unsigned id;
tree attr;
for (id = 0; id < EXT_ATTR_NUM; id++)
if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name)
{
attr = build_tree_list (
get_identifier (ext_attr_list[id].middle_end_name),
NULL_TREE);
list = chainon (list, attr);
}
tree clauses = NULL_TREE;
if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE)
{
omp_clause_code code;
switch (sym_attr.oacc_routine_lop)
{
case OACC_ROUTINE_LOP_GANG:
code = OMP_CLAUSE_GANG;
break;
case OACC_ROUTINE_LOP_WORKER:
code = OMP_CLAUSE_WORKER;
break;
case OACC_ROUTINE_LOP_VECTOR:
code = OMP_CLAUSE_VECTOR;
break;
case OACC_ROUTINE_LOP_SEQ:
code = OMP_CLAUSE_SEQ;
break;
case OACC_ROUTINE_LOP_NONE:
case OACC_ROUTINE_LOP_ERROR:
default:
gcc_unreachable ();
}
tree c = build_omp_clause (UNKNOWN_LOCATION, code);
OMP_CLAUSE_CHAIN (c) = clauses;
clauses = c;
tree dims = oacc_build_routine_dims (clauses);
list = oacc_replace_fn_attrib_attr (list, dims);
}
if (sym_attr.oacc_routine_nohost)
{
tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST);
OMP_CLAUSE_CHAIN (c) = clauses;
clauses = c;
}
if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET)
{
tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
switch (sym_attr.omp_device_type)
{
case OMP_DEVICE_TYPE_HOST:
OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
break;
case OMP_DEVICE_TYPE_NOHOST:
OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
break;
case OMP_DEVICE_TYPE_ANY:
OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
break;
default:
gcc_unreachable ();
}
OMP_CLAUSE_CHAIN (c) = clauses;
clauses = c;
}
if (sym_attr.omp_declare_target_link
|| sym_attr.oacc_declare_link)
list = tree_cons (get_identifier ("omp declare target link"),
clauses, list);
else if (sym_attr.omp_declare_target
|| sym_attr.oacc_declare_create
|| sym_attr.oacc_declare_copyin
|| sym_attr.oacc_declare_deviceptr
|| sym_attr.oacc_declare_device_resident)
list = tree_cons (get_identifier ("omp declare target"),
clauses, list);
return list;
}
static void build_function_decl (gfc_symbol * sym, bool global);
/* Return the decl for a gfc_symbol, create it if it doesn't already
exist. */
tree
gfc_get_symbol_decl (gfc_symbol * sym)
{
tree decl;
tree length = NULL_TREE;
tree attributes;
int byref;
bool intrinsic_array_parameter = false;
bool fun_or_res;
gcc_assert (sym->attr.referenced
|| sym->attr.flavor == FL_PROCEDURE
|| sym->attr.use_assoc
|| sym->attr.used_in_submodule
|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
|| (sym->module && sym->attr.if_source != IFSRC_DECL
&& sym->backend_decl));
if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
else
byref = 0;
/* Make sure that the vtab for the declared type is completed. */
if (sym->ts.type == BT_CLASS)
{
gfc_component *c = CLASS_DATA (sym);
if (!c->ts.u.derived->backend_decl)
{
gfc_find_derived_vtab (c->ts.u.derived);
gfc_get_derived_type (sym->ts.u.derived);
}
}
/* PDT parameterized array components and string_lengths must have the
'len' parameters substituted for the expressions appearing in the
declaration of the entity and memory allocated/deallocated. */
if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
&& sym->param_list != NULL
&& gfc_current_ns == sym->ns
&& !(sym->attr.use_assoc || sym->attr.dummy))
gfc_defer_symbol_init (sym);
/* Dummy PDT 'len' parameters should be checked when they are explicit. */
if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& sym->param_list != NULL
&& sym->attr.dummy)
gfc_defer_symbol_init (sym);
/* 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;
gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)));
sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
}
if (is_CFI_desc (sym, NULL))
gfc_defer_symbol_init (sym);
fun_or_res = byref && (sym->attr.result
|| (sym->attr.function && sym->ts.deferred));
if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
{
/* Return via extra parameter. */
if (sym->attr.result && byref
&& !sym->backend_decl)
{
sym->backend_decl =
DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
/* For entry master function skip over the __entry
argument. */
if (sym->ns->proc_name->attr.entry_master)
sym->backend_decl = DECL_CHAIN (sym->backend_decl);
}
/* Dummy variables should already have been created. */
gcc_assert (sym->backend_decl);
/* However, the string length of deferred arrays must be set. */
if (sym->ts.type == BT_CHARACTER
&& sym->ts.deferred
&& sym->attr.dimension
&& sym->attr.allocatable)
gfc_defer_symbol_init (sym);
if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
/* 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 && byref)
{
/* The string length of a deferred char array is stored in the
parameter at sym->ts.u.cl->backend_decl as a reference and
marked as a result. Exempt this variable from generating a
temporary for it. */
if (sym->attr.result)
{
/* We need to insert a indirect ref for param decls. */
if (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 =
build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
}
}
/* For all other parameters make sure, that they are copied so
that the value and any modifications are local to the routine
by generating a temporary variable. */
else if (sym->attr.function
&& 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;
if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)))
sym->ts.u.cl->backend_decl
= build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
else
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 (VAR_P (length) && DECL_FILE_SCOPE_P (length))
{
/* Add the string length to the same context as the symbol. */
if (DECL_CONTEXT (length) == NULL_TREE)
{
if (sym->backend_decl == current_function_decl
|| (DECL_CONTEXT (sym->backend_decl)
== current_function_decl))
gfc_add_decl_to_function (length);
else
gfc_add_decl_to_parent_function (length);
}
gcc_assert (sym->backend_decl == current_function_decl
? DECL_CONTEXT (length) == current_function_decl
: (DECL_CONTEXT (sym->backend_decl)
== DECL_CONTEXT (length)));
gfc_defer_symbol_init (sym);
}
}
/* Use a copy of the descriptor for dummy arrays. */
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. */
if (sym->backend_decl != NULL && decl != sym->backend_decl)
DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = decl;
}
/* Returning the descriptor for dummy class arrays is hazardous, because
some caller is expecting an expression to apply the component refs to.
Therefore the descriptor is only created and stored in
sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
responsible to extract it from there, when the descriptor is
desired. */
if (IS_CLASS_ARRAY (sym)
&& (!DECL_LANG_SPECIFIC (sym->backend_decl)
|| !GFC_DECL_SAVED_DESCRIPTOR (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. */
if (sym->backend_decl != NULL && decl != sym->backend_decl)
DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = decl;
}
TREE_USED (sym->backend_decl) = 1;
if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
gfc_add_assign_aux_vars (sym);
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
return sym->backend_decl;
}
if (sym->result == sym && sym->attr.assign
&& GFC_DECL_ASSIGN (sym->backend_decl) == 0)
gfc_add_assign_aux_vars (sym);
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->attr.flavor == FL_PARAMETER
&& (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
|| sym->from_intmod == INTMOD_ISO_C_BINDING))
intrinsic_array_parameter = true;
/* If use associated compilation, use the module
declaration. */
if ((sym->attr.flavor == FL_VARIABLE
|| sym->attr.flavor == FL_PARAMETER)
&& (sym->attr.use_assoc || sym->attr.used_in_submodule)
&& !intrinsic_array_parameter
&& sym->module
&& gfc_get_module_backend_decl (sym))
{
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
return sym->backend_decl;
}
if (sym->attr.flavor == FL_PROCEDURE)
{
/* Catch functions. Only used for actual parameters,
procedure pointers and procptr initialization targets. */
if (sym->attr.use_assoc
|| sym->attr.used_in_submodule
|| sym->attr.intrinsic
|| sym->attr.if_source != IFSRC_DECL)
{
decl = gfc_get_extern_function_decl (sym);
}
else
{
if (!sym->backend_decl)
build_function_decl (sym, false);
decl = sym->backend_decl;
}
return decl;
}
if (sym->attr.intrinsic)
gfc_internal_error ("intrinsic variable which isn't a procedure");
/* Create string length decl first so that they can be used in the
type declaration. For associate names, the target character
length is used. Set 'length' to a constant so that if the
string length is a variable, it is not finished a second time. */
if (sym->ts.type == BT_CHARACTER)
{
if (sym->attr.associate_var
&& sym->ts.deferred
&& sym->assoc && sym->assoc->target
&& ((sym->assoc->target->expr_type == EXPR_VARIABLE
&& sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
|| sym->assoc->target->expr_type != EXPR_VARIABLE))
sym->ts.u.cl->backend_decl = NULL_TREE;
if (sym->attr.associate_var
&& sym->ts.u.cl->backend_decl
&& (VAR_P (sym->ts.u.cl->backend_decl)
|| TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL))
length = gfc_index_zero_node;
else
length = gfc_create_string_length (sym);
}
/* Create the decl for the variable. */
decl = build_decl (gfc_get_location (&sym->declared_at),
VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
/* Add attributes to variables. Functions are handled elsewhere. */
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
decl_attributes (&decl, attributes, 0);
/* Symbols from modules should have their assembler names mangled.
This is done here rather than in gfc_finish_var_decl because it
is different for string length variables. */
if (sym->module || sym->fn_result_spec)
{
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.use_assoc && !intrinsic_array_parameter)
DECL_IGNORED_P (decl) = 1;
}
if (sym->attr.select_type_temporary)
{
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
}
if (sym->attr.dimension || sym->attr.codimension)
{
/* Create variables to hold the non-constant bits of array info. */
gfc_build_qualified_array (decl, sym);
if (sym->attr.contiguous
|| ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
/* Remember this variable for allocation/cleanup. */
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->ts.type == BT_DERIVED
&& (sym->ts.u.derived->attr.alloc_comp
|| (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
&& !sym->ns->proc_name->attr.is_main_program
&& gfc_is_finalizable (sym->ts.u.derived, NULL))))
/* This applies a derived type default initializer. */
|| (sym->ts.type == BT_DERIVED
&& sym->attr.save == SAVE_NONE
&& !sym->attr.data
&& !sym->attr.allocatable
&& (sym->value && !sym->ns->proc_name->attr.is_main_program)
&& !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
if (sym->ts.type == BT_CHARACTER
&& sym->attr.allocatable
&& !sym->attr.dimension
&& sym->ts.u.cl && sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
gfc_defer_symbol_init (sym);
/* Associate names can use the hidden string length variable
of their associated target. */
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (length) != INTEGER_CST
&& TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF)
{
length = fold_convert (gfc_charlen_type_node, length);
gfc_finish_var_decl (length, sym);
if (!sym->attr.associate_var
&& TREE_CODE (length) == VAR_DECL
&& sym->value && sym->value->expr_type != EXPR_NULL
&& sym->value->ts.u.cl->length)
{
gfc_expr *len = sym->value->ts.u.cl->length;
DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts,
TREE_TYPE (length),
false, false, false);
DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node,
DECL_INITIAL (length));
}
else
gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
}
gfc_finish_var_decl (decl, sym);
if (sym->ts.type == BT_CHARACTER)
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
if (sym->assoc && sym->attr.subref_array_pointer)
sym->attr.pointer = 1;
if (sym->attr.pointer && sym->attr.dimension
&& !sym->ts.deferred
&& !(sym->attr.select_type_temporary
&& !sym->attr.subref_array_pointer))
GFC_DECL_PTR_ARRAY_P (decl) = 1;
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 (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_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|| sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
&& (flag_coarray != GFC_FCOARRAY_LIB
|| !sym->attr.codimension || sym->attr.allocatable)
&& !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
&& !(sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
{
/* 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.codimension
&& sym->attr.allocatable),
sym->attr.pointer || sym->attr.allocatable
|| sym->ts.type == BT_CLASS,
sym->attr.proc_pointer);
}
if (!TREE_STATIC (decl)
&& POINTER_TYPE_P (TREE_TYPE (decl))
&& !sym->attr.pointer
&& !sym->attr.allocatable
&& !sym->attr.proc_pointer
&& !sym->attr.select_type_temporary)
DECL_BY_REFERENCE (decl) = 1;
if (sym->attr.associate_var)
GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
/* We only longer mark __def_init as read-only if it actually has an
initializer, it does not needlessly take up space in the
read-only section and can go into the BSS instead, see PR 84487.
Marking this as artificial means that OpenMP will treat this as
predetermined shared. */
bool def_init = startswith (sym->name, "__def_init");
if (sym->attr.vtab || def_init)
{
DECL_ARTIFICIAL (decl) = 1;
if (def_init && sym->value)
TREE_READONLY (decl) = 1;
}
return decl;
}
/* Substitute a temporary variable in place of the real one. */
void
gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
{
save->attr = sym->attr;
save->decl = sym->backend_decl;
gfc_clear_attr (&sym->attr);
sym->attr.referenced = 1;
sym->attr.flavor = FL_VARIABLE;
sym->backend_decl = decl;
}
/* Restore the original variable. */
void
gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
{
sym->attr = save->attr;
sym->backend_decl = save->decl;
}
/* Declare a procedure pointer. */
static tree
get_proc_pointer_decl (gfc_symbol *sym)
{
tree decl;
tree attributes;
if (sym->module || sym->fn_result_spec)
{
const char *name;
gfc_gsymbol *gsym;
name = mangled_identifier (sym);
gsym = gfc_find_gsymbol (gfc_gsym_root, name);
if (gsym != NULL)
{
gfc_symbol *s;
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
if (s && s->backend_decl)
return s->backend_decl;
}
}
decl = sym->backend_decl;
if (decl)
return decl;
decl = build_decl (input_location,
VAR_DECL, get_identifier (sym->name),
build_pointer_type (gfc_get_function_type (sym)));
if (sym->module)
{
/* Apply name mangling. */
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.use_assoc)
DECL_IGNORED_P (decl) = 1;
}
if ((sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == current_function_decl)
|| sym->attr.contained)
gfc_add_decl_to_function (decl);
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;
if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
{
DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
DECL_VISIBILITY_SPECIFIED (decl) = true;
}
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)))
TREE_STATIC (decl) = 1;
if (TREE_STATIC (decl) && sym->value)
{
/* Add static initializer. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
TREE_TYPE (decl),
sym->attr.dimension,
false, true);
}
/* Handle threadprivate procedure pointers. */
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
set_decl_tls_model (decl, decl_default_tls_model (decl));
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
decl_attributes (&decl, attributes, 0);
return decl;
}
/* Get a basic decl for an external function. */
tree
gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args,
const char *fnspec)
{
tree type;
tree fndecl;
tree attributes;
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
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;
/* We should never be creating external decls for alternate entry points.
The procedure may be an alternate entry point, but we don't want/need
to know that. */
gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
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. If we are looking at a BIND(C)
procedure and the symbol is not BIND(C), or vice versa, we
haven't found the right procedure. */
if (sym->binding_label)
{
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
if (gsym && !gsym->bind_c)
gsym = NULL;
}
else if (sym->module == NULL)
{
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
if (gsym && gsym->bind_c)
gsym = NULL;
}
else
{
/* Procedure from a different module. */
gsym = NULL;
}
if (gsym && !gsym->defined)
gsym = NULL;
/* This can happen because of C binding. */
if (gsym && gsym->ns && gsym->ns->proc_name
&& gsym->ns->proc_name->attr.flavor == FL_MODULE)
goto module_sym;
if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
&& !sym->backend_decl
&& gsym && gsym->ns
&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
&& (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
{
if (!gsym->ns->proc_name->backend_decl)
{
/* By construction, the external function cannot be
a contained procedure. */
locus old_loc;
gfc_save_backend_locus (&old_loc);
push_cfun (NULL);
gfc_create_function_decl (gsym->ns, true);
pop_cfun ();
gfc_restore_backend_locus (&old_loc);
}
/* 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)
{
/* Avoid problems of double deallocation of the backend declaration
later in gfc_trans_use_stmts; cf. PR 45087. */
if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
sym->attr.use_assoc = 0;
return sym->backend_decl;
}
}
/* See if this is a module procedure from the same file. If so,
return the backend_decl. */
if (sym->module)
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
module_sym:
if (gsym && gsym->ns
&& (gsym->type == GSYM_MODULE
|| (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
{
gfc_symbol *s;
s = NULL;
if (gsym->type == GSYM_MODULE)
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
else
gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
if (s && s->backend_decl)
{
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
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;
}
}
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
a nasty hack which relies on the resolution functions only looking
at the first argument. We pass NULL for the second argument
otherwise things like AINT get confused. */
isym = gfc_find_function (sym->name);
gcc_assert (isym->resolve.f0 != NULL);
memset (&e, 0, sizeof (e));
e.expr_type = EXPR_FUNCTION;
memset (&argexpr, 0, sizeof (argexpr));
gcc_assert (isym->formal);
argexpr.ts = isym->formal->ts;
if (isym->formal->next == NULL)
isym->resolve.f1 (&e, &argexpr);
else
{
if (isym->formal->next->next == NULL)
isym->resolve.f2 (&e, &argexpr, NULL);
else
{
if (isym->formal->next->next->next == NULL)
isym->resolve.f3 (&e, &argexpr, NULL, NULL);
else
{
/* All specific intrinsics take less than 5 arguments. */
gcc_assert (isym->formal->next->next->next->next == NULL);
if (isym->resolve.f1m == gfc_resolve_index_func)
{
/* gfc_resolve_index_func is special because it takes a
gfc_actual_arglist instead of individual arguments. */
gfc_actual_arglist *a, *n;
int i;
a = gfc_get_actual_arglist();
n = a;
for (i = 0; i < 4; i++)
{
n->next = gfc_get_actual_arglist();
n = n->next;
}
a->expr = &argexpr;
isym->resolve.f1m (&e, a);
a->expr = NULL;
gfc_free_actual_arglist (a);
}
else
isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
}
}
}
if (flag_f2c
&& ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
|| e.ts.type == BT_COMPLEX))
{
/* Specific which needs a different implementation if f2c
calling conventions are used. */
sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
}
else
sprintf (s, "_gfortran_specific%s", e.value.function.name);
name = get_identifier (s);
mangled_name = name;
}
else
{
name = gfc_sym_identifier (sym);
mangled_name = gfc_sym_mangled_function_id (sym);
}
type = gfc_get_function_type (sym, actual_args, fnspec);
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);
gfc_set_decl_assembler_name (fndecl, mangled_name);
/* Set the context of this decl. */
if (0 && sym->ns && sym->ns->proc_name)
{
/* TODO: Add external decls to the appropriate scope. */
DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
}
else
{
/* Global declaration, e.g. intrinsic subroutine. */
DECL_CONTEXT (fndecl) = NULL_TREE;
}
/* 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. */
if (sym->attr.pure || sym->attr.implicit_pure)
{
if (sym->attr.function && !gfc_return_by_reference (sym))
DECL_PURE_P (fndecl) = 1;
/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
parameters and don't use alternate returns (is this
allowed?). In that case, calls to them are meaningless, and
can be optimized away. See also in build_function_decl(). */
TREE_SIDE_EFFECTS (fndecl) = 0;
}
/* Mark non-returning functions. */
if (sym->attr.noreturn)
TREE_THIS_VOLATILE(fndecl) = 1;
sym->backend_decl = fndecl;
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
if (sym->formal_ns
&& sym->formal_ns->proc_name == sym)
{
if (sym->formal_ns->omp_declare_simd)
gfc_trans_omp_declare_simd (sym->formal_ns);
if (flag_openmp)
gfc_trans_omp_declare_variant (sym->formal_ns);
}
return fndecl;
}
/* Create a declaration for a procedure. For external functions (in the C
sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
a master function with alternate entry points. */
static void
build_function_decl (gfc_symbol * sym, bool global)
{
tree fndecl, type, attributes;
symbol_attribute attr;
tree result_decl;
gfc_formal_arglist *f;
bool module_procedure = sym->attr.module_procedure
&& sym->ns
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE;
gcc_assert (!sym->attr.external || module_procedure);
if (sym->backend_decl)
return;
/* Set the line and filename. sym->declared_at seems to point to the
last statement for subroutines, but it'll do for now. */
gfc_set_backend_locus (&sym->declared_at);
/* Allow only one nesting level. Allow public declarations. */
gcc_assert (current_function_decl == NULL_TREE
|| 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,
FUNCTION_DECL, gfc_sym_identifier (sym), type);
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 (sym->attr.access == ACCESS_UNKNOWN && sym->module
&& (sym->ns->default_access == ACCESS_PRIVATE
|| (sym->ns->default_access == ACCESS_UNKNOWN
&& flag_module_private)))
sym->attr.access = ACCESS_PRIVATE;
if (!current_function_decl
&& !sym->attr.entry_master && !sym->attr.is_main_program
&& (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
|| sym->attr.public_used))
TREE_PUBLIC (fndecl) = 1;
if (sym->attr.referenced || sym->attr.entry_master)
TREE_USED (fndecl) = 1;
attributes = add_attributes_to_decl (attr, NULL_TREE);
decl_attributes (&fndecl, attributes, 0);
/* 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. */
result_decl = NULL_TREE;
/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
if (attr.function)
{
if (gfc_return_by_reference (sym))
type = void_type_node;
else
{
if (sym->result != sym)
result_decl = gfc_sym_identifier (sym->result);
type = TREE_TYPE (TREE_TYPE (fndecl));
}
}
else
{
/* Look for alternate return placeholders. */
int has_alternate_returns = 0;
for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
if (f->sym == NULL)
{
has_alternate_returns = 1;
break;
}
}
if (has_alternate_returns)
type = integer_type_node;
else
type = void_type_node;
}
result_decl = build_decl (input_location,
RESULT_DECL, result_decl, type);
DECL_ARTIFICIAL (result_decl) = 1;
DECL_IGNORED_P (result_decl) = 1;
DECL_CONTEXT (result_decl) = fndecl;
DECL_RESULT (fndecl) = result_decl;
/* Don't call layout_decl for a RESULT_DECL.
layout_decl (result_decl, 0); */
/* TREE_STATIC means the function body is defined here. */
TREE_STATIC (fndecl) = 1;
/* Set attributes for PURE functions. A call to a PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
if (attr.pure || attr.implicit_pure)
{
/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
including an alternate return. In that case it can also be
marked as PURE. See also in gfc_get_extern_function_decl(). */
if (attr.function && !gfc_return_by_reference (sym))
DECL_PURE_P (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
/* Layout the function declaration and put it in the binding level
of the current function. */
if (global)
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;
}
/* Create the DECL_ARGUMENTS for a procedure.
NOTE: The arguments added here must match the argument type created by
gfc_get_function_type (). */
static void
create_function_arglist (gfc_symbol * sym)
{
tree fndecl;
gfc_formal_arglist *f;
tree typelist, hidden_typelist;
tree arglist, hidden_arglist;
tree type;
tree parm;
fndecl = sym->backend_decl;
/* Build formal argument list. Make sure that their TREE_CONTEXT is
the new FUNCTION_DECL node. */
arglist = NULL_TREE;
hidden_arglist = NULL_TREE;
typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
if (sym->attr.entry_master)
{
type = TREE_VALUE (typelist);
parm = build_decl (input_location,
PARM_DECL, get_identifier ("__entry"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm);
DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
if (gfc_return_by_reference (sym))
{
tree type = TREE_VALUE (typelist), length = NULL;
if (sym->ts.type == BT_CHARACTER)
{
/* Length of character result. */
tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
length = build_decl (input_location,
PARM_DECL,
get_identifier (".__result"),
len_type);
if (POINTER_TYPE_P (len_type))
{
sym->ts.u.cl->passed_length = length;
TREE_USED (length) = 1;
}
else if (!sym->ts.u.cl->length)
{
sym->ts.u.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
DECL_CONTEXT (length) = fndecl;
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length);
if (sym->ts.u.cl->backend_decl == NULL
|| sym->ts.u.cl->backend_decl == length)
{
gfc_symbol *arg;
tree backend_decl;
if (sym->ts.u.cl->backend_decl == NULL)
{
tree len = build_decl (input_location,
VAR_DECL,
get_identifier ("..__result"),
gfc_charlen_type_node);
DECL_ARTIFICIAL (len) = 1;
TREE_USED (len) = 1;
sym->ts.u.cl->backend_decl = len;
}
/* Make sure PARM_DECL type doesn't point to incomplete type. */
arg = sym->result ? sym->result : sym;
backend_decl = arg->backend_decl;
/* Temporary clear it, so that gfc_sym_type creates complete
type. */
arg->backend_decl = NULL;
type = gfc_sym_type (arg);
arg->backend_decl = backend_decl;
type = build_reference_type (type);
}
}
parm = build_decl (input_location,
PARM_DECL, get_identifier ("__result"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
TREE_READONLY (parm) = 1;
DECL_ARTIFICIAL (parm) = 1;
gfc_finish_decl (parm);
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
if (sym->ts.type == BT_CHARACTER)
{
gfc_allocate_lang_decl (parm);
arglist = chainon (arglist, length);
typelist = TREE_CHAIN (typelist);
}
}
hidden_typelist = typelist;
for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
if (f->sym != NULL) /* Ignore alternate returns. */
hidden_typelist = TREE_CHAIN (hidden_typelist);
for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
/* Ignore alternate returns. */
if (f->sym == NULL)
continue;
type = TREE_VALUE (typelist);
if (f->sym->ts.type == BT_CHARACTER
&& (!sym->attr.is_bind_c || sym->attr.entry_master))
{
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
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] = '_';
length = build_decl (input_location,
PARM_DECL, get_identifier (name), len_type);
hidden_arglist = chainon (hidden_arglist, length);
DECL_CONTEXT (length) = fndecl;
DECL_ARTIFICIAL (length) = 1;
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
gfc_finish_decl (length);
/* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
to tail calls being disabled. Only do that if we
potentially have broken callers. */
if (flag_tail_call_workaround
&& f->sym->ts.u.cl
&& f->sym->ts.u.cl->length
&& f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& (flag_tail_call_workaround == 2
|| f->sym->ns->implicit_interface_calls))
DECL_HIDDEN_STRING_LENGTH (length) = 1;
/* Remember the passed value. */
if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
{
/* This can happen if the same type is used for multiple
arguments. We need to copy cl as otherwise
cl->passed_length gets overwritten. */
f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
}
f->sym->ts.u.cl->passed_length = length;
/* Use the passed value for assumed length variables. */
if (!f->sym->ts.u.cl->length)
{
TREE_USED (length) = 1;
gcc_assert (!f->sym->ts.u.cl->backend_decl);
f->sym->ts.u.cl->backend_decl = length;
}
hidden_typelist = TREE_CHAIN (hidden_typelist);
if (f->sym->ts.u.cl->backend_decl == NULL
|| f->sym->ts.u.cl->backend_decl == length)
{
if (POINTER_TYPE_P (len_type))
f->sym->ts.u.cl->backend_decl
= build_fold_indirect_ref_loc (input_location, length);
else if (f->sym->ts.u.cl->backend_decl == NULL)
gfc_create_string_length (f->sym);
/* Make sure PARM_DECL type doesn't point to incomplete type. */
if (f->sym->attr.flavor == FL_PROCEDURE)
type = build_pointer_type (gfc_get_function_type (f->sym));
else
type = gfc_sym_type (f->sym);
}
}
/* For noncharacter scalar intrinsic types, VALUE passes the value,
hence, the optional status cannot be transferred via a NULL pointer.
Thus, we will use a hidden argument in that case. */
else if (f->sym->attr.optional && f->sym->attr.value
&& !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
&& !gfc_bt_struct (f->sym->ts.type))
{
tree tmp;
strcpy (&name[1], f->sym->name);
name[0] = '_';
tmp = build_decl (input_location,
PARM_DECL, get_identifier (name),
boolean_type_node);
hidden_arglist = chainon (hidden_arglist, tmp);
DECL_CONTEXT (tmp) = fndecl;
DECL_ARTIFICIAL (tmp) = 1;
DECL_ARG_TYPE (tmp) = boolean_type_node;
TREE_READONLY (tmp) = 1;
gfc_finish_decl (tmp);
hidden_typelist = TREE_CHAIN (hidden_typelist);
}
/* For non-constant length array arguments, make sure they use
a different type node from TYPE_ARG_TYPES type. */
if (f->sym->attr.dimension
&& type == TREE_VALUE (typelist)
&& TREE_CODE (type) == POINTER_TYPE
&& GFC_ARRAY_TYPE_P (type)
&& f->sym->as->type != AS_ASSUMED_SIZE
&& ! COMPLETE_TYPE_P (TREE_TYPE (type)))
{
if (f->sym->attr.flavor == FL_PROCEDURE)
type = build_pointer_type (gfc_get_function_type (f->sym));
else
type = gfc_sym_type (f->sym);
}
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);
/* All implementation args except for VALUE are read-only. */
if (!f->sym->attr.value)
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;
if (f->sym->attr.optional)
{
gfc_allocate_lang_decl (parm);
GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1;
}
gfc_finish_decl (parm);
gfc_finish_decl_attrs (parm, &f->sym->attr);
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 (flag_coarray == GFC_FCOARRAY_LIB
&& ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
&& !f->sym->attr.allocatable)
|| (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->attr.codimension
&& !CLASS_DATA (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 = f->sym->ts.type == BT_CLASS
? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
: 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->ts.type != BT_CLASS
&& f->sym->as->type != AS_DEFERRED)
|| (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
{
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);
hidden_typelist = TREE_CHAIN (hidden_typelist);
gfc_finish_decl (token);
offset = build_decl (input_location, PARM_DECL,
create_tmp_var_name ("caf_offset"),
gfc_array_index_type);
if ((f->sym->ts.type != BT_CLASS
&& f->sym->as->type != AS_DEFERRED)
|| (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
{
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);
hidden_typelist = TREE_CHAIN (hidden_typelist);
gfc_finish_decl (offset);
}
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
/* Add the hidden string length parameters, unless the procedure
is bind(C). */
if (!sym->attr.is_bind_c)
arglist = chainon (arglist, hidden_arglist);
gcc_assert (hidden_typelist == NULL_TREE
|| TREE_VALUE (hidden_typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
}
/* Do the setup necessary before generating the body of a function. */
static void
trans_function_start (gfc_symbol * sym)
{
tree fndecl;
fndecl = sym->backend_decl;
/* Let GCC know the current scope is this function. */
current_function_decl = fndecl;
/* Let the world know what we're about to do. */
announce_function (fndecl);
if (DECL_FILE_SCOPE_P (fndecl))
{
/* Create RTL for function declaration. */
rest_of_decl_compilation (fndecl, 1, 0);
}
/* Create RTL for function definition. */
make_decl_rtl (fndecl);
allocate_struct_function (fndecl, false);
/* function.c requires a push at the start of the function. */
pushlevel ();
}
/* Create thunks for alternate entry points. */
static void
build_entry_thunks (gfc_namespace * ns, bool global)
{
gfc_formal_arglist *formal;
gfc_formal_arglist *thunk_formal;
gfc_entry_list *el;
gfc_symbol *thunk_sym;
stmtblock_t body;
tree thunk_fndecl;
tree tmp;
locus old_loc;
/* This should always be a toplevel function. */
gcc_assert (current_function_decl == NULL_TREE);
gfc_save_backend_locus (&old_loc);
for (el = ns->entries; el; el = el->next)
{
vec<tree, va_gc> *args = NULL;
vec<tree, va_gc> *string_args = NULL;
thunk_sym = el->sym;
build_function_decl (thunk_sym, global);
create_function_arglist (thunk_sym);
trans_function_start (thunk_sym);
thunk_fndecl = thunk_sym->backend_decl;
gfc_init_block (&body);
/* Pass extra parameter identifying this entry point. */
tmp = build_int_cst (gfc_array_index_type, el->id);
vec_safe_push (args, tmp);
if (thunk_sym->attr.function)
{
if (gfc_return_by_reference (ns->proc_name))
{
tree ref = DECL_ARGUMENTS (current_function_decl);
vec_safe_push (args, ref);
if (ns->proc_name->ts.type == BT_CHARACTER)
vec_safe_push (args, DECL_CHAIN (ref));
}
}
for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
formal = formal->next)
{
/* Ignore alternate returns. */
if (formal->sym == NULL)
continue;
/* We don't have a clever way of identifying arguments, so resort to
a brute-force search. */
for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
thunk_formal;
thunk_formal = thunk_formal->next)
{
if (thunk_formal->sym == formal->sym)
break;
}
if (thunk_formal)
{
/* Pass the argument. */
DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
vec_safe_push (args, thunk_formal->sym->backend_decl);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = thunk_formal->sym->ts.u.cl->backend_decl;
vec_safe_push (string_args, tmp);
}
}
else
{
/* Pass NULL for a missing argument. */
vec_safe_push (args, null_pointer_node);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = build_int_cst (gfc_charlen_type_node, 0);
vec_safe_push (string_args, tmp);
}
}
}
/* Call the master function. */
vec_safe_splice (args, string_args);
tmp = ns->proc_name->backend_decl;
tmp = build_call_expr_loc_vec (input_location, tmp, args);
if (ns->proc_name->attr.mixed_entry_master)
{
tree union_decl, field;
tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
union_decl = build_decl (input_location,
VAR_DECL, get_identifier ("__result"),
TREE_TYPE (master_type));
DECL_ARTIFICIAL (union_decl) = 1;
DECL_EXTERNAL (union_decl) = 0;
TREE_PUBLIC (union_decl) = 0;
TREE_USED (union_decl) = 1;
layout_decl (union_decl, 0);
pushdecl (union_decl);
DECL_CONTEXT (union_decl) = current_function_decl;
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (union_decl), union_decl, tmp);
gfc_add_expr_to_block (&body, tmp);
for (field