trans-common.c: Fix whitespace issues, make variable names more readable.
* trans-common.c: Fix whitespace issues, make variable names more readable. (create_common): Additionally, make loop logic more obvious. Co-Authored-By: Paul Brook <paul@codesourcery.com> From-SVN: r84453
This commit is contained in:
parent
44bce8bfac
commit
a8a6b60373
|
@ -1,4 +1,10 @@
|
|||
2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* trans-common.c: Fix whitespace issues, make variable names
|
||||
more readable.
|
||||
(create_common): Additionally, make loop logic more obvious.
|
||||
|
||||
2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
Paul Brook <paul@codesourcery.com>
|
||||
|
||||
PR fortran/13415
|
||||
|
|
|
@ -113,7 +113,7 @@ typedef struct segment_info
|
|||
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;
|
||||
|
||||
|
@ -123,7 +123,6 @@ static gfc_namespace *gfc_common_ns = NULL;
|
|||
|
||||
#define BLANK_COMMON_NAME "__BLNK__"
|
||||
|
||||
|
||||
/* Make a segment_info based on a symbol. */
|
||||
|
||||
static segment_info *
|
||||
|
@ -146,7 +145,7 @@ get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
|
|||
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)
|
||||
|
@ -154,7 +153,7 @@ add_segments (segment_info *list, segment_info *v)
|
|||
segment_info *s;
|
||||
segment_info *p;
|
||||
segment_info *next;
|
||||
|
||||
|
||||
p = NULL;
|
||||
s = list;
|
||||
|
||||
|
@ -184,6 +183,7 @@ add_segments (segment_info *list, segment_info *v)
|
|||
p = v;
|
||||
v = next;
|
||||
}
|
||||
|
||||
return list;
|
||||
}
|
||||
|
||||
|
@ -197,6 +197,7 @@ gfc_sym_mangled_common_id (const char *name)
|
|||
|
||||
if (strcmp (name, BLANK_COMMON_NAME) == 0)
|
||||
return get_identifier (name);
|
||||
|
||||
if (gfc_option.flag_underscoring)
|
||||
{
|
||||
has_underscore = strchr (name, '_') != 0;
|
||||
|
@ -204,6 +205,7 @@ gfc_sym_mangled_common_id (const char *name)
|
|||
snprintf (mangled_name, sizeof mangled_name, "%s__", name);
|
||||
else
|
||||
snprintf (mangled_name, sizeof mangled_name, "%s_", name);
|
||||
|
||||
return get_identifier (mangled_name);
|
||||
}
|
||||
else
|
||||
|
@ -275,7 +277,7 @@ build_equiv_decl (tree union_type, bool is_init)
|
|||
/* 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;
|
||||
|
@ -298,8 +300,8 @@ build_common_decl (gfc_common_head *com, const char *name,
|
|||
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;
|
||||
}
|
||||
}
|
||||
|
@ -331,7 +333,6 @@ build_common_decl (gfc_common_head *com, const char *name,
|
|||
DECL_INITIAL (decl) = NULL_TREE;
|
||||
DECL_COMMON (decl) = 1;
|
||||
DECL_DEFER_OUTPUT (decl) = 1;
|
||||
|
||||
}
|
||||
else
|
||||
{
|
||||
|
@ -348,8 +349,8 @@ build_common_decl (gfc_common_head *com, const char *name,
|
|||
|
||||
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;
|
||||
|
@ -361,19 +362,17 @@ create_common (gfc_common_head *com, const char *name)
|
|||
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);
|
||||
|
||||
|
@ -389,46 +388,46 @@ create_common (gfc_common_head *com, const char *name)
|
|||
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);
|
||||
|
@ -445,23 +444,23 @@ create_common (gfc_common_head *com, const char *name)
|
|||
}
|
||||
|
||||
/* 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)
|
||||
|
@ -470,53 +469,54 @@ find_segment_info (gfc_symbol *symbol)
|
|||
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)
|
||||
|
@ -525,14 +525,14 @@ element_number (gfc_array_ref *ar)
|
|||
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;
|
||||
}
|
||||
|
||||
|
||||
|
@ -543,16 +543,16 @@ element_number (gfc_array_ref *ar)
|
|||
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:
|
||||
|
@ -562,16 +562,16 @@ calculate_offset (gfc_expr *s)
|
|||
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:
|
||||
|
@ -580,12 +580,12 @@ calculate_offset (gfc_expr *s)
|
|||
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. */
|
||||
|
||||
|
@ -594,7 +594,7 @@ 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);
|
||||
|
||||
|
@ -610,21 +610,21 @@ new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
|
|||
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)
|
||||
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);
|
||||
}
|
||||
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
|
||||
/* 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. */
|
||||
|
@ -648,41 +648,41 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
|
|||
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;
|
||||
}
|
||||
}
|
||||
|
@ -690,7 +690,7 @@ find_equivalence (segment_info *f)
|
|||
return found;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Add all symbols equivalenced within a segment. We need to scan the
|
||||
segment list multiple times to include indirect equivalences. */
|
||||
|
||||
|
@ -714,28 +714,27 @@ add_equivalences (void)
|
|||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
/* 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);
|
||||
|
@ -753,9 +752,10 @@ finish_equivalences (gfc_namespace *ns)
|
|||
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);
|
||||
|
||||
|
@ -778,8 +778,8 @@ finish_equivalences (gfc_namespace *ns)
|
|||
|
||||
/* 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;
|
||||
|
@ -795,14 +795,15 @@ translate_common (gfc_common_head *common, const char *name,
|
|||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
|
@ -810,8 +811,8 @@ named_common (gfc_symtree *st)
|
|||
/* 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;
|
||||
|
@ -824,7 +825,7 @@ gfc_trans_common (gfc_namespace *ns)
|
|||
}
|
||||
|
||||
/* 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 ();
|
||||
|
|
Loading…
Reference in New Issue