Allow automatics in equivalences
If a variable with an automatic attribute appears in an equivalence statement the storage should be allocated on the stack. Note: most of this patch was provided by Jeff Law <law@redhat.com>. From-SVN: r274565
This commit is contained in:
Mark Eggleston
parent
12f78d8bed
commit
b323be611b
|
|
@ -1,3 +1,24 @@
|
|||
2019-08-16 Jeff Law <law@redhat.com>
|
||||
Mark Eggleston <mark.eggleston@codethink.com>
|
||||
|
||||
* gfortran.h: Add gfc_check_conflict declaration.
|
||||
* symbol.c (check_conflict): Rename cfg_check_conflict and remove
|
||||
static.
|
||||
* symbol.c (cfg_check_conflict): Remove automatic in equivalence
|
||||
conflict check.
|
||||
* symbol.c (save_symbol): Add check for in equivalence to stop the
|
||||
the save attribute being added.
|
||||
* trans-common.c (build_equiv_decl): Add is_auto parameter and
|
||||
add !is_auto to condition where TREE_STATIC (decl) is set.
|
||||
* trans-common.c (build_equiv_decl): Add local variable is_auto,
|
||||
set it true if an atomatic attribute is encountered in the variable
|
||||
list. Call build_equiv_decl with is_auto as an additional parameter.
|
||||
flag_dec_format_defaults is enabled.
|
||||
* trans-common.c (accumulate_equivalence_attributes) : New subroutine.
|
||||
* trans-common.c (find_equivalence) : New local variable dummy_symbol,
|
||||
accumulated equivalence attributes from each symbol then check for
|
||||
conflicts.
|
||||
|
||||
2019-08-16 Richard Biener <rguenther@suse.de>
|
||||
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_findloc): Initialize
|
||||
|
|
|
|||
|
|
@ -3007,6 +3007,7 @@ bool gfc_merge_new_implicit (gfc_typespec *);
|
|||
void gfc_set_implicit_none (bool, bool, locus *);
|
||||
void gfc_check_function_type (gfc_namespace *);
|
||||
bool gfc_is_intrinsic_typename (const char *);
|
||||
bool gfc_check_conflict (symbol_attribute *, const char *, locus *);
|
||||
|
||||
gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *);
|
||||
bool gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);
|
||||
|
|
|
|||
|
|
@ -407,8 +407,8 @@ gfc_check_function_type (gfc_namespace *ns)
|
|||
goto conflict_std;\
|
||||
}
|
||||
|
||||
static bool
|
||||
check_conflict (symbol_attribute *attr, const char *name, locus *where)
|
||||
bool
|
||||
gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
|
||||
{
|
||||
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
|
||||
*target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
|
||||
|
|
@ -544,7 +544,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
|
|||
conf (allocatable, elemental);
|
||||
|
||||
conf (in_common, automatic);
|
||||
conf (in_equivalence, automatic);
|
||||
conf (result, automatic);
|
||||
conf (use_assoc, automatic);
|
||||
conf (dummy, automatic);
|
||||
|
|
@ -1004,7 +1003,7 @@ gfc_add_attribute (symbol_attribute *attr, locus *where)
|
|||
if (check_used (attr, NULL, where))
|
||||
return false;
|
||||
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1030,7 +1029,7 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->allocatable = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1045,7 +1044,7 @@ gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->automatic = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1071,7 +1070,7 @@ gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
|
|||
}
|
||||
|
||||
attr->codimension = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1097,7 +1096,7 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
|
|||
}
|
||||
|
||||
attr->dimension = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1109,7 +1108,7 @@ gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->contiguous = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1134,7 +1133,7 @@ gfc_add_external (symbol_attribute *attr, locus *where)
|
|||
|
||||
attr->external = 1;
|
||||
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1153,7 +1152,7 @@ gfc_add_intrinsic (symbol_attribute *attr, locus *where)
|
|||
|
||||
attr->intrinsic = 1;
|
||||
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1171,7 +1170,7 @@ gfc_add_optional (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->optional = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
bool
|
||||
|
|
@ -1184,7 +1183,7 @@ gfc_add_kind (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->pdt_kind = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
bool
|
||||
|
|
@ -1197,7 +1196,7 @@ gfc_add_len (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->pdt_len = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1222,7 +1221,7 @@ gfc_add_pointer (symbol_attribute *attr, locus *where)
|
|||
else
|
||||
attr->pointer = 1;
|
||||
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1234,7 +1233,7 @@ gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
|
|||
return false;
|
||||
|
||||
attr->cray_pointer = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1253,7 +1252,7 @@ gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->cray_pointee = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1272,7 +1271,7 @@ gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
|
|||
}
|
||||
|
||||
attr->is_protected = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1284,7 +1283,7 @@ gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->result = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1317,7 +1316,7 @@ gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
|
|||
}
|
||||
|
||||
attr->save = s;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1337,7 +1336,7 @@ gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
|
|||
}
|
||||
|
||||
attr->value = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1370,7 +1369,7 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
|
|||
|
||||
attr->volatile_ = 1;
|
||||
attr->volatile_ns = gfc_current_ns;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1389,7 +1388,7 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
|
|||
|
||||
attr->asynchronous = 1;
|
||||
attr->asynchronous_ns = gfc_current_ns;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1407,7 +1406,7 @@ gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
|
|||
}
|
||||
|
||||
attr->threadprivate = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1423,7 +1422,7 @@ gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
|
|||
return true;
|
||||
|
||||
attr->omp_declare_target = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1439,7 +1438,7 @@ gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
|
|||
return true;
|
||||
|
||||
attr->omp_declare_target_link = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1454,7 +1453,7 @@ gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
|
|||
return true;
|
||||
|
||||
attr->oacc_declare_create = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1469,7 +1468,7 @@ gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
|
|||
return true;
|
||||
|
||||
attr->oacc_declare_copyin = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1484,7 +1483,7 @@ gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
|
|||
return true;
|
||||
|
||||
attr->oacc_declare_deviceptr = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1499,7 +1498,7 @@ gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
|
|||
return true;
|
||||
|
||||
attr->oacc_declare_device_resident = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1517,7 +1516,7 @@ gfc_add_target (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->target = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1530,7 +1529,7 @@ gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
|
|||
|
||||
/* Duplicate dummy arguments are allowed due to ENTRY statements. */
|
||||
attr->dummy = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1543,7 +1542,7 @@ gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
|
|||
|
||||
/* Duplicate attribute already checked for. */
|
||||
attr->in_common = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1553,7 +1552,7 @@ gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
|
|||
|
||||
/* Duplicate attribute already checked for. */
|
||||
attr->in_equivalence = 1;
|
||||
if (!check_conflict (attr, name, where))
|
||||
if (!gfc_check_conflict (attr, name, where))
|
||||
return false;
|
||||
|
||||
if (attr->flavor == FL_VARIABLE)
|
||||
|
|
@ -1571,7 +1570,7 @@ gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->data = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1580,7 +1579,7 @@ gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
|
|||
{
|
||||
|
||||
attr->in_namelist = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1592,7 +1591,7 @@ gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->sequence = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1610,7 +1609,7 @@ gfc_add_elemental (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->elemental = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1628,7 +1627,7 @@ gfc_add_pure (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->pure = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1646,7 +1645,7 @@ gfc_add_recursive (symbol_attribute *attr, locus *where)
|
|||
}
|
||||
|
||||
attr->recursive = 1;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1664,7 +1663,7 @@ gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
|
|||
}
|
||||
|
||||
attr->entry = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1677,7 +1676,7 @@ gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->function = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1696,7 +1695,7 @@ gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
|
|||
compiler-generated), do not check. See PR 84394. */
|
||||
|
||||
if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA)
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
else
|
||||
return true;
|
||||
}
|
||||
|
|
@ -1711,7 +1710,7 @@ gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
|
|||
return false;
|
||||
|
||||
attr->generic = 1;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1734,7 +1733,7 @@ gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
|
|||
|
||||
attr->procedure = 1;
|
||||
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1749,7 +1748,7 @@ gfc_add_abstract (symbol_attribute* attr, locus* where)
|
|||
|
||||
attr->abstract = 1;
|
||||
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1795,7 +1794,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
|
|||
|
||||
attr->flavor = f;
|
||||
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1842,7 +1841,7 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t,
|
|||
|| attr->dimension))
|
||||
return false;
|
||||
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1856,7 +1855,7 @@ gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
|
|||
if (attr->intent == INTENT_UNKNOWN)
|
||||
{
|
||||
attr->intent = intent;
|
||||
return check_conflict (attr, NULL, where);
|
||||
return gfc_check_conflict (attr, NULL, where);
|
||||
}
|
||||
|
||||
if (where == NULL)
|
||||
|
|
@ -1881,7 +1880,7 @@ gfc_add_access (symbol_attribute *attr, gfc_access access,
|
|||
|| (attr->use_assoc && attr->access != ACCESS_PRIVATE))
|
||||
{
|
||||
attr->access = access;
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
if (where == NULL)
|
||||
|
|
@ -1913,7 +1912,7 @@ gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
|
|||
if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
|
||||
return false;
|
||||
|
||||
return check_conflict (attr, name, where);
|
||||
return gfc_check_conflict (attr, name, where);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -4244,6 +4243,7 @@ save_symbol (gfc_symbol *sym)
|
|||
return;
|
||||
|
||||
if (sym->attr.in_common
|
||||
|| sym->attr.in_equivalence
|
||||
|| sym->attr.dummy
|
||||
|| sym->attr.result
|
||||
|| sym->attr.flavor != FL_VARIABLE)
|
||||
|
|
|
|||
|
|
@ -339,7 +339,7 @@ build_field (segment_info *h, tree union_type, record_layout_info rli)
|
|||
/* Get storage for local equivalence. */
|
||||
|
||||
static tree
|
||||
build_equiv_decl (tree union_type, bool is_init, bool is_saved)
|
||||
build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto)
|
||||
{
|
||||
tree decl;
|
||||
char name[18];
|
||||
|
|
@ -359,8 +359,8 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved)
|
|||
DECL_ARTIFICIAL (decl) = 1;
|
||||
DECL_IGNORED_P (decl) = 1;
|
||||
|
||||
if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|
||||
|| is_saved)
|
||||
if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|
||||
|| is_saved))
|
||||
TREE_STATIC (decl) = 1;
|
||||
|
||||
TREE_ADDRESSABLE (decl) = 1;
|
||||
|
|
@ -611,6 +611,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
|||
tree decl;
|
||||
bool is_init = false;
|
||||
bool is_saved = false;
|
||||
bool is_auto = false;
|
||||
|
||||
/* Declare the variables inside the common block.
|
||||
If the current common block contains any equivalence object, then
|
||||
|
|
@ -654,6 +655,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
|||
/* Has SAVE attribute. */
|
||||
if (s->sym->attr.save)
|
||||
is_saved = true;
|
||||
|
||||
/* Has AUTOMATIC attribute. */
|
||||
if (s->sym->attr.automatic)
|
||||
is_auto = true;
|
||||
}
|
||||
|
||||
finish_record_layout (rli, true);
|
||||
|
|
@ -661,7 +666,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
|||
if (com)
|
||||
decl = build_common_decl (com, union_type, is_init);
|
||||
else
|
||||
decl = build_equiv_decl (union_type, is_init, is_saved);
|
||||
decl = build_equiv_decl (union_type, is_init, is_saved, is_auto);
|
||||
|
||||
if (is_init)
|
||||
{
|
||||
|
|
@ -948,6 +953,59 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
|
|||
confirm_condition (f, eq1, n, eq2);
|
||||
}
|
||||
|
||||
static void
|
||||
accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e)
|
||||
{
|
||||
symbol_attribute attr = e->expr->symtree->n.sym->attr;
|
||||
|
||||
dummy_symbol->dummy |= attr.dummy;
|
||||
dummy_symbol->pointer |= attr.pointer;
|
||||
dummy_symbol->target |= attr.target;
|
||||
dummy_symbol->external |= attr.external;
|
||||
dummy_symbol->intrinsic |= attr.intrinsic;
|
||||
dummy_symbol->allocatable |= attr.allocatable;
|
||||
dummy_symbol->elemental |= attr.elemental;
|
||||
dummy_symbol->recursive |= attr.recursive;
|
||||
dummy_symbol->in_common |= attr.in_common;
|
||||
dummy_symbol->result |= attr.result;
|
||||
dummy_symbol->in_namelist |= attr.in_namelist;
|
||||
dummy_symbol->optional |= attr.optional;
|
||||
dummy_symbol->entry |= attr.entry;
|
||||
dummy_symbol->function |= attr.function;
|
||||
dummy_symbol->subroutine |= attr.subroutine;
|
||||
dummy_symbol->dimension |= attr.dimension;
|
||||
dummy_symbol->in_equivalence |= attr.in_equivalence;
|
||||
dummy_symbol->use_assoc |= attr.use_assoc;
|
||||
dummy_symbol->cray_pointer |= attr.cray_pointer;
|
||||
dummy_symbol->cray_pointee |= attr.cray_pointee;
|
||||
dummy_symbol->data |= attr.data;
|
||||
dummy_symbol->value |= attr.value;
|
||||
dummy_symbol->volatile_ |= attr.volatile_;
|
||||
dummy_symbol->is_protected |= attr.is_protected;
|
||||
dummy_symbol->is_bind_c |= attr.is_bind_c;
|
||||
dummy_symbol->procedure |= attr.procedure;
|
||||
dummy_symbol->proc_pointer |= attr.proc_pointer;
|
||||
dummy_symbol->abstract |= attr.abstract;
|
||||
dummy_symbol->asynchronous |= attr.asynchronous;
|
||||
dummy_symbol->codimension |= attr.codimension;
|
||||
dummy_symbol->contiguous |= attr.contiguous;
|
||||
dummy_symbol->generic |= attr.generic;
|
||||
dummy_symbol->automatic |= attr.automatic;
|
||||
dummy_symbol->threadprivate |= attr.threadprivate;
|
||||
dummy_symbol->omp_declare_target |= attr.omp_declare_target;
|
||||
dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link;
|
||||
dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin;
|
||||
dummy_symbol->oacc_declare_create |= attr.oacc_declare_create;
|
||||
dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr;
|
||||
dummy_symbol->oacc_declare_device_resident
|
||||
|= attr.oacc_declare_device_resident;
|
||||
|
||||
/* Not strictly correct, but probably close enough. */
|
||||
if (attr.save > dummy_symbol->save)
|
||||
dummy_symbol->save = attr.save;
|
||||
if (attr.access > dummy_symbol->access)
|
||||
dummy_symbol->access = attr.access;
|
||||
}
|
||||
|
||||
/* Given a segment element, search through the equivalence lists for unused
|
||||
conditions that involve the symbol. Add these rules to the segment. */
|
||||
|
|
@ -965,9 +1023,12 @@ find_equivalence (segment_info *n)
|
|||
eq = NULL;
|
||||
|
||||
/* Search the equivalence list, including the root (first) element
|
||||
for the symbol that owns the segment. */
|
||||
for the symbol that owns the segment. */
|
||||
symbol_attribute dummy_symbol;
|
||||
memset (&dummy_symbol, 0, sizeof (dummy_symbol));
|
||||
for (e2 = e1; e2; e2 = e2->eq)
|
||||
{
|
||||
accumulate_equivalence_attributes (&dummy_symbol, e2);
|
||||
if (!e2->used && e2->expr->symtree->n.sym == n->sym)
|
||||
{
|
||||
eq = e2;
|
||||
|
|
@ -975,6 +1036,8 @@ find_equivalence (segment_info *n)
|
|||
}
|
||||
}
|
||||
|
||||
gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where);
|
||||
|
||||
/* Go to the next root element. */
|
||||
if (eq == NULL)
|
||||
continue;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2019-08-16 Mark Eggleston <mark.eggleston@codethink.com>
|
||||
|
||||
* gfortran.dg/auto_in_equiv_1.f90: New test.
|
||||
* gfortran.dg/auto_in_equiv_2.f90: New test.
|
||||
* gfortran.dg/auto_in_equiv_3.f90: New test.
|
||||
|
||||
2019-08-16 Richard Biener <rguenther@suse.de>
|
||||
|
||||
* gcc.dg/tree-ssa/forwprop-31.c: Adjust.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,36 @@
|
|||
! { dg-compile }
|
||||
|
||||
! Contributed by Mark Eggleston <mark.eggleston@codethink.com>
|
||||
program test
|
||||
call suba(0)
|
||||
call subb(0)
|
||||
call suba(1)
|
||||
|
||||
contains
|
||||
subroutine suba(option)
|
||||
integer, intent(in) :: option
|
||||
integer, automatic :: a ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" }
|
||||
integer :: b
|
||||
integer :: c
|
||||
equivalence (a, b)
|
||||
if (option.eq.0) then
|
||||
! initialise a and c
|
||||
a = 9
|
||||
c = 99
|
||||
if (a.ne.b) stop 1
|
||||
if (loc(a).ne.loc(b)) stop 2
|
||||
else
|
||||
! a should've been overwritten
|
||||
if (a.eq.9) stop 3
|
||||
end if
|
||||
end subroutine suba
|
||||
|
||||
subroutine subb(dummy)
|
||||
integer, intent(in) :: dummy
|
||||
integer, automatic :: x ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" }
|
||||
integer :: y
|
||||
x = 77
|
||||
y = 7
|
||||
end subroutine subb
|
||||
|
||||
end program test
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! { dg-run }
|
||||
! { dg-options "-fdec-static" }
|
||||
|
||||
! Contributed by Mark Eggleston <mark.eggleston@codethink.com>
|
||||
|
||||
program test
|
||||
call suba(0)
|
||||
call subb(0)
|
||||
call suba(1)
|
||||
|
||||
contains
|
||||
subroutine suba(option)
|
||||
integer, intent(in) :: option
|
||||
integer, automatic :: a
|
||||
integer :: b
|
||||
integer :: c
|
||||
equivalence (a, b)
|
||||
if (option.eq.0) then
|
||||
! initialise a and c
|
||||
a = 9
|
||||
c = 99
|
||||
if (a.ne.b) stop 1
|
||||
if (loc(a).ne.loc(b)) stop 2
|
||||
else
|
||||
! a should've been overwritten
|
||||
if (a.eq.9) stop 3
|
||||
end if
|
||||
end subroutine suba
|
||||
|
||||
subroutine subb(dummy)
|
||||
integer, intent(in) :: dummy
|
||||
integer, automatic :: x
|
||||
integer :: y
|
||||
x = 77
|
||||
y = 7
|
||||
end subroutine subb
|
||||
|
||||
end program test
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
! { dg-run }
|
||||
! { dg-options "-fdec-static -fno-automatic" }
|
||||
|
||||
! Contributed by Mark Eggleston <mark.eggleston@codethink.com>
|
||||
|
||||
! Storage is NOT on the static unless explicitly specified using the
|
||||
! DEC extension "automatic". The address of the first local variable
|
||||
! is used to determine that storage for the automatic local variable
|
||||
! is different to that of a local variable with no attributes. The
|
||||
! contents of the local variable in suba should be overwritten by the
|
||||
! call to subb.
|
||||
!
|
||||
program test
|
||||
integer :: dummy
|
||||
integer, parameter :: address = kind(loc(dummy))
|
||||
integer(address) :: ad1
|
||||
integer(address) :: ad2
|
||||
integer(address) :: ad3
|
||||
logical :: ok
|
||||
|
||||
call suba(0, ad1)
|
||||
call subb(0, ad2)
|
||||
call suba(1, ad1)
|
||||
call subc(0, ad3)
|
||||
ok = (ad1.eq.ad3).and.(ad1.ne.ad2)
|
||||
if (.not.ok) stop 4
|
||||
|
||||
contains
|
||||
subroutine suba(option, addr)
|
||||
integer, intent(in) :: option
|
||||
integer(address), intent(out) :: addr
|
||||
integer, automatic :: a
|
||||
integer :: b
|
||||
equivalence (a, b)
|
||||
addr = loc(a)
|
||||
if (option.eq.0) then
|
||||
! initialise a and c
|
||||
a = 9
|
||||
if (a.ne.b) stop 1
|
||||
if (loc(a).ne.loc(b)) stop 2
|
||||
else
|
||||
! a should've been overwritten
|
||||
if (a.eq.9) stop 3
|
||||
end if
|
||||
end subroutine suba
|
||||
|
||||
subroutine subb(dummy, addr)
|
||||
integer, intent(in) :: dummy
|
||||
integer(address), intent(out) :: addr
|
||||
integer :: x
|
||||
addr = loc(x)
|
||||
x = 77
|
||||
end subroutine subb
|
||||
|
||||
subroutine subc(dummy, addr)
|
||||
integer, intent(in) :: dummy
|
||||
integer(address), intent(out) :: addr
|
||||
integer, automatic :: y
|
||||
addr = loc(y)
|
||||
y = 77
|
||||
end subroutine subc
|
||||
|
||||
end program test
|
||||
Loading…
Reference in New Issue