gfc_expr *
gfc_get_parentheses (gfc_expr *e)
{
gfc_expr *e2;
e2 = gfc_get_expr();
e2->expr_type = EXPR_OP;
e2->ts = e->ts;
e2->rank = e->rank;
e2->where = e->where;
e2->value.op.op = INTRINSIC_PARENTHESES;
e2->value.op.op1 = e;
e2->value.op.op2 = NULL;
return e2;
}
static gfc_expr *
build_node (gfc_intrinsic_op op, locus *where,
gfc_expr *op1, gfc_expr *op2)
{
gfc_expr *new_expr;
new_expr = gfc_get_expr ();
new_expr->expr_type = EXPR_OP;
new_expr->value.op.op = op;
new_expr->where = *where;
new_expr->value.op.op1 = op1;
new_expr->value.op.op2 = op2;
return new_expr;
}
gfc_expr *
gfc_class_null_initializer (gfc_typespec *ts)
{
gfc_expr *init;
gfc_component *comp;
init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
&ts->u.derived->declared_at);
init->ts = *ts;
for (comp = ts->u.derived->components; comp; comp = comp->next)
{
gfc_constructor *ctor = gfc_constructor_get();
ctor->expr = gfc_get_expr ();
ctor->expr->expr_type = EXPR_NULL;
ctor->expr->ts = comp->ts;
gfc_constructor_append (&init->value.constructor, ctor);
}
return init;
}
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 gfc_expr *
create_character_intializer (gfc_expr * init, gfc_typespec * ts,
gfc_ref * ref, gfc_expr * rvalue)
{
int len;
int start;
int end;
char *dest;
gfc_extract_int (ts->cl->length, &len);
if (init == NULL)
{
/* Create a new initializer. */
init = gfc_get_expr ();
init->expr_type = EXPR_CONSTANT;
init->ts = *ts;
dest = gfc_getmem (len + 1);
dest[len] = '\0';
init->value.character.length = len;
init->value.character.string = dest;
/* Blank the string if we're only setting a substring. */
if (ref != NULL)
memset (dest, ' ', len);
}
else
dest = init->value.character.string;
if (ref)
{
gfc_expr *start_expr, *end_expr;
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
{
gfc_error ("failure to simplify substring reference in DATA"
"statement at %L", &ref->u.ss.start->where);
return NULL;
}
gfc_extract_int (start_expr, &start);
start--;
gfc_extract_int (end_expr, &end);
}
else
{
/* Set the whole string. */
start = 0;
end = len;
}
/* Copy the initial value. */
len = rvalue->value.character.length;
if (len > end - start)
{
len = end - start;
gfc_warning_now ("initialization string truncated to match variable "
"at %L", &rvalue->where);
}
memcpy (&dest[start], rvalue->value.character.string, len);
/* Pad with spaces. Substrings will already be blanked. */
if (len < end - start && ref == NULL)
memset (&dest[start + len], ' ', end - (start + len));
if (rvalue->ts.type == BT_HOLLERITH)
init->from_H = 1;
return init;
}
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;
}
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
/* Find the top-level namespace (MODULE or PROGRAM). */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
break;
/* If the type is a class container, use the underlying derived type. */
if (derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
get_unique_hashed_string (tname, derived);
sprintf (name, "__vtab_%s", tname);
/* Look for the vtab symbol in various namespaces. */
gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
if (vtab == NULL)
gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
gfc_find_symbol (name, derived->ns, 0, &vtab);
if (vtab == NULL)
{
gfc_get_symbol (name, ns, &vtab);
vtab->ts.type = BT_DERIVED;
if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
&gfc_current_locus) == FAILURE)
goto cleanup;
vtab->attr.target = 1;
vtab->attr.save = SAVE_IMPLICIT;
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
sprintf (name, "__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
goto cleanup;
vtype->attr.access = ACCESS_PUBLIC;
vtype->attr.vtype = 1;
gfc_set_sym_referenced (vtype);
/* Add component '_hash'. */
if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, derived->hash_value);
/* Add component '_size'. */
if (gfc_add_component (vtype, "_size", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 0);
/* Add component _extends. */
if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
0, &c->initializer->symtree);
}
else
{
c->ts.type = BT_DERIVED;
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
if (derived->components == NULL && !derived->attr.zero_comp)
{
/* At this point an error must have occurred.
Prevent further errors on the vtype components. */
found_sym = vtab;
goto have_vtype;
}
/* Add component _def_init. */
if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
c->ts.type = BT_DERIVED;
c->ts.u.derived = derived;
if (derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
/* Construct default initialization variable. */
sprintf (name, "__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
def_init->attr.save = SAVE_IMPLICIT;
def_init->attr.access = ACCESS_PUBLIC;
def_init->attr.flavor = FL_VARIABLE;
gfc_set_sym_referenced (def_init);
def_init->ts.type = BT_DERIVED;
def_init->ts.u.derived = derived;
def_init->value = gfc_default_initializer (&def_init->ts);
c->initializer = gfc_lval_expr_from_sym (def_init);
}
/* Add component _copy. */
if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
if (derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
/* Set up namespace. */
gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
sub_ns->sibling = ns->contained;
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
sprintf (name, "__copy_%s", tname);
gfc_get_symbol (name, sub_ns, ©);
sub_ns->proc_name = copy;
copy->attr.flavor = FL_PROCEDURE;
copy->attr.if_source = IFSRC_DECL;
if (ns->proc_name->attr.flavor == FL_MODULE)
copy->module = ns->proc_name->name;
gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
gfc_get_symbol ("src", sub_ns, &src);
src->ts.type = BT_DERIVED;
src->ts.u.derived = derived;
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
gfc_get_symbol ("dst", sub_ns, &dst);
dst->ts.type = BT_DERIVED;
dst->ts.u.derived = derived;
dst->attr.flavor = FL_VARIABLE;
dst->attr.dummy = 1;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
/* Set up code. */
sub_ns->code = gfc_get_code ();
sub_ns->code->op = EXEC_INIT_ASSIGN;
sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
/* Set initializer. */
c->initializer = gfc_lval_expr_from_sym (copy);
c->ts.interface = copy;
}
/* Add procedure pointers for type-bound procedures. */
add_procs_to_declared_vtab (derived, vtype);
}
have_vtype:
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
found_sym = vtab;
cleanup:
/* It is unexpected to have some symbols added at resolution or code
generation time. We commit the changes in order to keep a clean state. */
if (found_sym)
{
gfc_commit_symbol (vtab);
if (vtype)
gfc_commit_symbol (vtype);
if (def_init)
gfc_commit_symbol (def_init);
if (copy)
gfc_commit_symbol (copy);
if (src)
gfc_commit_symbol (src);
if (dst)
gfc_commit_symbol (dst);
}
else
gfc_undo_symbols ();
return found_sym;
}
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
char name[2 * GFC_MAX_SYMBOL_LEN + 8];
ns = gfc_current_ns;
for (; ns; ns = ns->parent)
if (!ns->parent)
break;
if (ns)
{
sprintf (name, "vtab$%s", derived->name);
gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
{
gfc_get_symbol (name, ns, &vtab);
vtab->ts.type = BT_DERIVED;
vtab->attr.flavor = FL_VARIABLE;
vtab->attr.target = 1;
vtab->attr.save = SAVE_EXPLICIT;
vtab->attr.vtab = 1;
vtab->refs++;
gfc_set_sym_referenced (vtab);
sprintf (name, "vtype$%s", derived->name);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
goto cleanup;
vtype->refs++;
gfc_set_sym_referenced (vtype);
/* Add component '$hash'. */
if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, derived->hash_value);
/* Add component '$size'. */
if (gfc_add_component (vtype, "$size", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 0);
/* Add component $extends. */
if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
0, &c->initializer->symtree);
}
else
{
c->ts.type = BT_DERIVED;
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
add_procs_to_declared_vtab (derived, vtype);
vtype->attr.vtype = 1;
}
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
found_sym = vtab;
cleanup:
/* It is unexpected to have some symbols added at resolution or code
generation time. We commit the changes in order to keep a clean state. */
if (found_sym)
gfc_commit_symbols ();
else
gfc_undo_symbols ();
return found_sym;
}
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;
}
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
gfc_expr *e1, *e2, *e3, *e4;
gfc_ref *ref;
tree decl, backend_decl, stmt;
locus old_loc = gfc_current_locus;
const char *iname;
try t;
decl = OMP_CLAUSE_DECL (c);
gfc_current_locus = where;
/* Create a fake symbol for init value. */
memset (&init_val_sym, 0, sizeof (init_val_sym));
init_val_sym.ns = sym->ns;
init_val_sym.name = sym->name;
init_val_sym.ts = sym->ts;
init_val_sym.attr.referenced = 1;
init_val_sym.declared_at = where;
init_val_sym.attr.flavor = FL_VARIABLE;
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
init_val_sym.backend_decl = backend_decl;
/* Create a fake symbol for the outer array reference. */
outer_sym = *sym;
outer_sym.as = gfc_copy_array_spec (sym->as);
outer_sym.attr.dummy = 0;
outer_sym.attr.result = 0;
outer_sym.attr.flavor = FL_VARIABLE;
outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
/* Create fake symtrees for it. */
symtree1 = gfc_new_symtree (&root1, sym->name);
symtree1->n.sym = sym;
gcc_assert (symtree1 == root1);
symtree2 = gfc_new_symtree (&root2, sym->name);
symtree2->n.sym = &init_val_sym;
gcc_assert (symtree2 == root2);
symtree3 = gfc_new_symtree (&root3, sym->name);
symtree3->n.sym = &outer_sym;
gcc_assert (symtree3 == root3);
/* Create expressions. */
e1 = gfc_get_expr ();
e1->expr_type = EXPR_VARIABLE;
e1->where = where;
e1->symtree = symtree1;
e1->ts = sym->ts;
e1->ref = ref = gfc_get_ref ();
ref->u.ar.where = where;
ref->u.ar.as = sym->as;
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = 0;
t = gfc_resolve_expr (e1);
gcc_assert (t == SUCCESS);
e2 = gfc_get_expr ();
e2->expr_type = EXPR_VARIABLE;
e2->where = where;
e2->symtree = symtree2;
e2->ts = sym->ts;
t = gfc_resolve_expr (e2);
gcc_assert (t == SUCCESS);
e3 = gfc_copy_expr (e1);
e3->symtree = symtree3;
t = gfc_resolve_expr (e3);
gcc_assert (t == SUCCESS);
iname = NULL;
switch (OMP_CLAUSE_REDUCTION_CODE (c))
{
case PLUS_EXPR:
case MINUS_EXPR:
e4 = gfc_add (e3, e1);
break;
case MULT_EXPR:
e4 = gfc_multiply (e3, e1);
break;
case TRUTH_ANDIF_EXPR:
e4 = gfc_and (e3, e1);
break;
case TRUTH_ORIF_EXPR:
e4 = gfc_or (e3, e1);
break;
case EQ_EXPR:
e4 = gfc_eqv (e3, e1);
break;
case NE_EXPR:
e4 = gfc_neqv (e3, e1);
break;
case MIN_EXPR:
iname = "min";
break;
case MAX_EXPR:
iname = "max";
break;
case BIT_AND_EXPR:
iname = "iand";
break;
case BIT_IOR_EXPR:
iname = "ior";
break;
case BIT_XOR_EXPR:
iname = "ieor";
break;
default:
gcc_unreachable ();
}
if (iname != NULL)
{
memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
intrinsic_sym.ns = sym->ns;
intrinsic_sym.name = iname;
intrinsic_sym.ts = sym->ts;
intrinsic_sym.attr.referenced = 1;
intrinsic_sym.attr.intrinsic = 1;
intrinsic_sym.attr.function = 1;
intrinsic_sym.result = &intrinsic_sym;
intrinsic_sym.declared_at = where;
symtree4 = gfc_new_symtree (&root4, iname);
symtree4->n.sym = &intrinsic_sym;
gcc_assert (symtree4 == root4);
e4 = gfc_get_expr ();
e4->expr_type = EXPR_FUNCTION;
e4->where = where;
e4->symtree = symtree4;
e4->value.function.isym = gfc_find_function (iname);
e4->value.function.actual = gfc_get_actual_arglist ();
e4->value.function.actual->expr = e3;
e4->value.function.actual->next = gfc_get_actual_arglist ();
e4->value.function.actual->next->expr = e1;
}
/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
e1 = gfc_copy_expr (e1);
e3 = gfc_copy_expr (e3);
t = gfc_resolve_expr (e4);
gcc_assert (t == SUCCESS);
/* Create the init statement list. */
pushlevel (0);
stmt = gfc_trans_assignment (e1, e2, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
poplevel (0, 0, 0);
OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
/* Create the merge statement list. */
pushlevel (0);
stmt = gfc_trans_assignment (e3, e4, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
poplevel (0, 0, 0);
OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
/* And stick the placeholder VAR_DECL into the clause as well. */
OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
gfc_current_locus = old_loc;
gfc_free_expr (e1);
gfc_free_expr (e2);
gfc_free_expr (e3);
gfc_free_expr (e4);
gfc_free (symtree1);
gfc_free (symtree2);
gfc_free (symtree3);
if (symtree4)
gfc_free (symtree4);
gfc_free_array_spec (outer_sym.as);
}
static tree
gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
enum tree_code reduction_code, locus where)
{
for (; namelist != NULL; namelist = namelist->next)
if (namelist->sym->attr.referenced)
{
tree t = gfc_trans_omp_variable (namelist->sym);
if (t != error_mark_node)
{
tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
OMP_CLAUSE_DECL (node) = t;
OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
if (namelist->sym->attr.dimension)
gfc_trans_omp_array_reduction (node, namelist->sym, where);
list = gfc_trans_add_clause (node, list);
}
}
return list;
}
static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
locus where)
{
tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
int list;
enum omp_clause_code clause_code;
gfc_se se;
if (clauses == NULL)
return NULL_TREE;
for (list = 0; list < OMP_LIST_NUM; list++)
{
gfc_namelist *n = clauses->lists[list];
if (n == NULL)
continue;
if (list >= OMP_LIST_REDUCTION_FIRST
&& list <= OMP_LIST_REDUCTION_LAST)
{
enum tree_code reduction_code;
switch (list)
{
case OMP_LIST_PLUS:
reduction_code = PLUS_EXPR;
break;
case OMP_LIST_MULT:
reduction_code = MULT_EXPR;
break;
case OMP_LIST_SUB:
reduction_code = MINUS_EXPR;
break;
case OMP_LIST_AND:
reduction_code = TRUTH_ANDIF_EXPR;
break;
case OMP_LIST_OR:
reduction_code = TRUTH_ORIF_EXPR;
break;
case OMP_LIST_EQV:
reduction_code = EQ_EXPR;
break;
case OMP_LIST_NEQV:
reduction_code = NE_EXPR;
break;
case OMP_LIST_MAX:
reduction_code = MAX_EXPR;
break;
case OMP_LIST_MIN:
reduction_code = MIN_EXPR;
break;
case OMP_LIST_IAND:
reduction_code = BIT_AND_EXPR;
break;
case OMP_LIST_IOR:
reduction_code = BIT_IOR_EXPR;
break;
case OMP_LIST_IEOR:
reduction_code = BIT_XOR_EXPR;
break;
default:
gcc_unreachable ();
}
old_clauses = omp_clauses;
omp_clauses
= gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
where);
continue;
}
switch (list)
{
case OMP_LIST_PRIVATE:
clause_code = OMP_CLAUSE_PRIVATE;
goto add_clause;
case OMP_LIST_SHARED:
clause_code = OMP_CLAUSE_SHARED;
goto add_clause;
case OMP_LIST_FIRSTPRIVATE:
clause_code = OMP_CLAUSE_FIRSTPRIVATE;
goto add_clause;
case OMP_LIST_LASTPRIVATE:
clause_code = OMP_CLAUSE_LASTPRIVATE;
goto add_clause;
case OMP_LIST_COPYIN:
clause_code = OMP_CLAUSE_COPYIN;
goto add_clause;
case OMP_LIST_COPYPRIVATE:
clause_code = OMP_CLAUSE_COPYPRIVATE;
/* FALLTHROUGH */
add_clause:
omp_clauses
= gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
break;
default:
break;
}
}
if (clauses->if_expr)
{
tree if_var;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, clauses->if_expr);
gfc_add_block_to_block (block, &se.pre);
if_var = gfc_evaluate_now (se.expr, block);
gfc_add_block_to_block (block, &se.post);
c = build_omp_clause (OMP_CLAUSE_IF);
OMP_CLAUSE_IF_EXPR (c) = if_var;
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
if (clauses->num_threads)
{
tree num_threads;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, clauses->num_threads);
gfc_add_block_to_block (block, &se.pre);
num_threads = gfc_evaluate_now (se.expr, block);
gfc_add_block_to_block (block, &se.post);
c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
chunk_size = NULL_TREE;
if (clauses->chunk_size)
{
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, clauses->chunk_size);
gfc_add_block_to_block (block, &se.pre);
chunk_size = gfc_evaluate_now (se.expr, block);
gfc_add_block_to_block (block, &se.post);
}
if (clauses->sched_kind != OMP_SCHED_NONE)
{
c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
switch (clauses->sched_kind)
{
case OMP_SCHED_STATIC:
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
break;
case OMP_SCHED_DYNAMIC:
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
break;
case OMP_SCHED_GUIDED:
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
break;
case OMP_SCHED_RUNTIME:
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
break;
default:
gcc_unreachable ();
}
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
{
c = build_omp_clause (OMP_CLAUSE_DEFAULT);
switch (clauses->default_sharing)
{
case OMP_DEFAULT_NONE:
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
break;
case OMP_DEFAULT_SHARED:
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
break;
case OMP_DEFAULT_PRIVATE:
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
break;
default:
gcc_unreachable ();
}
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
if (clauses->nowait)
{
c = build_omp_clause (OMP_CLAUSE_NOWAIT);
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
if (clauses->ordered)
{
c = build_omp_clause (OMP_CLAUSE_ORDERED);
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
return omp_clauses;
}
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
gfc_expr *e1, *e2, *e3, *e4;
gfc_ref *ref;
tree decl, backend_decl, stmt;
locus old_loc = gfc_current_locus;
const char *iname;
gfc_try t;
decl = OMP_CLAUSE_DECL (c);
gfc_current_locus = where;
/* Create a fake symbol for init value. */
memset (&init_val_sym, 0, sizeof (init_val_sym));
init_val_sym.ns = sym->ns;
init_val_sym.name = sym->name;
init_val_sym.ts = sym->ts;
init_val_sym.attr.referenced = 1;
init_val_sym.declared_at = where;
init_val_sym.attr.flavor = FL_VARIABLE;
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
init_val_sym.backend_decl = backend_decl;
/* Create a fake symbol for the outer array reference. */
outer_sym = *sym;
outer_sym.as = gfc_copy_array_spec (sym->as);
outer_sym.attr.dummy = 0;
outer_sym.attr.result = 0;
outer_sym.attr.flavor = FL_VARIABLE;
outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
/* Create fake symtrees for it. */
symtree1 = gfc_new_symtree (&root1, sym->name);
symtree1->n.sym = sym;
gcc_assert (symtree1 == root1);
symtree2 = gfc_new_symtree (&root2, sym->name);
symtree2->n.sym = &init_val_sym;
gcc_assert (symtree2 == root2);
symtree3 = gfc_new_symtree (&root3, sym->name);
symtree3->n.sym = &outer_sym;
gcc_assert (symtree3 == root3);
/* Create expressions. */
e1 = gfc_get_expr ();
e1->expr_type = EXPR_VARIABLE;
e1->where = where;
e1->symtree = symtree1;
e1->ts = sym->ts;
e1->ref = ref = gfc_get_ref ();
ref->type = REF_ARRAY;
ref->u.ar.where = where;
ref->u.ar.as = sym->as;
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = 0;
t = gfc_resolve_expr (e1);
gcc_assert (t == SUCCESS);
e2 = gfc_get_expr ();
e2->expr_type = EXPR_VARIABLE;
e2->where = where;
e2->symtree = symtree2;
e2->ts = sym->ts;
t = gfc_resolve_expr (e2);
gcc_assert (t == SUCCESS);
e3 = gfc_copy_expr (e1);
e3->symtree = symtree3;
t = gfc_resolve_expr (e3);
gcc_assert (t == SUCCESS);
iname = NULL;
switch (OMP_CLAUSE_REDUCTION_CODE (c))
{
case PLUS_EXPR:
case MINUS_EXPR:
e4 = gfc_add (e3, e1);
break;
case MULT_EXPR:
e4 = gfc_multiply (e3, e1);
break;
case TRUTH_ANDIF_EXPR:
e4 = gfc_and (e3, e1);
break;
case TRUTH_ORIF_EXPR:
e4 = gfc_or (e3, e1);
break;
case EQ_EXPR:
e4 = gfc_eqv (e3, e1);
break;
case NE_EXPR:
e4 = gfc_neqv (e3, e1);
break;
case MIN_EXPR:
iname = "min";
break;
case MAX_EXPR:
iname = "max";
break;
case BIT_AND_EXPR:
iname = "iand";
break;
case BIT_IOR_EXPR:
iname = "ior";
break;
case BIT_XOR_EXPR:
iname = "ieor";
break;
default:
gcc_unreachable ();
}
if (iname != NULL)
{
memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
intrinsic_sym.ns = sym->ns;
intrinsic_sym.name = iname;
intrinsic_sym.ts = sym->ts;
intrinsic_sym.attr.referenced = 1;
intrinsic_sym.attr.intrinsic = 1;
intrinsic_sym.attr.function = 1;
intrinsic_sym.result = &intrinsic_sym;
intrinsic_sym.declared_at = where;
symtree4 = gfc_new_symtree (&root4, iname);
symtree4->n.sym = &intrinsic_sym;
gcc_assert (symtree4 == root4);
e4 = gfc_get_expr ();
e4->expr_type = EXPR_FUNCTION;
e4->where = where;
e4->symtree = symtree4;
e4->value.function.isym = gfc_find_function (iname);
e4->value.function.actual = gfc_get_actual_arglist ();
e4->value.function.actual->expr = e3;
e4->value.function.actual->next = gfc_get_actual_arglist ();
e4->value.function.actual->next->expr = e1;
}
/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
e1 = gfc_copy_expr (e1);
e3 = gfc_copy_expr (e3);
t = gfc_resolve_expr (e4);
gcc_assert (t == SUCCESS);
/* Create the init statement list. */
pushlevel (0);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
{
/* If decl is an allocatable array, it needs to be allocated
with the same bounds as the outer var. */
tree type = TREE_TYPE (decl), rank, size, esize, ptr;
stmtblock_t block;
gfc_start_block (&block);
gfc_add_modify (&block, decl, outer_sym.backend_decl);
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (decl, rank);
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
gfc_conv_descriptor_lbound_get (decl, rank));
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
gfc_conv_descriptor_stride_get (decl, rank));
esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
ptr = gfc_allocate_array_with_status (&block,
build_int_cst (pvoid_type_node, 0),
size, NULL, NULL);
gfc_conv_descriptor_data_set (&block, decl, ptr);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
stmt = gfc_finish_block (&block);
}
else
stmt = gfc_trans_assignment (e1, e2, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
poplevel (0, 0, 0);
OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
/* Create the merge statement list. */
pushlevel (0);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
{
/* If decl is an allocatable array, it needs to be deallocated
afterwards. */
stmtblock_t block;
gfc_start_block (&block);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
stmt = gfc_finish_block (&block);
}
else
stmt = gfc_trans_assignment (e3, e4, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
poplevel (0, 0, 0);
OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
/* And stick the placeholder VAR_DECL into the clause as well. */
OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
gfc_current_locus = old_loc;
gfc_free_expr (e1);
gfc_free_expr (e2);
gfc_free_expr (e3);
gfc_free_expr (e4);
gfc_free (symtree1);
gfc_free (symtree2);
gfc_free (symtree3);
if (symtree4)
gfc_free (symtree4);
gfc_free_array_spec (outer_sym.as);
}