/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2015 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "system.h"
#include "coretypes.h"
#include "tm.h"
+#include "gfortran.h"
+#include "hash-set.h"
+#include "machmode.h"
+#include "vec.h"
+#include "double-int.h"
+#include "input.h"
+#include "alias.h"
+#include "symtab.h"
+#include "wide-int.h"
+#include "inchash.h"
#include "tree.h"
+#include "fold-const.h"
+#include "stringpool.h"
+#include "stor-layout.h"
+#include "varasm.h"
+#include "attribs.h"
#include "tree-dump.h"
-#include "gimple.h" /* For create_tmp_var_raw. */
+#include "gimple-expr.h" /* For create_tmp_var_raw. */
#include "ggc.h"
#include "diagnostic-core.h" /* For internal_error. */
#include "toplev.h" /* For announce_function. */
#include "target.h"
+#include "hard-reg-set.h"
+#include "input.h"
#include "function.h"
#include "flags.h"
+#include "hash-map.h"
+#include "is-a.h"
+#include "plugin-api.h"
+#include "ipa-ref.h"
#include "cgraph.h"
#include "debug.h"
-#include "gfortran.h"
-#include "pointer-set.h"
#include "constructor.h"
#include "trans.h"
#include "trans-types.h"
static GTY(()) tree saved_function_decls;
static GTY(()) tree saved_parent_function_decls;
-static struct pointer_set_t *nonlocal_dummy_decl_pset;
+static hash_set<tree> *nonlocal_dummy_decl_pset;
static GTY(()) tree nonlocal_dummy_decls;
/* Holds the variable DECLs that are locals. */
/* 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. */
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_in_pack;
tree gfor_fndecl_in_unpack;
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_critical;
-tree gfor_fndecl_caf_end_critical;
+tree gfor_fndecl_caf_get;
+tree gfor_fndecl_caf_send;
+tree gfor_fndecl_caf_sendget;
tree gfor_fndecl_caf_sync_all;
+tree gfor_fndecl_caf_sync_memory;
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;
+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_co_broadcast;
+tree gfor_fndecl_co_max;
+tree gfor_fndecl_co_min;
+tree gfor_fndecl_co_reduce;
+tree gfor_fndecl_co_sum;
/* Math functions. Many other math functions are handled in
binding label (mainly those that are bind(c)). */
if (sym->attr.is_bind_c == 1 && sym->binding_label)
return get_identifier (sym->binding_label);
-
+
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
if (sym->attr.proc == PROC_INTRINSIC)
return get_identifier (sym->name);
- if (gfc_option.flag_underscoring)
+ if (flag_underscoring)
{
has_underscore = strchr (sym->name, '_') != 0;
- if (gfc_option.flag_second_underscore && has_underscore)
+ if (flag_second_underscore && has_underscore)
snprintf (name, sizeof name, "%s__", sym->name);
else
snprintf (name, sizeof name, "%s_", sym->name);
if (!INTEGER_CST_P (size))
return 0;
- if (gfc_option.flag_max_stack_var_size < 0)
+ if (flag_max_stack_var_size < 0)
return 1;
- if (TREE_INT_CST_HIGH (size) != 0)
+ if (!tree_fits_uhwi_p (size))
return 0;
low = TREE_INT_CST_LOW (size);
- if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
+ if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size)
return 0;
/* TODO: Set a per-function stack size limit. */
tree value;
/* Parameters need to be dereferenced. */
- if (sym->cp_pointer->attr.dummy)
+ 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)
- {
+ && 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);
/* We should know the storage size. */
gcc_assert (DECL_SIZE (decl) != NULL_TREE
- || (TREE_STATIC (decl)
+ || (TREE_STATIC (decl)
? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
: DECL_EXTERNAL (decl)));
}
+/* 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;
+ }
+ }
+}
+
+
/* 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;
- /* 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. */
/* 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;
TREE_PUBLIC(decl) = 1;
DECL_COMMON(decl) = 1;
}
-
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
{
/* TODO: Don't set sym->module for result or dummy variables. */
gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
- /* This is the declaration of a module variable. */
- if (sym->attr.access == ACCESS_UNKNOWN
- && (sym->ns->default_access == ACCESS_PRIVATE
- || (sym->ns->default_access == ACCESS_UNKNOWN
- && gfc_option.flag_module_private)))
- sym->attr.access = ACCESS_PRIVATE;
if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)
TREE_PUBLIC (decl) = 1;
if (!sym->attr.use_assoc
&& (sym->attr.save != SAVE_NONE || sym->attr.data
|| (sym->value && sym->ns->proc_name->attr.is_main_program)
- || (gfc_option.coarray == GFC_FCOARRAY_LIB
+ || (flag_coarray == GFC_FCOARRAY_LIB
&& sym->attr.codimension && !sym->attr.allocatable)))
TREE_STATIC (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->attr.recursive
/* Handle threadprivate variables. */
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
- DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+ set_decl_tls_model (decl, decl_default_tls_model (decl));
- if (!sym->attr.target
- && !sym->attr.pointer
- && !sym->attr.cray_pointee
- && !sym->attr.proc_pointer)
- DECL_RESTRICTED_P (decl) = 1;
+ gfc_finish_decl_attrs (decl, &sym->attr);
}
void
gfc_allocate_lang_decl (tree decl)
{
- DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
- (struct lang_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
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))
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
+ 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;
+
+ if (sym->attr.use_assoc || sym->attr.access != ACCESS_PRIVATE ||
+ sym->attr.public_used)
+ TREE_PUBLIC (token) = 1;
+ }
+ else
+ {
+ token = gfc_create_var_np (token_type, "caf_token");
+ TREE_STATIC (token) = 1;
+ }
- 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);
+ 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
+ gfc_add_decl_to_function (token);
}
for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
}
/* Don't try to use the unknown bound for assumed shape arrays. */
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
- && (sym->as->type != AS_ASSUMED_SIZE
- || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
+ && (as->type != AS_ASSUMED_SIZE
+ || dim < GFC_TYPE_ARRAY_RANK (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_SIZE (type) == NULL_TREE
- && sym->as->type != AS_ASSUMED_SIZE)
+ && as->type != AS_ASSUMED_SIZE)
{
GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
}
if (TYPE_NAME (type) != NULL_TREE
- && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
- && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
+ && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
+ && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)) == VAR_DECL)
{
tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
- for (dim = 0; dim < sym->as->rank - 1; dim++)
+ for (dim = 0; dim < as->rank - 1; dim++)
{
gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
gtype = TREE_TYPE (gtype);
{
tree gtype = TREE_TYPE (type), rtype, type_decl;
- for (dim = sym->as->rank - 1; dim >= 0; dim--)
+ for (dim = as->rank - 1; dim >= 0; dim--)
{
tree lbound, ubound;
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
tree decl;
tree type;
gfc_array_spec *as;
+ symbol_attribute *array_attr;
char *name;
gfc_packed packed;
int n;
bool known_size;
-
- if (sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ 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. */
+ /* 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);
- type = TREE_TYPE (dummy);
+ /* 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 (type));
+ && 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 (TREE_TYPE (type)))
+
+ if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
{
/* For descriptorless arrays with known element size the actual
argument is sufficient. */
- gcc_assert (GFC_ARRAY_TYPE_P (type));
gfc_build_qualified_array (dummy, sym);
return dummy;
}
- type = TREE_TYPE (type);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
/* Create a descriptorless array pointer. */
- as = sym->as;
packed = PACKED_NO;
/* Even when -frepack-arrays is used, symbols with TARGET attribute
are not repacked. */
- if (!gfc_option.flag_repack_arrays || sym->attr.target)
+ if (!flag_repack_arrays || sym->attr.target)
{
if (as->type == AS_ASSUMED_SIZE)
packed = PACKED_FULL;
&& as->lower[n]
&& as->upper[n]->expr_type == EXPR_CONSTANT
&& as->lower[n]->expr_type == EXPR_CONSTANT))
- packed = PACKED_PARTIAL;
+ {
+ packed = PACKED_PARTIAL;
+ break;
+ }
}
}
else
packed = PACKED_PARTIAL;
}
- type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ /* 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
TREE_STATIC (decl) = 0;
DECL_EXTERNAL (decl) = 0;
+ /* Avoid uninitialized warnings for optional dummy arguments. */
+ if (sym->attr.optional)
+ TREE_NO_WARNING (decl) = 1;
+
/* We should never get deferred shape arrays here. We used to because of
frontend bugs. */
- gcc_assert (sym->as->type != AS_DEFERRED);
+ gcc_assert (as->type != AS_DEFERRED);
if (packed == PACKED_PARTIAL)
GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
tree decl, dummy;
if (! nonlocal_dummy_decl_pset)
- nonlocal_dummy_decl_pset = pointer_set_create ();
+ nonlocal_dummy_decl_pset = new hash_set<tree>;
- if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
+ if (nonlocal_dummy_decl_pset->add (sym->backend_decl))
return;
dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
tree length;
const char *name;
- /* Also prefix the mangled name. */
- if (sym->module)
+ /* 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);
sym->ts.u.cl->backend_decl = length;
- if (sym->attr.save || sym->ns->proc_name->attr.flavor == FL_MODULE)
+ if (static_length)
TREE_STATIC (length) = 1;
if (sym->ns->proc_name->attr.flavor == FL_MODULE
list = chainon (list, attr);
}
+ if (sym_attr.omp_declare_target)
+ list = tree_cons (get_identifier ("omp declare target"),
+ NULL_TREE, list);
+
return list;
}
tree attributes;
int byref;
bool intrinsic_array_parameter = false;
+ bool fun_or_res;
gcc_assert (sym->attr.referenced
|| sym->attr.flavor == FL_PROCEDURE
length = gfc_create_string_length (sym);
}
- if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
+ fun_or_res = byref && (sym->attr.result
+ || (sym->attr.function && sym->ts.deferred));
+ if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
{
/* Return via extra parameter. */
if (sym->attr.result && byref
(sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
sym->ts.u.cl->backend_decl = NULL_TREE;
- if (sym->ts.deferred && sym->attr.result
- && sym->ts.u.cl->passed_length == NULL
- && sym->ts.u.cl->backend_decl)
+ if (sym->ts.deferred && byref)
{
- sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
- sym->ts.u.cl->backend_decl = NULL_TREE;
+ /* 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->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;
+ sym->ts.u.cl->backend_decl = NULL_TREE;
+ }
}
if (sym->ts.u.cl->backend_decl == NULL_TREE)
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->attr.dimension
+ if ((sym->attr.dimension || IS_CLASS_ARRAY (sym))
&& DECL_LANG_SPECIFIC (sym->backend_decl)
&& GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
&& DECL_CONTEXT (sym->backend_decl) != current_function_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;
}
/* 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)
+ 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 and whole file compilation, use the module
+ /* If use associated compilation, use the module
declaration. */
- if (gfc_option.flag_whole_file
- && (sym->attr.flavor == FL_VARIABLE
- || sym->attr.flavor == FL_PARAMETER)
- && sym->attr.use_assoc
- && !intrinsic_array_parameter
- && sym->module
- && gfc_get_module_backend_decl (sym))
+ if ((sym->attr.flavor == FL_VARIABLE
+ || sym->attr.flavor == FL_PARAMETER)
+ && sym->attr.use_assoc
+ && !intrinsic_array_parameter
+ && sym->module
+ && gfc_get_module_backend_decl (sym))
{
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
if (sym->attr.flavor == FL_PROCEDURE)
{
- /* Catch function declarations. Only used for actual parameters,
+ /* Catch functions. Only used for actual parameters,
procedure pointers and procptr initialization targets. */
- if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
+ if (sym->attr.use_assoc || sym->attr.intrinsic
+ || sym->attr.if_source != IFSRC_DECL)
{
decl = gfc_get_extern_function_decl (sym);
gfc_set_decl_location (decl, &sym->declared_at);
}
if (sym->attr.intrinsic)
- internal_error ("intrinsic variable which isn't a procedure");
+ 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. */
+ type declaration. For associate names, the target character
+ length is used. Set 'length' to a constant so that if the
+ string lenght is a variable, it is not finished a second time. */
if (sym->ts.type == BT_CHARACTER)
- length = gfc_create_string_length (sym);
+ {
+ if (sym->attr.associate_var
+ && sym->ts.u.cl->backend_decl
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
+ length = gfc_index_zero_node;
+ else
+ length = gfc_create_string_length (sym);
+ }
/* Create the decl for the variable. */
decl = build_decl (sym->declared_at.lb->location,
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. */
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
- || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+ || (sym->ts.type == BT_DERIVED
+ && (sym->ts.u.derived->attr.alloc_comp
+ || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
+ && !sym->ns->proc_name->attr.is_main_program
+ && gfc_is_finalizable (sym->ts.u.derived, NULL))))
/* This applies a derived type default initializer. */
|| (sym->ts.type == BT_DERIVED
&& sym->attr.save == SAVE_NONE
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
+ /* Associate names can use the hidden string length variable
+ of their associated target. */
if (TREE_CODE (length) != INTEGER_CST)
{
gfc_finish_var_decl (length, sym);
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
+ || flag_max_stack_var_size == 0
|| sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
- && (gfc_option.coarray != GFC_FCOARRAY_LIB
+ && (flag_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
every time the procedure is entered. The TREE_STATIC is
in this case due to -fmax-stack-var-size=. */
+
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl),
- sym->attr.dimension
- || (sym->attr.codimension
- && sym->attr.allocatable),
- sym->attr.pointer
- || sym->attr.allocatable,
- sym->attr.proc_pointer);
+ TREE_TYPE (decl), sym->attr.dimension
+ || (sym->attr.codimension
+ && sym->attr.allocatable),
+ sym->attr.pointer || sym->attr.allocatable
+ || sym->ts.type == BT_CLASS,
+ sym->attr.proc_pointer);
}
if (!TREE_STATIC (decl)
&& POINTER_TYPE_P (TREE_TYPE (decl))
&& !sym->attr.pointer
&& !sym->attr.allocatable
- && !sym->attr.proc_pointer)
+ && !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;
+
if (sym->attr.vtab
|| (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
TREE_READONLY (decl) = 1;
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)
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->ns->proc_name->attr.flavor == FL_MODULE
+ && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
+ TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
}
/* Handle threadprivate procedure pointers. */
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
- DECL_TLS_MODEL (decl) = decl_default_tls_model (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);
/* See if this is an external procedure from the same file. If so,
return the backend_decl. */
- gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
-
- if (gfc_option.flag_whole_file
- && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
- && !sym->backend_decl
- && gsym && gsym->ns
- && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
- && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
+ ? sym->binding_label : sym->name);
+
+ if (gsym && !gsym->defined)
+ gsym = NULL;
+
+ /* This can happen because of C binding. */
+ if (gsym && gsym->ns && gsym->ns->proc_name
+ && gsym->ns->proc_name->attr.flavor == FL_MODULE)
+ goto module_sym;
+
+ if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
+ && !sym->backend_decl
+ && gsym && gsym->ns
+ && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+ && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
{
if (!gsym->ns->proc_name->backend_decl)
{
if (sym->module)
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
- if (gfc_option.flag_whole_file
- && gsym && gsym->ns
- && gsym->type == GSYM_MODULE)
+module_sym:
+ if (gsym && gsym->ns
+ && (gsym->type == GSYM_MODULE
+ || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
{
gfc_symbol *s;
s = NULL;
- gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (gsym->type == GSYM_MODULE)
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ else
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
+
if (s && s->backend_decl)
{
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
}
}
- if (gfc_option.flag_f2c
+ if (flag_f2c
&& ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
|| e.ts.type == BT_COMPLEX))
{
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
+ if (sym->formal_ns
+ && sym->formal_ns->proc_name == sym
+ && sym->formal_ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (sym->formal_ns);
+
return fndecl;
}
if (sym->attr.access == ACCESS_UNKNOWN && sym->module
&& (sym->ns->default_access == ACCESS_PRIVATE
|| (sym->ns->default_access == ACCESS_UNKNOWN
- && gfc_option.flag_module_private)))
+ && flag_module_private)))
sym->attr.access = ACCESS_PRIVATE;
if (!current_function_decl
{
/* Look for alternate return placeholders. */
int has_alternate_returns = 0;
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
if (f->sym == NULL)
{
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;
}
hidden_typelist = typelist;
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
if (f->sym != NULL) /* Ignore alternate returns. */
hidden_typelist = TREE_CHAIN (hidden_typelist);
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
gfc_finish_decl (length);
/* Remember the passed value. */
- if (f->sym->ts.u.cl->passed_length != NULL)
+ 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
type = gfc_sym_type (f->sym);
}
}
+ /* For noncharacter scalar intrinsic types, VALUE passes the value,
+ hence, the optional status cannot be transferred via a NULL pointer.
+ Thus, we will use a hidden argument in that case. */
+ else if (f->sym->attr.optional && f->sym->attr.value
+ && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
+ && f->sym->ts.type != BT_DERIVED)
+ {
+ tree tmp;
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ tmp = build_decl (input_location,
+ PARM_DECL, get_identifier (name),
+ boolean_type_node);
+
+ hidden_arglist = chainon (hidden_arglist, tmp);
+ DECL_CONTEXT (tmp) = fndecl;
+ DECL_ARTIFICIAL (tmp) = 1;
+ DECL_ARG_TYPE (tmp) = boolean_type_node;
+ TREE_READONLY (tmp) = 1;
+ gfc_finish_decl (tmp);
+ }
/* For non-constant length array arguments, make sure they use
a different type node from TYPE_ARG_TYPES type. */
/* Fill in arg stuff. */
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
- /* All implementation args are read-only. */
- TREE_READONLY (parm) = 1;
+ /* 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;
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 (f->sym->attr.codimension
- && gfc_option.coarray == GFC_FCOARRAY_LIB
- && !f->sym->attr.allocatable)
+ 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;
gcc_assert (f->sym->backend_decl != NULL_TREE
&& !sym->attr.is_bind_c);
- caf_type = TREE_TYPE (f->sym->backend_decl);
+ 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->as->type == AS_ASSUMED_SHAPE)
+ 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);
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);
create_tmp_var_name ("caf_offset"),
gfc_array_index_type);
- if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ 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);
vec<tree, va_gc> *string_args = NULL;
thunk_sym = el->sym;
-
+
build_function_decl (thunk_sym, global);
create_function_arglist (thunk_sym);
}
}
- for (formal = ns->proc_name->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
+ formal = formal->next)
{
/* Ignore alternate returns. */
if (formal->sym == NULL)
/* We don't have a clever way of identifying arguments, so resort to
a brute-force search. */
- for (thunk_formal = thunk_sym->formal;
+ for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
thunk_formal;
thunk_formal = thunk_formal->next)
{
tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), union_decl, field,
NULL_TREE);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
current_function_decl = NULL_TREE;
- cgraph_finalize_function (thunk_fndecl, true);
+ cgraph_node::finalize_function (thunk_fndecl, true);
/* We share the symbols in the formal argument list with other entry
points and the master function. Clear them so that they are
recreated for each function. */
- for (formal = thunk_sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
+ formal = formal->next)
if (formal->sym != NULL) /* Ignore alternate returns. */
{
formal->sym->backend_decl = NULL_TREE;
/* Now create the read argument list. */
create_function_arglist (ns->proc_name);
+
+ if (ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (ns);
}
/* Return the decl used to hold the function return value. If
TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0);
+ gfc_finish_decl_attrs (decl, &sym->attr);
if (parent_flag)
gfc_add_decl_to_parent_function (decl);
gfc_build_intrinsic_function_decls (void)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
tree gfc_int8_type_node = gfc_get_int_type (8);
+ tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
tree gfc_int16_type_node = gfc_get_int_type (16);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
tree pchar1_type_node = gfc_get_pchar_type (1);
DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
+ gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
+ get_identifier (PREFIX("system_clock_4")),
+ void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node,
+ gfc_pint4_type_node);
+
+ gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
+ get_identifier (PREFIX("system_clock_8")),
+ void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node,
+ gfc_pint8_type_node);
+
/* Power functions. */
{
tree ctype, rtype, itype, jtype;
gfc_int4_type_node);
TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
-
+
gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
get_identifier (PREFIX("ishftc8")),
gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
gfor_fndecl_sgemm = gfc_build_library_function_decl
(get_identifier
- (gfc_option.flag_underscoring ? "sgemm_"
- : "sgemm"),
+ (flag_underscoring ? "sgemm_" : "sgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, ps, ps, pint,
ps, pint, ps, ps, pint, integer_type_node,
integer_type_node);
gfor_fndecl_dgemm = gfc_build_library_function_decl
(get_identifier
- (gfc_option.flag_underscoring ? "dgemm_"
- : "dgemm"),
+ (flag_underscoring ? "dgemm_" : "dgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, pd, pd, pint,
pd, pint, pd, pd, pint, integer_type_node,
integer_type_node);
gfor_fndecl_cgemm = gfc_build_library_function_decl
(get_identifier
- (gfc_option.flag_underscoring ? "cgemm_"
- : "cgemm"),
+ (flag_underscoring ? "cgemm_" : "cgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, pc, pc, pint,
pc, pint, pc, pc, pint, integer_type_node,
integer_type_node);
gfor_fndecl_zgemm = gfc_build_library_function_decl
(get_identifier
- (gfc_option.flag_underscoring ? "zgemm_"
- : "zgemm"),
+ (flag_underscoring ? "zgemm_" : "zgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, pz, pz, pint,
pz, pint, pz, pz, pint, integer_type_node,
void_type_node, -2, pchar_type_node, pchar_type_node);
/* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
-
+
gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("runtime_warning_at")), ".RR",
void_type_node, -2, pchar_type_node, pchar_type_node);
get_identifier (PREFIX("set_fpe")),
void_type_node, 1, integer_type_node);
+ gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
+ get_identifier (PREFIX("ieee_procedure_entry")),
+ void_type_node, 1, pvoid_type_node);
+
+ gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
+ get_identifier (PREFIX("ieee_procedure_exit")),
+ void_type_node, 1, pvoid_type_node);
+
/* Keep the array dimension in sync with the call, later in this file. */
gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("set_options")), "..R",
TREE_NOTHROW (gfor_fndecl_associated) = 1;
/* Coarray library calls. */
- if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+ if (flag_coarray == GFC_FCOARRAY_LIB)
{
tree pint_type, pppchar_type;
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);
+ 2, pint_type, pppchar_type);
gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
+ gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_this_image")), integer_type_node,
+ 1, integer_type_node);
+
+ gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_num_images")), integer_type_node,
+ 2, integer_type_node, integer_type_node);
+
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,
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_get = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 9,
+ pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
+ pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
+ boolean_type_node);
+
+ gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 9,
+ pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
+ pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
+ boolean_type_node);
+
+ gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node,
+ 13, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
+ pvoid_type_node, pvoid_type_node, size_type_node, integer_type_node,
+ pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
+ boolean_type_node);
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);
+ 3, pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node,
+ 3, pint_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);
+ 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, 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;
+
+ gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_atomic_define")), "R..RW",
+ void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
+ pvoid_type_node, pint_type, integer_type_node, integer_type_node);
+
+ gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
+ void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
+ pvoid_type_node, pint_type, integer_type_node, integer_type_node);
+
+ gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
+ void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node,
+ pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
+ integer_type_node, integer_type_node);
+
+ gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
+ void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node,
+ integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
+ integer_type_node, integer_type_node);
+
+ gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_lock")), "R..WWW",
+ void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_unlock")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
+ void_type_node, 5, pvoid_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_co_max")), "W.WW",
+ void_type_node, 6, pvoid_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node, integer_type_node);
+
+ gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_co_min")), "W.WW",
+ void_type_node, 6, pvoid_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node, integer_type_node);
+
+ gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
+ void_type_node, 8, pvoid_type_node,
+ build_pointer_type (build_varargs_function_type_list (void_type_node,
+ NULL_TREE)),
+ integer_type_node, integer_type_node, pint_type, pchar_type_node,
+ integer_type_node, integer_type_node);
+
+ gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_co_sum")), "W.WW",
+ void_type_node, 5, pvoid_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
}
gfc_build_intrinsic_function_decls ();
/* Initialize INTENT(OUT) derived type dummies. As well as giving
them their default initializer, if they do not have allocatable
- components, they have their allocatable components deallocated. */
+ components, they have their allocatable components deallocated. */
static void
init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
tree present;
gfc_init_block (&init);
- for (f = proc_sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
if (f->sym && f->sym->attr.intent == INTENT_OUT
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = NULL_TREE;
+
+ /* Note: Allocatables are excluded as they are already handled
+ by the caller. */
+ if (!f->sym->attr.allocatable
+ && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
+ }
- if (f->sym->attr.optional
- || f->sym->ns->proc_name->attr.entry_master)
- {
- present = gfc_conv_expr_present (f->sym);
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- present, tmp,
- build_empty_stmt (input_location));
- }
+ if (tmp == NULL_TREE && !f->sym->attr.allocatable
+ && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
+ f->sym->backend_decl,
+ f->sym->as ? f->sym->as->rank : 0);
- gfc_add_expr_to_block (&init, tmp);
+ if (tmp != NULL_TREE && (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master))
+ {
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ present, tmp, build_empty_stmt (input_location));
}
- else if (f->sym->value)
+
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&init, tmp);
+ else if (f->sym->value && !f->sym->attr.allocatable)
gfc_init_default_dt (f->sym, &init, true);
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
&& !CLASS_DATA (f->sym)->attr.class_pointer
- && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+ && !CLASS_DATA (f->sym)->attr.allocatable)
{
- tmp = gfc_class_data_get (f->sym->backend_decl);
- if (CLASS_DATA (f->sym)->as == NULL)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
- tmp,
- CLASS_DATA (f->sym)->as ?
- CLASS_DATA (f->sym)->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
{
}
/* TODO: move to the appropriate place in resolve.c. */
if (warn_return_type && el == NULL)
- gfc_warning ("Return value of function '%s' at %L not set",
+ gfc_warning (OPT_Wreturn_type,
+ "Return value of function %qs at %L not set",
proc_sym->name, &proc_sym->declared_at);
}
else if (proc_sym->as)
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else
- gcc_assert (gfc_option.flag_f2c
- && proc_sym->ts.type == BT_COMPLEX);
+ gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
}
/* Initialize the INTENT(OUT) derived type dummy arguments. This
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
- bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
- && sym->ts.u.derived->attr.alloc_comp;
+ bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
+ && (sym->ts.u.derived->attr.alloc_comp
+ || gfc_is_finalizable (sym->ts.u.derived,
+ NULL));
if (sym->assoc)
continue;
NULL_TREE);
}
- if (sym->attr.dimension || sym->attr.codimension)
+ if (sym->ts.type == BT_CLASS
+ && (sym->attr.save || flag_max_stack_var_size == 0)
+ && CLASS_DATA (sym)->attr.allocatable)
{
- /* 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)
+ tree vptr;
+
+ if (UNLIMITED_POLY (sym))
+ vptr = null_pointer_node;
+ else
+ {
+ gfc_symbol *vsym;
+ vsym = gfc_find_derived_vtab (sym->ts.u.derived);
+ vptr = gfc_get_symbol_decl (vsym);
+ vptr = gfc_build_addr_expr (NULL, vptr);
+ }
+
+ if (CLASS_DATA (sym)->attr.dimension
+ || (CLASS_DATA (sym)->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
+ }
+ else
+ tmp = null_pointer_node;
+
+ DECL_INITIAL (sym->backend_decl)
+ = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
+ TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
+ }
+ else if (sym->attr.dimension || sym->attr.codimension
+ || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))
+ {
+ bool is_classarray = IS_CLASS_ARRAY (sym);
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ array_type tmp;
+
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
+ /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
+ tmp = as->type;
+ if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed)
+ tmp = AS_EXPLICIT;
+ switch (tmp)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
- else if (sym->attr.pointer || sym->attr.allocatable)
+ /* Allocatable and pointer arrays need to processed
+ explicitly. */
+ else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.class_pointer)
+ || array_attr->allocatable)
{
if (TREE_STATIC (sym->backend_decl))
{
gfc_trans_deferred_array (sym, block);
}
}
- else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
+ else if (sym->attr.codimension
+ && TREE_STATIC (sym->backend_decl))
{
gfc_init_block (&tmpblock);
gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
NULL_TREE);
continue;
}
- else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+ else
{
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
- if (sym_has_alloc_comp)
+ if (alloc_comp_or_fini)
{
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
case AS_ASSUMED_SIZE:
/* Must be a dummy parameter. */
- gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
+ gcc_assert (sym->attr.dummy || as->cp_was_assumed);
/* We should always pass assumed size arrays the g77 way. */
if (sym->attr.dummy)
default:
gcc_unreachable ();
}
- if (sym_has_alloc_comp && !seen_trans_deferred_array)
+ if (alloc_comp_or_fini && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block);
}
else if ((!sym->attr.dummy || sym->ts.deferred)
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable)))
{
- if (!sym->attr.save)
+ if (!sym->attr.save && flag_max_stack_var_size != 0)
{
tree descriptor = NULL_TREE;
}
else
{
+ se.descriptor_only = 1;
gfc_conv_expr (&se, e);
descriptor = se.expr;
se.expr = gfc_conv_descriptor_data_addr (se.expr);
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
/* Nullify when entering the scope. */
- gfc_add_modify (&init, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- null_pointer_node));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (se.expr), se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&init, tmp);
}
- if ((sym->attr.dummy ||sym->attr.result)
+ if ((sym->attr.dummy || sym->attr.result)
&& sym->ts.type == BT_CHARACTER
&& sym->ts.deferred)
{
gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
build_int_cst (gfc_charlen_type_node, 0));
else
- gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
+ {
+ tree tmp2;
+
+ tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node,
+ sym->ts.u.cl->backend_decl, tmp);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp2 = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp2,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&init, tmp2);
+ }
gfc_restore_backend_locus (&loc);
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- gfc_charlen_type_node, tmp,
- sym->ts.u.cl->backend_decl);
+ {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node, tmp,
+ sym->ts.u.cl->backend_decl);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ }
else
tmp = NULL_TREE;
}
/* Deallocate when leaving the scope. Nullifying is not
needed. */
- if (!sym->attr.result && !sym->attr.dummy)
+ if (!sym->attr.result && !sym->attr.dummy
+ && !sym->ns->proc_name->attr.is_main_program)
{
if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.codimension)
NULL_TREE, true, NULL,
true);
else
- tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
- true, NULL,
- sym->ts);
+ {
+ gfc_expr *expr = gfc_lval_expr_from_sym (sym);
+ tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
+ true, expr, sym->ts);
+ gfc_free_expr (expr);
+ }
}
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
- gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ gfc_symbol *vtab;
tree rhs;
gfc_save_backend_locus (&loc);
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));
+ if (UNLIMITED_POLY (sym))
+ rhs = build_int_cst (TREE_TYPE (se.expr), 0);
+ else
+ {
+ vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ 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);
}
}
else if (sym->ts.deferred)
gfc_fatal_error ("Deferred type parameter not yet supported");
- else if (sym_has_alloc_comp)
+ else if (alloc_comp_or_fini)
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
- else
+ else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
gfc_init_block (&tmpblock);
- for (f = proc_sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
{
if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
{
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
}
-static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
-
-/* Hash and equality functions for module_htab. */
-
-static hashval_t
-module_htab_do_hash (const void *x)
+struct module_hasher : ggc_hasher<module_htab_entry *>
{
- return htab_hash_string (((const struct module_htab_entry *)x)->name);
-}
+ typedef const char *compare_type;
-static int
-module_htab_eq (const void *x1, const void *x2)
-{
- return strcmp ((((const struct module_htab_entry *)x1)->name),
- (const char *)x2) == 0;
-}
+ static hashval_t hash (module_htab_entry *s) { return htab_hash_string (s); }
+ static bool
+ equal (module_htab_entry *a, const char *b)
+ {
+ return !strcmp (a->name, b);
+ }
+};
+
+static GTY (()) hash_table<module_hasher> *module_htab;
/* Hash and equality functions for module_htab's decls. */
-static hashval_t
-module_htab_decls_hash (const void *x)
+hashval_t
+module_decl_hasher::hash (tree t)
{
- const_tree t = (const_tree) x;
const_tree n = DECL_NAME (t);
if (n == NULL_TREE)
n = TYPE_NAME (TREE_TYPE (t));
return htab_hash_string (IDENTIFIER_POINTER (n));
}
-static int
-module_htab_decls_eq (const void *x1, const void *x2)
+bool
+module_decl_hasher::equal (tree t1, const char *x2)
{
- const_tree t1 = (const_tree) x1;
const_tree n1 = DECL_NAME (t1);
if (n1 == NULL_TREE)
n1 = TYPE_NAME (TREE_TYPE (t1));
- return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
+ return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
}
struct module_htab_entry *
gfc_find_module (const char *name)
{
- void **slot;
-
if (! module_htab)
- module_htab = htab_create_ggc (10, module_htab_do_hash,
- module_htab_eq, NULL);
+ module_htab = hash_table<module_hasher>::create_ggc (10);
- slot = htab_find_slot_with_hash (module_htab, name,
- htab_hash_string (name), INSERT);
+ module_htab_entry **slot
+ = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT);
if (*slot == NULL)
{
- struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
+ module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
entry->name = gfc_get_string (name);
- entry->decls = htab_create_ggc (10, module_htab_decls_hash,
- module_htab_decls_eq, NULL);
- *slot = (void *) entry;
+ entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
+ *slot = entry;
}
- return (struct module_htab_entry *) *slot;
+ return *slot;
}
void
gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
{
- void **slot;
const char *name;
if (DECL_NAME (decl))
gcc_assert (TREE_CODE (decl) == TYPE_DECL);
name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
}
- slot = htab_find_slot_with_hash (entry->decls, name,
- htab_hash_string (name), INSERT);
+ tree *slot
+ = entry->decls->find_slot_with_hash (name, htab_hash_string (name),
+ INSERT);
if (*slot == NULL)
- *slot = (void *) decl;
+ *slot = decl;
+}
+
+
+/* Generate debugging symbols for namelists. This function must come after
+ generate_local_decl to ensure that the variables in the namelist are
+ already declared. */
+
+static tree
+generate_namelist_decl (gfc_symbol * sym)
+{
+ gfc_namelist *nml;
+ tree decl;
+ vec<constructor_elt, va_gc> *nml_decls = NULL;
+
+ gcc_assert (sym->attr.flavor == FL_NAMELIST);
+ for (nml = sym->namelist; nml; nml = nml->next)
+ {
+ if (nml->sym->backend_decl == NULL_TREE)
+ {
+ nml->sym->attr.referenced = 1;
+ nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
+ }
+ DECL_IGNORED_P (nml->sym->backend_decl) = 0;
+ CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
+ }
+
+ decl = make_node (NAMELIST_DECL);
+ TREE_TYPE (decl) = void_type_node;
+ NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
+ DECL_NAME (decl) = get_identifier (sym->name);
+ return decl;
}
-static struct module_htab_entry *cur_module;
/* Output an initialized decl for a module variable. */
decl = sym->backend_decl;
gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
- /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
- if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
+ if (!sym->attr.use_assoc)
{
gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
|| TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
}
/* Don't generate variables from other modules. Variables from
- COMMONs will already have been generated. */
- if (sym->attr.use_assoc || sym->attr.in_common)
+ COMMONs and Cray pointees will already have been generated. */
+ if (sym->attr.use_assoc || sym->attr.in_common || sym->attr.cray_pointee)
return;
/* Equivalenced variables arrive here after creation. */
return;
if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
- internal_error ("backend decl for module variable %s already exists",
- sym->name);
+ gfc_internal_error ("backend decl for module variable %qs already exists",
+ sym->name);
+
+ if (sym->module && !sym->attr.result && !sym->attr.dummy
+ && (sym->attr.access == ACCESS_UNKNOWN
+ && (sym->ns->default_access == ACCESS_PRIVATE
+ || (sym->ns->default_access == ACCESS_UNKNOWN
+ && flag_module_private))))
+ sym->attr.access = ACCESS_PRIVATE;
+
+ if (warn_unused_variable && !sym->attr.referenced
+ && sym->attr.access == ACCESS_PRIVATE)
+ gfc_warning (OPT_Wunused_value,
+ "Unused PRIVATE module variable %qs declared at %L",
+ sym->name, &sym->declared_at);
/* We always want module variables to be created. */
sym->attr.referenced = 1;
for (rent = use_stmt->rename; rent; rent = rent->next)
{
tree decl, local_name;
- void **slot;
if (rent->op != INTRINSIC_NONE)
continue;
- slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
- htab_hash_string (rent->use_name),
- INSERT);
+ hashval_t hash = htab_hash_string (rent->use_name);
+ tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
+ INSERT);
if (*slot == NULL)
{
gfc_symtree *st;
DECL_IGNORED_P (decl) = 0;
DECL_INITIAL (decl) = NULL_TREE;
}
+ else if (st->n.sym->attr.flavor == FL_NAMELIST
+ && st->n.sym->attr.use_only
+ && st->n.sym->module
+ && strcmp (st->n.sym->module, use_stmt->module_name)
+ == 0)
+ {
+ decl = generate_namelist_decl (st->n.sym);
+ DECL_CONTEXT (decl) = entry->namespace_decl;
+ DECL_EXTERNAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 0;
+ DECL_INITIAL (decl) = NULL_TREE;
+ }
else
{
*slot = error_mark_node;
- htab_clear_slot (entry->decls, slot);
+ entry->decls->clear_slot (slot);
continue;
}
*slot = decl;
sym->attr.dimension, false))
return;
- if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+ if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
return;
/* Create the decl for the variable or constant. */
generate_coarray_sym_init (gfc_symbol *sym)
{
tree tmp, size, decl, token;
+ bool is_lock_type;
+ int reg_type;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
- || sym->attr.use_assoc || !sym->attr.referenced)
+ || sym->attr.use_assoc || !sym->attr.referenced
+ || sym->attr.select_type_temporary)
return;
decl = sym->backend_decl;
TREE_USED(decl) = 1;
gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
+ is_lock_type = sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
+
/* 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)));
+ /* For lock types, we pass the array size as only the library knows the
+ size of the variable. */
+ if (is_lock_type)
+ size = gfc_index_one_node;
+ else
+ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
- /* Ensure that we do not have size=0 for zero-sized arrays. */
+ /* 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));
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)));
-
+ if (is_lock_type)
+ reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
+ else
+ reg_type = GFC_CAF_COARRAY_STATIC;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
- build_int_cst (integer_type_node,
- GFC_CAF_COARRAY_STATIC), /* type. */
+ build_int_cst (integer_type_node, reg_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)
{
set_cfun (NULL);
if (decl_function_context (fndecl))
- (void) cgraph_create_node (fndecl);
+ (void) cgraph_node::create (fndecl);
else
- cgraph_finalize_function (fndecl, true);
+ cgraph_node::finalize_function (fndecl, true);
pop_function_context ();
current_function_decl = save_fn_decl;
}
+static void
+create_module_nml_decl (gfc_symbol *sym)
+{
+ if (sym->attr.flavor == FL_NAMELIST)
+ {
+ tree decl = generate_namelist_decl (sym);
+ pushdecl (decl);
+ gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+ rest_of_decl_compilation (decl, 1, 0);
+ gfc_module_add_decl (cur_module, decl);
+ }
+}
+
+
/* Generate all the required code for module variables. */
void
/* Create decls for all the module variables. */
gfc_traverse_ns (ns, gfc_create_module_variable);
+ gfc_traverse_ns (ns, create_module_nml_decl);
- if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+ if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
generate_coarray_init (ns);
cur_module = NULL;
gfc_get_symbol_decl (sym);
/* Warnings for unused dummy arguments. */
- else if (sym->attr.dummy)
+ else if (sym->attr.dummy && !sym->attr.in_namelist)
{
/* INTENT(out) dummy arguments are likely meant to be set. */
- if (gfc_option.warn_unused_dummy_argument
- && sym->attr.intent == INTENT_OUT)
+ if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
{
if (sym->ts.type != BT_DERIVED)
- gfc_warning ("Dummy argument '%s' at %L was declared "
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Dummy argument %qs at %L was declared "
"INTENT(OUT) but was not set", sym->name,
&sym->declared_at);
- else if (!gfc_has_default_initializer (sym->ts.u.derived))
- gfc_warning ("Derived-type dummy argument '%s' at %L was "
+ else if (!gfc_has_default_initializer (sym->ts.u.derived)
+ && !sym->ts.u.derived->attr.zero_comp)
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Derived-type dummy argument %qs at %L was "
"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)
+ else if (warn_unused_dummy_argument)
{
- gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
- &sym->declared_at);
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Unused dummy argument %qs at %L", sym->name,
+ &sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
{
if (sym->attr.use_only)
{
- gfc_warning ("Unused module variable '%s' which has been "
+ gfc_warning (OPT_Wunused_variable,
+ "Unused module variable %qs which has been "
"explicitly imported at %L", sym->name,
&sym->declared_at);
if (sym->backend_decl != NULL_TREE)
}
else if (!sym->attr.use_assoc)
{
- gfc_warning ("Unused variable '%s' declared at %L",
+ gfc_warning (OPT_Wunused_variable,
+ "Unused variable %qs declared at %L",
sym->name, &sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
&& !sym->attr.referenced)
{
if (!sym->attr.use_assoc)
- gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
+ gfc_warning (OPT_Wunused_parameter,
+ "Unused parameter %qs declared at %L", sym->name,
&sym->declared_at);
else if (sym->attr.use_only)
- gfc_warning ("Unused parameter '%s' which has been explicitly "
+ gfc_warning (OPT_Wunused_parameter,
+ "Unused parameter %qs which has been explicitly "
"imported at %L", sym->name, &sym->declared_at);
}
}
&& !sym->attr.use_assoc
&& sym->attr.if_source != IFSRC_IFBODY)
{
- gfc_warning ("Return value '%s' of function '%s' declared at "
+ gfc_warning (OPT_Wreturn_type,
+ "Return value %qs of function %qs declared at "
"%L not set", sym->result->name, sym->name,
&sym->result->declared_at);
{
if (!sym->attr.referenced)
{
- if (gfc_option.warn_unused_dummy_argument)
- gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
- &sym->declared_at);
+ if (warn_unused_dummy_argument)
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Unused dummy argument %qs at %L", sym->name,
+ &sym->declared_at);
}
/* Silence bogus "unused parameter" warnings from the
sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
}
+
+static void
+generate_local_nml_decl (gfc_symbol * sym)
+{
+ if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
+ {
+ tree decl = generate_namelist_decl (sym);
+ pushdecl (decl);
+ }
+}
+
+
static void
generate_local_vars (gfc_namespace * ns)
{
gfc_traverse_ns (ns, generate_local_decl);
+ gfc_traverse_ns (ns, generate_local_nml_decl);
}
{
gfc_formal_arglist *formal;
- for (formal = sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
if (formal->sym && formal->sym->ts.type == BT_CHARACTER
&& !formal->sym->ts.deferred)
{
}
-/* 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)
-{
- if (gfc_option.coarray != GFC_FCOARRAY_LIB)
- return;
-
- if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
- return;
-
- 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 ();
-}
-
-
static void
create_main_function (tree fndecl)
{
gfc_init_block (&body);
- /* Call some libgfortran initialization routines, call then MAIN__(). */
+ /* 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)
+ /* Call _gfortran_caf_init (*argc, ***argv). */
+ if (flag_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,
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
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_build_addr_expr (pppchar_type, argv));
gfc_add_expr_to_block (&body, tmp);
}
build_int_cst (integer_type_node,
0));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_backtrace));
+ build_int_cst (integer_type_node, flag_backtrace));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
- build_int_cst (integer_type_node,
- gfc_option.flag_sign_zero));
+ build_int_cst (integer_type_node, flag_sign_zero));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node,
(gfc_option.rtcheck
/* TODO: This is the -frange-check option, which no longer affects
library behavior; when bumping the library ABI this slot can be
reused for something else. As it is the last element in the
- array, we can instead leave it out altogether.
+ array, we can instead leave it out altogether. */
+ CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
+ build_int_cst (integer_type_node, 0));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node,
- gfc_option.flag_range_check));
- */
+ gfc_option.fpe_summary));
array_type = build_array_type (integer_type_node,
- build_index_type (size_int (6)));
+ build_index_type (size_int (8)));
array = build_constructor (array_type, v);
TREE_CONSTANT (array) = 1;
TREE_STATIC (array) = 1;
/* Create a static variable to hold the jump table. */
- var = gfc_create_var (array_type, "options");
+ var = build_decl (input_location, VAR_DECL,
+ create_tmp_var_name ("options"),
+ array_type);
+ DECL_ARTIFICIAL (var) = 1;
+ DECL_IGNORED_P (var) = 1;
TREE_CONSTANT (var) = 1;
TREE_STATIC (var) = 1;
TREE_READONLY (var) = 1;
DECL_INITIAL (var) = array;
+ pushdecl (var);
var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_set_options, 2,
- build_int_cst (integer_type_node, 7), var);
+ build_int_cst (integer_type_node, 9), var);
gfc_add_expr_to_block (&body, tmp);
}
/* If this is the main program and an -fconvert option was provided,
add a call to set_convert. */
- if (gfc_option.convert != GFC_CONVERT_NATIVE)
+ if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
{
tmp = build_call_expr_loc (input_location,
gfor_fndecl_set_convert, 1,
- build_int_cst (integer_type_node,
- gfc_option.convert));
+ build_int_cst (integer_type_node, flag_convert));
gfc_add_expr_to_block (&body, tmp);
}
/* If this is the main program and an -frecord-marker option was provided,
add a call to set_record_marker. */
- if (gfc_option.record_marker != 0)
+ if (flag_record_marker != 0)
{
tmp = build_call_expr_loc (input_location,
gfor_fndecl_set_record_marker, 1,
build_int_cst (integer_type_node,
- gfc_option.record_marker));
+ flag_record_marker));
gfc_add_expr_to_block (&body, tmp);
}
- if (gfc_option.max_subrecord_length != 0)
+ if (flag_max_subrecord_length != 0)
{
tmp = build_call_expr_loc (input_location,
gfor_fndecl_set_max_subrecord_length, 1,
build_int_cst (integer_type_node,
- gfc_option.max_subrecord_length));
+ flag_max_subrecord_length));
gfc_add_expr_to_block (&body, tmp);
}
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);
-
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
gfc_add_expr_to_block (&body, tmp);
}
/* Output the GENERIC tree. */
dump_function (TDI_original, ftn_main);
- cgraph_finalize_function (ftn_main, true);
+ cgraph_node::finalize_function (ftn_main, true);
if (old_context)
{
}
+static void
+is_from_ieee_module (gfc_symbol *sym)
+{
+ if (sym->from_intmod == INTMOD_IEEE_FEATURES
+ || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
+ || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
+ seen_ieee_symbol = 1;
+}
+
+
+static int
+is_ieee_module_used (gfc_namespace *ns)
+{
+ seen_ieee_symbol = 0;
+ gfc_traverse_ns (ns, is_from_ieee_module);
+ return seen_ieee_symbol;
+}
+
+
/* Generate code for a function. */
void
tree old_context;
tree decl;
tree tmp;
+ tree fpstate = NULL_TREE;
stmtblock_t init, cleanup;
stmtblock_t body;
gfc_wrapped_block try_block;
tree recurcheckvar = NULL_TREE;
gfc_symbol *sym;
gfc_symbol *previous_procedure_symbol;
- int rank;
+ int rank, ieee;
bool is_recursive;
sym = ns->proc_name;
has_coarray_vars = false;
generate_local_vars (ns);
- if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+ if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
generate_coarray_init (ns);
/* Keep the parent fake result declaration in module functions
|| (sym->attr.entry_master
&& sym->ns->entries->sym->attr.recursive);
if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
- && !is_recursive
- && !gfc_option.flag_recursive)
+ && !is_recursive && !flag_recursive)
{
char * msg;
- asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
- sym->name);
+ msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
+ sym->name);
recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
TREE_STATIC (recurcheckvar) = 1;
DECL_INITIAL (recurcheckvar) = boolean_false_node;
free (msg);
}
+ /* Check if an IEEE module is used in the procedure. If so, save
+ the floating point state. */
+ ieee = is_ieee_module_used (ns);
+ if (ieee)
+ fpstate = gfc_save_fp_state (&init);
+
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
add_argument_checking (&body, sym);
+ /* Generate !$ACC DECLARE directive. */
+ if (ns->oacc_declare_clauses)
+ {
+ tree tmp = gfc_trans_oacc_declare (&body, ns);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
{
/* TODO: move to the appropriate place in resolve.c. */
if (warn_return_type && sym == sym->result)
- gfc_warning ("Return value of function '%s' at %L not set",
+ gfc_warning (OPT_Wreturn_type,
+ "Return value of function %qs at %L not set",
sym->name, &sym->declared_at);
if (warn_return_type)
TREE_NO_WARNING(sym->backend_decl) = 1;
/* Reset recursion-check variable. */
if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
- && !is_recursive
- && !gfc_option.gfc_flag_openmp
- && recurcheckvar != NULL_TREE)
+ && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
{
gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
recurcheckvar = NULL;
}
+ /* If IEEE modules are loaded, restore the floating-point state. */
+ if (ieee)
+ gfc_restore_fp_state (&cleanup, fpstate);
+
/* Finish the function body and add init and cleanup code. */
tmp = gfc_finish_block (&body);
gfc_start_wrapped_block (&try_block, tmp);
{
BLOCK_VARS (DECL_INITIAL (fndecl))
= chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
- pointer_set_destroy (nonlocal_dummy_decl_pset);
+ delete nonlocal_dummy_decl_pset;
nonlocal_dummy_decls = NULL;
nonlocal_dummy_decl_pset = NULL;
}
}
current_function_decl = old_context;
- if (decl_function_context (fndecl) && gfc_option.coarray != GFC_FCOARRAY_LIB
- && has_coarray_vars)
- /* Register this function with cgraph just far enough to get it
- added to our parent's nested function list.
- If there are static coarrays in this function, the nested _caf_init
- function has already called cgraph_create_node, which also created
- the cgraph node for this function. */
- (void) cgraph_create_node (fndecl);
+ if (decl_function_context (fndecl))
+ {
+ /* Register this function with cgraph just far enough to get it
+ added to our parent's nested function list.
+ If there are static coarrays in this function, the nested _caf_init
+ function has already called cgraph_create_node, which also created
+ the cgraph node for this function. */
+ if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
+ (void) cgraph_node::create (fndecl);
+ }
else
- cgraph_finalize_function (fndecl, true);
+ cgraph_node::finalize_function (fndecl, true);
gfc_trans_use_stmts (ns);
gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
generate_local_vars (ns);
- if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+ if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
generate_coarray_init (ns);
decl = saved_local_decls;
projects / gcc.git / blobdiff