static int
compare_parameter (gfc_symbol * formal, gfc_expr * actual,
int ranks_must_agree, int is_elemental)
{
gfc_ref *ref;
if (actual->ts.type == BT_PROCEDURE)
{
if (formal->attr.flavor != FL_PROCEDURE)
return 0;
if (formal->attr.function
&& !compare_type_rank (formal, actual->symtree->n.sym))
return 0;
if (formal->attr.if_source == IFSRC_UNKNOWN)
return 1; /* Assume match */
return compare_interfaces (formal, actual->symtree->n.sym, 0);
}
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& !gfc_compare_types (&formal->ts, &actual->ts))
return 0;
if (symbol_rank (formal) == actual->rank)
return 1;
/* At this point the ranks didn't agree. */
if (ranks_must_agree || formal->attr.pointer)
return 0;
if (actual->rank != 0)
return is_elemental || formal->attr.dimension;
/* At this point, we are considering a scalar passed to an array.
This is legal if the scalar is an array element of the right sort. */
if (formal->as->type == AS_ASSUMED_SHAPE)
return 0;
for (ref = actual->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING)
return 0;
for (ref = actual->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
break;
if (ref == NULL)
return 0; /* Not an array element */
return 1;
}
static int
compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
{
int r1, r2;
r1 = (s1->as != NULL) ? s1->as->rank : 0;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
if (r1 != r2)
return 0; /* Ranks differ */
return gfc_compare_types (&s1->ts, &s2->ts);
}
void
gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
mpz_t index, mpz_t repeat)
{
gfc_ref *ref;
gfc_expr *init, *expr;
gfc_constructor *con, *last_con;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
/* Find/create the parent expressions for subobject references. */
for (ref = lvalue->ref; ref; ref = ref->next)
{
/* Use the existing initializer expression if it exists.
Otherwise create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
/* Find or create this element. */
switch (ref->type)
{
case REF_ARRAY:
if (init == NULL)
{
/* The element typespec will be the same as the array
typespec. */
expr->ts = *last_ts;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
}
else
gcc_assert (expr->expr_type == EXPR_ARRAY);
if (ref->u.ar.type == AR_ELEMENT)
{
get_array_index (&ref->u.ar, &offset);
/* This had better not be the bottom of the reference.
We can still get to a full array via a component. */
gcc_assert (ref->next != NULL);
}
else
{
mpz_set (offset, index);
/* We're at a full array or an array section. This means
that we've better have found a full array, and that we're
at the bottom of the reference. */
gcc_assert (ref->u.ar.type == AR_FULL);
gcc_assert (ref->next == NULL);
}
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_offset (offset, con);
/* Create a new constructor. */
if (con == NULL)
{
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
gfc_insert_constructor (expr, con);
}
else
gcc_assert (ref->next != NULL);
break;
case REF_COMPONENT:
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_component (ref->u.c.component, con);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
con->n.component = ref->u.c.component;
con->next = expr->value.constructor;
expr->value.constructor = con;
}
/* Since we're only intending to initialize arrays here,
there better be an inner reference. */
gcc_assert (ref->next != NULL);
break;
case REF_SUBSTRING:
default:
gcc_unreachable ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
if (last_ts->type == BT_CHARACTER)
expr = create_character_intializer (init, last_ts, NULL, rvalue);
else
{
/* We should never be overwriting an existing initializer. */
gcc_assert (!init);
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
void
gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
{
gfc_ref *ref;
gfc_expr *init;
gfc_expr *expr;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
/* Find/create the parent expressions for subobject references. */
for (ref = lvalue->ref; ref; ref = ref->next)
{
/* Break out of the loop if we find a substring. */
if (ref->type == REF_SUBSTRING)
{
/* A substring should always be the last subobject reference. */
gcc_assert (ref->next == NULL);
break;
}
/* Use the existing initializer expression if it exists. Otherwise
create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
/* Find or create this element. */
switch (ref->type)
{
case REF_ARRAY:
if (init == NULL)
{
/* The element typespec will be the same as the array
typespec. */
expr->ts = *last_ts;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
}
else
gcc_assert (expr->expr_type == EXPR_ARRAY);
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_offset (offset, con);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
gfc_insert_constructor (expr, con);
}
break;
case REF_COMPONENT:
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_component (ref->u.c.component, con);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
con->n.component = ref->u.c.component;
con->next = expr->value.constructor;
expr->value.constructor = con;
}
break;
default:
gcc_unreachable ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
if (ref || last_ts->type == BT_CHARACTER)
expr = create_character_intializer (init, last_ts, ref, rvalue);
else
{
/* Overwriting an existing initializer is non-standard but usually only
provokes a warning from other compilers. */
if (init != NULL)
{
/* Order in which the expressions arrive here depends on whether they
are from data statements or F95 style declarations. Therefore,
check which is the most recent. */
#ifdef USE_MAPPED_LOCATION
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
#else
expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
init : rvalue;
#endif
gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
"of '%s' at %L", symbol->name, &expr->where);
}
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
static void
show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
int op;
gfc_equiv *eq;
int i;
gcc_assert (ns);
save = gfc_current_ns;
show_indent ();
fputs ("Namespace:", dumpfile);
i = 0;
do
{
int l = i;
while (i < GFC_LETTERS - 1
&& gfc_compare_types (&ns->default_type[i+1],
&ns->default_type[l]))
i++;
if (i > l)
fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
else
fprintf (dumpfile, " %c: ", l+'A');
show_typespec(&ns->default_type[l]);
i++;
} while (i < GFC_LETTERS);
if (ns->proc_name != NULL)
{
show_indent ();
fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
}
++show_level;
gfc_current_ns = ns;
gfc_traverse_symtree (ns->common_root, show_common);
gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
/* User operator interfaces */
intr = ns->op[op];
if (intr == NULL)
continue;
show_indent ();
fprintf (dumpfile, "Operator interfaces for %s:",
gfc_op2string ((gfc_intrinsic_op) op));
for (; intr; intr = intr->next)
fprintf (dumpfile, " %s", intr->sym->name);
}
if (ns->uop_root != NULL)
{
show_indent ();
fputs ("User operators:\n", dumpfile);
gfc_traverse_user_op (ns, show_uop);
}
for (eq = ns->equiv; eq; eq = eq->next)
show_equiv (eq);
fputc ('\n', dumpfile);
show_indent ();
fputs ("code:", dumpfile);
show_code (show_level, ns->code);
--show_level;
for (ns = ns->contained; ns; ns = ns->sibling)
{
fputs ("\nCONTAINS\n", dumpfile);
++show_level;
show_namespace (ns);
--show_level;
}
fputc ('\n', dumpfile);
gfc_current_ns = save;
}
static bool
check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
{
gfc_component *cm1;
gfc_symbol *sym1;
gfc_symbol *sym2;
gfc_ref *ref1;
bool seen_component_ref;
if (expr1->expr_type != EXPR_VARIABLE
|| expr1->expr_type != EXPR_VARIABLE)
return false;
sym1 = expr1->symtree->n.sym;
sym2 = expr2->symtree->n.sym;
/* Keep it simple for now. */
if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
return false;
if (sym1->attr.pointer)
{
if (gfc_compare_types (&sym1->ts, &sym2->ts))
return false;
}
/* This is a conservative check on the components of the derived type
if no component references have been seen. Since we will not dig
into the components of derived type components, we play it safe by
returning false. First we check the reference chain and then, if
no component references have been seen, the components. */
seen_component_ref = false;
if (sym1->ts.type == BT_DERIVED)
{
for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
{
if (ref1->type != REF_COMPONENT)
continue;
if (ref1->u.c.component->ts.type == BT_DERIVED)
return false;
if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
&& gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
return false;
seen_component_ref = true;
}
}
if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
{
for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
{
if (cm1->ts.type == BT_DERIVED)
return false;
if ((sym2->attr.pointer || cm1->attr.pointer)
&& gfc_compare_types (&cm1->ts, &sym2->ts))
return false;
}
}
return true;
}
bool
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
mpz_t *repeat)
{
gfc_ref *ref;
gfc_expr *init;
gfc_expr *expr = NULL;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
/* Find/create the parent expressions for subobject references. */
for (ref = lvalue->ref; ref; ref = ref->next)
{
/* Break out of the loop if we find a substring. */
if (ref->type == REF_SUBSTRING)
{
/* A substring should always be the last subobject reference. */
gcc_assert (ref->next == NULL);
break;
}
/* Use the existing initializer expression if it exists. Otherwise
create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
/* Find or create this element. */
switch (ref->type)
{
case REF_ARRAY:
if (ref->u.ar.as->rank == 0)
{
gcc_assert (ref->u.ar.as->corank > 0);
if (init == NULL)
free (expr);
continue;
}
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("%qs at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where,
&init->where);
goto abort;
}
if (init == NULL)
{
/* The element typespec will be the same as the array
typespec. */
expr->ts = *last_ts;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
}
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
/* Check the bounds. */
if (mpz_cmp_si (offset, 0) < 0)
{
gfc_error ("Data element below array lower bound at %L",
&lvalue->where);
goto abort;
}
else if (repeat != NULL
&& ref->u.ar.type != AR_ELEMENT)
{
mpz_t size, end;
gcc_assert (ref->u.ar.type == AR_FULL
&& ref->next == NULL);
mpz_init_set (end, offset);
mpz_add (end, end, *repeat);
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (end, size) > 0)
{
mpz_clear (size);
gfc_error ("Data element above array upper bound at %L",
&lvalue->where);
goto abort;
}
mpz_clear (size);
}
con = gfc_constructor_lookup (expr->value.constructor,
mpz_get_si (offset));
if (!con)
{
con = gfc_constructor_lookup_next (expr->value.constructor,
mpz_get_si (offset));
if (con != NULL && mpz_cmp (con->offset, end) >= 0)
con = NULL;
}
/* Overwriting an existing initializer is non-standard but
usually only provokes a warning from other compilers. */
if (con != NULL && con->expr != NULL)
{
/* Order in which the expressions arrive here depends on
whether they are from data statements or F95 style
declarations. Therefore, check which is the most
recent. */
gfc_expr *exprd;
exprd = (LOCATION_LINE (con->expr->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? con->expr : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of %qs at %L",
symbol->name, &exprd->where) == false)
return false;
}
while (con != NULL)
{
gfc_constructor *next_con = gfc_constructor_next (con);
if (mpz_cmp (con->offset, end) >= 0)
break;
if (mpz_cmp (con->offset, offset) < 0)
{
gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
mpz_sub (con->repeat, offset, con->offset);
}
else if (mpz_cmp_si (con->repeat, 1) > 0
&& mpz_get_si (con->offset)
+ mpz_get_si (con->repeat) > mpz_get_si (end))
{
int endi;
splay_tree_node node
= splay_tree_lookup (con->base,
mpz_get_si (con->offset));
gcc_assert (node
&& con == (gfc_constructor *) node->value
&& node->key == (splay_tree_key)
mpz_get_si (con->offset));
endi = mpz_get_si (con->offset)
+ mpz_get_si (con->repeat);
if (endi > mpz_get_si (end) + 1)
mpz_set_si (con->repeat, endi - mpz_get_si (end));
else
mpz_set_si (con->repeat, 1);
mpz_set (con->offset, end);
node->key = (splay_tree_key) mpz_get_si (end);
break;
}
else
gfc_constructor_remove (con);
con = next_con;
}
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &rvalue->where,
mpz_get_si (offset));
mpz_set (con->repeat, *repeat);
repeat = NULL;
mpz_clear (end);
break;
}
else
{
mpz_t size;
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (offset, size) >= 0)
{
mpz_clear (size);
gfc_error ("Data element above array upper bound at %L",
&lvalue->where);
goto abort;
}
mpz_clear (size);
}
}
con = gfc_constructor_lookup (expr->value.constructor,
mpz_get_si (offset));
if (!con)
{
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &rvalue->where,
mpz_get_si (offset));
}
else if (mpz_cmp_si (con->repeat, 1) > 0)
{
/* Need to split a range. */
if (mpz_cmp (con->offset, offset) < 0)
{
gfc_constructor *pred_con = con;
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &con->where,
mpz_get_si (offset));
con->expr = gfc_copy_expr (pred_con->expr);
mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
mpz_sub (con->repeat, con->repeat, offset);
mpz_sub (pred_con->repeat, offset, pred_con->offset);
}
if (mpz_cmp_si (con->repeat, 1) > 0)
{
gfc_constructor *succ_con;
succ_con
= gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &con->where,
mpz_get_si (offset) + 1);
succ_con->expr = gfc_copy_expr (con->expr);
mpz_sub_ui (succ_con->repeat, con->repeat, 1);
mpz_set_si (con->repeat, 1);
}
}
break;
case REF_COMPONENT:
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.u.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
con = find_con_by_component (ref->u.c.component,
expr->value.constructor);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_constructor_append_expr (&expr->value.constructor,
NULL, NULL);
con->n.component = ref->u.c.component;
}
break;
default:
gcc_unreachable ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
mpz_clear (offset);
gcc_assert (repeat == NULL);
if (ref || last_ts->type == BT_CHARACTER)
{
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
return false;
expr = create_character_initializer (init, last_ts, ref, rvalue);
}
else
{
/* Overwriting an existing initializer is non-standard but usually only
provokes a warning from other compilers. */
if (init != NULL)
{
/* Order in which the expressions arrive here depends on whether
they are from data statements or F95 style declarations.
Therefore, check which is the most recent. */
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of %qs at %L",
symbol->name, &expr->where) == false)
return false;
}
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
return true;
abort:
if (!init)
gfc_free_expr (expr);
mpz_clear (offset);
return false;
}
void
gfc_show_namespace (gfc_namespace * ns)
{
gfc_interface *intr;
gfc_namespace *save;
gfc_intrinsic_op op;
gfc_equiv *eq;
int i;
save = gfc_current_ns;
show_level++;
show_indent ();
gfc_status ("Namespace:");
if (ns != NULL)
{
i = 0;
do
{
int l = i;
while (i < GFC_LETTERS - 1
&& gfc_compare_types(&ns->default_type[i+1],
&ns->default_type[l]))
i++;
if (i > l)
gfc_status(" %c-%c: ", l+'A', i+'A');
else
gfc_status(" %c: ", l+'A');
gfc_show_typespec(&ns->default_type[l]);
i++;
} while (i < GFC_LETTERS);
if (ns->proc_name != NULL)
{
show_indent ();
gfc_status ("procedure name = %s", ns->proc_name->name);
}
gfc_current_ns = ns;
gfc_traverse_symtree (ns->common_root, show_common);
gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
/* User operator interfaces */
intr = ns->operator[op];
if (intr == NULL)
continue;
show_indent ();
gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
for (; intr; intr = intr->next)
gfc_status (" %s", intr->sym->name);
}
if (ns->uop_root != NULL)
{
show_indent ();
gfc_status ("User operators:\n");
gfc_traverse_user_op (ns, show_uop);
}
}
for (eq = ns->equiv; eq; eq = eq->next)
gfc_show_equiv (eq);
gfc_status_char ('\n');
gfc_status_char ('\n');
gfc_show_code (0, ns->code);
for (ns = ns->contained; ns; ns = ns->sibling)
{
show_indent ();
gfc_status ("CONTAINS\n");
gfc_show_namespace (ns);
}
show_level--;
gfc_status_char ('\n');
gfc_current_ns = save;
}
gfc_try
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
{
gfc_ref *ref;
gfc_expr *init;
gfc_expr *expr;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_constructor *pred;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
splay_tree spt;
splay_tree_node sptn;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
/* Find/create the parent expressions for subobject references. */
for (ref = lvalue->ref; ref; ref = ref->next)
{
/* Break out of the loop if we find a substring. */
if (ref->type == REF_SUBSTRING)
{
/* A substring should always be the last subobject reference. */
gcc_assert (ref->next == NULL);
break;
}
/* Use the existing initializer expression if it exists. Otherwise
create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
/* Find or create this element. */
switch (ref->type)
{
case REF_ARRAY:
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("'%s' at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where,
&init->where);
return FAILURE;
}
if (init == NULL)
{
/* The element typespec will be the same as the array
typespec. */
expr->ts = *last_ts;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
}
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
/* Check the bounds. */
if (mpz_cmp_si (offset, 0) < 0)
{
gfc_error ("Data element below array lower bound at %L",
&lvalue->where);
return FAILURE;
}
else
{
mpz_t size;
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
{
if (mpz_cmp (offset, size) >= 0)
{
mpz_clear (size);
gfc_error ("Data element above array upper bound at %L",
&lvalue->where);
return FAILURE;
}
mpz_clear (size);
}
}
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (con == NULL)
{
splay_tree_key j;
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
j = (splay_tree_key) mpz_get_si (offset);
sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, j);
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
break;
case REF_COMPONENT:
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_component (ref->u.c.component, con);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
con->n.component = ref->u.c.component;
con->next = expr->value.constructor;
expr->value.constructor = con;
}
break;
default:
gcc_unreachable ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
if (ref || last_ts->type == BT_CHARACTER)
expr = create_character_intializer (init, last_ts, ref, rvalue);
else
{
/* Overwriting an existing initializer is non-standard but usually only
provokes a warning from other compilers. */
if (init != NULL)
{
/* Order in which the expressions arrive here depends on whether
they are from data statements or F95 style declarations.
Therefore, check which is the most recent. */
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
"of '%s' at %L", symbol->name, &expr->where);
}
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
return SUCCESS;
}
int
gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
{
gfc_component *dt1, *dt2;
if (ts1->type != ts2->type)
return 0;
if (ts1->type != BT_DERIVED)
return (ts1->kind == ts2->kind);
/* Compare derived types. */
if (ts1->derived == ts2->derived)
return 1;
/* Special case for comparing derived types across namespaces. If the
true names and module names are the same and the module name is
nonnull, then they are equal. */
if (strcmp (ts1->derived->name, ts2->derived->name) == 0
&& ((ts1->derived->module == NULL && ts2->derived->module == NULL)
|| (ts1->derived != NULL && ts2->derived != NULL
&& strcmp (ts1->derived->module, ts2->derived->module) == 0)))
return 1;
/* Compare type via the rules of the standard. Both types must have
the SEQUENCE attribute to be equal. */
if (strcmp (ts1->derived->name, ts2->derived->name))
return 0;
dt1 = ts1->derived->components;
dt2 = ts2->derived->components;
if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
return 0;
/* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
simple test can speed things up. Otherwise, lots of things have to
match. */
for (;;)
{
if (strcmp (dt1->name, dt2->name) != 0)
return 0;
if (dt1->pointer != dt2->pointer)
return 0;
if (dt1->dimension != dt2->dimension)
return 0;
if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 0;
if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
return 0;
dt1 = dt1->next;
dt2 = dt2->next;
if (dt1 == NULL && dt2 == NULL)
break;
if (dt1 == NULL || dt2 == NULL)
return 0;
}
return 1;
}
static void
resolve_omp_atomic (gfc_code *code)
{
gfc_symbol *var;
gfc_expr *expr2;
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
gcc_assert (code->next == NULL);
if (code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
|| code->expr1->rank != 0
|| (code->expr1->ts.type != BT_INTEGER
&& code->expr1->ts.type != BT_REAL
&& code->expr1->ts.type != BT_COMPLEX
&& code->expr1->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
"intrinsic type at %L", &code->loc);
return;
}
var = code->expr1->symtree->n.sym;
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
expr2 = code->expr2;
if (expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
gfc_intrinsic_op op = expr2->value.op.op;
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
switch (op)
{
case INTRINSIC_PLUS:
alt_op = INTRINSIC_MINUS;
break;
case INTRINSIC_TIMES:
alt_op = INTRINSIC_DIVIDE;
break;
case INTRINSIC_MINUS:
alt_op = INTRINSIC_PLUS;
break;
case INTRINSIC_DIVIDE:
alt_op = INTRINSIC_TIMES;
break;
case INTRINSIC_AND:
case INTRINSIC_OR:
break;
case INTRINSIC_EQV:
alt_op = INTRINSIC_NEQV;
break;
case INTRINSIC_NEQV:
alt_op = INTRINSIC_EQV;
break;
default:
gfc_error ("!$OMP ATOMIC assignment operator must be "
"+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
&expr2->where);
return;
}
/* Check for var = var op expr resp. var = expr op var where
expr doesn't reference var and var op expr is mathematically
equivalent to var op (expr) resp. expr op var equivalent to
(expr) op var. We rely here on the fact that the matcher
for x op1 y op2 z where op1 and op2 have equal precedence
returns (x op1 y) op2 z. */
e = expr2->value.op.op2;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
v = e;
else if ((c = is_conversion (e, true)) != NULL
&& c->expr_type == EXPR_VARIABLE
&& c->symtree != NULL
&& c->symtree->n.sym == var)
v = c;
else
{
gfc_expr **p = NULL, **q;
for (q = &expr2->value.op.op1; (e = *q) != NULL; )
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
{
v = e;
break;
}
else if ((c = is_conversion (e, true)) != NULL)
q = &e->value.function.actual->expr;
else if (e->expr_type != EXPR_OP
|| (e->value.op.op != op
&& e->value.op.op != alt_op)
|| e->rank != 0)
break;
else
{
p = q;
q = &e->value.op.op1;
}
if (v == NULL)
{
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
"or var = expr op var at %L", &expr2->where);
return;
}
if (p != NULL)
{
e = *p;
switch (e->value.op.op)
{
case INTRINSIC_MINUS:
case INTRINSIC_DIVIDE:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
gfc_error ("!$OMP ATOMIC var = var op expr not "
"mathematically equivalent to var = var op "
"(expr) at %L", &expr2->where);
break;
default:
break;
}
/* Canonicalize into var = var op (expr). */
*p = e->value.op.op2;
e->value.op.op2 = expr2;
e->ts = expr2->ts;
if (code->expr2 == expr2)
code->expr2 = expr2 = e;
else
code->expr2->value.function.actual->expr = expr2 = e;
if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
{
for (p = &expr2->value.op.op1; *p != v;
p = &(*p)->value.function.actual->expr)
;
*p = NULL;
gfc_free_expr (expr2->value.op.op1);
expr2->value.op.op1 = v;
gfc_convert_type (v, &expr2->ts, 2);
}
}
}
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
{
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
"must be scalar and cannot reference var at %L",
&expr2->where);
return;
}
}
else if (expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym != NULL
&& expr2->value.function.esym == NULL
&& expr2->value.function.actual != NULL
&& expr2->value.function.actual->next != NULL)
{
gfc_actual_arglist *arg, *var_arg;
switch (expr2->value.function.isym->id)
{
case GFC_ISYM_MIN:
case GFC_ISYM_MAX:
break;
case GFC_ISYM_IAND:
case GFC_ISYM_IOR:
case GFC_ISYM_IEOR:
if (expr2->value.function.actual->next->next != NULL)
{
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
"or IEOR must have two arguments at %L",
&expr2->where);
return;
}
break;
default:
gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
"MIN, MAX, IAND, IOR or IEOR at %L",
&expr2->where);
return;
}
var_arg = NULL;
for (arg = expr2->value.function.actual; arg; arg = arg->next)
{
if ((arg == expr2->value.function.actual
|| (var_arg == NULL && arg->next == NULL))
&& arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree != NULL
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
"reference '%s' at %L", var->name, &arg->expr->where);
if (arg->expr->rank != 0)
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
"at %L", &arg->expr->where);
}
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
"be '%s' at %L", var->name, &expr2->where);
return;
}
if (var_arg != expr2->value.function.actual)
{
/* Canonicalize, so that var comes first. */
gcc_assert (var_arg->next == NULL);
for (arg = expr2->value.function.actual;
arg->next != var_arg; arg = arg->next)
;
var_arg->next = expr2->value.function.actual;
expr2->value.function.actual = var_arg;
arg->next = NULL;
}
}
else
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
"on right hand side at %L", &expr2->where);
}
