/* Common block and equivalence list handling
- Copyright (C) 2000-2014 Free Software Foundation, Inc.
+ Copyright (C) 2000-2019 Free Software Foundation, Inc.
Contributed by Canqun Yang <canqun@nudt.edu.cn>
This file is part of GCC.
is examined for still-unused equivalence conditions. We create a
block for each merged equivalence list. */
-#include <map>
#include "config.h"
+#define INCLUDE_MAP
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
+#include "gfortran.h"
+#include "trans.h"
#include "stringpool.h"
+#include "fold-const.h"
#include "stor-layout.h"
#include "varasm.h"
-#include "gfortran.h"
-#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"
#include "target-memory.h"
if (strcmp (name, BLANK_COMMON_NAME) == 0)
return get_identifier (name);
- if (gfc_option.flag_underscoring)
+ if (flag_underscoring)
{
has_underscore = strchr (name, '_') != 0;
- if (gfc_option.flag_second_underscore && has_underscore)
+ if (flag_second_underscore && has_underscore)
snprintf (mangled_name, sizeof mangled_name, "%s__", name);
else
snprintf (mangled_name, sizeof mangled_name, "%s_", name);
build_equiv_decl (tree union_type, bool is_init, bool is_saved)
{
tree decl;
- char name[15];
+ char name[18];
static int serial = 0;
if (is_init)
blank common blocks may be of different sizes. */
if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
&& strcmp (com->name, BLANK_COMMON_NAME))
- gfc_warning ("Named COMMON block %qs at %L shall be of the "
+ gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
"same size as elsewhere (%lu vs %lu bytes)", com->name,
&com->where,
(unsigned long) TREE_INT_CST_LOW (size),
{
DECL_SIZE (decl) = TYPE_SIZE (union_type);
DECL_SIZE_UNIT (decl) = size;
- DECL_MODE (decl) = TYPE_MODE (union_type);
+ SET_DECL_MODE (decl, TYPE_MODE (union_type));
TREE_TYPE (decl) = union_type;
layout_decl (decl, 0);
}
TREE_STATIC (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (!com->is_bind_c)
- DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
+ SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT);
else
{
/* Do not set the alignment for bind(c) common blocks to
tree field = NULL_TREE;
field = TYPE_FIELDS (TREE_TYPE (decl));
if (DECL_CHAIN (field) == NULL_TREE)
- DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
+ SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field)));
}
DECL_USER_ALIGN (decl) = 0;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
if (com->threadprivate)
set_decl_tls_model (decl, decl_default_tls_model (decl));
- if (com->omp_declare_target)
+ if (com->omp_declare_target_link)
+ DECL_ATTRIBUTES (decl)
+ = tree_cons (get_identifier ("omp declare target link"),
+ NULL_TREE, DECL_ATTRIBUTES (decl));
+ else if (com->omp_declare_target)
DECL_ATTRIBUTES (decl)
= tree_cons (get_identifier ("omp declare target"),
NULL_TREE, DECL_ATTRIBUTES (decl));
memset (chk, '\0', (size_t)length);
for (s = head; s; s = s->next)
if (s->sym->value)
- gfc_merge_initializers (s->sym->ts, s->sym->value,
+ {
+ locus *loc = NULL;
+ if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
+ loc = &s->sym->ns->equiv->eq->expr->where;
+ gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
&data[s->offset],
&chk[s->offset],
(size_t)s->length);
+ }
for (i = 0; i < length; i++)
CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
TREE_STATIC (ctor) = 1;
DECL_INITIAL (decl) = ctor;
-#ifdef ENABLE_CHECKING
- {
- tree field, value;
- unsigned HOST_WIDE_INT idx;
- FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
- gcc_assert (TREE_CODE (field) == FIELD_DECL);
- }
-#endif
+ if (flag_checking)
+ {
+ tree field, value;
+ unsigned HOST_WIDE_INT idx;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
+ gcc_assert (TREE_CODE (field) == FIELD_DECL);
+ }
}
/* Build component reference for each variable. */
if (ar->dimen_type[i] != DIMEN_ELEMENT)
gfc_internal_error ("element_number(): Bad dimension type");
- mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+ if (as && as->lower[i])
+ mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+ else
+ mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
mpz_mul (n, n, multiplier);
mpz_add (offset, offset, n);
- mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
- mpz_add_ui (extent, extent, 1);
+ if (as && as->upper[i] && as->lower[i])
+ {
+ mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
+ mpz_add_ui (extent, extent, 1);
+ }
+ else
+ mpz_set_ui (extent, 0);
if (mpz_sgn (extent) < 0)
mpz_set_ui (extent, 0);
offset2 = calculate_offset (eq2->expr);
if (s1->offset + offset1 != s2->offset + offset2)
- gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and "
- "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
+ gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
+ "%qs at %L", s1->sym->name, &s1->sym->declared_at,
s2->sym->name, &s2->sym->declared_at);
}
"extension to COMMON %qs at %L", sym->name,
common->name, &common->where);
- if (gfc_option.flag_align_commons)
+ if (flag_align_commons)
offset = align_segment (&align);
if (offset)
if (warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
- gfc_warning ("Padding of %d bytes required before %qs in "
+ gfc_warning (OPT_Walign_commons,
+ "Padding of %d bytes required before %qs in "
"COMMON %qs at %L; reorder elements or use "
- "-fno-align-commons", (int)offset,
+ "%<-fno-align-commons%>", (int)offset,
s->sym->name, common->name, &common->where);
else
- gfc_warning ("Padding of %d bytes required before %qs in "
+ gfc_warning (OPT_Walign_commons,
+ "Padding of %d bytes required before %qs in "
"COMMON at %L; reorder elements or use "
- "-fno-align-commons", (int)offset,
+ "%<-fno-align-commons%>", (int)offset,
s->sym->name, &common->where);
}
}
if (common_segment == NULL)
{
- gfc_error ("COMMON '%s' at %L does not exist",
+ gfc_error ("COMMON %qs at %L does not exist",
common->name, &common->where);
return;
}
{
c = gfc_get_common_head ();
/* We've lost the real location, so use the location of the
- enclosing procedure. */
- c->where = ns->proc_name->declared_at;
+ enclosing procedure. If we're in a BLOCK DATA block, then
+ use the location in the sym_root. */
+ if (ns->proc_name)
+ c->where = ns->proc_name->declared_at;
+ else if (ns->is_block_data)
+ c->where = ns->sym_root->n.sym->declared_at;
strcpy (c->name, z->module);
}
else
projects / thirdparty / gcc.git / blobdiff