#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"
#include <assert.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, *current_common;
static HOST_WIDE_INT current_offset;
static gfc_namespace *gfc_common_ns = NULL;
#define get_segment_info() gfc_getmem (sizeof (segment_info))
#define BLANK_COMMON_NAME "__BLNK__"
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 (gfc_symbol *sym)
{
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
if (strcmp (sym->name, BLANK_COMMON_NAME) == 0)
return get_identifier (sym->name);
if (gfc_option.flag_underscoring)
{
has_underscore = strchr (sym->name, '_') != 0;
if (gfc_option.flag_second_underscore && has_underscore)
snprintf (name, sizeof name, "%s__", sym->name);
else
snprintf (name, sizeof name, "%s_", sym->name);
return get_identifier (name);
}
else
return get_identifier (sym->name);
}
static tree
build_field (segment_info *h, tree union_type, record_layout_info rli)
{
tree type = gfc_sym_type (h->sym);
tree name = get_identifier (h->sym->name);
tree field = build_decl (FIELD_DECL, name, type);
HOST_WIDE_INT offset = h->offset;
unsigned HOST_WIDE_INT desired_align, known_align;
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)));
return field;
}
static tree
build_equiv_decl (tree union_type, bool is_init)
{
tree decl;
if (is_init)
{
decl = gfc_create_var (union_type, "equiv");
TREE_STATIC (decl) = 1;
return decl;
}
decl = build_decl (VAR_DECL, NULL, union_type);
DECL_ARTIFICIAL (decl) = 1;
DECL_COMMON (decl) = 1;
TREE_ADDRESSABLE (decl) = 1;
TREE_USED (decl) = 1;
gfc_add_decl_to_function (decl);
return decl;
}
static tree
build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL);
gfc_get_symbol (sym->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 (sym->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size", sym->name, &sym->declared_at);
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 (sym->name), union_type);
SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (sym));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
DECL_USER_ALIGN (decl) = 0;
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_symbol *sym)
{
segment_info *h, *next_s;
tree union_type;
tree *field_link;
record_layout_info rli;
tree decl;
bool is_init = false;
union_type = make_node (UNION_TYPE);
rli = start_record_layout (union_type);
field_link = &TYPE_FIELDS (union_type);
for (h = current_common; h; h = next_s)
{
tree field;
field = build_field (h, union_type, rli);
*field_link = field;
field_link = &TREE_CHAIN (field);
h->field = field;
if (h->sym->value)
is_init = true;
next_s = h->next;
}
finish_record_layout (rli, true);
if (sym)
decl = build_common_decl (sym, union_type, is_init);
else
decl = build_equiv_decl (union_type, is_init);
if (is_init)
{
tree list, ctor, tmp;
gfc_se se;
HOST_WIDE_INT offset = 0;
list = NULL_TREE;
for (h = current_common; h; h = h->next)
{
if (h->sym->value)
{
if (h->offset < offset)
{
gfc_todo_error ("Initialization of overlapping variables");
}
if (h->sym->attr.dimension)
{
tmp = gfc_conv_array_initializer (TREE_TYPE (h->field),
h->sym->value);
list = tree_cons (h->field, tmp, list);
}
else
{
switch (h->sym->ts.type)
{
case BT_CHARACTER:
se.expr = gfc_conv_string_init
(h->sym->ts.cl->backend_decl, h->sym->value);
break;
case BT_DERIVED:
gfc_init_se (&se, NULL);
gfc_conv_structure (&se, sym->value, 1);
break;
default:
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, h->sym->value);
break;
}
list = tree_cons (h->field, se.expr, list);
}
offset = h->offset + h->length;
}
}
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))
assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL);
#endif
}
for (h = current_common; h; h = next_s)
{
h->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (h->field),
decl, h->field);
next_s = h->next;
gfc_free (h);
}
}
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 HOST_WIDE_INT
calculate_length (gfc_symbol *symbol)
{
HOST_WIDE_INT j, element_size;
mpz_t elements;
if (symbol->ts.type == BT_CHARACTER)
gfc_conv_const_charlen (symbol->ts.cl);
element_size = int_size_in_bytes (gfc_typenode_for_spec (&symbol->ts));
if (symbol->as == NULL)
return element_size;
if (spec_size (symbol->as, &elements) == FAILURE)
gfc_internal_error ("calculate_length(): Unable to determine array size");
j = mpz_get_ui (elements);
mpz_clear (elements);
return j*element_size;;
}
static mpz_t *
get_mpz (gfc_expr *g)
{
if (g->expr_type != EXPR_CONSTANT)
gfc_internal_error ("get_mpz(): Not an integer constant");
return &g->value.integer;
}
static HOST_WIDE_INT
element_number (gfc_array_ref *ar)
{
mpz_t multiplier, offset, extent, l;
gfc_array_spec *as;
HOST_WIDE_INT b, rank;
as = ar->as;
rank = as->rank;
mpz_init_set_ui (multiplier, 1);
mpz_init_set_ui (offset, 0);
mpz_init (extent);
mpz_init (l);
for (b = 0; b < rank; b++)
{
if (ar->dimen_type[b] != DIMEN_ELEMENT)
gfc_internal_error ("element_number(): Bad dimension type");
mpz_sub (l, *get_mpz (ar->start[b]), *get_mpz (as->lower[b]));
mpz_mul (l, l, multiplier);
mpz_add (offset, offset, l);
mpz_sub (extent, *get_mpz (as->upper[b]), *get_mpz (as->lower[b]));
mpz_add_ui (extent, extent, 1);
if (mpz_sgn (extent) < 0)
mpz_set_ui (extent, 0);
mpz_mul (multiplier, multiplier, extent);
}
b = mpz_get_ui (offset);
mpz_clear (multiplier);
mpz_clear (offset);
mpz_clear (extent);
mpz_clear (l);
return b;
}
static HOST_WIDE_INT
calculate_offset (gfc_expr *s)
{
HOST_WIDE_INT a, element_size, offset;
gfc_typespec *element_type;
gfc_ref *reference;
offset = 0;
element_type = &s->symtree->n.sym->ts;
for (reference = s->ref; reference; reference = reference->next)
switch (reference->type)
{
case REF_ARRAY:
switch (reference->u.ar.type)
{
case AR_FULL:
break;
case AR_ELEMENT:
a = 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 += a * element_size;
break;
default:
gfc_error ("Bad array reference at %L", &s->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",
&s->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 ();
a->sym = eq2->expr->symtree->n.sym;
a->offset = v->offset + offset1 - offset2;
a->length = calculate_length (eq2->expr->symtree->n.sym);
current_segment = add_segments (current_segment, a);
}
static void
confirm_condition (segment_info *k, gfc_equiv *eq1, segment_info *e,
gfc_equiv *eq2)
{
HOST_WIDE_INT offset1, offset2;
offset1 = calculate_offset (eq1->expr);
offset2 = calculate_offset (eq2->expr);
if (k->offset + offset1 != e->offset + offset2)
gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
"'%s' at %L", k->sym->name, &k->sym->declared_at,
e->sym->name, &e->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 *f)
{
gfc_equiv *c, *l, *eq, *other;
bool found;
found = FALSE;
for (c = f->sym->ns->equiv; c; c = c->next)
{
other = NULL;
for (l = c->eq; l; l = l->eq)
{
if (l->used)
continue;
if (c->expr->symtree->n.sym ==f-> sym)
{
eq = c;
other = l;
}
else if (l->expr->symtree->n.sym == f->sym)
{
eq = l;
other = c;
}
else
eq = NULL;
if (eq)
{
add_condition (f, eq, other);
l->used = 1;
found = TRUE;
break;
}
}
}
return found;
}
static void
add_equivalences (void)
{
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);
}
}
}
}
static void
new_segment (gfc_symbol *common_sym, gfc_symbol *sym)
{
HOST_WIDE_INT length;
current_segment = get_segment_info ();
current_segment->sym = sym;
current_segment->offset = current_offset;
length = calculate_length (sym);
current_segment->length = length;
add_equivalences ();
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid extension "
"to COMMON '%s' at %L",
sym->name, common_sym->name, &common_sym->declared_at);
current_offset += length;
current_common = add_segments (current_common, current_segment);
}
static void
finish_equivalences (gfc_namespace *ns)
{
gfc_equiv *z, *y;
gfc_symbol *sym;
segment_info *v;
HOST_WIDE_INT min_offset;
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 ();
current_segment->sym = sym;
current_segment->offset = 0;
current_segment->length = calculate_length (sym);
add_equivalences ();
min_offset = current_segment->offset;
for (v = current_segment; v; v = v->next)
v->offset -= min_offset;
current_common = current_segment;
create_common (NULL);
break;
}
}
static void
translate_common (gfc_symbol *common_sym, gfc_symbol *var_list)
{
gfc_symbol *sym;
current_common = NULL;
current_offset = 0;
for (sym = var_list; sym; sym = sym->common_next)
{
if (! sym->equiv_built)
new_segment (common_sym, sym);
}
create_common (common_sym);
}
static void
named_common (gfc_symbol *s)
{
if (s->attr.common)
translate_common (s, s->common_head);
}
void
gfc_trans_common (gfc_namespace *ns)
{
gfc_symbol *sym;
if (ns->blank_common != NULL)
{
gfc_get_symbol (BLANK_COMMON_NAME, ns, &sym);
translate_common (sym, ns->blank_common);
}
gfc_traverse_ns (ns, named_common);
gfc_commit_symbols ();
finish_equivalences (ns);
}