/* Common block and equivalence list handling
|
/* Common block and equivalence list handling
|
Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Canqun Yang <canqun@nudt.edu.cn>
|
Contributed by Canqun Yang <canqun@nudt.edu.cn>
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
GCC is free software; you can redistribute it and/or modify it under
|
the terms of the GNU General Public License as published by the Free
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
/* The core algorithm is based on Andy Vaught's g95 tree. Also the
|
/* The core algorithm is based on Andy Vaught's g95 tree. Also the
|
way to build UNION_TYPE is borrowed from Richard Henderson.
|
way to build UNION_TYPE is borrowed from Richard Henderson.
|
|
|
Transform common blocks. An integral part of this is processing
|
Transform common blocks. An integral part of this is processing
|
equivalence variables. Equivalenced variables that are not in a
|
equivalence variables. Equivalenced variables that are not in a
|
common block end up in a private block of their own.
|
common block end up in a private block of their own.
|
|
|
Each common block or local equivalence list is declared as a union.
|
Each common block or local equivalence list is declared as a union.
|
Variables within the block are represented as a field within the
|
Variables within the block are represented as a field within the
|
block with the proper offset.
|
block with the proper offset.
|
|
|
So if two variables are equivalenced, they just point to a common
|
So if two variables are equivalenced, they just point to a common
|
area in memory.
|
area in memory.
|
|
|
Mathematically, laying out an equivalence block is equivalent to
|
Mathematically, laying out an equivalence block is equivalent to
|
solving a linear system of equations. The matrix is usually a
|
solving a linear system of equations. The matrix is usually a
|
sparse matrix in which each row contains all zero elements except
|
sparse matrix in which each row contains all zero elements except
|
for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
|
for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
|
matrix is usually block diagonal. The system can be
|
matrix is usually block diagonal. The system can be
|
overdetermined, underdetermined or have a unique solution. If the
|
overdetermined, underdetermined or have a unique solution. If the
|
system is inconsistent, the program is not standard conforming.
|
system is inconsistent, the program is not standard conforming.
|
The solution vector is integral, since all of the pivots are +1 or -1.
|
The solution vector is integral, since all of the pivots are +1 or -1.
|
|
|
How we lay out an equivalence block is a little less complicated.
|
How we lay out an equivalence block is a little less complicated.
|
In an equivalence list with n elements, there are n-1 conditions to
|
In an equivalence list with n elements, there are n-1 conditions to
|
be satisfied. The conditions partition the variables into what we
|
be satisfied. The conditions partition the variables into what we
|
will call segments. If A and B are equivalenced then A and B are
|
will call segments. If A and B are equivalenced then A and B are
|
in the same segment. If B and C are equivalenced as well, then A,
|
in the same segment. If B and C are equivalenced as well, then A,
|
B and C are in a segment and so on. Each segment is a block of
|
B and C are in a segment and so on. Each segment is a block of
|
memory that has one or more variables equivalenced in some way. A
|
memory that has one or more variables equivalenced in some way. A
|
common block is made up of a series of segments that are joined one
|
common block is made up of a series of segments that are joined one
|
after the other. In the linear system, a segment is a block
|
after the other. In the linear system, a segment is a block
|
diagonal.
|
diagonal.
|
|
|
To lay out a segment we first start with some variable and
|
To lay out a segment we first start with some variable and
|
determine its length. The first variable is assumed to start at
|
determine its length. The first variable is assumed to start at
|
offset one and extends to however long it is. We then traverse the
|
offset one and extends to however long it is. We then traverse the
|
list of equivalences to find an unused condition that involves at
|
list of equivalences to find an unused condition that involves at
|
least one of the variables currently in the segment.
|
least one of the variables currently in the segment.
|
|
|
Each equivalence condition amounts to the condition B+b=C+c where B
|
Each equivalence condition amounts to the condition B+b=C+c where B
|
and C are the offsets of the B and C variables, and b and c are
|
and C are the offsets of the B and C variables, and b and c are
|
constants which are nonzero for array elements, substrings or
|
constants which are nonzero for array elements, substrings or
|
structure components. So for
|
structure components. So for
|
|
|
EQUIVALENCE(B(2), C(3))
|
EQUIVALENCE(B(2), C(3))
|
we have
|
we have
|
B + 2*size of B's elements = C + 3*size of C's elements.
|
B + 2*size of B's elements = C + 3*size of C's elements.
|
|
|
If B and C are known we check to see if the condition already
|
If B and C are known we check to see if the condition already
|
holds. If B is known we can solve for C. Since we know the length
|
holds. If B is known we can solve for C. Since we know the length
|
of C, we can see if the minimum and maximum extents of the segment
|
of C, we can see if the minimum and maximum extents of the segment
|
are affected. Eventually, we make a full pass through the
|
are affected. Eventually, we make a full pass through the
|
equivalence list without finding any new conditions and the segment
|
equivalence list without finding any new conditions and the segment
|
is fully specified.
|
is fully specified.
|
|
|
At this point, the segment is added to the current common block.
|
At this point, the segment is added to the current common block.
|
Since we know the minimum extent of the segment, everything in the
|
Since we know the minimum extent of the segment, everything in the
|
segment is translated to its position in the common block. The
|
segment is translated to its position in the common block. The
|
usual case here is that there are no equivalence statements and the
|
usual case here is that there are no equivalence statements and the
|
common block is series of segments with one variable each, which is
|
common block is series of segments with one variable each, which is
|
a diagonal matrix in the matrix formulation.
|
a diagonal matrix in the matrix formulation.
|
|
|
Each segment is described by a chain of segment_info structures. Each
|
Each segment is described by a chain of segment_info structures. Each
|
segment_info structure describes the extents of a single variable within
|
segment_info structure describes the extents of a single variable within
|
the segment. This list is maintained in the order the elements are
|
the segment. This list is maintained in the order the elements are
|
positioned withing the segment. If two elements have the same starting
|
positioned withing the segment. If two elements have the same starting
|
offset the smaller will come first. If they also have the same size their
|
offset the smaller will come first. If they also have the same size their
|
ordering is undefined.
|
ordering is undefined.
|
|
|
Once all common blocks have been created, the list of equivalences
|
Once all common blocks have been created, the list of equivalences
|
is examined for still-unused equivalence conditions. We create a
|
is examined for still-unused equivalence conditions. We create a
|
block for each merged equivalence list. */
|
block for each merged equivalence list. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "coretypes.h"
|
#include "coretypes.h"
|
#include "target.h"
|
#include "target.h"
|
#include "tree.h"
|
#include "tree.h"
|
#include "toplev.h"
|
#include "toplev.h"
|
#include "tm.h"
|
#include "tm.h"
|
#include "rtl.h"
|
#include "rtl.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "trans.h"
|
#include "trans.h"
|
#include "trans-types.h"
|
#include "trans-types.h"
|
#include "trans-const.h"
|
#include "trans-const.h"
|
#include "target-memory.h"
|
#include "target-memory.h"
|
|
|
|
|
/* Holds a single variable in an equivalence set. */
|
/* Holds a single variable in an equivalence set. */
|
typedef struct segment_info
|
typedef struct segment_info
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
HOST_WIDE_INT offset;
|
HOST_WIDE_INT offset;
|
HOST_WIDE_INT length;
|
HOST_WIDE_INT length;
|
/* This will contain the field type until the field is created. */
|
/* This will contain the field type until the field is created. */
|
tree field;
|
tree field;
|
struct segment_info *next;
|
struct segment_info *next;
|
} segment_info;
|
} segment_info;
|
|
|
static segment_info * current_segment;
|
static segment_info * current_segment;
|
static gfc_namespace *gfc_common_ns = NULL;
|
static gfc_namespace *gfc_common_ns = NULL;
|
|
|
|
|
/* Make a segment_info based on a symbol. */
|
/* Make a segment_info based on a symbol. */
|
|
|
static segment_info *
|
static segment_info *
|
get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
|
get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
|
{
|
{
|
segment_info *s;
|
segment_info *s;
|
|
|
/* Make sure we've got the character length. */
|
/* Make sure we've got the character length. */
|
if (sym->ts.type == BT_CHARACTER)
|
if (sym->ts.type == BT_CHARACTER)
|
gfc_conv_const_charlen (sym->ts.u.cl);
|
gfc_conv_const_charlen (sym->ts.u.cl);
|
|
|
/* Create the segment_info and fill it in. */
|
/* Create the segment_info and fill it in. */
|
s = (segment_info *) gfc_getmem (sizeof (segment_info));
|
s = (segment_info *) gfc_getmem (sizeof (segment_info));
|
s->sym = sym;
|
s->sym = sym;
|
/* We will use this type when building the segment aggregate type. */
|
/* We will use this type when building the segment aggregate type. */
|
s->field = gfc_sym_type (sym);
|
s->field = gfc_sym_type (sym);
|
s->length = int_size_in_bytes (s->field);
|
s->length = int_size_in_bytes (s->field);
|
s->offset = offset;
|
s->offset = offset;
|
|
|
return s;
|
return s;
|
}
|
}
|
|
|
|
|
/* Add a copy of a segment list to the namespace. This is specifically for
|
/* Add a copy of a segment list to the namespace. This is specifically for
|
equivalence segments, so that dependency checking can be done on
|
equivalence segments, so that dependency checking can be done on
|
equivalence group members. */
|
equivalence group members. */
|
|
|
static void
|
static void
|
copy_equiv_list_to_ns (segment_info *c)
|
copy_equiv_list_to_ns (segment_info *c)
|
{
|
{
|
segment_info *f;
|
segment_info *f;
|
gfc_equiv_info *s;
|
gfc_equiv_info *s;
|
gfc_equiv_list *l;
|
gfc_equiv_list *l;
|
|
|
l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list));
|
l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list));
|
|
|
l->next = c->sym->ns->equiv_lists;
|
l->next = c->sym->ns->equiv_lists;
|
c->sym->ns->equiv_lists = l;
|
c->sym->ns->equiv_lists = l;
|
|
|
for (f = c; f; f = f->next)
|
for (f = c; f; f = f->next)
|
{
|
{
|
s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
|
s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
|
s->next = l->equiv;
|
s->next = l->equiv;
|
l->equiv = s;
|
l->equiv = s;
|
s->sym = f->sym;
|
s->sym = f->sym;
|
s->offset = f->offset;
|
s->offset = f->offset;
|
s->length = f->length;
|
s->length = f->length;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Add combine segment V and segment LIST. */
|
/* Add combine segment V and segment LIST. */
|
|
|
static segment_info *
|
static segment_info *
|
add_segments (segment_info *list, segment_info *v)
|
add_segments (segment_info *list, segment_info *v)
|
{
|
{
|
segment_info *s;
|
segment_info *s;
|
segment_info *p;
|
segment_info *p;
|
segment_info *next;
|
segment_info *next;
|
|
|
p = NULL;
|
p = NULL;
|
s = list;
|
s = list;
|
|
|
while (v)
|
while (v)
|
{
|
{
|
/* Find the location of the new element. */
|
/* Find the location of the new element. */
|
while (s)
|
while (s)
|
{
|
{
|
if (v->offset < s->offset)
|
if (v->offset < s->offset)
|
break;
|
break;
|
if (v->offset == s->offset
|
if (v->offset == s->offset
|
&& v->length <= s->length)
|
&& v->length <= s->length)
|
break;
|
break;
|
|
|
p = s;
|
p = s;
|
s = s->next;
|
s = s->next;
|
}
|
}
|
|
|
/* Insert the new element in between p and s. */
|
/* Insert the new element in between p and s. */
|
next = v->next;
|
next = v->next;
|
v->next = s;
|
v->next = s;
|
if (p == NULL)
|
if (p == NULL)
|
list = v;
|
list = v;
|
else
|
else
|
p->next = v;
|
p->next = v;
|
|
|
p = v;
|
p = v;
|
v = next;
|
v = next;
|
}
|
}
|
|
|
return list;
|
return list;
|
}
|
}
|
|
|
|
|
/* Construct mangled common block name from symbol name. */
|
/* Construct mangled common block name from symbol name. */
|
|
|
/* We need the bind(c) flag to tell us how/if we should mangle the symbol
|
/* We need the bind(c) flag to tell us how/if we should mangle the symbol
|
name. There are few calls to this function, so few places that this
|
name. There are few calls to this function, so few places that this
|
would need to be added. At the moment, there is only one call, in
|
would need to be added. At the moment, there is only one call, in
|
build_common_decl(). We can't attempt to look up the common block
|
build_common_decl(). We can't attempt to look up the common block
|
because we may be building it for the first time and therefore, it won't
|
because we may be building it for the first time and therefore, it won't
|
be in the common_root. We also need the binding label, if it's bind(c).
|
be in the common_root. We also need the binding label, if it's bind(c).
|
Therefore, send in the pointer to the common block, so whatever info we
|
Therefore, send in the pointer to the common block, so whatever info we
|
have so far can be used. All of the necessary info should be available
|
have so far can be used. All of the necessary info should be available
|
in the gfc_common_head by now, so it should be accurate to test the
|
in the gfc_common_head by now, so it should be accurate to test the
|
isBindC flag and use the binding label given if it is bind(c).
|
isBindC flag and use the binding label given if it is bind(c).
|
|
|
We may NOT know yet if it's bind(c) or not, but we can try at least.
|
We may NOT know yet if it's bind(c) or not, but we can try at least.
|
Will have to figure out what to do later if it's labeled bind(c)
|
Will have to figure out what to do later if it's labeled bind(c)
|
after this is called. */
|
after this is called. */
|
|
|
static tree
|
static tree
|
gfc_sym_mangled_common_id (gfc_common_head *com)
|
gfc_sym_mangled_common_id (gfc_common_head *com)
|
{
|
{
|
int has_underscore;
|
int has_underscore;
|
char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
|
char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
|
|
/* Get the name out of the common block pointer. */
|
/* Get the name out of the common block pointer. */
|
strcpy (name, com->name);
|
strcpy (name, com->name);
|
|
|
/* If we're suppose to do a bind(c). */
|
/* If we're suppose to do a bind(c). */
|
if (com->is_bind_c == 1 && com->binding_label[0] != '\0')
|
if (com->is_bind_c == 1 && com->binding_label[0] != '\0')
|
return get_identifier (com->binding_label);
|
return get_identifier (com->binding_label);
|
|
|
if (strcmp (name, BLANK_COMMON_NAME) == 0)
|
if (strcmp (name, BLANK_COMMON_NAME) == 0)
|
return get_identifier (name);
|
return get_identifier (name);
|
|
|
if (gfc_option.flag_underscoring)
|
if (gfc_option.flag_underscoring)
|
{
|
{
|
has_underscore = strchr (name, '_') != 0;
|
has_underscore = strchr (name, '_') != 0;
|
if (gfc_option.flag_second_underscore && has_underscore)
|
if (gfc_option.flag_second_underscore && has_underscore)
|
snprintf (mangled_name, sizeof mangled_name, "%s__", name);
|
snprintf (mangled_name, sizeof mangled_name, "%s__", name);
|
else
|
else
|
snprintf (mangled_name, sizeof mangled_name, "%s_", name);
|
snprintf (mangled_name, sizeof mangled_name, "%s_", name);
|
|
|
return get_identifier (mangled_name);
|
return get_identifier (mangled_name);
|
}
|
}
|
else
|
else
|
return get_identifier (name);
|
return get_identifier (name);
|
}
|
}
|
|
|
|
|
/* Build a field declaration for a common variable or a local equivalence
|
/* Build a field declaration for a common variable or a local equivalence
|
object. */
|
object. */
|
|
|
static void
|
static void
|
build_field (segment_info *h, tree union_type, record_layout_info rli)
|
build_field (segment_info *h, tree union_type, record_layout_info rli)
|
{
|
{
|
tree field;
|
tree field;
|
tree name;
|
tree name;
|
HOST_WIDE_INT offset = h->offset;
|
HOST_WIDE_INT offset = h->offset;
|
unsigned HOST_WIDE_INT desired_align, known_align;
|
unsigned HOST_WIDE_INT desired_align, known_align;
|
|
|
name = get_identifier (h->sym->name);
|
name = get_identifier (h->sym->name);
|
field = build_decl (h->sym->declared_at.lb->location,
|
field = build_decl (h->sym->declared_at.lb->location,
|
FIELD_DECL, name, h->field);
|
FIELD_DECL, name, h->field);
|
known_align = (offset & -offset) * BITS_PER_UNIT;
|
known_align = (offset & -offset) * BITS_PER_UNIT;
|
if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
|
if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
|
known_align = BIGGEST_ALIGNMENT;
|
known_align = BIGGEST_ALIGNMENT;
|
|
|
desired_align = update_alignment_for_field (rli, field, known_align);
|
desired_align = update_alignment_for_field (rli, field, known_align);
|
if (desired_align > known_align)
|
if (desired_align > known_align)
|
DECL_PACKED (field) = 1;
|
DECL_PACKED (field) = 1;
|
|
|
DECL_FIELD_CONTEXT (field) = union_type;
|
DECL_FIELD_CONTEXT (field) = union_type;
|
DECL_FIELD_OFFSET (field) = size_int (offset);
|
DECL_FIELD_OFFSET (field) = size_int (offset);
|
DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
|
DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
|
SET_DECL_OFFSET_ALIGN (field, known_align);
|
SET_DECL_OFFSET_ALIGN (field, known_align);
|
|
|
rli->offset = size_binop (MAX_EXPR, rli->offset,
|
rli->offset = size_binop (MAX_EXPR, rli->offset,
|
size_binop (PLUS_EXPR,
|
size_binop (PLUS_EXPR,
|
DECL_FIELD_OFFSET (field),
|
DECL_FIELD_OFFSET (field),
|
DECL_SIZE_UNIT (field)));
|
DECL_SIZE_UNIT (field)));
|
/* If this field is assigned to a label, we create another two variables.
|
/* If this field is assigned to a label, we create another two variables.
|
One will hold the address of target label or format label. The other will
|
One will hold the address of target label or format label. The other will
|
hold the length of format label string. */
|
hold the length of format label string. */
|
if (h->sym->attr.assign)
|
if (h->sym->attr.assign)
|
{
|
{
|
tree len;
|
tree len;
|
tree addr;
|
tree addr;
|
|
|
gfc_allocate_lang_decl (field);
|
gfc_allocate_lang_decl (field);
|
GFC_DECL_ASSIGN (field) = 1;
|
GFC_DECL_ASSIGN (field) = 1;
|
len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
|
len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
|
addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
|
addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
|
TREE_STATIC (len) = 1;
|
TREE_STATIC (len) = 1;
|
TREE_STATIC (addr) = 1;
|
TREE_STATIC (addr) = 1;
|
DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
|
DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
|
gfc_set_decl_location (len, &h->sym->declared_at);
|
gfc_set_decl_location (len, &h->sym->declared_at);
|
gfc_set_decl_location (addr, &h->sym->declared_at);
|
gfc_set_decl_location (addr, &h->sym->declared_at);
|
GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
|
GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
|
GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
|
GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
|
}
|
}
|
|
|
/* If this field is volatile, mark it. */
|
/* If this field is volatile, mark it. */
|
if (h->sym->attr.volatile_)
|
if (h->sym->attr.volatile_)
|
{
|
{
|
tree new_type;
|
tree new_type;
|
TREE_THIS_VOLATILE (field) = 1;
|
TREE_THIS_VOLATILE (field) = 1;
|
new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
|
new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
|
TREE_TYPE (field) = new_type;
|
TREE_TYPE (field) = new_type;
|
}
|
}
|
|
|
h->field = field;
|
h->field = field;
|
}
|
}
|
|
|
|
|
/* Get storage for local equivalence. */
|
/* Get storage for local equivalence. */
|
|
|
static tree
|
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)
|
{
|
{
|
tree decl;
|
tree decl;
|
char name[15];
|
char name[15];
|
static int serial = 0;
|
static int serial = 0;
|
|
|
if (is_init)
|
if (is_init)
|
{
|
{
|
decl = gfc_create_var (union_type, "equiv");
|
decl = gfc_create_var (union_type, "equiv");
|
TREE_STATIC (decl) = 1;
|
TREE_STATIC (decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
return decl;
|
return decl;
|
}
|
}
|
|
|
snprintf (name, sizeof (name), "equiv.%d", serial++);
|
snprintf (name, sizeof (name), "equiv.%d", serial++);
|
decl = build_decl (input_location,
|
decl = build_decl (input_location,
|
VAR_DECL, get_identifier (name), union_type);
|
VAR_DECL, get_identifier (name), union_type);
|
DECL_ARTIFICIAL (decl) = 1;
|
DECL_ARTIFICIAL (decl) = 1;
|
DECL_IGNORED_P (decl) = 1;
|
DECL_IGNORED_P (decl) = 1;
|
|
|
if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|
if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|
|| is_saved)
|
|| is_saved)
|
TREE_STATIC (decl) = 1;
|
TREE_STATIC (decl) = 1;
|
|
|
TREE_ADDRESSABLE (decl) = 1;
|
TREE_ADDRESSABLE (decl) = 1;
|
TREE_USED (decl) = 1;
|
TREE_USED (decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
|
|
/* The source location has been lost, and doesn't really matter.
|
/* The source location has been lost, and doesn't really matter.
|
We need to set it to something though. */
|
We need to set it to something though. */
|
gfc_set_decl_location (decl, &gfc_current_locus);
|
gfc_set_decl_location (decl, &gfc_current_locus);
|
|
|
gfc_add_decl_to_function (decl);
|
gfc_add_decl_to_function (decl);
|
|
|
return decl;
|
return decl;
|
}
|
}
|
|
|
|
|
/* Get storage for common block. */
|
/* Get storage for common block. */
|
|
|
static tree
|
static tree
|
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
|
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
|
{
|
{
|
gfc_symbol *common_sym;
|
gfc_symbol *common_sym;
|
tree decl;
|
tree decl;
|
|
|
/* Create a namespace to store symbols for common blocks. */
|
/* Create a namespace to store symbols for common blocks. */
|
if (gfc_common_ns == NULL)
|
if (gfc_common_ns == NULL)
|
gfc_common_ns = gfc_get_namespace (NULL, 0);
|
gfc_common_ns = gfc_get_namespace (NULL, 0);
|
|
|
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
|
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
|
decl = common_sym->backend_decl;
|
decl = common_sym->backend_decl;
|
|
|
/* Update the size of this common block as needed. */
|
/* Update the size of this common block as needed. */
|
if (decl != NULL_TREE)
|
if (decl != NULL_TREE)
|
{
|
{
|
tree size = TYPE_SIZE_UNIT (union_type);
|
tree size = TYPE_SIZE_UNIT (union_type);
|
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
|
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
|
{
|
{
|
/* Named common blocks of the same name shall be of the same size
|
/* Named common blocks of the same name shall be of the same size
|
in all scoping units of a program in which they appear, but
|
in all scoping units of a program in which they appear, but
|
blank common blocks may be of different sizes. */
|
blank common blocks may be of different sizes. */
|
if (strcmp (com->name, BLANK_COMMON_NAME))
|
if (strcmp (com->name, BLANK_COMMON_NAME))
|
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
|
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
|
"same size", com->name, &com->where);
|
"same size", com->name, &com->where);
|
DECL_SIZE (decl) = TYPE_SIZE (union_type);
|
DECL_SIZE (decl) = TYPE_SIZE (union_type);
|
DECL_SIZE_UNIT (decl) = size;
|
DECL_SIZE_UNIT (decl) = size;
|
DECL_MODE (decl) = TYPE_MODE (union_type);
|
DECL_MODE (decl) = TYPE_MODE (union_type);
|
TREE_TYPE (decl) = union_type;
|
TREE_TYPE (decl) = union_type;
|
layout_decl (decl, 0);
|
layout_decl (decl, 0);
|
}
|
}
|
}
|
}
|
|
|
/* If this common block has been declared in a previous program unit,
|
/* If this common block has been declared in a previous program unit,
|
and either it is already initialized or there is no new initialization
|
and either it is already initialized or there is no new initialization
|
for it, just return. */
|
for it, just return. */
|
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
|
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
|
return decl;
|
return decl;
|
|
|
/* If there is no backend_decl for the common block, build it. */
|
/* If there is no backend_decl for the common block, build it. */
|
if (decl == NULL_TREE)
|
if (decl == NULL_TREE)
|
{
|
{
|
decl = build_decl (input_location,
|
decl = build_decl (input_location,
|
VAR_DECL, get_identifier (com->name), union_type);
|
VAR_DECL, get_identifier (com->name), union_type);
|
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
|
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
|
TREE_PUBLIC (decl) = 1;
|
TREE_PUBLIC (decl) = 1;
|
TREE_STATIC (decl) = 1;
|
TREE_STATIC (decl) = 1;
|
DECL_IGNORED_P (decl) = 1;
|
DECL_IGNORED_P (decl) = 1;
|
if (!com->is_bind_c)
|
if (!com->is_bind_c)
|
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
|
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
|
else
|
else
|
{
|
{
|
/* Do not set the alignment for bind(c) common blocks to
|
/* Do not set the alignment for bind(c) common blocks to
|
BIGGEST_ALIGNMENT because that won't match what C does. Also,
|
BIGGEST_ALIGNMENT because that won't match what C does. Also,
|
for common blocks with one element, the alignment must be
|
for common blocks with one element, the alignment must be
|
that of the field within the common block in order to match
|
that of the field within the common block in order to match
|
what C will do. */
|
what C will do. */
|
tree field = NULL_TREE;
|
tree field = NULL_TREE;
|
field = TYPE_FIELDS (TREE_TYPE (decl));
|
field = TYPE_FIELDS (TREE_TYPE (decl));
|
if (TREE_CHAIN (field) == NULL_TREE)
|
if (TREE_CHAIN (field) == NULL_TREE)
|
DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
|
DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
|
}
|
}
|
DECL_USER_ALIGN (decl) = 0;
|
DECL_USER_ALIGN (decl) = 0;
|
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
|
|
gfc_set_decl_location (decl, &com->where);
|
gfc_set_decl_location (decl, &com->where);
|
|
|
if (com->threadprivate)
|
if (com->threadprivate)
|
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
|
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
|
|
|
/* Place the back end declaration for this common block in
|
/* Place the back end declaration for this common block in
|
GLOBAL_BINDING_LEVEL. */
|
GLOBAL_BINDING_LEVEL. */
|
common_sym->backend_decl = pushdecl_top_level (decl);
|
common_sym->backend_decl = pushdecl_top_level (decl);
|
}
|
}
|
|
|
/* Has no initial values. */
|
/* Has no initial values. */
|
if (!is_init)
|
if (!is_init)
|
{
|
{
|
DECL_INITIAL (decl) = NULL_TREE;
|
DECL_INITIAL (decl) = NULL_TREE;
|
DECL_COMMON (decl) = 1;
|
DECL_COMMON (decl) = 1;
|
DECL_DEFER_OUTPUT (decl) = 1;
|
DECL_DEFER_OUTPUT (decl) = 1;
|
}
|
}
|
else
|
else
|
{
|
{
|
DECL_INITIAL (decl) = error_mark_node;
|
DECL_INITIAL (decl) = error_mark_node;
|
DECL_COMMON (decl) = 0;
|
DECL_COMMON (decl) = 0;
|
DECL_DEFER_OUTPUT (decl) = 0;
|
DECL_DEFER_OUTPUT (decl) = 0;
|
}
|
}
|
return decl;
|
return decl;
|
}
|
}
|
|
|
|
|
/* Return a field that is the size of the union, if an equivalence has
|
/* Return a field that is the size of the union, if an equivalence has
|
overlapping initializers. Merge the initializers into a single
|
overlapping initializers. Merge the initializers into a single
|
initializer for this new field, then free the old ones. */
|
initializer for this new field, then free the old ones. */
|
|
|
static tree
|
static tree
|
get_init_field (segment_info *head, tree union_type, tree *field_init,
|
get_init_field (segment_info *head, tree union_type, tree *field_init,
|
record_layout_info rli)
|
record_layout_info rli)
|
{
|
{
|
segment_info *s;
|
segment_info *s;
|
HOST_WIDE_INT length = 0;
|
HOST_WIDE_INT length = 0;
|
HOST_WIDE_INT offset = 0;
|
HOST_WIDE_INT offset = 0;
|
unsigned HOST_WIDE_INT known_align, desired_align;
|
unsigned HOST_WIDE_INT known_align, desired_align;
|
bool overlap = false;
|
bool overlap = false;
|
tree tmp, field;
|
tree tmp, field;
|
tree init;
|
tree init;
|
unsigned char *data, *chk;
|
unsigned char *data, *chk;
|
VEC(constructor_elt,gc) *v = NULL;
|
VEC(constructor_elt,gc) *v = NULL;
|
|
|
tree type = unsigned_char_type_node;
|
tree type = unsigned_char_type_node;
|
int i;
|
int i;
|
|
|
/* Obtain the size of the union and check if there are any overlapping
|
/* Obtain the size of the union and check if there are any overlapping
|
initializers. */
|
initializers. */
|
for (s = head; s; s = s->next)
|
for (s = head; s; s = s->next)
|
{
|
{
|
HOST_WIDE_INT slen = s->offset + s->length;
|
HOST_WIDE_INT slen = s->offset + s->length;
|
if (s->sym->value)
|
if (s->sym->value)
|
{
|
{
|
if (s->offset < offset)
|
if (s->offset < offset)
|
overlap = true;
|
overlap = true;
|
offset = slen;
|
offset = slen;
|
}
|
}
|
length = length < slen ? slen : length;
|
length = length < slen ? slen : length;
|
}
|
}
|
|
|
if (!overlap)
|
if (!overlap)
|
return NULL_TREE;
|
return NULL_TREE;
|
|
|
/* Now absorb all the initializer data into a single vector,
|
/* Now absorb all the initializer data into a single vector,
|
whilst checking for overlapping, unequal values. */
|
whilst checking for overlapping, unequal values. */
|
data = (unsigned char*)gfc_getmem ((size_t)length);
|
data = (unsigned char*)gfc_getmem ((size_t)length);
|
chk = (unsigned char*)gfc_getmem ((size_t)length);
|
chk = (unsigned char*)gfc_getmem ((size_t)length);
|
|
|
/* TODO - change this when default initialization is implemented. */
|
/* TODO - change this when default initialization is implemented. */
|
memset (data, '\0', (size_t)length);
|
memset (data, '\0', (size_t)length);
|
memset (chk, '\0', (size_t)length);
|
memset (chk, '\0', (size_t)length);
|
for (s = head; s; s = s->next)
|
for (s = head; s; s = s->next)
|
if (s->sym->value)
|
if (s->sym->value)
|
gfc_merge_initializers (s->sym->ts, s->sym->value,
|
gfc_merge_initializers (s->sym->ts, s->sym->value,
|
&data[s->offset],
|
&data[s->offset],
|
&chk[s->offset],
|
&chk[s->offset],
|
(size_t)s->length);
|
(size_t)s->length);
|
|
|
for (i = 0; i < length; i++)
|
for (i = 0; i < length; i++)
|
CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
|
CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
|
|
|
gfc_free (data);
|
gfc_free (data);
|
gfc_free (chk);
|
gfc_free (chk);
|
|
|
/* Build a char[length] array to hold the initializers. Much of what
|
/* Build a char[length] array to hold the initializers. Much of what
|
follows is borrowed from build_field, above. */
|
follows is borrowed from build_field, above. */
|
|
|
tmp = build_int_cst (gfc_array_index_type, length - 1);
|
tmp = build_int_cst (gfc_array_index_type, length - 1);
|
tmp = build_range_type (gfc_array_index_type,
|
tmp = build_range_type (gfc_array_index_type,
|
gfc_index_zero_node, tmp);
|
gfc_index_zero_node, tmp);
|
tmp = build_array_type (type, tmp);
|
tmp = build_array_type (type, tmp);
|
field = build_decl (gfc_current_locus.lb->location,
|
field = build_decl (gfc_current_locus.lb->location,
|
FIELD_DECL, NULL_TREE, tmp);
|
FIELD_DECL, NULL_TREE, tmp);
|
|
|
known_align = BIGGEST_ALIGNMENT;
|
known_align = BIGGEST_ALIGNMENT;
|
|
|
desired_align = update_alignment_for_field (rli, field, known_align);
|
desired_align = update_alignment_for_field (rli, field, known_align);
|
if (desired_align > known_align)
|
if (desired_align > known_align)
|
DECL_PACKED (field) = 1;
|
DECL_PACKED (field) = 1;
|
|
|
DECL_FIELD_CONTEXT (field) = union_type;
|
DECL_FIELD_CONTEXT (field) = union_type;
|
DECL_FIELD_OFFSET (field) = size_int (0);
|
DECL_FIELD_OFFSET (field) = size_int (0);
|
DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
|
DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
|
SET_DECL_OFFSET_ALIGN (field, known_align);
|
SET_DECL_OFFSET_ALIGN (field, known_align);
|
|
|
rli->offset = size_binop (MAX_EXPR, rli->offset,
|
rli->offset = size_binop (MAX_EXPR, rli->offset,
|
size_binop (PLUS_EXPR,
|
size_binop (PLUS_EXPR,
|
DECL_FIELD_OFFSET (field),
|
DECL_FIELD_OFFSET (field),
|
DECL_SIZE_UNIT (field)));
|
DECL_SIZE_UNIT (field)));
|
|
|
init = build_constructor (TREE_TYPE (field), v);
|
init = build_constructor (TREE_TYPE (field), v);
|
TREE_CONSTANT (init) = 1;
|
TREE_CONSTANT (init) = 1;
|
|
|
*field_init = init;
|
*field_init = init;
|
|
|
for (s = head; s; s = s->next)
|
for (s = head; s; s = s->next)
|
{
|
{
|
if (s->sym->value == NULL)
|
if (s->sym->value == NULL)
|
continue;
|
continue;
|
|
|
gfc_free_expr (s->sym->value);
|
gfc_free_expr (s->sym->value);
|
s->sym->value = NULL;
|
s->sym->value = NULL;
|
}
|
}
|
|
|
return field;
|
return field;
|
}
|
}
|
|
|
|
|
/* Declare memory for the common block or local equivalence, and create
|
/* Declare memory for the common block or local equivalence, and create
|
backend declarations for all of the elements. */
|
backend declarations for all of the elements. */
|
|
|
static void
|
static void
|
create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
{
|
{
|
segment_info *s, *next_s;
|
segment_info *s, *next_s;
|
tree union_type;
|
tree union_type;
|
tree *field_link;
|
tree *field_link;
|
tree field;
|
tree field;
|
tree field_init = NULL_TREE;
|
tree field_init = NULL_TREE;
|
record_layout_info rli;
|
record_layout_info rli;
|
tree decl;
|
tree decl;
|
bool is_init = false;
|
bool is_init = false;
|
bool is_saved = false;
|
bool is_saved = false;
|
|
|
/* Declare the variables inside the common block.
|
/* Declare the variables inside the common block.
|
If the current common block contains any equivalence object, then
|
If the current common block contains any equivalence object, then
|
make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
|
make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
|
alias analyzer work well when there is no address overlapping for
|
alias analyzer work well when there is no address overlapping for
|
common variables in the current common block. */
|
common variables in the current common block. */
|
if (saw_equiv)
|
if (saw_equiv)
|
union_type = make_node (UNION_TYPE);
|
union_type = make_node (UNION_TYPE);
|
else
|
else
|
union_type = make_node (RECORD_TYPE);
|
union_type = make_node (RECORD_TYPE);
|
|
|
rli = start_record_layout (union_type);
|
rli = start_record_layout (union_type);
|
field_link = &TYPE_FIELDS (union_type);
|
field_link = &TYPE_FIELDS (union_type);
|
|
|
/* Check for overlapping initializers and replace them with a single,
|
/* Check for overlapping initializers and replace them with a single,
|
artificial field that contains all the data. */
|
artificial field that contains all the data. */
|
if (saw_equiv)
|
if (saw_equiv)
|
field = get_init_field (head, union_type, &field_init, rli);
|
field = get_init_field (head, union_type, &field_init, rli);
|
else
|
else
|
field = NULL_TREE;
|
field = NULL_TREE;
|
|
|
if (field != NULL_TREE)
|
if (field != NULL_TREE)
|
{
|
{
|
is_init = true;
|
is_init = true;
|
*field_link = field;
|
*field_link = field;
|
field_link = &TREE_CHAIN (field);
|
field_link = &TREE_CHAIN (field);
|
}
|
}
|
|
|
for (s = head; s; s = s->next)
|
for (s = head; s; s = s->next)
|
{
|
{
|
build_field (s, union_type, rli);
|
build_field (s, union_type, rli);
|
|
|
/* Link the field into the type. */
|
/* Link the field into the type. */
|
*field_link = s->field;
|
*field_link = s->field;
|
field_link = &TREE_CHAIN (s->field);
|
field_link = &TREE_CHAIN (s->field);
|
|
|
/* Has initial value. */
|
/* Has initial value. */
|
if (s->sym->value)
|
if (s->sym->value)
|
is_init = true;
|
is_init = true;
|
|
|
/* Has SAVE attribute. */
|
/* Has SAVE attribute. */
|
if (s->sym->attr.save)
|
if (s->sym->attr.save)
|
is_saved = true;
|
is_saved = true;
|
}
|
}
|
|
|
finish_record_layout (rli, true);
|
finish_record_layout (rli, true);
|
|
|
if (com)
|
if (com)
|
decl = build_common_decl (com, union_type, is_init);
|
decl = build_common_decl (com, union_type, is_init);
|
else
|
else
|
decl = build_equiv_decl (union_type, is_init, is_saved);
|
decl = build_equiv_decl (union_type, is_init, is_saved);
|
|
|
if (is_init)
|
if (is_init)
|
{
|
{
|
tree ctor, tmp;
|
tree ctor, tmp;
|
VEC(constructor_elt,gc) *v = NULL;
|
VEC(constructor_elt,gc) *v = NULL;
|
|
|
if (field != NULL_TREE && field_init != NULL_TREE)
|
if (field != NULL_TREE && field_init != NULL_TREE)
|
CONSTRUCTOR_APPEND_ELT (v, field, field_init);
|
CONSTRUCTOR_APPEND_ELT (v, field, field_init);
|
else
|
else
|
for (s = head; s; s = s->next)
|
for (s = head; s; s = s->next)
|
{
|
{
|
if (s->sym->value)
|
if (s->sym->value)
|
{
|
{
|
/* Add the initializer for this field. */
|
/* Add the initializer for this field. */
|
tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
|
tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
|
TREE_TYPE (s->field), s->sym->attr.dimension,
|
TREE_TYPE (s->field), s->sym->attr.dimension,
|
s->sym->attr.pointer || s->sym->attr.allocatable);
|
s->sym->attr.pointer || s->sym->attr.allocatable);
|
|
|
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
|
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
|
}
|
}
|
}
|
}
|
|
|
gcc_assert (!VEC_empty (constructor_elt, v));
|
gcc_assert (!VEC_empty (constructor_elt, v));
|
ctor = build_constructor (union_type, v);
|
ctor = build_constructor (union_type, v);
|
TREE_CONSTANT (ctor) = 1;
|
TREE_CONSTANT (ctor) = 1;
|
TREE_STATIC (ctor) = 1;
|
TREE_STATIC (ctor) = 1;
|
DECL_INITIAL (decl) = ctor;
|
DECL_INITIAL (decl) = ctor;
|
|
|
#ifdef ENABLE_CHECKING
|
#ifdef ENABLE_CHECKING
|
{
|
{
|
tree field, value;
|
tree field, value;
|
unsigned HOST_WIDE_INT idx;
|
unsigned HOST_WIDE_INT idx;
|
FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
|
FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
|
gcc_assert (TREE_CODE (field) == FIELD_DECL);
|
gcc_assert (TREE_CODE (field) == FIELD_DECL);
|
}
|
}
|
#endif
|
#endif
|
}
|
}
|
|
|
/* Build component reference for each variable. */
|
/* Build component reference for each variable. */
|
for (s = head; s; s = next_s)
|
for (s = head; s; s = next_s)
|
{
|
{
|
tree var_decl;
|
tree var_decl;
|
|
|
var_decl = build_decl (s->sym->declared_at.lb->location,
|
var_decl = build_decl (s->sym->declared_at.lb->location,
|
VAR_DECL, DECL_NAME (s->field),
|
VAR_DECL, DECL_NAME (s->field),
|
TREE_TYPE (s->field));
|
TREE_TYPE (s->field));
|
TREE_STATIC (var_decl) = TREE_STATIC (decl);
|
TREE_STATIC (var_decl) = TREE_STATIC (decl);
|
TREE_USED (var_decl) = TREE_USED (decl);
|
TREE_USED (var_decl) = TREE_USED (decl);
|
if (s->sym->attr.use_assoc)
|
if (s->sym->attr.use_assoc)
|
DECL_IGNORED_P (var_decl) = 1;
|
DECL_IGNORED_P (var_decl) = 1;
|
if (s->sym->attr.target)
|
if (s->sym->attr.target)
|
TREE_ADDRESSABLE (var_decl) = 1;
|
TREE_ADDRESSABLE (var_decl) = 1;
|
/* This is a fake variable just for debugging purposes. */
|
/* This is a fake variable just for debugging purposes. */
|
TREE_ASM_WRITTEN (var_decl) = 1;
|
TREE_ASM_WRITTEN (var_decl) = 1;
|
/* Fake variables are not visible from other translation units. */
|
/* Fake variables are not visible from other translation units. */
|
TREE_PUBLIC (var_decl) = 0;
|
TREE_PUBLIC (var_decl) = 0;
|
|
|
/* To preserve identifier names in COMMON, chain to procedure
|
/* To preserve identifier names in COMMON, chain to procedure
|
scope unless at top level in a module definition. */
|
scope unless at top level in a module definition. */
|
if (com
|
if (com
|
&& s->sym->ns->proc_name
|
&& s->sym->ns->proc_name
|
&& s->sym->ns->proc_name->attr.flavor == FL_MODULE)
|
&& s->sym->ns->proc_name->attr.flavor == FL_MODULE)
|
var_decl = pushdecl_top_level (var_decl);
|
var_decl = pushdecl_top_level (var_decl);
|
else
|
else
|
gfc_add_decl_to_function (var_decl);
|
gfc_add_decl_to_function (var_decl);
|
|
|
SET_DECL_VALUE_EXPR (var_decl,
|
SET_DECL_VALUE_EXPR (var_decl,
|
fold_build3 (COMPONENT_REF, TREE_TYPE (s->field),
|
fold_build3 (COMPONENT_REF, TREE_TYPE (s->field),
|
decl, s->field, NULL_TREE));
|
decl, s->field, NULL_TREE));
|
DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
|
DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
|
GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
|
|
|
if (s->sym->attr.assign)
|
if (s->sym->attr.assign)
|
{
|
{
|
gfc_allocate_lang_decl (var_decl);
|
gfc_allocate_lang_decl (var_decl);
|
GFC_DECL_ASSIGN (var_decl) = 1;
|
GFC_DECL_ASSIGN (var_decl) = 1;
|
GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
|
GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
|
GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
|
GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
|
}
|
}
|
|
|
s->sym->backend_decl = var_decl;
|
s->sym->backend_decl = var_decl;
|
|
|
next_s = s->next;
|
next_s = s->next;
|
gfc_free (s);
|
gfc_free (s);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Given a symbol, find it in the current segment list. Returns NULL if
|
/* Given a symbol, find it in the current segment list. Returns NULL if
|
not found. */
|
not found. */
|
|
|
static segment_info *
|
static segment_info *
|
find_segment_info (gfc_symbol *symbol)
|
find_segment_info (gfc_symbol *symbol)
|
{
|
{
|
segment_info *n;
|
segment_info *n;
|
|
|
for (n = current_segment; n; n = n->next)
|
for (n = current_segment; n; n = n->next)
|
{
|
{
|
if (n->sym == symbol)
|
if (n->sym == symbol)
|
return n;
|
return n;
|
}
|
}
|
|
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
|
|
/* Given an expression node, make sure it is a constant integer and return
|
/* Given an expression node, make sure it is a constant integer and return
|
the mpz_t value. */
|
the mpz_t value. */
|
|
|
static mpz_t *
|
static mpz_t *
|
get_mpz (gfc_expr *e)
|
get_mpz (gfc_expr *e)
|
{
|
{
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
if (e->expr_type != EXPR_CONSTANT)
|
gfc_internal_error ("get_mpz(): Not an integer constant");
|
gfc_internal_error ("get_mpz(): Not an integer constant");
|
|
|
return &e->value.integer;
|
return &e->value.integer;
|
}
|
}
|
|
|
|
|
/* Given an array specification and an array reference, figure out the
|
/* Given an array specification and an array reference, figure out the
|
array element number (zero based). Bounds and elements are guaranteed
|
array element number (zero based). Bounds and elements are guaranteed
|
to be constants. If something goes wrong we generate an error and
|
to be constants. If something goes wrong we generate an error and
|
return zero. */
|
return zero. */
|
|
|
static HOST_WIDE_INT
|
static HOST_WIDE_INT
|
element_number (gfc_array_ref *ar)
|
element_number (gfc_array_ref *ar)
|
{
|
{
|
mpz_t multiplier, offset, extent, n;
|
mpz_t multiplier, offset, extent, n;
|
gfc_array_spec *as;
|
gfc_array_spec *as;
|
HOST_WIDE_INT i, rank;
|
HOST_WIDE_INT i, rank;
|
|
|
as = ar->as;
|
as = ar->as;
|
rank = as->rank;
|
rank = as->rank;
|
mpz_init_set_ui (multiplier, 1);
|
mpz_init_set_ui (multiplier, 1);
|
mpz_init_set_ui (offset, 0);
|
mpz_init_set_ui (offset, 0);
|
mpz_init (extent);
|
mpz_init (extent);
|
mpz_init (n);
|
mpz_init (n);
|
|
|
for (i = 0; i < rank; i++)
|
for (i = 0; i < rank; i++)
|
{
|
{
|
if (ar->dimen_type[i] != DIMEN_ELEMENT)
|
if (ar->dimen_type[i] != DIMEN_ELEMENT)
|
gfc_internal_error ("element_number(): Bad dimension type");
|
gfc_internal_error ("element_number(): Bad dimension type");
|
|
|
mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
|
mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
|
|
|
mpz_mul (n, n, multiplier);
|
mpz_mul (n, n, multiplier);
|
mpz_add (offset, offset, n);
|
mpz_add (offset, offset, n);
|
|
|
mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
|
mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
|
mpz_add_ui (extent, extent, 1);
|
mpz_add_ui (extent, extent, 1);
|
|
|
if (mpz_sgn (extent) < 0)
|
if (mpz_sgn (extent) < 0)
|
mpz_set_ui (extent, 0);
|
mpz_set_ui (extent, 0);
|
|
|
mpz_mul (multiplier, multiplier, extent);
|
mpz_mul (multiplier, multiplier, extent);
|
}
|
}
|
|
|
i = mpz_get_ui (offset);
|
i = mpz_get_ui (offset);
|
|
|
mpz_clear (multiplier);
|
mpz_clear (multiplier);
|
mpz_clear (offset);
|
mpz_clear (offset);
|
mpz_clear (extent);
|
mpz_clear (extent);
|
mpz_clear (n);
|
mpz_clear (n);
|
|
|
return i;
|
return i;
|
}
|
}
|
|
|
|
|
/* Given a single element of an equivalence list, figure out the offset
|
/* Given a single element of an equivalence list, figure out the offset
|
from the base symbol. For simple variables or full arrays, this is
|
from the base symbol. For simple variables or full arrays, this is
|
simply zero. For an array element we have to calculate the array
|
simply zero. For an array element we have to calculate the array
|
element number and multiply by the element size. For a substring we
|
element number and multiply by the element size. For a substring we
|
have to calculate the further reference. */
|
have to calculate the further reference. */
|
|
|
static HOST_WIDE_INT
|
static HOST_WIDE_INT
|
calculate_offset (gfc_expr *e)
|
calculate_offset (gfc_expr *e)
|
{
|
{
|
HOST_WIDE_INT n, element_size, offset;
|
HOST_WIDE_INT n, element_size, offset;
|
gfc_typespec *element_type;
|
gfc_typespec *element_type;
|
gfc_ref *reference;
|
gfc_ref *reference;
|
|
|
offset = 0;
|
offset = 0;
|
element_type = &e->symtree->n.sym->ts;
|
element_type = &e->symtree->n.sym->ts;
|
|
|
for (reference = e->ref; reference; reference = reference->next)
|
for (reference = e->ref; reference; reference = reference->next)
|
switch (reference->type)
|
switch (reference->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
switch (reference->u.ar.type)
|
switch (reference->u.ar.type)
|
{
|
{
|
case AR_FULL:
|
case AR_FULL:
|
break;
|
break;
|
|
|
case AR_ELEMENT:
|
case AR_ELEMENT:
|
n = element_number (&reference->u.ar);
|
n = element_number (&reference->u.ar);
|
if (element_type->type == BT_CHARACTER)
|
if (element_type->type == BT_CHARACTER)
|
gfc_conv_const_charlen (element_type->u.cl);
|
gfc_conv_const_charlen (element_type->u.cl);
|
element_size =
|
element_size =
|
int_size_in_bytes (gfc_typenode_for_spec (element_type));
|
int_size_in_bytes (gfc_typenode_for_spec (element_type));
|
offset += n * element_size;
|
offset += n * element_size;
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("Bad array reference at %L", &e->where);
|
gfc_error ("Bad array reference at %L", &e->where);
|
}
|
}
|
break;
|
break;
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
if (reference->u.ss.start != NULL)
|
if (reference->u.ss.start != NULL)
|
offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
|
offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
|
break;
|
break;
|
default:
|
default:
|
gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
|
gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
|
&e->where);
|
&e->where);
|
}
|
}
|
return offset;
|
return offset;
|
}
|
}
|
|
|
|
|
/* Add a new segment_info structure to the current segment. eq1 is already
|
/* Add a new segment_info structure to the current segment. eq1 is already
|
in the list, eq2 is not. */
|
in the list, eq2 is not. */
|
|
|
static void
|
static void
|
new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
|
new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
|
{
|
{
|
HOST_WIDE_INT offset1, offset2;
|
HOST_WIDE_INT offset1, offset2;
|
segment_info *a;
|
segment_info *a;
|
|
|
offset1 = calculate_offset (eq1->expr);
|
offset1 = calculate_offset (eq1->expr);
|
offset2 = calculate_offset (eq2->expr);
|
offset2 = calculate_offset (eq2->expr);
|
|
|
a = get_segment_info (eq2->expr->symtree->n.sym,
|
a = get_segment_info (eq2->expr->symtree->n.sym,
|
v->offset + offset1 - offset2);
|
v->offset + offset1 - offset2);
|
|
|
current_segment = add_segments (current_segment, a);
|
current_segment = add_segments (current_segment, a);
|
}
|
}
|
|
|
|
|
/* Given two equivalence structures that are both already in the list, make
|
/* Given two equivalence structures that are both already in the list, make
|
sure that this new condition is not violated, generating an error if it
|
sure that this new condition is not violated, generating an error if it
|
is. */
|
is. */
|
|
|
static void
|
static void
|
confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
|
confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
|
gfc_equiv *eq2)
|
gfc_equiv *eq2)
|
{
|
{
|
HOST_WIDE_INT offset1, offset2;
|
HOST_WIDE_INT offset1, offset2;
|
|
|
offset1 = calculate_offset (eq1->expr);
|
offset1 = calculate_offset (eq1->expr);
|
offset2 = calculate_offset (eq2->expr);
|
offset2 = calculate_offset (eq2->expr);
|
|
|
if (s1->offset + offset1 != s2->offset + offset2)
|
if (s1->offset + offset1 != s2->offset + offset2)
|
gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
|
gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
|
"'%s' at %L", s1->sym->name, &s1->sym->declared_at,
|
"'%s' at %L", s1->sym->name, &s1->sym->declared_at,
|
s2->sym->name, &s2->sym->declared_at);
|
s2->sym->name, &s2->sym->declared_at);
|
}
|
}
|
|
|
|
|
/* Process a new equivalence condition. eq1 is know to be in segment f.
|
/* Process a new equivalence condition. eq1 is know to be in segment f.
|
If eq2 is also present then confirm that the condition holds.
|
If eq2 is also present then confirm that the condition holds.
|
Otherwise add a new variable to the segment list. */
|
Otherwise add a new variable to the segment list. */
|
|
|
static void
|
static void
|
add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
|
add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
|
{
|
{
|
segment_info *n;
|
segment_info *n;
|
|
|
n = find_segment_info (eq2->expr->symtree->n.sym);
|
n = find_segment_info (eq2->expr->symtree->n.sym);
|
|
|
if (n == NULL)
|
if (n == NULL)
|
new_condition (f, eq1, eq2);
|
new_condition (f, eq1, eq2);
|
else
|
else
|
confirm_condition (f, eq1, n, eq2);
|
confirm_condition (f, eq1, n, eq2);
|
}
|
}
|
|
|
|
|
/* Given a segment element, search through the equivalence lists for unused
|
/* Given a segment element, search through the equivalence lists for unused
|
conditions that involve the symbol. Add these rules to the segment. */
|
conditions that involve the symbol. Add these rules to the segment. */
|
|
|
static bool
|
static bool
|
find_equivalence (segment_info *n)
|
find_equivalence (segment_info *n)
|
{
|
{
|
gfc_equiv *e1, *e2, *eq;
|
gfc_equiv *e1, *e2, *eq;
|
bool found;
|
bool found;
|
|
|
found = FALSE;
|
found = FALSE;
|
|
|
for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
|
for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
|
{
|
{
|
eq = NULL;
|
eq = NULL;
|
|
|
/* Search the equivalence list, including the root (first) element
|
/* Search the equivalence list, including the root (first) element
|
for the symbol that owns the segment. */
|
for the symbol that owns the segment. */
|
for (e2 = e1; e2; e2 = e2->eq)
|
for (e2 = e1; e2; e2 = e2->eq)
|
{
|
{
|
if (!e2->used && e2->expr->symtree->n.sym == n->sym)
|
if (!e2->used && e2->expr->symtree->n.sym == n->sym)
|
{
|
{
|
eq = e2;
|
eq = e2;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
/* Go to the next root element. */
|
/* Go to the next root element. */
|
if (eq == NULL)
|
if (eq == NULL)
|
continue;
|
continue;
|
|
|
eq->used = 1;
|
eq->used = 1;
|
|
|
/* Now traverse the equivalence list matching the offsets. */
|
/* Now traverse the equivalence list matching the offsets. */
|
for (e2 = e1; e2; e2 = e2->eq)
|
for (e2 = e1; e2; e2 = e2->eq)
|
{
|
{
|
if (!e2->used && e2 != eq)
|
if (!e2->used && e2 != eq)
|
{
|
{
|
add_condition (n, eq, e2);
|
add_condition (n, eq, e2);
|
e2->used = 1;
|
e2->used = 1;
|
found = TRUE;
|
found = TRUE;
|
}
|
}
|
}
|
}
|
}
|
}
|
return found;
|
return found;
|
}
|
}
|
|
|
|
|
/* Add all symbols equivalenced within a segment. We need to scan the
|
/* Add all symbols equivalenced within a segment. We need to scan the
|
segment list multiple times to include indirect equivalences. Since
|
segment list multiple times to include indirect equivalences. Since
|
a new segment_info can inserted at the beginning of the segment list,
|
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
|
depending on its offset, we have to force a final pass through the
|
loop by demanding that completion sees a pass with no matches; i.e.,
|
loop by demanding that completion sees a pass with no matches; i.e.,
|
all symbols with equiv_built set and no new equivalences found. */
|
all symbols with equiv_built set and no new equivalences found. */
|
|
|
static void
|
static void
|
add_equivalences (bool *saw_equiv)
|
add_equivalences (bool *saw_equiv)
|
{
|
{
|
segment_info *f;
|
segment_info *f;
|
bool seen_one, more;
|
bool seen_one, more;
|
|
|
seen_one = false;
|
seen_one = false;
|
more = TRUE;
|
more = TRUE;
|
while (more)
|
while (more)
|
{
|
{
|
more = FALSE;
|
more = FALSE;
|
for (f = current_segment; f; f = f->next)
|
for (f = current_segment; f; f = f->next)
|
{
|
{
|
if (!f->sym->equiv_built)
|
if (!f->sym->equiv_built)
|
{
|
{
|
f->sym->equiv_built = 1;
|
f->sym->equiv_built = 1;
|
seen_one = find_equivalence (f);
|
seen_one = find_equivalence (f);
|
if (seen_one)
|
if (seen_one)
|
{
|
{
|
*saw_equiv = true;
|
*saw_equiv = true;
|
more = true;
|
more = true;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Add a copy of this segment list to the namespace. */
|
/* Add a copy of this segment list to the namespace. */
|
copy_equiv_list_to_ns (current_segment);
|
copy_equiv_list_to_ns (current_segment);
|
}
|
}
|
|
|
|
|
/* Returns the offset necessary to properly align the current equivalence.
|
/* Returns the offset necessary to properly align the current equivalence.
|
Sets *palign to the required alignment. */
|
Sets *palign to the required alignment. */
|
|
|
static HOST_WIDE_INT
|
static HOST_WIDE_INT
|
align_segment (unsigned HOST_WIDE_INT *palign)
|
align_segment (unsigned HOST_WIDE_INT *palign)
|
{
|
{
|
segment_info *s;
|
segment_info *s;
|
unsigned HOST_WIDE_INT offset;
|
unsigned HOST_WIDE_INT offset;
|
unsigned HOST_WIDE_INT max_align;
|
unsigned HOST_WIDE_INT max_align;
|
unsigned HOST_WIDE_INT this_align;
|
unsigned HOST_WIDE_INT this_align;
|
unsigned HOST_WIDE_INT this_offset;
|
unsigned HOST_WIDE_INT this_offset;
|
|
|
max_align = 1;
|
max_align = 1;
|
offset = 0;
|
offset = 0;
|
for (s = current_segment; s; s = s->next)
|
for (s = current_segment; s; s = s->next)
|
{
|
{
|
this_align = TYPE_ALIGN_UNIT (s->field);
|
this_align = TYPE_ALIGN_UNIT (s->field);
|
if (s->offset & (this_align - 1))
|
if (s->offset & (this_align - 1))
|
{
|
{
|
/* Field is misaligned. */
|
/* Field is misaligned. */
|
this_offset = this_align - ((s->offset + offset) & (this_align - 1));
|
this_offset = this_align - ((s->offset + offset) & (this_align - 1));
|
if (this_offset & (max_align - 1))
|
if (this_offset & (max_align - 1))
|
{
|
{
|
/* Aligning this field would misalign a previous field. */
|
/* Aligning this field would misalign a previous field. */
|
gfc_error ("The equivalence set for variable '%s' "
|
gfc_error ("The equivalence set for variable '%s' "
|
"declared at %L violates alignment requirements",
|
"declared at %L violates alignment requirements",
|
s->sym->name, &s->sym->declared_at);
|
s->sym->name, &s->sym->declared_at);
|
}
|
}
|
offset += this_offset;
|
offset += this_offset;
|
}
|
}
|
max_align = this_align;
|
max_align = this_align;
|
}
|
}
|
if (palign)
|
if (palign)
|
*palign = max_align;
|
*palign = max_align;
|
return offset;
|
return offset;
|
}
|
}
|
|
|
|
|
/* Adjust segment offsets by the given amount. */
|
/* Adjust segment offsets by the given amount. */
|
|
|
static void
|
static void
|
apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
|
apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
|
{
|
{
|
for (; s; s = s->next)
|
for (; s; s = s->next)
|
s->offset += offset;
|
s->offset += offset;
|
}
|
}
|
|
|
|
|
/* Lay out a symbol in a common block. If the symbol has already been seen
|
/* Lay out a symbol in a common block. If the symbol has already been seen
|
then check the location is consistent. Otherwise create segments
|
then check the location is consistent. Otherwise create segments
|
for that symbol and all the symbols equivalenced with it. */
|
for that symbol and all the symbols equivalenced with it. */
|
|
|
/* Translate a single common block. */
|
/* Translate a single common block. */
|
|
|
static void
|
static void
|
translate_common (gfc_common_head *common, gfc_symbol *var_list)
|
translate_common (gfc_common_head *common, gfc_symbol *var_list)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
segment_info *s;
|
segment_info *s;
|
segment_info *common_segment;
|
segment_info *common_segment;
|
HOST_WIDE_INT offset;
|
HOST_WIDE_INT offset;
|
HOST_WIDE_INT current_offset;
|
HOST_WIDE_INT current_offset;
|
unsigned HOST_WIDE_INT align;
|
unsigned HOST_WIDE_INT align;
|
unsigned HOST_WIDE_INT max_align;
|
unsigned HOST_WIDE_INT max_align;
|
bool saw_equiv;
|
bool saw_equiv;
|
|
|
common_segment = NULL;
|
common_segment = NULL;
|
offset = 0;
|
offset = 0;
|
current_offset = 0;
|
current_offset = 0;
|
align = 1;
|
align = 1;
|
max_align = 1;
|
max_align = 1;
|
saw_equiv = false;
|
saw_equiv = false;
|
|
|
/* Add symbols to the segment. */
|
/* Add symbols to the segment. */
|
for (sym = var_list; sym; sym = sym->common_next)
|
for (sym = var_list; sym; sym = sym->common_next)
|
{
|
{
|
current_segment = common_segment;
|
current_segment = common_segment;
|
s = find_segment_info (sym);
|
s = find_segment_info (sym);
|
|
|
/* Symbol has already been added via an equivalence. Multiple
|
/* Symbol has already been added via an equivalence. Multiple
|
use associations of the same common block result in equiv_built
|
use associations of the same common block result in equiv_built
|
being set but no information about the symbol in the segment. */
|
being set but no information about the symbol in the segment. */
|
if (s && sym->equiv_built)
|
if (s && sym->equiv_built)
|
{
|
{
|
/* Ensure the current location is properly aligned. */
|
/* Ensure the current location is properly aligned. */
|
align = TYPE_ALIGN_UNIT (s->field);
|
align = TYPE_ALIGN_UNIT (s->field);
|
current_offset = (current_offset + align - 1) &~ (align - 1);
|
current_offset = (current_offset + align - 1) &~ (align - 1);
|
|
|
/* Verify that it ended up where we expect it. */
|
/* Verify that it ended up where we expect it. */
|
if (s->offset != current_offset)
|
if (s->offset != current_offset)
|
{
|
{
|
gfc_error ("Equivalence for '%s' does not match ordering of "
|
gfc_error ("Equivalence for '%s' does not match ordering of "
|
"COMMON '%s' at %L", sym->name,
|
"COMMON '%s' at %L", sym->name,
|
common->name, &common->where);
|
common->name, &common->where);
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* A symbol we haven't seen before. */
|
/* A symbol we haven't seen before. */
|
s = current_segment = get_segment_info (sym, current_offset);
|
s = current_segment = get_segment_info (sym, current_offset);
|
|
|
/* Add all objects directly or indirectly equivalenced with this
|
/* Add all objects directly or indirectly equivalenced with this
|
symbol. */
|
symbol. */
|
add_equivalences (&saw_equiv);
|
add_equivalences (&saw_equiv);
|
|
|
if (current_segment->offset < 0)
|
if (current_segment->offset < 0)
|
gfc_error ("The equivalence set for '%s' cause an invalid "
|
gfc_error ("The equivalence set for '%s' cause an invalid "
|
"extension to COMMON '%s' at %L", sym->name,
|
"extension to COMMON '%s' at %L", sym->name,
|
common->name, &common->where);
|
common->name, &common->where);
|
|
|
if (gfc_option.flag_align_commons)
|
if (gfc_option.flag_align_commons)
|
offset = align_segment (&align);
|
offset = align_segment (&align);
|
|
|
if (offset & (max_align - 1))
|
if (offset & (max_align - 1))
|
{
|
{
|
/* The required offset conflicts with previous alignment
|
/* The required offset conflicts with previous alignment
|
requirements. Insert padding immediately before this
|
requirements. Insert padding immediately before this
|
segment. */
|
segment. */
|
if (gfc_option.warn_align_commons)
|
if (gfc_option.warn_align_commons)
|
{
|
{
|
if (strcmp (common->name, BLANK_COMMON_NAME))
|
if (strcmp (common->name, BLANK_COMMON_NAME))
|
gfc_warning ("Padding of %d bytes required before '%s' in "
|
gfc_warning ("Padding of %d bytes required before '%s' in "
|
"COMMON '%s' at %L; reorder elements or use "
|
"COMMON '%s' at %L; reorder elements or use "
|
"-fno-align-commons", (int)offset,
|
"-fno-align-commons", (int)offset,
|
s->sym->name, common->name, &common->where);
|
s->sym->name, common->name, &common->where);
|
else
|
else
|
gfc_warning ("Padding of %d bytes required before '%s' in "
|
gfc_warning ("Padding of %d bytes required before '%s' in "
|
"COMMON at %L; reorder elements or use "
|
"COMMON at %L; reorder elements or use "
|
"-fno-align-commons", (int)offset,
|
"-fno-align-commons", (int)offset,
|
s->sym->name, &common->where);
|
s->sym->name, &common->where);
|
}
|
}
|
}
|
}
|
|
|
/* Apply the offset to the new segments. */
|
/* Apply the offset to the new segments. */
|
apply_segment_offset (current_segment, offset);
|
apply_segment_offset (current_segment, offset);
|
current_offset += offset;
|
current_offset += offset;
|
if (max_align < align)
|
if (max_align < align)
|
max_align = align;
|
max_align = align;
|
|
|
/* Add the new segments to the common block. */
|
/* Add the new segments to the common block. */
|
common_segment = add_segments (common_segment, current_segment);
|
common_segment = add_segments (common_segment, current_segment);
|
}
|
}
|
|
|
/* The offset of the next common variable. */
|
/* The offset of the next common variable. */
|
current_offset += s->length;
|
current_offset += s->length;
|
}
|
}
|
|
|
if (common_segment == NULL)
|
if (common_segment == NULL)
|
{
|
{
|
gfc_error ("COMMON '%s' at %L does not exist",
|
gfc_error ("COMMON '%s' at %L does not exist",
|
common->name, &common->where);
|
common->name, &common->where);
|
return;
|
return;
|
}
|
}
|
|
|
if (common_segment->offset != 0 && gfc_option.warn_align_commons)
|
if (common_segment->offset != 0 && gfc_option.warn_align_commons)
|
{
|
{
|
if (strcmp (common->name, BLANK_COMMON_NAME))
|
if (strcmp (common->name, BLANK_COMMON_NAME))
|
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start; "
|
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start; "
|
"reorder elements or use -fno-align-commons",
|
"reorder elements or use -fno-align-commons",
|
common->name, &common->where, (int)common_segment->offset);
|
common->name, &common->where, (int)common_segment->offset);
|
else
|
else
|
gfc_warning ("COMMON at %L requires %d bytes of padding at start; "
|
gfc_warning ("COMMON at %L requires %d bytes of padding at start; "
|
"reorder elements or use -fno-align-commons",
|
"reorder elements or use -fno-align-commons",
|
&common->where, (int)common_segment->offset);
|
&common->where, (int)common_segment->offset);
|
}
|
}
|
|
|
create_common (common, common_segment, saw_equiv);
|
create_common (common, common_segment, saw_equiv);
|
}
|
}
|
|
|
|
|
/* Create a new block for each merged equivalence list. */
|
/* Create a new block for each merged equivalence list. */
|
|
|
static void
|
static void
|
finish_equivalences (gfc_namespace *ns)
|
finish_equivalences (gfc_namespace *ns)
|
{
|
{
|
gfc_equiv *z, *y;
|
gfc_equiv *z, *y;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_common_head * c;
|
gfc_common_head * c;
|
HOST_WIDE_INT offset;
|
HOST_WIDE_INT offset;
|
unsigned HOST_WIDE_INT align;
|
unsigned HOST_WIDE_INT align;
|
bool dummy;
|
bool dummy;
|
|
|
for (z = ns->equiv; z; z = z->next)
|
for (z = ns->equiv; z; z = z->next)
|
for (y = z->eq; y; y = y->eq)
|
for (y = z->eq; y; y = y->eq)
|
{
|
{
|
if (y->used)
|
if (y->used)
|
continue;
|
continue;
|
sym = z->expr->symtree->n.sym;
|
sym = z->expr->symtree->n.sym;
|
current_segment = get_segment_info (sym, 0);
|
current_segment = get_segment_info (sym, 0);
|
|
|
/* All objects directly or indirectly equivalenced with this
|
/* All objects directly or indirectly equivalenced with this
|
symbol. */
|
symbol. */
|
add_equivalences (&dummy);
|
add_equivalences (&dummy);
|
|
|
/* Align the block. */
|
/* Align the block. */
|
offset = align_segment (&align);
|
offset = align_segment (&align);
|
|
|
/* Ensure all offsets are positive. */
|
/* Ensure all offsets are positive. */
|
offset -= current_segment->offset & ~(align - 1);
|
offset -= current_segment->offset & ~(align - 1);
|
|
|
apply_segment_offset (current_segment, offset);
|
apply_segment_offset (current_segment, offset);
|
|
|
/* Create the decl. If this is a module equivalence, it has a
|
/* Create the decl. If this is a module equivalence, it has a
|
unique name, pointed to by z->module. This is written to a
|
unique name, pointed to by z->module. This is written to a
|
gfc_common_header to push create_common into using
|
gfc_common_header to push create_common into using
|
build_common_decl, so that the equivalence appears as an
|
build_common_decl, so that the equivalence appears as an
|
external symbol. Otherwise, a local declaration is built using
|
external symbol. Otherwise, a local declaration is built using
|
build_equiv_decl. */
|
build_equiv_decl. */
|
if (z->module)
|
if (z->module)
|
{
|
{
|
c = gfc_get_common_head ();
|
c = gfc_get_common_head ();
|
/* We've lost the real location, so use the location of the
|
/* We've lost the real location, so use the location of the
|
enclosing procedure. */
|
enclosing procedure. */
|
c->where = ns->proc_name->declared_at;
|
c->where = ns->proc_name->declared_at;
|
strcpy (c->name, z->module);
|
strcpy (c->name, z->module);
|
}
|
}
|
else
|
else
|
c = NULL;
|
c = NULL;
|
|
|
create_common (c, current_segment, true);
|
create_common (c, current_segment, true);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Work function for translating a named common block. */
|
/* Work function for translating a named common block. */
|
|
|
static void
|
static void
|
named_common (gfc_symtree *st)
|
named_common (gfc_symtree *st)
|
{
|
{
|
translate_common (st->n.common, st->n.common->head);
|
translate_common (st->n.common, st->n.common->head);
|
}
|
}
|
|
|
|
|
/* Translate the common blocks in a namespace. Unlike other variables,
|
/* Translate the common blocks in a namespace. Unlike other variables,
|
these have to be created before code, because the backend_decl depends
|
these have to be created before code, because the backend_decl depends
|
on the rest of the common block. */
|
on the rest of the common block. */
|
|
|
void
|
void
|
gfc_trans_common (gfc_namespace *ns)
|
gfc_trans_common (gfc_namespace *ns)
|
{
|
{
|
gfc_common_head *c;
|
gfc_common_head *c;
|
|
|
/* Translate the blank common block. */
|
/* Translate the blank common block. */
|
if (ns->blank_common.head != NULL)
|
if (ns->blank_common.head != NULL)
|
{
|
{
|
c = gfc_get_common_head ();
|
c = gfc_get_common_head ();
|
c->where = ns->blank_common.head->common_head->where;
|
c->where = ns->blank_common.head->common_head->where;
|
strcpy (c->name, BLANK_COMMON_NAME);
|
strcpy (c->name, BLANK_COMMON_NAME);
|
translate_common (c, ns->blank_common.head);
|
translate_common (c, ns->blank_common.head);
|
}
|
}
|
|
|
/* Translate all named common blocks. */
|
/* Translate all named common blocks. */
|
gfc_traverse_symtree (ns->common_root, named_common);
|
gfc_traverse_symtree (ns->common_root, named_common);
|
|
|
/* Translate local equivalence. */
|
/* Translate local equivalence. */
|
finish_equivalences (ns);
|
finish_equivalences (ns);
|
|
|
/* Commit the newly created symbols for common blocks and module
|
/* Commit the newly created symbols for common blocks and module
|
equivalences. */
|
equivalences. */
|
gfc_commit_symbols ();
|
gfc_commit_symbols ();
|
}
|
}
|
|
|
