/* Common block and equivalence list handling
- Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Canqun Yang <canqun@nudt.edu.cn>
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "target.h"
-#include "tree.h"
-#include "toplev.h"
#include "tm.h"
-#include "rtl.h"
+#include "tree.h"
+#include "toplev.h" /* For exact_log2. */
+#include "output.h" /* For decl_default_tls_model. */
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
/* 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;
}
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_IGNORED_P (decl) = 1;
if (!com->is_bind_c)
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
else
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;
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;
}
}
{
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;
-
+ /* 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
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;
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
