static void
finish_equivalences (gfc_namespace *ns)
{
gfc_equiv *z, *y;
gfc_symbol *sym;
HOST_WIDE_INT offset;
unsigned HOST_WIDE_INT align;
bool dummy;
for (z = ns->equiv; z; z = z->next)
for (y = z->eq; y; y = y->eq)
{
if (y->used)
continue;
sym = z->expr->symtree->n.sym;
current_segment = get_segment_info (sym, 0);
/* All objects directly or indirectly equivalenced with this symbol. */
add_equivalences (&dummy);
/* Align the block. */
offset = align_segment (&align);
/* Ensure all offsets are positive. */
offset -= current_segment->offset & ~(align - 1);
apply_segment_offset (current_segment, offset);
/* Create the decl. */
create_common (NULL, current_segment, true);
break;
}
}
static void
finish_equivalences (gfc_namespace *ns)
{
gfc_equiv *z, *y;
gfc_symbol *sym;
gfc_common_head * c;
HOST_WIDE_INT offset;
unsigned HOST_WIDE_INT align;
bool dummy;
for (z = ns->equiv; z; z = z->next)
for (y = z->eq; y; y = y->eq)
{
if (y->used)
continue;
sym = z->expr->symtree->n.sym;
current_segment = get_segment_info (sym, 0);
/* All objects directly or indirectly equivalenced with this
symbol. */
add_equivalences (&dummy);
/* Align the block. */
offset = align_segment (&align);
/* Ensure all offsets are positive. */
offset -= current_segment->offset & ~(align - 1);
apply_segment_offset (current_segment, offset);
/* Create the decl. If this is a module equivalence, it has a
unique name, pointed to by z->module. This is written to a
gfc_common_header to push create_common into using
build_common_decl, so that the equivalence appears as an
external symbol. Otherwise, a local declaration is built using
build_equiv_decl. */
if (z->module)
{
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;
strcpy (c->name, z->module);
}
else
c = NULL;
create_common (c, current_segment, true);
break;
}
}
static void
translate_common (gfc_common_head *common, gfc_symbol *var_list)
{
gfc_symbol *sym;
segment_info *s;
segment_info *common_segment;
HOST_WIDE_INT offset;
HOST_WIDE_INT current_offset;
unsigned HOST_WIDE_INT align;
bool saw_equiv;
common_segment = NULL;
offset = 0;
current_offset = 0;
align = 1;
saw_equiv = false;
/* Add symbols to the segment. */
for (sym = var_list; sym; sym = sym->common_next)
{
current_segment = common_segment;
s = find_segment_info (sym);
/* Symbol has already been added via an equivalence. Multiple
use associations of the same common block result in equiv_built
being set but no information about the symbol in the segment. */
if (s && sym->equiv_built)
{
/* Ensure the current location is properly aligned. */
align = TYPE_ALIGN_UNIT (s->field);
current_offset = (current_offset + align - 1) &~ (align - 1);
/* Verify that it ended up where we expect it. */
if (s->offset != current_offset)
{
gfc_error ("Equivalence for '%s' does not match ordering of "
"COMMON '%s' at %L", sym->name,
common->name, &common->where);
}
}
else
{
/* A symbol we haven't seen before. */
s = current_segment = get_segment_info (sym, current_offset);
/* Add all objects directly or indirectly equivalenced with this
symbol. */
add_equivalences (&saw_equiv);
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid "
"extension to COMMON '%s' at %L", sym->name,
common->name, &common->where);
if (gfc_option.flag_align_commons)
offset = align_segment (&align);
if (offset)
{
/* The required offset conflicts with previous alignment
requirements. Insert padding immediately before this
segment. */
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. */
apply_segment_offset (current_segment, offset);
current_offset += offset;
/* Add the new segments to the common block. */
common_segment = add_segments (common_segment, current_segment);
}
/* The offset of the next common variable. */
current_offset += s->length;
}
if (common_segment == NULL)
{
gfc_error ("COMMON '%s' at %L does not exist",
common->name, &common->where);
return;
}
if (common_segment->offset != 0 && gfc_option.warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
"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; "
"reorder elements or use -fno-align-commons",
&common->where, (int)common_segment->offset);
}
create_common (common, common_segment, saw_equiv);
}
static void
translate_common (gfc_common_head *common, gfc_symbol *var_list)
{
gfc_symbol *sym;
segment_info *s;
segment_info *common_segment;
HOST_WIDE_INT offset;
HOST_WIDE_INT current_offset;
unsigned HOST_WIDE_INT align;
unsigned HOST_WIDE_INT max_align;
bool saw_equiv;
common_segment = NULL;
current_offset = 0;
max_align = 1;
saw_equiv = false;
/* Add symbols to the segment. */
for (sym = var_list; sym; sym = sym->common_next)
{
if (sym->equiv_built)
{
/* Symbol has already been added via an equivalence. */
current_segment = common_segment;
s = find_segment_info (sym);
/* Ensure the current location is properly aligned. */
align = TYPE_ALIGN_UNIT (s->field);
current_offset = (current_offset + align - 1) &~ (align - 1);
/* Verify that it ended up where we expect it. */
if (s->offset != current_offset)
{
gfc_error ("Equivalence for '%s' does not match ordering of "
"COMMON '%s' at %L", sym->name,
common->name, &common->where);
}
}
else
{
/* A symbol we haven't seen before. */
s = current_segment = get_segment_info (sym, current_offset);
/* Add all objects directly or indirectly equivalenced with this
symbol. */
add_equivalences (&saw_equiv);
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid "
"extension to COMMON '%s' at %L", sym->name,
common->name, &common->where);
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", offset, s->sym->name,
common->name, &common->where);
}
else
{
/* Offset the whole common block. */
apply_segment_offset (common_segment, offset);
}
/* Apply the offset to the new segments. */
apply_segment_offset (current_segment, offset);
current_offset += offset;
if (max_align < align)
max_align = align;
/* Add the new segments to the common block. */
common_segment = add_segments (common_segment, current_segment);
}
/* The offset of the next common variable. */
current_offset += s->length;
}
if (common_segment->offset != 0)
{
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
common->name, &common->where, common_segment->offset);
}
create_common (common, common_segment, saw_equiv);
}
