Compute the corank of an expression along side to the regular rank.
This safe costly calls to gfc_get_corank (), which consecutively has
been removed. In some locations the code needed some adaption to model
the difference between expr.corank and gfc_get_corank correctly. The
latter always returned the codimension of the expression and not its
current corank, i.e. the resolution of all indezes.
This commit is preparatory to fixing PR fortran/110033 and may contain
parts of that fix already.
gcc/fortran/ChangeLog:
* arith.cc (reduce_unary): Use expr.corank.
(reduce_binary_ac): Same.
(reduce_binary_ca): Same.
(reduce_binary_aa): Same.
* array.cc (gfc_match_array_ref): Same.
* check.cc (dim_corank_check): Same.
(gfc_check_move_alloc): Same.
(gfc_check_image_index): Same.
* class.cc (gfc_add_class_array_ref): Same.
(finalize_component): Same.
* data.cc (gfc_assign_data_value): Same.
* decl.cc (match_clist_expr): Same.
(add_init_expr_to_sym): Same.
* expr.cc (simplify_intrinsic_op): Same.
(simplify_parameter_variable): Same.
(gfc_check_assign_symbol): Same.
(gfc_get_variable_expr): Same.
(gfc_add_full_array_ref): Same.
(gfc_lval_expr_from_sym): Same.
(gfc_get_corank): Removed.
* frontend-passes.cc (callback_reduction): Use expr.corank.
(create_var): Same.
(combine_array_constructor): Same.
(optimize_minmaxloc): Same.
* gfortran.h (gfc_get_corank): Add corank to gfc_expr.
* intrinsic.cc (gfc_get_intrinsic_function_symbol): Use
expr.corank.
(gfc_convert_type_warn): Same.
(gfc_convert_chartype): Same.
* iresolve.cc (resolve_bound): Same.
(gfc_resolve_cshift): Same.
(gfc_resolve_eoshift): Same.
(gfc_resolve_logical): Same.
(gfc_resolve_matmul): Same.
* match.cc (copy_ts_from_selector_to_associate): Same.
* matchexp.cc (gfc_get_parentheses): Same.
* parse.cc (parse_associate): Same.
* primary.cc (gfc_match_rvalue): Same.
* resolve.cc (resolve_structure_cons): Same.
(resolve_actual_arglist): Same.
(resolve_elemental_actual): Same.
(resolve_generic_f0): Same.
(resolve_unknown_f): Same.
(resolve_operator): Same.
(gfc_expression_rank): Same and set dimen_type for coarray to
default.
(gfc_op_rank_conformable): Use expr.corank.
(add_caf_get_intrinsic): Same.
(resolve_variable): Same.
(gfc_fixup_inferred_type_refs): Same.
(check_host_association): Same.
(resolve_compcall): Same.
(resolve_expr_ppc): Same.
(resolve_assoc_var): Same.
(fixup_array_ref): Same.
(resolve_select_type): Same.
(add_comp_ref): Same.
(get_temp_from_expr): Same.
(resolve_fl_var_and_proc): Same.
(resolve_symbol): Same.
* symbol.cc (gfc_is_associate_pointer): Same.
* trans-array.cc (walk_coarray): Same.
(gfc_conv_expr_descriptor): Same.
(gfc_walk_array_ref): Same.
* trans-array.h (gfc_walk_array_ref): Same.
* trans-expr.cc (gfc_get_ultimate_alloc_ptr_comps_caf_token):
Same.
* trans-intrinsic.cc (trans_this_image): Same.
(trans_image_index): Same.
(conv_intrinsic_cobound): Same.
(gfc_walk_intrinsic_function): Same.
(conv_intrinsic_move_alloc): Same.
* trans-stmt.cc (gfc_trans_lock_unlock): Same.
(trans_associate_var): Same and adapt to slightly different
behaviour of expr.corank and gfc_get_corank.
(gfc_trans_allocate): Same.
* trans.cc (gfc_add_finalizer_call): Same.
}
r->shape = gfc_copy_shape (op->shape, op->rank);
r->rank = op->rank;
+ r->corank = op->corank;
r->value.constructor = head;
*result = r;
}
r->shape = gfc_get_shape (op1->rank);
}
r->rank = op1->rank;
+ r->corank = op1->corank;
r->value.constructor = head;
*result = r;
}
r->shape = gfc_get_shape (op2->rank);
}
r->rank = op2->rank;
+ r->corank = op2->corank;
r->value.constructor = head;
*result = r;
}
}
r->shape = gfc_copy_shape (op1->shape, op1->rank);
r->rank = op1->rank;
+ r->corank = op1->corank;
r->value.constructor = head;
*result = r;
}
{
ar->type = AR_FULL;
ar->dimen = 0;
+ if (corank != 0)
+ {
+ for (int i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+ ar->dimen_type[i] = DIMEN_THIS_IMAGE;
+ ar->codimen = corank;
+ }
return MATCH_YES;
}
if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
{
if (ar->dimen > 0)
- return MATCH_YES;
+ {
+ if (corank != 0)
+ {
+ for (int i = ar->dimen; i < GFC_MAX_DIMENSIONS; ++i)
+ ar->dimen_type[i] = DIMEN_THIS_IMAGE;
+ ar->codimen = corank;
+ }
+ return MATCH_YES;
+ }
else
return MATCH_ERROR;
}
static bool
dim_corank_check (gfc_expr *dim, gfc_expr *array)
{
- int corank;
-
gcc_assert (array->expr_type == EXPR_VARIABLE);
if (dim->expr_type != EXPR_CONSTANT)
if (array->ts.type == BT_CLASS)
return true;
- corank = gfc_get_corank (array);
-
if (mpz_cmp_ui (dim->value.integer, 1) < 0
- || mpz_cmp_ui (dim->value.integer, corank) > 0)
+ || mpz_cmp_ui (dim->value.integer, array->corank) > 0)
{
gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"codimension index", gfc_current_intrinsic, &dim->where);
}
/* IR F08/0040; cf. 12-006A. */
- if (gfc_get_corank (to) != gfc_get_corank (from))
+ if (to->corank != from->corank)
{
gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
- "must have the same corank %d/%d", &to->where,
- gfc_get_corank (from), gfc_get_corank (to));
+ "must have the same corank %d/%d",
+ &to->where, from->corank, to->corank);
return false;
}
if (gfc_array_size (sub, &nelems))
{
- int corank = gfc_get_corank (coarray);
-
- if (mpz_cmp_ui (nelems, corank) != 0)
+ if (mpz_cmp_ui (nelems, coarray->corank) != 0)
{
gfc_error ("The number of array elements of the SUB argument to "
"IMAGE_INDEX at %L shall be %d (corank) not %d",
- &sub->where, corank, (int) mpz_get_si (nelems));
+ &sub->where, coarray->corank, (int) mpz_get_si (nelems));
mpz_clear (nelems);
return false;
}
gfc_add_class_array_ref (gfc_expr *e)
{
int rank = CLASS_DATA (e)->as->rank;
+ int corank = CLASS_DATA (e)->as->corank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
gfc_add_data_component (e);
e->rank = rank;
+ e->corank = corank;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
break;
ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
: comp->as;
e->rank = ref->next->u.ar.as->rank;
+ e->corank = ref->next->u.ar.as->corank;
ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
}
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
+ expr->corank = ref->u.ar.as->corank;
}
if (ref->u.ar.type == AR_ELEMENT)
/* Set the rank/shape to match the LHS as auto-reshape is implied. */
expr->rank = as->rank;
+ expr->corank = as->corank;
expr->shape = gfc_get_shape (as->rank);
for (int i = 0; i < as->rank; ++i)
spec_dimen_size (as, i, &expr->shape[i]);
mpz_clear (size);
}
init->rank = sym->as->rank;
+ init->corank = sym->as->corank;
}
sym->value = init;
}
result->rank = p->rank;
+ result->corank = p->corank;
result->where = p->where;
gfc_replace_expr (p, result);
e->expr_type = EXPR_ARRAY;
e->ts = p->ts;
e->rank = p->rank;
+ e->corank = p->corank;
e->value.constructor = NULL;
e->shape = gfc_copy_shape (p->shape, p->rank);
e->where = p->where;
gfc_free_shape (&e->shape, e->rank);
e->shape = gfc_copy_shape (p->shape, p->rank);
e->rank = p->rank;
+ e->corank = p->corank;
if (e->ts.type == BT_CHARACTER && p->ts.u.cl)
e->ts = p->ts;
lvalue.expr_type = EXPR_VARIABLE;
lvalue.ts = sym->ts;
if (sym->as)
- lvalue.rank = sym->as->rank;
+ {
+ lvalue.rank = sym->as->rank;
+ lvalue.corank = sym->as->corank;
+ }
lvalue.symtree = XCNEW (gfc_symtree);
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
lvalue.ref->u.c.sym = sym;
lvalue.ts = comp->ts;
lvalue.rank = comp->as ? comp->as->rank : 0;
+ lvalue.corank = comp->as ? comp->as->corank : 0;
lvalue.where = comp->loc;
pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)
? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
&& CLASS_DATA (var->n.sym)
&& CLASS_DATA (var->n.sym)->as)))
{
- e->rank = var->n.sym->ts.type == BT_CLASS
- ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
+ gfc_array_spec *as = var->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (var->n.sym)->as
+ : var->n.sym->as;
+ e->rank = as->rank;
+ e->corank = as->corank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
- e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
- ? CLASS_DATA (var->n.sym)->as
- : var->n.sym->as);
+ e->ref->u.ar.as = gfc_copy_array_spec (as);
}
return e;
ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = e->rank;
+ /* Do not set the corank here, or resolve will not be able to set correct
+ dimen-types for the coarray. */
ref->u.ar.where = e->where;
ref->u.ar.as = as;
}
/* It will always be a full array. */
as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
lval->rank = as ? as->rank : 0;
- if (lval->rank)
+ lval->corank = as ? as->corank : 0;
+ if (lval->rank || lval->corank)
gfc_add_full_array_ref (lval, as);
return lval;
}
}
-int
-gfc_get_corank (gfc_expr *e)
-{
- int corank;
- gfc_ref *ref;
-
- if (!gfc_is_coarray (e))
- return 0;
-
- if (e->ts.type == BT_CLASS && CLASS_DATA (e))
- corank = CLASS_DATA (e)->as
- ? CLASS_DATA (e)->as->corank : 0;
- else
- corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
-
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY)
- corank = ref->u.ar.as->corank;
- gcc_assert (ref->type != REF_SUBSTRING);
- }
-
- return corank;
-}
-
-
/* Check whether the expression has an ultimate allocatable component.
Being itself allocatable does not count. */
bool
new_expr->ts = fn->ts;
new_expr->expr_type = EXPR_OP;
new_expr->rank = fn->rank;
+ new_expr->corank = fn->corank;
new_expr->where = fn->where;
new_expr->value.op.op = op;
new_expr->value.op.op1 = res;
{
symbol->as = gfc_get_array_spec ();
symbol->as->rank = e->rank;
+ symbol->as->corank = e->corank;
if (e->shape == NULL)
{
result->ts = symbol->ts;
result->ts.deferred = deferred;
result->rank = e->rank;
+ result->corank = e->corank;
result->shape = gfc_copy_shape (e->shape, e->rank);
result->symtree = symtree;
result->where = e->where;
new_expr->ts = e->ts;
new_expr->expr_type = EXPR_OP;
new_expr->rank = c->expr->rank;
+ new_expr->corank = c->expr->corank;
new_expr->where = c->expr->where;
new_expr->value.op.op = e->value.op.op;
*e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
(*e)->shape = fn->shape;
fn->rank = 0;
+ fn->corank = 0;
fn->shape = NULL;
gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
gfc_typespec ts; /* These two refer to the overall expression */
int rank; /* 0 indicates a scalar, -1 an assumed-rank array. */
+ int corank; /* same as rank, but for coarrays. */
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
/* Nonnull for functions and structure constructors, may also used to hold the
bool gfc_ref_this_image (gfc_ref *ref);
bool gfc_is_coindexed (gfc_expr *);
bool gfc_is_coarray (gfc_expr *);
-int gfc_get_corank (gfc_expr *);
bool gfc_has_ultimate_allocatable (gfc_expr *);
bool gfc_has_ultimate_pointer (gfc_expr *);
gfc_expr* gfc_find_team_co (gfc_expr *);
sym->as = gfc_get_array_spec ();
sym->as->type = AS_ASSUMED_SHAPE;
sym->as->rank = expr->rank;
+ sym->as->corank = expr->corank;
}
return sym;
}
new_expr->where = old_where;
new_expr->ts = *ts;
new_expr->rank = rank;
+ new_expr->corank = expr->corank;
new_expr->shape = gfc_copy_shape (shape, rank);
gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
new_expr->where = old_where;
new_expr->ts = *ts;
new_expr->rank = rank;
+ new_expr->corank = expr->corank;
new_expr->shape = gfc_copy_shape (shape, rank);
gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
if (dim == NULL)
{
- f->rank = 1;
if (array->rank != -1)
{
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
- : array->rank);
+ /* Assume f->rank gives the size of the shape, because there is no
+ other way to determine the size. */
+ if (!f->shape || f->rank != 1)
+ {
+ if (f->shape)
+ gfc_free_shape (&f->shape, f->rank);
+ f->shape = gfc_get_shape (1);
+ }
+ mpz_init_set_ui (f->shape[0], coarray ? array->corank : array->rank);
}
+ /* Applying bound to a coarray always results in a regular array. */
+ f->rank = 1;
+ f->corank = 0;
}
f->value.function.name = gfc_get_string ("%s", name);
f->ts = array->ts;
f->rank = array->rank;
+ f->corank = array->corank;
f->shape = gfc_copy_shape (array->shape, array->rank);
if (shift->rank > 0)
f->ts = array->ts;
f->rank = array->rank;
+ f->corank = array->corank;
f->shape = gfc_copy_shape (array->shape, array->rank);
n = 0;
f->ts.kind = (kind == NULL)
? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
f->rank = a->rank;
+ f->corank = a->corank;
f->value.function.name
= gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
}
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
+ f->corank = a->corank;
if (a->rank == 2 && b->rank == 2)
{
{
gfc_ref *ref;
gfc_symbol *assoc_sym;
- int rank = 0;
+ int rank = 0, corank = 0;
assoc_sym = associate->symtree->n.sym;
{
assoc_sym->attr.dimension = 1;
assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
+ corank = assoc_sym->as->corank;
goto build_class_sym;
}
else if (selector->ts.type == BT_CLASS
}
if (!ref || ref->u.ar.type == AR_FULL)
- selector->rank = CLASS_DATA (selector)->as->rank;
+ {
+ selector->rank = CLASS_DATA (selector)->as->rank;
+ selector->corank = CLASS_DATA (selector)->as->corank;
+ }
else if (ref->u.ar.type == AR_SECTION)
- selector->rank = ref->u.ar.dimen;
+ {
+ selector->rank = ref->u.ar.dimen;
+ selector->corank = ref->u.ar.codimen;
+ }
else
selector->rank = 0;
rank = selector->rank;
+ corank = selector->corank;
}
if (rank)
assoc_sym->as->rank = rank;
assoc_sym->as->type = AS_DEFERRED;
}
- else
- assoc_sym->as = NULL;
}
- else
- assoc_sym->as = NULL;
+ if (corank != 0 && rank == 0)
+ {
+ if (!assoc_sym->as)
+ assoc_sym->as = gfc_get_array_spec ();
+ assoc_sym->as->corank = corank;
+ assoc_sym->attr.codimension = 1;
+ }
+ else if (corank == 0 && rank == 0 && assoc_sym->as)
+ {
+ free (assoc_sym->as);
+ assoc_sym->as = NULL;
+ }
build_class_sym:
/* Deal with the very specific case of a SELECT_TYPE selector being an
associate_name whose type has been identified by component references.
e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
e2->ts = e->ts;
e2->rank = e->rank;
+ e2->corank = e->corank;
return e2;
}
{
gfc_symbol *sym, *tsym;
gfc_expr *target;
- int rank;
+ int rank, corank;
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
gcc_unreachable ();
if (sym->ts.type == BT_CLASS)
{
if (CLASS_DATA (sym)->as)
- target->rank = CLASS_DATA (sym)->as->rank;
+ {
+ target->rank = CLASS_DATA (sym)->as->rank;
+ target->corank = CLASS_DATA (sym)->as->corank;
+ }
sym->attr.class_ok = 1;
}
else
- target->rank = tsym->result->as ? tsym->result->as->rank : 0;
+ {
+ target->rank = tsym->result->as ? tsym->result->as->rank : 0;
+ target->corank = tsym->result->as ? tsym->result->as->corank : 0;
+ }
}
/* Check if the target expression is array valued. This cannot be done
}
rank = target->rank;
+ corank = target->corank;
/* Fixup cases where the ranks are mismatched. */
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
{
- if ((!CLASS_DATA (sym)->as && rank != 0)
- || (CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->rank != rank))
+ if ((!CLASS_DATA (sym)->as && (rank != 0 || corank != 0))
+ || (CLASS_DATA (sym)->as
+ && (CLASS_DATA (sym)->as->rank != rank
+ || CLASS_DATA (sym)->as->corank != corank)))
{
/* Don't just (re-)set the attr and as in the sym.ts,
because this modifies the target's attr and as. Copy the
data and do a build_class_symbol. */
symbol_attribute attr = CLASS_DATA (target)->attr;
- int corank = gfc_get_corank (target);
gfc_typespec type;
if (rank || corank)
attr.dimension = attr.codimension = 0;
}
attr.class_ok = 0;
+ attr.associate_var = 1;
type = CLASS_DATA (sym)->ts;
if (!gfc_build_class_symbol (&type, &attr, &as))
gcc_unreachable ();
else
sym->attr.class_ok = 1;
}
- else if ((!sym->as && rank != 0)
- || (sym->as && sym->as->rank != rank))
+ else if ((!sym->as && (rank != 0 || corank != 0))
+ || (sym->as
+ && (sym->as->rank != rank || sym->as->corank != corank)))
{
as = gfc_get_array_spec ();
as->type = AS_DEFERRED;
as->rank = rank;
- as->corank = gfc_get_corank (target);
+ as->corank = corank;
sym->as = as;
- sym->attr.dimension = 1;
- if (as->corank)
- sym->attr.codimension = 1;
+ if (rank)
+ sym->attr.dimension = 1;
+ if (corank)
+ {
+ as->cotype = AS_ASSUMED_SHAPE;
+ sym->attr.codimension = 1;
+ }
}
}
if (sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as)
- e->rank = CLASS_DATA (sym)->as->rank;
+ {
+ e->rank = CLASS_DATA (sym)->as->rank;
+ e->corank = CLASS_DATA (sym)->as->corank;
+ }
else if (sym->as != NULL)
- e->rank = sym->as->rank;
+ {
+ e->rank = sym->as->rank;
+ e->corank = sym->as->corank;
+ }
if (!sym->attr.function
&& !gfc_add_function (&sym->attr, sym->name, NULL))
cons->expr->where = para->where;
cons->expr->expr_type = EXPR_ARRAY;
cons->expr->rank = para->rank;
+ cons->expr->corank = para->corank;
cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
gfc_constructor_append_expr (&cons->expr->value.constructor,
para, &cons->expr->where);
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as))
{
- e->rank = sym->ts.type == BT_CLASS
- ? CLASS_DATA (sym)->as->rank : sym->as->rank;
+ gfc_array_spec *as
+ = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
+ e->rank = as->rank;
+ e->corank = as->corank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
- e->ref->u.ar.as = sym->ts.type == BT_CLASS
- ? CLASS_DATA (sym)->as : sym->as;
+ e->ref->u.ar.as = as;
}
/* These symbols are set untyped by calls to gfc_set_default_type
if (expr)
{
expr->rank = rank;
+ expr->corank = arg->expr->corank;
if (!expr->shape && arg->expr->shape)
{
expr->shape = gfc_get_shape (rank);
expr->ts = s->result->ts;
if (s->as != NULL)
- expr->rank = s->as->rank;
+ {
+ expr->rank = s->as->rank;
+ expr->corank = s->as->corank;
+ }
else if (s->result != NULL && s->result->as != NULL)
- expr->rank = s->result->as->rank;
+ {
+ expr->rank = s->result->as->rank;
+ expr->corank = s->result->as->corank;
+ }
gfc_set_sym_referenced (expr->value.function.esym);
if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
return MATCH_ERROR;
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
- expr->rank = CLASS_DATA (sym)->as->rank;
+ {
+ expr->rank = CLASS_DATA (sym)->as->rank;
+ expr->corank = CLASS_DATA (sym)->as->corank;
+ }
else if (sym->as != NULL)
- expr->rank = sym->as->rank;
+ {
+ expr->rank = sym->as->rank;
+ expr->corank = sym->as->corank;
+ }
return MATCH_YES;
}
expr->value.function.esym = expr->symtree->n.sym;
if (sym->as != NULL)
- expr->rank = sym->as->rank;
+ {
+ expr->rank = sym->as->rank;
+ expr->corank = sym->as->corank;
+ }
/* Type of the expression is either the type of the symbol or the
default type of the symbol. */
}
}
+ /* coranks have to be equal or one has to be zero to be combinable. */
+ if (op1->corank == op2->corank || (op1->corank != 0 && op2->corank == 0))
+ {
+ e->corank = op1->corank;
+ /* Only do this, when regular array has not set a shape yet. */
+ if (e->shape == NULL)
+ {
+ if (op1->corank != 0)
+ {
+ e->shape = gfc_copy_shape (op1->shape, op1->corank);
+ }
+ }
+ }
+ else if (op1->corank == 0 && op2->corank != 0)
+ {
+ e->corank = op2->corank;
+ /* Only do this, when regular array has not set a shape yet. */
+ if (e->shape == NULL)
+ e->shape = gfc_copy_shape (op2->shape, op2->corank);
+ }
+ else
+ {
+ gfc_error ("Inconsistent coranks for operator at %%L and %%L",
+ &op1->where, &op2->where);
+ return false;
+ }
+
break;
case INTRINSIC_PARENTHESES:
case INTRINSIC_UMINUS:
/* Simply copy arrayness attribute */
e->rank = op1->rank;
+ e->corank = op1->corank;
if (e->shape == NULL)
e->shape = gfc_copy_shape (op1->shape, op1->rank);
void
gfc_expression_rank (gfc_expr *e)
{
- gfc_ref *ref;
- int i, rank;
+ gfc_ref *ref, *last_arr_ref = nullptr;
+ int i, rank, corank;
/* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
could lead to serious confusion... */
goto done;
/* Constructors can have a rank different from one via RESHAPE(). */
- e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
- ? 0 : e->symtree->n.sym->as->rank);
+ if (e->symtree != NULL)
+ {
+ /* After errors the ts.u.derived of a CLASS might not be set. */
+ gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
+ && e->symtree->n.sym->ts.u.derived
+ && CLASS_DATA (e->symtree->n.sym))
+ ? CLASS_DATA (e->symtree->n.sym)->as
+ : e->symtree->n.sym->as;
+ if (as)
+ {
+ e->rank = as->rank;
+ e->corank = as->corank;
+ goto done;
+ }
+ }
+ e->rank = 0;
+ e->corank = 0;
goto done;
}
rank = 0;
+ corank = 0;
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
&& ref->u.c.component->attr.function && !ref->next)
- rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
+ {
+ rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
+ corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
+ }
if (ref->type != REF_ARRAY)
continue;
+ last_arr_ref = ref;
if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
{
rank = ref->u.ar.as->rank;
break;
}
}
+ if (last_arr_ref && last_arr_ref->u.ar.as)
+ {
+ for (i = last_arr_ref->u.ar.as->rank;
+ i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
+ {
+ /* For unknown dimen in non-resolved as assume full corank. */
+ if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_STAR
+ || (last_arr_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
+ && !last_arr_ref->u.ar.as->resolved))
+ {
+ corank = last_arr_ref->u.ar.as->corank;
+ break;
+ }
+ else if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_RANGE
+ || last_arr_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
+ || last_arr_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
+ corank++;
+ else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
+ gfc_internal_error ("Illegal coarray index");
+ }
+ }
e->rank = rank;
+ e->corank = corank;
done:
expression_shape (e);
if (op2->expr_type == EXPR_VARIABLE)
gfc_expression_rank (op2);
- return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank);
+ return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
+ && (op1->corank == 0 || op2->corank == 0
+ || op1->corank == op2->corank);
}
"caf_get", tmp_expr->where, 1, tmp_expr);
wrapper->ts = e->ts;
wrapper->rank = e->rank;
+ wrapper->corank = e->corank;
if (e->rank)
wrapper->shape = gfc_copy_shape (e->shape, e->rank);
*e = *wrapper;
{
if (sym->ts.type == BT_CLASS)
gfc_fix_class_refs (e);
- if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
+ if (!sym->attr.dimension && !sym->attr.codimension && e->ref
+ && e->ref->type == REF_ARRAY)
{
/* Unambiguously scalar! */
if (sym->assoc->target
sym->name, &e->where);
return false;
}
- else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
+ else if ((sym->attr.dimension || sym->attr.codimension)
+ && (!e->ref || e->ref->type != REF_ARRAY))
{
/* This can happen because the parser did not detect that the
associate name is an array and the expression had no array
}
ref->next = e->ref;
e->ref = ref;
-
}
}
/* On the other hand, the parser may not have known this is an array;
in this case, we have to add a FULL reference. */
- if (sym->assoc && sym->attr.dimension && !e->ref)
+ if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
{
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
the full array ref to _vptr or _len refs. */
if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
&& CLASS_DATA (sym)
- && CLASS_DATA (sym)->attr.dimension
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
&& (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
{
gfc_ref *ref, *newref;
if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
{
sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+ sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
{
ref = e->ref;
&& sym->assoc->target->ts.type == BT_CLASS)
{
e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
+ e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
sym->attr.dimension = 0;
+ sym->attr.codimension = 0;
CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
+ CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
if (e->ref && (e->ref->type != REF_COMPONENT
|| e->ref->u.c.component->name[0] != '_'))
{
gfc_free_ref_list (e->ref);
e->ref = NULL;
e->rank = sym->as ? sym->as->rank : 0;
+ e->corank = sym->as ? sym->as->corank : 0;
}
gfc_resolve_expr (e);
/* Take the rank from the function's symbol. */
if (e->value.compcall.tbp->u.specific->n.sym->as)
- e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
+ {
+ e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
+ e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
+ }
/* For now, we simply transform it into an EXPR_FUNCTION call with the same
arglist to the TBP's binding target. */
e->value.function.actual = e->value.compcall.actual;
e->ts = comp->ts;
if (comp->as != NULL)
- e->rank = comp->as->rank;
+ {
+ e->rank = comp->as->rank;
+ e->corank = comp->as->corank;
+ }
if (!comp->attr.function)
gfc_add_function (&comp->attr, comp->name, &e->where);
sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
sym->attr.dimension = target->rank ? 1 : 0;
- gfc_change_class (&sym->ts, &attr, sym->as,
- target->rank, gfc_get_corank (target));
+ gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
+ target->corank);
sym->as = NULL;
}
else if (target->ts.type == BT_DERIVED
sym->ts = target->ts;
attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
sym->attr.dimension = target->rank ? 1 : 0;
- gfc_change_class (&sym->ts, &attr, sym->as,
- target->rank, gfc_get_corank (target));
+ gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
+ target->corank);
sym->as = NULL;
target->ts = sym->ts;
}
&& CLASS_DATA (target)->as)
{
target->rank = CLASS_DATA (target)->as->rank;
+ target->corank = CLASS_DATA (target)->as->corank;
if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
{
sym->ts = target->ts;
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
- if (target->rank != 0 && !sym->attr.select_rank_temporary)
+ if ((target->rank != 0 || target->corank != 0)
+ && !sym->attr.select_rank_temporary)
{
gfc_array_spec *as;
/* The rank may be incorrectly guessed at parsing, therefore make sure
it is corrected now. */
- if (sym->ts.type != BT_CLASS && !sym->as)
+ if (sym->ts.type != BT_CLASS
+ && (!sym->as || sym->as->corank != target->corank))
{
if (!sym->as)
sym->as = gfc_get_array_spec ();
as = sym->as;
as->rank = target->rank;
as->type = AS_DEFERRED;
- as->corank = gfc_get_corank (target);
+ as->corank = target->corank;
sym->attr.dimension = 1;
if (as->corank != 0)
sym->attr.codimension = 1;
}
- else if (sym->ts.type == BT_CLASS
- && CLASS_DATA (sym) && !CLASS_DATA (sym)->as)
+ else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && (!CLASS_DATA (sym)->as
+ || CLASS_DATA (sym)->as->corank != target->corank))
{
if (!CLASS_DATA (sym)->as)
CLASS_DATA (sym)->as = gfc_get_array_spec ();
as = CLASS_DATA (sym)->as;
as->rank = target->rank;
as->type = AS_DEFERRED;
- as->corank = gfc_get_corank (target);
+ as->corank = target->corank;
CLASS_DATA (sym)->attr.dimension = 1;
if (as->corank != 0)
CLASS_DATA (sym)->attr.codimension = 1;
This is corrected here as well.*/
static void
-fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
- int rank, gfc_ref *ref)
+fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
+ gfc_ref *ref)
{
gfc_ref *nref = (*expr1)->ref;
gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
gfc_expr *selector = gfc_copy_expr (expr2);
(*expr1)->rank = rank;
+ (*expr1)->corank = corank;
if (selector)
{
gfc_resolve_expr (selector);
if ((*expr1)->ts.type != BT_CLASS)
(*expr1)->ts = sym1->ts;
- CLASS_DATA (sym1)->attr.dimension = 1;
+ CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
+ CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
if (CLASS_DATA (sym1)->as == NULL && sym2)
CLASS_DATA (sym1)->as
= gfc_copy_array_spec (CLASS_DATA (sym2)->as);
}
else
{
- sym1->attr.dimension = 1;
+ sym1->attr.dimension = rank > 0 ? 1 : 0;
+ sym1->attr.codimension = corank > 0 ? 1 : 0;
if (sym1->as == NULL && sym2)
sym1->as = gfc_copy_array_spec (sym2->as);
}
nref->next = gfc_copy_ref (ref);
else if (ref && !nref)
(*expr1)->ref = gfc_copy_ref (ref);
+ else if (ref && nref->u.ar.codimen != corank)
+ {
+ for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
+ nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
+ nref->u.ar.codimen = corank;
+ }
}
char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
gfc_namespace *ns;
int error = 0;
- int rank = 0;
+ int rank = 0, corank = 0;
gfc_ref* ref = NULL;
gfc_expr *selector_expr = NULL;
ns = code->ext.block.ns;
+ if (code->expr2)
+ {
+ /* Set this, or coarray checks in resolve will fail. */
+ code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
+ }
gfc_resolve (ns);
/* Check for F03:C813. */
return;
}
- if (!code->expr1->symtree->n.sym->attr.class_ok)
+ /* Prevent segfault, when class type is not initialized due to previous
+ error. */
+ if (!code->expr1->symtree->n.sym->attr.class_ok
+ || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
return;
if (code->expr2)
? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
}
- if (code->expr2->rank
- && code->expr1->ts.type == BT_CLASS
- && CLASS_DATA (code->expr1)->as)
- CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
+ if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
+ {
+ CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
+ CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
+ CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
+ }
/* F2008: C803 The selector expression must not be coindexed. */
if (gfc_is_coindexed (code->expr2))
/* Ensure that the selector rank and arrayspec are available to
correct expressions in which they might be missing. */
- if (code->expr2 && code->expr2->rank)
+ if (code->expr2 && (code->expr2->rank || code->expr2->corank))
{
rank = code->expr2->rank;
+ corank = code->expr2->corank;
for (ref = code->expr2->ref; ref; ref = ref->next)
if (ref->next == NULL)
break;
ref = gfc_copy_ref (ref);
/* Fixup expr1 if necessary. */
- if (rank)
- fixup_array_ref (&code->expr1, code->expr2, rank, ref);
+ if (rank || corank)
+ fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
}
- else if (code->expr1->rank)
+ else if (code->expr1->rank || code->expr1->corank)
{
rank = code->expr1->rank;
+ corank = code->expr1->corank;
for (ref = code->expr1->ref; ref; ref = ref->next)
if (ref->next == NULL)
break;
expression has to be set to zero. */
gfc_add_vptr_component (code->expr1);
code->expr1->rank = 0;
+ code->expr1->corank = 0;
code->expr1 = build_loc_call (code->expr1);
selector_expr = code->expr1->value.function.actual->expr;
{
gfc_add_data_component (st->n.sym->assoc->target);
/* Fixup the target expression if necessary. */
- if (rank)
- fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref);
+ if (rank || corank)
+ fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
+ ref);
}
new_st = gfc_get_code (EXEC_BLOCK);
{
gfc_add_full_array_ref (e, c->as);
e->rank = c->as->rank;
+ e->corank = c->as->corank;
}
}
if (as->type == AS_DEFERRED)
tmp->n.sym->attr.allocatable = 1;
}
- else if (e->rank && (e->expr_type == EXPR_ARRAY
- || e->expr_type == EXPR_FUNCTION
- || e->expr_type == EXPR_OP))
+ else if ((e->rank || e->corank)
+ && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
+ || e->expr_type == EXPR_OP))
{
tmp->n.sym->as = gfc_get_array_spec ();
tmp->n.sym->as->type = AS_DEFERRED;
tmp->n.sym->as->rank = e->rank;
+ tmp->n.sym->as->corank = e->corank;
tmp->n.sym->attr.allocatable = 1;
- tmp->n.sym->attr.dimension = 1;
+ tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
+ tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
}
else
tmp->n.sym->attr.dimension = 0;
/* Assume that use associated symbols were checked in the module ns.
Class-variables that are associate-names are also something special
and excepted from the test. */
- if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
+ if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
+ && !sym->attr.select_type_temporary
+ && !sym->attr.select_rank_temporary)
{
gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
sym->attr.dimension = sym->result->attr.dimension;
+ sym->attr.codimension = sym->result->attr.codimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
sym->attr.contiguous = sym->result->attr.contiguous;
if (!sym->assoc->variable)
return false;
- if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+ if ((sym->attr.dimension || sym->attr.codimension)
+ && sym->as->type != AS_EXPLICIT)
return false;
return true;
{
gfc_ss *ss;
- gcc_assert (gfc_get_corank (e) > 0);
-
ss = gfc_walk_expr (e);
/* Fix scalar coarray. */
gcc_assert (ref != NULL);
if (ref->u.ar.type == AR_ELEMENT)
ref->u.ar.type = AR_SECTION;
- ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+ ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref, false));
}
return ss;
bool substr = false;
gfc_expr *arg, *ss_expr;
- if (se->want_coarray)
+ if (se->want_coarray || expr->rank == 0)
ss = walk_coarray (expr);
else
ss = gfc_walk_expr (expr);
{
gfc_array_ref *ar = &info->ref->u.ar;
- codim = gfc_get_corank (expr);
+ codim = expr->corank;
for (n = 0; n < codim - 1; n++)
{
/* Make sure we are not lost somehow. */
/* The 1st element in the section. */
base = gfc_index_zero_node;
+ if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
+ base = gfc_index_one_node;
/* The offset from the 1st element in the section. */
offset = gfc_index_zero_node;
gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
+ if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
+ {
+ tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ tmp = gfc_conv_descriptor_token (tmp);
+ }
+ else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
+ && GFC_DECL_TOKEN (tmp) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (tmp);
+ else
+ {
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
+ }
+
+ gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
+ }
desc = parm;
}
return gfc_walk_array_ref (ss, expr, ref);
}
-
gfc_ss *
-gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
+gfc_walk_array_ref (gfc_ss *ss, gfc_expr *expr, gfc_ref *ref, bool array_only)
{
gfc_array_ref *ar;
gfc_ss *newss;
}
/* We're only interested in array sections from now on. */
- if (ref->type != REF_ARRAY)
+ if (ref->type != REF_ARRAY
+ || (array_only && ref->u.ar.as && ref->u.ar.as->rank == 0))
continue;
ar = &ref->u.ar;
/* Workhorse for gfc_walk_expr. */
gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
/* Workhorse for gfc_walk_variable_expr. */
-gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
+gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref *ref,
+ bool = true);
/* Walk the arguments of an elemental function. */
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
gfc_intrinsic_sym *,
gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
{
gfc_symbol *sym = expr->symtree->n.sym;
- bool is_coarray = sym->attr.codimension;
+ bool is_coarray = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->attr.codimension
+ : sym->attr.codimension;
gfc_expr *caf_expr = gfc_copy_expr (expr);
gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
gfc_free_ref_list (last_caf_ref->next);
last_caf_ref->next = NULL;
caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
+ caf_expr->corank = last_caf_ref->u.c.component->as
+ ? last_caf_ref->u.c.component->as->corank
+ : expr->corank;
se.want_pointer = comp_ref;
gfc_conv_expr (&se, caf_expr);
gfc_add_block_to_block (&outerse->pre, &se.pre);
/* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
type = gfc_get_int_type (gfc_default_integer_kind);
- corank = gfc_get_corank (expr->value.function.actual->expr);
+ corank = expr->value.function.actual->expr->corank;
rank = expr->value.function.actual->expr->rank;
/* Obtain the descriptor of the COARRAY. */
int rank, corank, codim;
type = gfc_get_int_type (gfc_default_integer_kind);
- corank = gfc_get_corank (expr->value.function.actual->expr);
+ corank = expr->value.function.actual->expr->corank;
rank = expr->value.function.actual->expr->rank;
/* Obtain the descriptor of the COARRAY. */
arg2 = arg->next;
gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
- corank = gfc_get_corank (arg->expr);
+ corank = arg->expr->corank;
gfc_init_se (&argse, NULL);
argse.want_coarray = 1;
expr->value.function.isym,
GFC_SS_SCALAR);
- if (expr->rank == 0)
+ if (expr->rank == 0 && expr->corank == 0)
return ss;
if (gfc_inline_intrinsic_function_p (expr))
return walk_inline_intrinsic_function (ss, expr);
- if (gfc_is_intrinsic_libcall (expr))
+ if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
return gfc_walk_intrinsic_libfunc (ss, expr);
/* Special cases. */
gfc_init_se (&to_se, NULL);
gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
- coarray = gfc_get_corank (from_expr) != 0;
+ coarray = from_expr->corank != 0;
from_is_class = from_expr->ts.type == BT_CLASS;
from_is_scalar = from_expr->rank == 0 && !coarray;
if (gfc_expr_attr (code->expr1).dimension)
{
tree desc, tmp, extent, lbound, ubound;
- gfc_array_ref *ar, ar2;
- int i;
+ gfc_array_ref *ar, ar2;
+ int i, rank;
/* TODO: Extend this, once DT components are supported. */
ar = &code->expr1->ref->u.ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
+ rank = code->expr1->rank;
+ code->expr1->rank = ar->as->rank;
gfc_init_se (&argse, NULL);
argse.descriptor_only = 1;
gfc_add_block_to_block (&se.pre, &argse.pre);
desc = argse.expr;
*ar = ar2;
+ code->expr1->rank = rank;
extent = build_one_cst (gfc_array_index_type);
for (i = 0; i < ar->dimen; i++)
tree charlen;
bool need_len_assign;
bool whole_array = true;
+ bool same_class;
gfc_ref *ref;
gfc_symbol *sym2;
&& e->ts.type == BT_CLASS
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
+ same_class = e->ts.type == BT_CLASS && sym->ts.type == BT_CLASS
+ && strcmp (sym->ts.u.derived->name, e->ts.u.derived->name) == 0;
unlimited = UNLIMITED_POLY (e);
for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY
- && ref->u.ar.type == AR_FULL
- && ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
+ && ref->u.ar.dimen != 0 && ref->next)
{
whole_array = false;
break;
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
}
/* Now all the other kinds of associate variable. */
- else if (sym->attr.dimension && !class_target
+ else if ((sym->attr.dimension || sym->attr.codimension) && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
}
+ if (sym->attr.codimension && !sym->attr.dimension)
+ se.want_coarray = 1;
+
gfc_conv_expr_descriptor (&se, e);
if (sym->ts.type == BT_CHARACTER
/* Temporaries, arising from TYPE IS, just need the descriptor of class
arrays to be assigned directly. */
- else if (class_target && sym->attr.dimension
+ else if (class_target && (sym->attr.dimension || sym->attr.codimension)
&& (sym->ts.type == BT_DERIVED || unlimited))
{
gfc_se se;
gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp)));
}
else
- gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+ gfc_add_modify (&se.pre, sym->backend_decl,
+ build1 (VIEW_CONVERT_EXPR,
+ TREE_TYPE (sym->backend_decl), se.expr));
if (unlimited)
{
{
gfc_se se;
- gcc_assert (!sym->attr.dimension);
+ gcc_assert (!sym->attr.dimension && !sym->attr.codimension);
gfc_init_se (&se, NULL);
e->symtree->name);
need_len_assign = false;
}
+ else if (whole_array && (same_class || unlimited)
+ && e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.codimension)
+ {
+ gfc_expr *class_e = gfc_find_and_cut_at_last_class_ref (e);
+ gfc_conv_expr (&se, class_e);
+ gfc_free_expr (class_e);
+ need_len_assign = false;
+ }
else
{
/* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
tree ctree = gfc_get_class_from_expr (se.expr);
tmp = TREE_TYPE (sym->backend_decl);
- /* F2018:19.5.1.6 "If a selector has the POINTER attribute,
- it shall be associated; the associate name is associated
- with the target of the pointer and does not have the
- POINTER attribute." */
- if (sym->ts.type == BT_CLASS
- && e->ts.type == BT_CLASS && e->rank == 0 && ctree
- && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
- || CLASS_DATA (e)->attr.class_pointer))
+ if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
{
- tree stmp;
- tree dtmp;
- tree ctmp;
+ /* F2018:19.5.1.6 "If a selector has the POINTER attribute,
+ it shall be associated; the associate name is associated
+ with the target of the pointer and does not have the
+ POINTER attribute." */
+ if (e->rank == 0 && ctree
+ && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
+ || CLASS_DATA (e)->attr.class_pointer))
+ {
+ tree stmp;
+ tree dtmp;
+ tree ctmp;
- ctmp = ctree;
- dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
- ctree = gfc_create_var (dtmp, "class");
+ ctmp = ctree;
+ dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
+ ctree = gfc_create_var (dtmp, "class");
- if (IS_INFERRED_TYPE (e)
- && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
- stmp = se.expr;
- else
- stmp = gfc_class_data_get (ctmp);
-
- /* Coarray scalar component expressions can emerge from
- the front end as array elements of the _data field. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
- stmp = gfc_conv_descriptor_data_get (stmp);
-
- if (!POINTER_TYPE_P (TREE_TYPE (stmp)))
- stmp = gfc_build_addr_expr (NULL, stmp);
-
- dtmp = gfc_class_data_get (ctree);
- stmp = fold_convert (TREE_TYPE (dtmp), stmp);
- gfc_add_modify (&se.pre, dtmp, stmp);
- stmp = gfc_class_vptr_get (ctmp);
- dtmp = gfc_class_vptr_get (ctree);
- stmp = fold_convert (TREE_TYPE (dtmp), stmp);
- gfc_add_modify (&se.pre, dtmp, stmp);
- if (UNLIMITED_POLY (sym))
- {
- stmp = gfc_class_len_get (ctmp);
- dtmp = gfc_class_len_get (ctree);
+ if (IS_INFERRED_TYPE (e)
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+ stmp = se.expr;
+ else
+ stmp = gfc_class_data_get (ctmp);
+
+ /* Coarray scalar component expressions can emerge from
+ the front end as array elements of the _data field. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
+ stmp = gfc_conv_descriptor_data_get (stmp);
+
+ if (!POINTER_TYPE_P (TREE_TYPE (stmp)))
+ stmp = gfc_build_addr_expr (NULL, stmp);
+
+ dtmp = gfc_class_data_get (ctree);
+ stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+ gfc_add_modify (&se.pre, dtmp, stmp);
+ stmp = gfc_class_vptr_get (ctmp);
+ dtmp = gfc_class_vptr_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
- need_len_assign = false;
+ if (UNLIMITED_POLY (sym))
+ {
+ stmp = gfc_class_len_get (ctmp);
+ dtmp = gfc_class_len_get (ctree);
+ stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+ gfc_add_modify (&se.pre, dtmp, stmp);
+ need_len_assign = false;
+ }
+ se.expr = ctree;
+ }
+ else if (CLASS_DATA (sym)->attr.codimension)
+ {
+ gfc_conv_class_to_class (&se, e, sym->ts, false, false, false,
+ false);
+ tmp = se.expr;
}
- se.expr = ctree;
}
- tmp = gfc_build_addr_expr (tmp, se.expr);
+ if (!POINTER_TYPE_P (TREE_TYPE (se.expr)))
+ tmp = gfc_build_addr_expr (tmp, se.expr);
}
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
newsym->n.sym->backend_decl = expr3;
e3rhs = gfc_get_expr ();
e3rhs->rank = code->expr3->rank;
+ e3rhs->corank = code->expr3->corank;
e3rhs->symtree = newsym;
/* Mark the symbol referenced or gfc_trans_assignment will bug. */
newsym->n.sym->attr.referenced = 1;
gfc_array_spec *arr;
arr = gfc_get_array_spec ();
arr->rank = e3rhs->rank;
+ arr->corank = e3rhs->corank;
arr->type = AS_DEFERRED;
/* Set the dimension and pointer attribute for arrays
- to be on the safe side. */
+ to be on the safe side. */
newsym->n.sym->attr.dimension = 1;
newsym->n.sym->attr.pointer = 1;
newsym->n.sym->as = arr;
ref->next = NULL;
}
- if (expr->ts.type == BT_CLASS
- && !expr2->rank
- && !expr2->ref
- && CLASS_DATA (expr2->symtree->n.sym)->as)
- expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
+ if (expr->ts.type == BT_CLASS && (!expr2->rank || !expr2->corank)
+ && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
+ {
+ expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
+ expr->corank = CLASS_DATA (expr2->symtree->n.sym)->as->corank;
+ }
stmtblock_t tmp_block;
gfc_start_block (&tmp_block);
projects / thirdparty / gcc.git / commitdiff
