#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "toplev.h"
#include "tm.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"
typedef struct segment_info
{
gfc_symbol *sym;
HOST_WIDE_INT offset;
HOST_WIDE_INT length;
tree field;
struct segment_info *next;
} segment_info;
static segment_info * current_segment;
static gfc_namespace *gfc_common_ns = NULL;
#define BLANK_COMMON_NAME "__BLNK__"
static segment_info *
get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
{
segment_info *s;
if (sym->ts.type == BT_CHARACTER)
gfc_conv_const_charlen (sym->ts.cl);
s = (segment_info *) gfc_getmem (sizeof (segment_info));
s->sym = sym;
s->field = gfc_sym_type (sym);
s->length = int_size_in_bytes (s->field);
s->offset = offset;
return s;
}
static segment_info *
add_segments (segment_info *list, segment_info *v)
{
segment_info *s;
segment_info *p;
segment_info *next;
p = NULL;
s = list;
while (v)
{
while (s)
{
if (v->offset < s->offset)
break;
if (v->offset == s->offset
&& v->length <= s->length)
break;
p = s;
s = s->next;
}
next = v->next;
v->next = s;
if (p == NULL)
list = v;
else
p->next = v;
p = v;
v = next;
}
return list;
}
static tree
gfc_sym_mangled_common_id (const char *name)
{
int has_underscore;
char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
if (strcmp (name, BLANK_COMMON_NAME) == 0)
return get_identifier (name);
if (gfc_option.flag_underscoring)
{
has_underscore = strchr (name, '_') != 0;
if (gfc_option.flag_second_underscore && has_underscore)
snprintf (mangled_name, sizeof mangled_name, "%s__", name);
else
snprintf (mangled_name, sizeof mangled_name, "%s_", name);
return get_identifier (mangled_name);
}
else
return get_identifier (name);
}
static void
build_field (segment_info *h, tree union_type, record_layout_info rli)
{
tree field;
tree name;
HOST_WIDE_INT offset = h->offset;
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);
known_align = (offset & -offset) * BITS_PER_UNIT;
if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
known_align = BIGGEST_ALIGNMENT;
desired_align = update_alignment_for_field (rli, field, known_align);
if (desired_align > known_align)
DECL_PACKED (field) = 1;
DECL_FIELD_CONTEXT (field) = union_type;
DECL_FIELD_OFFSET (field) = size_int (offset);
DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
SET_DECL_OFFSET_ALIGN (field, known_align);
rli->offset = size_binop (MAX_EXPR, rli->offset,
size_binop (PLUS_EXPR,
DECL_FIELD_OFFSET (field),
DECL_SIZE_UNIT (field)));
if (h->sym->attr.assign)
{
tree len;
tree addr;
gfc_allocate_lang_decl (field);
GFC_DECL_ASSIGN (field) = 1;
len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
TREE_STATIC (len) = 1;
TREE_STATIC (addr) = 1;
DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
gfc_set_decl_location (len, &h->sym->declared_at);
gfc_set_decl_location (addr, &h->sym->declared_at);
GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
}
h->field = field;
}
static tree
build_equiv_decl (tree union_type, bool is_init)
{
tree decl;
char name[15];
static int serial = 0;
if (is_init)
{
decl = gfc_create_var (union_type, "equiv");
TREE_STATIC (decl) = 1;
return decl;
}
snprintf (name, sizeof (name), "equiv.%d", serial++);
decl = build_decl (VAR_DECL, get_identifier (name), union_type);
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
TREE_STATIC (decl) = 1;
TREE_ADDRESSABLE (decl) = 1;
TREE_USED (decl) = 1;
gfc_set_decl_location (decl, &gfc_current_locus);
gfc_add_decl_to_function (decl);
return decl;
}
static tree
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL, 0);
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
if (decl != NULL_TREE)
{
tree size = TYPE_SIZE_UNIT (union_type);
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
{
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_UNIT (decl) = size;
}
}
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
return decl;
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->name));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
DECL_USER_ALIGN (decl) = 0;
gfc_set_decl_location (decl, &com->where);
common_sym->backend_decl = pushdecl_top_level (decl);
}
if (!is_init)
{
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
}
else
{
DECL_INITIAL (decl) = error_mark_node;
DECL_COMMON (decl) = 0;
DECL_DEFER_OUTPUT (decl) = 0;
}
return decl;
}
static void
create_common (gfc_common_head *com, segment_info * head, bool saw_equiv)
{
segment_info *s, *next_s;
tree union_type;
tree *field_link;
record_layout_info rli;
tree decl;
bool is_init = false;
if (saw_equiv)
union_type = make_node (UNION_TYPE);
else
union_type = make_node (RECORD_TYPE);
rli = start_record_layout (union_type);
field_link = &TYPE_FIELDS (union_type);
for (s = head; s; s = s->next)
{
build_field (s, union_type, rli);
*field_link = s->field;
field_link = &TREE_CHAIN (s->field);
if (s->sym->value)
is_init = true;
}
finish_record_layout (rli, true);
if (com)
decl = build_common_decl (com, union_type, is_init);
else
decl = build_equiv_decl (union_type, is_init);
if (is_init)
{
tree list, ctor, tmp;
HOST_WIDE_INT offset = 0;
list = NULL_TREE;
for (s = head; s; s = s->next)
{
if (s->sym->value)
{
if (s->offset < offset)
{
gfc_todo_error ("Initialization of overlapping variables");
}
tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
TREE_TYPE (s->field), s->sym->attr.dimension,
s->sym->attr.pointer || s->sym->attr.allocatable);
list = tree_cons (s->field, tmp, list);
offset = s->offset + s->length;
}
}
gcc_assert (list);
ctor = build1 (CONSTRUCTOR, union_type, nreverse(list));
TREE_CONSTANT (ctor) = 1;
TREE_INVARIANT (ctor) = 1;
TREE_STATIC (ctor) = 1;
DECL_INITIAL (decl) = ctor;
#ifdef ENABLE_CHECKING
for (tmp = CONSTRUCTOR_ELTS (ctor); tmp; tmp = TREE_CHAIN (tmp))
gcc_assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL);
#endif
}
for (s = head; s; s = next_s)
{
s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
decl, s->field, NULL_TREE);
next_s = s->next;
gfc_free (s);
}
}
static segment_info *
find_segment_info (gfc_symbol *symbol)
{
segment_info *n;
for (n = current_segment; n; n = n->next)
{
if (n->sym == symbol)
return n;
}
return NULL;
}
static mpz_t *
get_mpz (gfc_expr *e)
{
if (e->expr_type != EXPR_CONSTANT)
gfc_internal_error ("get_mpz(): Not an integer constant");
return &e->value.integer;
}
static HOST_WIDE_INT
element_number (gfc_array_ref *ar)
{
mpz_t multiplier, offset, extent, n;
gfc_array_spec *as;
HOST_WIDE_INT i, rank;
as = ar->as;
rank = as->rank;
mpz_init_set_ui (multiplier, 1);
mpz_init_set_ui (offset, 0);
mpz_init (extent);
mpz_init (n);
for (i = 0; i < rank; i++)
{
if (ar->dimen_type[i] != DIMEN_ELEMENT)
gfc_internal_error ("element_number(): Bad dimension type");
mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
mpz_mul (n, n, multiplier);
mpz_add (offset, offset, n);
mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
mpz_add_ui (extent, extent, 1);
if (mpz_sgn (extent) < 0)
mpz_set_ui (extent, 0);
mpz_mul (multiplier, multiplier, extent);
}
i = mpz_get_ui (offset);
mpz_clear (multiplier);
mpz_clear (offset);
mpz_clear (extent);
mpz_clear (n);
return i;
}
static HOST_WIDE_INT
calculate_offset (gfc_expr *e)
{
HOST_WIDE_INT n, element_size, offset;
gfc_typespec *element_type;
gfc_ref *reference;
offset = 0;
element_type = &e->symtree->n.sym->ts;
for (reference = e->ref; reference; reference = reference->next)
switch (reference->type)
{
case REF_ARRAY:
switch (reference->u.ar.type)
{
case AR_FULL:
break;
case AR_ELEMENT:
n = element_number (&reference->u.ar);
if (element_type->type == BT_CHARACTER)
gfc_conv_const_charlen (element_type->cl);
element_size =
int_size_in_bytes (gfc_typenode_for_spec (element_type));
offset += n * element_size;
break;
default:
gfc_error ("Bad array reference at %L", &e->where);
}
break;
case REF_SUBSTRING:
if (reference->u.ss.start != NULL)
offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
break;
default:
gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
&e->where);
}
return offset;
}
static void
new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
{
HOST_WIDE_INT offset1, offset2;
segment_info *a;
offset1 = calculate_offset (eq1->expr);
offset2 = calculate_offset (eq2->expr);
a = get_segment_info (eq2->expr->symtree->n.sym,
v->offset + offset1 - offset2);
current_segment = add_segments (current_segment, a);
}
static void
confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
gfc_equiv *eq2)
{
HOST_WIDE_INT offset1, offset2;
offset1 = calculate_offset (eq1->expr);
offset2 = calculate_offset (eq2->expr);
if (s1->offset + offset1 != s2->offset + offset2)
gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
"'%s' at %L", s1->sym->name, &s1->sym->declared_at,
s2->sym->name, &s2->sym->declared_at);
}
static void
add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
{
segment_info *n;
n = find_segment_info (eq2->expr->symtree->n.sym);
if (n == NULL)
new_condition (f, eq1, eq2);
else
confirm_condition (f, eq1, n, eq2);
}
static bool
find_equivalence (segment_info *n)
{
gfc_equiv *e1, *e2, *eq, *other;
bool found;
found = FALSE;
for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
{
other = NULL;
for (e2 = e1->eq; e2; e2 = e2->eq)
{
if (e2->used)
continue;
if (e1->expr->symtree->n.sym == n->sym)
{
eq = e1;
other = e2;
}
else if (e2->expr->symtree->n.sym == n->sym)
{
eq = e2;
other = e1;
}
else
eq = NULL;
if (eq)
{
add_condition (n, eq, other);
eq->used = 1;
found = TRUE;
if (eq == e2)
break;
}
}
}
return found;
}
static void
add_equivalences (bool *saw_equiv)
{
segment_info *f;
bool more;
more = TRUE;
while (more)
{
more = FALSE;
for (f = current_segment; f; f = f->next)
{
if (!f->sym->equiv_built)
{
f->sym->equiv_built = 1;
more = find_equivalence (f);
if (more)
*saw_equiv = true;
}
}
}
}
static HOST_WIDE_INT
align_segment (unsigned HOST_WIDE_INT * palign)
{
segment_info *s;
unsigned HOST_WIDE_INT offset;
unsigned HOST_WIDE_INT max_align;
unsigned HOST_WIDE_INT this_align;
unsigned HOST_WIDE_INT this_offset;
max_align = 1;
offset = 0;
for (s = current_segment; s; s = s->next)
{
this_align = TYPE_ALIGN_UNIT (s->field);
if (s->offset & (this_align - 1))
{
this_offset = this_align - ((s->offset + offset) & (this_align - 1));
if (this_offset & (max_align - 1))
{
gfc_error ("The equivalence set for variable '%s' "
"declared at %L violates alignment requirents",
s->sym->name, &s->sym->declared_at);
}
offset += this_offset;
}
max_align = this_align;
}
if (palign)
*palign = max_align;
return offset;
}
static void
apply_segment_offset (segment_info * s, HOST_WIDE_INT offset)
{
for (; s; s = s->next)
s->offset += offset;
}
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;
for (sym = var_list; sym; sym = sym->common_next)
{
if (sym->equiv_built)
{
current_segment = common_segment;
s = find_segment_info (sym);
align = TYPE_ALIGN_UNIT (s->field);
current_offset = (current_offset + align - 1) &~ (align - 1);
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
{
s = current_segment = get_segment_info (sym, current_offset);
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))
{
gfc_warning ("Padding of %d bytes required before '%s' in "
"COMMON '%s' at %L", offset, s->sym->name,
common->name, &common->where);
}
else
{
apply_segment_offset (common_segment, offset);
}
apply_segment_offset (current_segment, offset);
current_offset += offset;
if (max_align < align)
max_align = align;
common_segment = add_segments (common_segment, current_segment);
}
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);
}
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);
add_equivalences (&dummy);
offset = align_segment (&align);
offset -= current_segment->offset & ~(align - 1);
apply_segment_offset (current_segment, offset);
create_common (NULL, current_segment, true);
break;
}
}
static void
named_common (gfc_symtree *st)
{
translate_common (st->n.common, st->n.common->head);
}
void
gfc_trans_common (gfc_namespace *ns)
{
gfc_common_head *c;
if (ns->blank_common.head != NULL)
{
c = gfc_get_common_head ();
c->where = ns->proc_name->declared_at;
strcpy (c->name, BLANK_COMMON_NAME);
translate_common (c, ns->blank_common.head);
}
gfc_traverse_symtree (ns->common_root, named_common);
gfc_commit_symbols ();
finish_equivalences (ns);
}