/* Common block and equivalence list handling
- Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Canqun Yang <canqun@nudt.edu.cn>
#include "target.h"
#include "tree.h"
#include "toplev.h"
-#include "tm.h"
-#include "rtl.h"
+#include "tm.h" /* For rtl.h. */
+#include "rtl.h" /* For decl_default_tls_model. */
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "target-memory.h"
-/* TODO: This is defined in match.h, and probably shouldn't be here also,
- but we need it for now at least and don't want to include the whole
- match.h. */
-gfc_common_head *gfc_get_common (const char *, int);
-
-
/* Holds a single variable in an equivalence set. */
typedef struct segment_info
{
/* Make sure we've got the character length. */
if (sym->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (sym->ts.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
/* Create the segment_info and fill it in. */
s = (segment_info *) gfc_getmem (sizeof (segment_info));
unsigned HOST_WIDE_INT desired_align, known_align;
name = get_identifier (h->sym->name);
- field = build_decl (FIELD_DECL, name, h->field);
- gfc_set_decl_location (field, &h->sym->declared_at);
+ field = build_decl (h->sym->declared_at.lb->location,
+ FIELD_DECL, name, h->field);
known_align = (offset & -offset) * BITS_PER_UNIT;
if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
known_align = BIGGEST_ALIGNMENT;
GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
}
+ /* If this field is volatile, mark it. */
+ if (h->sym->attr.volatile_)
+ {
+ tree new_type;
+ TREE_THIS_VOLATILE (field) = 1;
+ new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
+ TREE_TYPE (field) = new_type;
+ }
+
h->field = field;
}
}
snprintf (name, sizeof (name), "equiv.%d", serial++);
- decl = build_decl (VAR_DECL, get_identifier (name), union_type);
+ decl = build_decl (input_location,
+ VAR_DECL, get_identifier (name), union_type);
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (strcmp (com->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size", com->name, &com->where);
+ DECL_SIZE (decl) = TYPE_SIZE (union_type);
DECL_SIZE_UNIT (decl) = size;
+ DECL_MODE (decl) = TYPE_MODE (union_type);
TREE_TYPE (decl) = union_type;
+ layout_decl (decl, 0);
}
}
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
- decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
- SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com));
+ decl = build_decl (input_location,
+ VAR_DECL, get_identifier (com->name), union_type);
+ gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
- DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
+ DECL_IGNORED_P (decl) = 1;
+ if (!com->is_bind_c)
+ DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
+ else
+ {
+ /* Do not set the alignment for bind(c) common blocks to
+ BIGGEST_ALIGNMENT because that won't match what C does. Also,
+ for common blocks with one element, the alignment must be
+ that of the field within the common block in order to match
+ what C will do. */
+ tree field = NULL_TREE;
+ field = TYPE_FIELDS (TREE_TYPE (decl));
+ if (TREE_CHAIN (field) == NULL_TREE)
+ DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
+ }
DECL_USER_ALIGN (decl) = 0;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
tmp = build_range_type (gfc_array_index_type,
gfc_index_zero_node, tmp);
tmp = build_array_type (type, tmp);
- field = build_decl (FIELD_DECL, NULL_TREE, tmp);
- gfc_set_decl_location (field, &gfc_current_locus);
+ field = build_decl (gfc_current_locus.lb->location,
+ FIELD_DECL, NULL_TREE, tmp);
known_align = BIGGEST_ALIGNMENT;
init = build_constructor (TREE_TYPE (field), v);
TREE_CONSTANT (init) = 1;
- TREE_INVARIANT (init) = 1;
*field_init = init;
if (is_init)
{
tree ctor, tmp;
- HOST_WIDE_INT offset = 0;
VEC(constructor_elt,gc) *v = NULL;
if (field != NULL_TREE && field_init != NULL_TREE)
s->sym->attr.pointer || s->sym->attr.allocatable);
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
- offset = s->offset + s->length;
}
}
gcc_assert (!VEC_empty (constructor_elt, v));
ctor = build_constructor (union_type, v);
TREE_CONSTANT (ctor) = 1;
- TREE_INVARIANT (ctor) = 1;
TREE_STATIC (ctor) = 1;
DECL_INITIAL (decl) = ctor;
{
tree var_decl;
- var_decl = build_decl (VAR_DECL, DECL_NAME (s->field),
+ var_decl = build_decl (s->sym->declared_at.lb->location,
+ VAR_DECL, DECL_NAME (s->field),
TREE_TYPE (s->field));
- gfc_set_decl_location (var_decl, &s->sym->declared_at);
- TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl);
TREE_STATIC (var_decl) = TREE_STATIC (decl);
TREE_USED (var_decl) = TREE_USED (decl);
+ if (s->sym->attr.use_assoc)
+ DECL_IGNORED_P (var_decl) = 1;
if (s->sym->attr.target)
TREE_ADDRESSABLE (var_decl) = 1;
/* This is a fake variable just for debugging purposes. */
TREE_ASM_WRITTEN (var_decl) = 1;
-
- if (com)
+ /* Fake variables are not visible from other translation units. */
+ TREE_PUBLIC (var_decl) = 0;
+
+ /* To preserve identifier names in COMMON, chain to procedure
+ scope unless at top level in a module definition. */
+ if (com
+ && s->sym->ns->proc_name
+ && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
var_decl = pushdecl_top_level (var_decl);
else
gfc_add_decl_to_function (var_decl);
SET_DECL_VALUE_EXPR (var_decl,
- build3 (COMPONENT_REF, TREE_TYPE (s->field),
- decl, s->field, NULL_TREE));
+ fold_build3 (COMPONENT_REF, TREE_TYPE (s->field),
+ decl, s->field, NULL_TREE));
DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
case AR_ELEMENT:
n = element_number (&reference->u.ar);
if (element_type->type == BT_CHARACTER)
- gfc_conv_const_charlen (element_type->cl);
+ gfc_conv_const_charlen (element_type->u.cl);
element_size =
int_size_in_bytes (gfc_typenode_for_spec (element_type));
offset += n * element_size;
segment list multiple times to include indirect equivalences. Since
a new segment_info can inserted at the beginning of the segment list,
depending on its offset, we have to force a final pass through the
- loop by demanding that completion sees a pass with no matches; ie.
+ loop by demanding that completion sees a pass with no matches; i.e.,
all symbols with equiv_built set and no new equivalences found. */
static void
bool saw_equiv;
common_segment = NULL;
+ offset = 0;
current_offset = 0;
+ align = 1;
max_align = 1;
saw_equiv = false;
"extension to COMMON '%s' at %L", sym->name,
common->name, &common->where);
- offset = align_segment (&align);
+ if (gfc_option.flag_align_commons)
+ offset = align_segment (&align);
if (offset & (max_align - 1))
{
/* The required offset conflicts with previous alignment
requirements. Insert padding immediately before this
segment. */
- gfc_warning ("Padding of %d bytes required before '%s' in "
- "COMMON '%s' at %L", (int)offset, s->sym->name,
- common->name, &common->where);
- }
- else
- {
- /* Offset the whole common block. */
- apply_segment_offset (common_segment, offset);
+ if (gfc_option.warn_align_commons)
+ {
+ if (strcmp (common->name, BLANK_COMMON_NAME))
+ gfc_warning ("Padding of %d bytes required before '%s' in "
+ "COMMON '%s' at %L; reorder elements or use "
+ "-fno-align-commons", (int)offset,
+ s->sym->name, common->name, &common->where);
+ else
+ gfc_warning ("Padding of %d bytes required before '%s' in "
+ "COMMON at %L; reorder elements or use "
+ "-fno-align-commons", (int)offset,
+ s->sym->name, &common->where);
+ }
}
/* Apply the offset to the new segments. */
return;
}
- if (common_segment->offset != 0)
+ if (common_segment->offset != 0 && gfc_option.warn_align_commons)
{
- gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
- common->name, &common->where, (int)common_segment->offset);
+ if (strcmp (common->name, BLANK_COMMON_NAME))
+ gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start; "
+ "reorder elements or use -fno-align-commons",
+ common->name, &common->where, (int)common_segment->offset);
+ else
+ gfc_warning ("COMMON at %L requires %d bytes of padding at start; "
+ "reorder elements or use -fno-align-commons",
+ &common->where, (int)common_segment->offset);
}
create_common (common, common_segment, saw_equiv);
if (ns->blank_common.head != NULL)
{
c = gfc_get_common_head ();
-
- /* We've lost the real location, so use the location of the
- enclosing procedure. */
- if (ns->proc_name != NULL)
- c->where = ns->proc_name->declared_at;
- else
- c->where = ns->blank_common.head->common_head->where;
-
+ c->where = ns->blank_common.head->common_head->where;
strcpy (c->name, BLANK_COMMON_NAME);
translate_common (c, ns->blank_common.head);
}
OSDN Git Service
