HOST_WIDE_INT offset;
HOST_WIDE_INT length;
/* This will contain the field type until the field is created. */
- tree field;
+ tree field;
struct segment_info *next;
} segment_info;
#define BLANK_COMMON_NAME "__BLNK__"
-
/* Make a segment_info based on a symbol. */
static segment_info *
return s;
}
-/* Add combine segment V and segement LIST. */
+/* Add combine segment V and segment LIST. */
static segment_info *
add_segments (segment_info *list, segment_info *v)
segment_info *s;
segment_info *p;
segment_info *next;
-
+
p = NULL;
s = list;
p = v;
v = next;
}
+
return list;
}
if (strcmp (name, BLANK_COMMON_NAME) == 0)
return get_identifier (name);
+
if (gfc_option.flag_underscoring)
{
has_underscore = strchr (name, '_') != 0;
snprintf (mangled_name, sizeof mangled_name, "%s__", name);
else
snprintf (mangled_name, sizeof mangled_name, "%s_", name);
+
return get_identifier (mangled_name);
}
else
/* Get storage for common block. */
static tree
-build_common_decl (gfc_common_head *com, const char *name,
+build_common_decl (gfc_common_head *com, const char *name,
tree union_type, bool is_init)
{
gfc_symbol *common_sym;
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (strcmp (name, BLANK_COMMON_NAME))
- gfc_warning ("Named COMMON block '%s' at %L shall be of the "
- "same size", name, &com->where);
+ gfc_warning ("Named COMMON block '%s' at %L shall be of the "
+ "same size", name, &com->where);
DECL_SIZE_UNIT (decl) = size;
}
}
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
-
}
else
{
static void
create_common (gfc_common_head *com, const char *name)
-{
- segment_info *h, *next_s;
+{
+ segment_info *s, *next_s;
tree union_type;
tree *field_link;
record_layout_info rli;
rli = start_record_layout (union_type);
field_link = &TYPE_FIELDS (union_type);
- for (h = current_common; h; h = next_s)
+ for (s = current_common; s; s = s->next)
{
- build_field (h, union_type, rli);
+ build_field (s, union_type, rli);
/* Link the field into the type. */
- *field_link = h->field;
- field_link = &TREE_CHAIN (h->field);
+ *field_link = s->field;
+ field_link = &TREE_CHAIN (s->field);
- /* Has initial value. */
- if (h->sym->value)
+ /* Has initial value. */
+ if (s->sym->value)
is_init = true;
-
- next_s = h->next;
}
finish_record_layout (rli, true);
HOST_WIDE_INT offset = 0;
list = NULL_TREE;
- for (h = current_common; h; h = h->next)
+ for (s = current_common; s; s = s->next)
{
- if (h->sym->value)
+ if (s->sym->value)
{
- if (h->offset < offset)
+ if (s->offset < offset)
{
/* We have overlapping initializers. It could either be
- partially initilalized arrays (lagal), or the user
+ partially initilalized arrays (legal), or the user
specified multiple initial values (illegal).
We don't implement this yet, so bail out. */
gfc_todo_error ("Initialization of overlapping variables");
}
- if (h->sym->attr.dimension)
+ if (s->sym->attr.dimension)
{
- tmp = gfc_conv_array_initializer (TREE_TYPE (h->field),
- h->sym->value);
- list = tree_cons (h->field, tmp, list);
+ tmp = gfc_conv_array_initializer (TREE_TYPE (s->field),
+ s->sym->value);
+ list = tree_cons (s->field, tmp, list);
}
else
{
- switch (h->sym->ts.type)
+ switch (s->sym->ts.type)
{
case BT_CHARACTER:
se.expr = gfc_conv_string_init
- (h->sym->ts.cl->backend_decl, h->sym->value);
+ (s->sym->ts.cl->backend_decl, s->sym->value);
break;
case BT_DERIVED:
gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, h->sym->value, 1);
+ gfc_conv_structure (&se, s->sym->value, 1);
break;
default:
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, h->sym->value);
+ gfc_conv_expr (&se, s->sym->value);
break;
}
- list = tree_cons (h->field, se.expr, list);
+ list = tree_cons (s->field, se.expr, list);
}
- offset = h->offset + h->length;
+ offset = s->offset + s->length;
}
}
assert (list);
}
/* Build component reference for each variable. */
- for (h = current_common; h; h = next_s)
+ for (s = current_common; s; s = next_s)
{
- h->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (h->field),
- decl, h->field, NULL_TREE);
+ s->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (s->field),
+ decl, s->field, NULL_TREE);
- next_s = h->next;
- gfc_free (h);
+ next_s = s->next;
+ gfc_free (s);
}
-}
+}
/* 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)
-{
+{
segment_info *n;
for (n = current_segment; n; n = n->next)
return n;
}
- return NULL;
-}
+ return NULL;
+}
/* Given an expression node, make sure it is a constant integer and return
- the mpz_t value. */
+ the mpz_t value. */
-static mpz_t *
-get_mpz (gfc_expr *g)
+static mpz_t *
+get_mpz (gfc_expr *e)
{
- if (g->expr_type != EXPR_CONSTANT)
+
+ if (e->expr_type != EXPR_CONSTANT)
gfc_internal_error ("get_mpz(): Not an integer constant");
- return &g->value.integer;
-}
+ return &e->value.integer;
+}
/* Given an array specification and an array reference, figure out the
array element number (zero based). Bounds and elements are guaranteed
to be constants. If something goes wrong we generate an error and
- return zero. */
+ return zero. */
static HOST_WIDE_INT
element_number (gfc_array_ref *ar)
-{
- mpz_t multiplier, offset, extent, l;
+{
+ mpz_t multiplier, offset, extent, n;
gfc_array_spec *as;
- HOST_WIDE_INT b, rank;
+ 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 (l);
+ mpz_init (n);
- for (b = 0; b < rank; b++)
+ for (i = 0; i < rank; i++)
{
- if (ar->dimen_type[b] != DIMEN_ELEMENT)
+ if (ar->dimen_type[i] != DIMEN_ELEMENT)
gfc_internal_error ("element_number(): Bad dimension type");
- mpz_sub (l, *get_mpz (ar->start[b]), *get_mpz (as->lower[b]));
+ mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
- mpz_mul (l, l, multiplier);
- mpz_add (offset, offset, l);
+ mpz_mul (n, n, multiplier);
+ mpz_add (offset, offset, n);
- mpz_sub (extent, *get_mpz (as->upper[b]), *get_mpz (as->lower[b]));
+ 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_mul (multiplier, multiplier, extent);
}
- b = mpz_get_ui (offset);
+ i = mpz_get_ui (offset);
mpz_clear (multiplier);
mpz_clear (offset);
mpz_clear (extent);
- mpz_clear (l);
+ mpz_clear (n);
- return b;
+ return i;
}
have to calculate the further reference. */
static HOST_WIDE_INT
-calculate_offset (gfc_expr *s)
+calculate_offset (gfc_expr *e)
{
- HOST_WIDE_INT a, element_size, offset;
+ HOST_WIDE_INT n, element_size, offset;
gfc_typespec *element_type;
gfc_ref *reference;
offset = 0;
- element_type = &s->symtree->n.sym->ts;
+ element_type = &e->symtree->n.sym->ts;
- for (reference = s->ref; reference; reference = reference->next)
+ for (reference = e->ref; reference; reference = reference->next)
switch (reference->type)
{
case REF_ARRAY:
break;
case AR_ELEMENT:
- a = element_number (&reference->u.ar);
+ 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 += a * element_size;
+ offset += n * element_size;
break;
default:
- gfc_error ("Bad array reference at %L", &s->where);
+ gfc_error ("Bad array reference at %L", &e->where);
}
break;
case REF_SUBSTRING:
break;
default:
gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
- &s->where);
- }
+ &e->where);
+ }
return offset;
}
-
+
/* Add a new segment_info structure to the current segment. eq1 is already
in the list, eq2 is not. */
{
HOST_WIDE_INT offset1, offset2;
segment_info *a;
-
+
offset1 = calculate_offset (eq1->expr);
offset2 = calculate_offset (eq2->expr);
is. */
static void
-confirm_condition (segment_info *k, gfc_equiv *eq1, segment_info *e,
+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 (k->offset + offset1 != e->offset + offset2)
+
+ if (s1->offset + offset1 != s2->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);
-}
+ "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
+ s2->sym->name, &s2->sym->declared_at);
+}
+
-
/* Process a new equivalence condition. eq1 is know to be in segment f.
If eq2 is also present then confirm that the condition holds.
Otherwise add a new variable to the segment list. */
checks for rules involving the first symbol in the equivalence set. */
static bool
-find_equivalence (segment_info *f)
+find_equivalence (segment_info *n)
{
- gfc_equiv *c, *l, *eq, *other;
+ gfc_equiv *e1, *e2, *eq, *other;
bool found;
found = FALSE;
- for (c = f->sym->ns->equiv; c; c = c->next)
+ for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
{
other = NULL;
- for (l = c->eq; l; l = l->eq)
+ for (e2 = e1->eq; e2; e2 = e2->eq)
{
- if (l->used)
+ if (e2->used)
continue;
- if (c->expr->symtree->n.sym == f-> sym)
+ if (e1->expr->symtree->n.sym == n->sym)
{
- eq = c;
- other = l;
+ eq = e1;
+ other = e2;
}
- else if (l->expr->symtree->n.sym == f->sym)
+ else if (e2->expr->symtree->n.sym == n->sym)
{
- eq = l;
- other = c;
+ eq = e2;
+ other = e1;
}
else
eq = NULL;
if (eq)
{
- add_condition (f, eq, other);
+ add_condition (n, eq, other);
eq->used = 1;
found = TRUE;
/* If this symbol is the first in the chain we may find other
matches. Otherwise we can skip to the next equivalence. */
- if (eq == l)
+ if (eq == e2)
break;
}
}
return found;
}
-
+
/* Add all symbols equivalenced within a segment. We need to scan the
segment list multiple times to include indirect equivalences. */
}
}
}
-
-
+
+
/* Given a seed symbol, create a new segment consisting of that symbol
and all of the symbols equivalenced with that symbol. */
-
+
static void
new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
{
+
current_segment = get_segment_info (sym, current_offset);
- /* The offset of the next common variable. */
+ /* The offset of the next common variable. */
current_offset += current_segment->length;
/* Add all object directly or indirectly equivalenced with this common
- variable. */
+ variable. */
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, name, &common->where);
-
+ "to COMMON '%s' at %L", sym->name, name, &common->where);
/* Add these to the common block. */
current_common = add_segments (current_common, current_segment);
HOST_WIDE_INT min_offset;
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) continue;
+ if (y->used)
+ continue;
sym = z->expr->symtree->n.sym;
current_segment = get_segment_info (sym, 0);
/* Translate a single common block. */
-static void
-translate_common (gfc_common_head *common, const char *name,
+static void
+translate_common (gfc_common_head *common, const char *name,
gfc_symbol *var_list)
{
gfc_symbol *sym;
}
create_common (common, name);
-}
-
+}
+
/* Work function for translating a named common block. */
static void
named_common (gfc_symtree *st)
{
+
translate_common (st->n.common, st->name, st->n.common->head);
}
/* Translate the common blocks in a namespace. Unlike other variables,
these have to be created before code, because the backend_decl depends
on the rest of the common block. */
-
-void
+
+void
gfc_trans_common (gfc_namespace *ns)
{
gfc_common_head *c;
}
/* Translate all named common blocks. */
- gfc_traverse_symtree (ns->common_root, named_common);
+ gfc_traverse_symtree (ns->common_root, named_common);
/* Commit the newly created symbols for common blocks. */
gfc_commit_symbols ();
projects / gcc.git / commitdiff