Hi all,
the attached two patches fix ASSOCIATE for coarrays, i.e. that a coarray
associated to a variable is also a coarray in the block of the ASSOCIATE
command. The patch has two parts:
1. pr110033p1_1.patch: Adds a corank member to the gfc_expr structure. I
decided to add it here and keep track of the corank of an expression, because
calling gfc_get_corank was getting to expensive with the associate patch. This
patch also improves the usage of coarrays in select type/rank constructs.
2. pr110033p2_1.patch: The changes and testcase for PR 110033. In essence the
coarray is not detected correctly on the expression to associate to and
therefore not propagated correctly into the block of the ASSOCIATE command. The
patch adds correct treatment for propagating the coarray token into the block,
too.
The costs of tracking the corank along side to the rank of an expression are
about 30 seconds real user time (i.e. time's "real" row) on a rather old Intel
i7-5775C@3.3GHz with 24G RAM that was used for work during the test. If need be
I can tuned that more.
Regtests ok on x86_64-pc-linux-gnu / Fedora 39. Ok for mainline?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
From 7b7f2bad87e1c10b2addc54b1e6746cb56de0c78 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri, 9 Aug 2024 12:47:18 +0200
Subject: [PATCH 1/2] [Fortran] Add corank to gfc_expr.
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.
---
gcc/fortran/arith.cc | 4 +
gcc/fortran/array.cc | 16 ++-
gcc/fortran/check.cc | 18 +--
gcc/fortran/class.cc | 3 +
gcc/fortran/data.cc | 1 +
gcc/fortran/decl.cc | 2 +
gcc/fortran/expr.cc | 51 +++----
gcc/fortran/frontend-passes.cc | 5 +
gcc/fortran/gfortran.h | 2 +-
gcc/fortran/intrinsic.cc | 3 +
gcc/fortran/iresolve.cc | 20 ++-
gcc/fortran/match.cc | 30 +++-
gcc/fortran/matchexp.cc | 1 +
gcc/fortran/parse.cc | 39 ++++--
gcc/fortran/primary.cc | 10 +-
gcc/fortran/resolve.cc | 243 ++++++++++++++++++++++++++-------
gcc/fortran/symbol.cc | 3 +-
gcc/fortran/trans-array.cc | 33 +++--
gcc/fortran/trans-array.h | 3 +-
gcc/fortran/trans-expr.cc | 7 +-
gcc/fortran/trans-intrinsic.cc | 12 +-
gcc/fortran/trans-stmt.cc | 133 +++++++++++-------
gcc/fortran/trans.cc | 11 +-
23 files changed, 450 insertions(+), 200 deletions(-)
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index b373c25e5e1..19916c105ad 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -1393,6 +1393,7 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
}
r->shape = gfc_copy_shape (op->shape, op->rank);
r->rank = op->rank;
+ r->corank = op->corank;
r->value.constructor = head;
*result = r;
}
@@ -1456,6 +1457,7 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
r->shape = gfc_get_shape (op1->rank);
}
r->rank = op1->rank;
+ r->corank = op1->corank;
r->value.constructor = head;
*result = r;
}
@@ -1519,6 +1521,7 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
r->shape = gfc_get_shape (op2->rank);
}
r->rank = op2->rank;
+ r->corank = op2->corank;
r->value.constructor = head;
*result = r;
}
@@ -1585,6 +1588,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
}
r->shape = gfc_copy_shape (op1->shape, op1->rank);
r->rank = op1->rank;
+ r->corank = op1->corank;
r->value.constructor = head;
*result = r;
}
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 79c774d59a0..4d71e8eaf6b 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -203,6 +203,12 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
{
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;
}
@@ -238,7 +244,15 @@ coarray:
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;
}
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 2f50d84b876..ee1e7417f38 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -1075,8 +1075,6 @@ dim_check (gfc_expr *dim, int n, bool optional)
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)
@@ -1085,10 +1083,8 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
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);
@@ -4269,11 +4265,11 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
}
/* 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;
}
@@ -5996,13 +5992,11 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
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;
}
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index b9dcc0a3d98..88fbba2818a 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -264,10 +264,12 @@ void
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;
@@ -1061,6 +1063,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
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;
}
diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc
index 70247490e47..d80ba66d358 100644
--- a/gcc/fortran/data.cc
+++ b/gcc/fortran/data.cc
@@ -327,6 +327,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
/* 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)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index b8308aeee55..f712a454154 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -912,6 +912,7 @@ match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
/* 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]);
@@ -2277,6 +2278,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
mpz_clear (size);
}
init->rank = sym->as->rank;
+ init->corank = sym->as->corank;
}
sym->value = init;
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index be138d196a2..d3a1f8c0ba1 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1320,6 +1320,7 @@ simplify_intrinsic_op (gfc_expr *p, int type)
}
result->rank = p->rank;
+ result->corank = p->corank;
result->where = p->where;
gfc_replace_expr (p, result);
@@ -2161,6 +2162,7 @@ simplify_parameter_variable (gfc_expr *p, int type)
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;
@@ -2181,6 +2183,7 @@ simplify_parameter_variable (gfc_expr *p, int type)
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;
@@ -4596,7 +4599,10 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
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;
@@ -4609,6 +4615,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
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;
@@ -5261,14 +5268,15 @@ gfc_get_variable_expr (gfc_symtree *var)
&& 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;
@@ -5297,6 +5305,8 @@ gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
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;
}
@@ -5316,7 +5326,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
/* 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;
}
@@ -5872,32 +5883,6 @@ gfc_is_coarray (gfc_expr *e)
}
-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
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 3c06018fdbb..104ccb1a4c1 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -515,6 +515,7 @@ callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
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;
@@ -791,6 +792,7 @@ create_var (gfc_expr * e, const char *vname)
{
symbol->as = gfc_get_array_spec ();
symbol->as->rank = e->rank;
+ symbol->as->corank = e->corank;
if (e->shape == NULL)
{
@@ -853,6 +855,7 @@ create_var (gfc_expr * e, const char *vname)
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;
@@ -1839,6 +1842,7 @@ combine_array_constructor (gfc_expr *e)
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;
@@ -2283,6 +2287,7 @@ optimize_minmaxloc (gfc_expr **e)
*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);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8d89797412e..729d811d945 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2571,6 +2571,7 @@ typedef struct gfc_expr
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
@@ -3801,7 +3802,6 @@ bool gfc_is_class_array_function (gfc_expr *);
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 *);
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 62c349da7f6..f7cbb4bb5e2 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -165,6 +165,7 @@ gfc_get_intrinsic_function_symbol (gfc_expr *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;
}
@@ -5382,6 +5383,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag,
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);
@@ -5457,6 +5459,7 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
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);
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index c63a4a8d38c..753c636a1af 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -152,13 +152,21 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
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);
@@ -748,6 +756,7 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
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)
@@ -916,6 +925,7 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
f->ts = array->ts;
f->rank = array->rank;
+ f->corank = array->corank;
f->shape = gfc_copy_shape (array->shape, array->rank);
n = 0;
@@ -1554,6 +1564,7 @@ gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
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,
@@ -1584,6 +1595,7 @@ gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
}
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
+ f->corank = a->corank;
if (a->rank == 2 && b->rank == 2)
{
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 1851a8f94a5..4acdb146439 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6327,7 +6327,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
{
gfc_ref *ref;
gfc_symbol *assoc_sym;
- int rank = 0;
+ int rank = 0, corank = 0;
assoc_sym = associate->symtree->n.sym;
@@ -6345,6 +6345,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
{
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
@@ -6371,13 +6372,20 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
}
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)
@@ -6399,12 +6407,20 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
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.
diff --git a/gcc/fortran/matchexp.cc b/gcc/fortran/matchexp.cc
index 3f7140a6973..9e773cf8fee 100644
--- a/gcc/fortran/matchexp.cc
+++ b/gcc/fortran/matchexp.cc
@@ -133,6 +133,7 @@ gfc_get_parentheses (gfc_expr *e)
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;
}
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index b28c8a94547..a814b7910d3 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5164,7 +5164,7 @@ parse_associate (void)
{
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 ();
@@ -5225,11 +5225,17 @@ parse_associate (void)
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
@@ -5261,18 +5267,19 @@ parse_associate (void)
}
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)
@@ -5290,6 +5297,7 @@ parse_associate (void)
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 ();
@@ -5300,17 +5308,22 @@ parse_associate (void)
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;
+ }
}
}
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 76f6bcb8a78..fb00c08163b 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3895,9 +3895,15 @@ gfc_match_rvalue (gfc_expr **result)
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))
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index a748c11261b..b776d6149a7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1439,6 +1439,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
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);
@@ -2180,13 +2181,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|| (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
@@ -2355,6 +2357,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
if (expr)
{
expr->rank = rank;
+ expr->corank = arg->expr->corank;
if (!expr->shape && arg->expr->shape)
{
expr->shape = gfc_get_shape (rank);
@@ -2801,9 +2804,15 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
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);
@@ -2943,9 +2952,15 @@ found:
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;
}
@@ -3066,7 +3081,10 @@ resolve_unknown_f (gfc_expr *expr)
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. */
@@ -4606,6 +4624,33 @@ resolve_operator (gfc_expr *e)
}
}
+ /* 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:
@@ -4614,6 +4659,7 @@ resolve_operator (gfc_expr *e)
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);
@@ -5651,8 +5697,8 @@ fail:
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... */
@@ -5664,22 +5710,42 @@ gfc_expression_rank (gfc_expr *e)
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;
@@ -5700,8 +5766,30 @@ gfc_expression_rank (gfc_expr *e)
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);
@@ -5719,7 +5807,9 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
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);
}
@@ -5746,6 +5836,7 @@ add_caf_get_intrinsic (gfc_expr *e)
"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;
@@ -5926,7 +6017,8 @@ resolve_variable (gfc_expr *e)
{
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
@@ -5936,7 +6028,8 @@ resolve_variable (gfc_expr *e)
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
@@ -5951,7 +6044,6 @@ resolve_variable (gfc_expr *e)
}
ref->next = e->ref;
e->ref = ref;
-
}
}
@@ -5960,7 +6052,7 @@ resolve_variable (gfc_expr *e)
/* 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;
@@ -5973,7 +6065,8 @@ resolve_variable (gfc_expr *e)
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;
@@ -6219,6 +6312,7 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
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;
@@ -6282,8 +6376,11 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
&& 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] != '_'))
{
@@ -6463,6 +6560,7 @@ check_host_association (gfc_expr *e)
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);
@@ -7085,7 +7183,10 @@ resolve_compcall (gfc_expr* e, const char **name)
/* 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. */
@@ -7410,7 +7511,10 @@ resolve_expr_ppc (gfc_expr* e)
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);
@@ -9482,8 +9586,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
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
@@ -9500,8 +9604,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
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;
}
@@ -9555,6 +9659,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
&& 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;
@@ -9598,32 +9703,35 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
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;
@@ -9733,8 +9841,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
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;
@@ -9742,6 +9850,7 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
gfc_expr *selector = gfc_copy_expr (expr2);
(*expr1)->rank = rank;
+ (*expr1)->corank = corank;
if (selector)
{
gfc_resolve_expr (selector);
@@ -9762,14 +9871,16 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
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);
}
@@ -9782,6 +9893,12 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
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;
+ }
}
@@ -9818,11 +9935,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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. */
@@ -9834,7 +9956,10 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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)
@@ -9865,10 +9990,12 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
? 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))
@@ -10005,9 +10132,10 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
/* 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;
@@ -10015,12 +10143,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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;
@@ -10047,6 +10176,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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;
@@ -10121,8 +10251,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
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);
@@ -11775,6 +11906,7 @@ add_comp_ref (gfc_expr *e, gfc_component *c)
{
gfc_add_full_array_ref (e, c->as);
e->rank = c->as->rank;
+ e->corank = c->as->corank;
}
}
@@ -11869,15 +12001,17 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
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;
@@ -13674,7 +13808,9 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
/* 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);
@@ -16459,6 +16595,7 @@ resolve_symbol (gfc_symbol *sym)
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;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index a8b623dd92a..dd209a22fc1 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -5410,7 +5410,8 @@ gfc_is_associate_pointer (gfc_symbol* sym)
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;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9fb0b2b398d..ea5fff2e0c2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7882,8 +7882,6 @@ walk_coarray (gfc_expr *e)
{
gfc_ss *ss;
- gcc_assert (gfc_get_corank (e) > 0);
-
ss = gfc_walk_expr (e);
/* Fix scalar coarray. */
@@ -7904,7 +7902,7 @@ walk_coarray (gfc_expr *e)
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;
@@ -8005,7 +8003,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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);
@@ -8338,7 +8336,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_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. */
@@ -8488,6 +8486,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
/* 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;
@@ -8587,6 +8587,23 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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;
}
@@ -12110,9 +12127,8 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
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;
@@ -12128,7 +12144,8 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
}
/* 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;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 29499a337c2..ab27f15cab2 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -89,7 +89,8 @@ gfc_ss *gfc_walk_expr (gfc_expr *);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5b9d1cde54f..dd89d9cb5ea 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -147,7 +147,9 @@ tree
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;
@@ -173,6 +175,9 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
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);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 8580b4b44c9..34115c2679b 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2410,7 +2410,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
/* 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. */
@@ -2687,7 +2687,7 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
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. */
@@ -3165,7 +3165,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
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;
@@ -11733,13 +11733,13 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
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. */
@@ -12756,7 +12756,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
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;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 41740ab762e..807fa8c6351 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -922,8 +922,8 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
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;
@@ -931,6 +931,8 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
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;
@@ -938,6 +940,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
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++)
@@ -1740,6 +1743,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
tree charlen;
bool need_len_assign;
bool whole_array = true;
+ bool same_class;
gfc_ref *ref;
gfc_symbol *sym2;
@@ -1750,13 +1754,14 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
&& 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;
@@ -1905,7 +1910,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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;
@@ -1931,6 +1936,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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
@@ -1994,7 +2002,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
/* 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;
@@ -2023,7 +2031,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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)
{
@@ -2043,7 +2053,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
gfc_se se;
- gcc_assert (!sym->attr.dimension);
+ gcc_assert (!sym->attr.dimension && !sym->attr.codimension);
gfc_init_se (&se, NULL);
@@ -2123,6 +2133,14 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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,
@@ -2158,55 +2176,64 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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);
@@ -6708,6 +6735,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
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;
@@ -6733,9 +6761,10 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
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;
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index d4c54093cbc..ce4618562b7 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1404,11 +1404,12 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2,
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);
--
2.46.0
From 95a2a34ce314e1a1b8f8d531035622a64ac707f8 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Wed, 24 Jul 2024 09:39:45 +0200
Subject: [PATCH 2/2] [Fortran] Fix Coarray in associate not a coarray.
[PR110033]
A coarray used in an associate did not become a coarray in the block of
the associate. This patch fixes that and the same also in select type
statements.
PR fortran/110033
gcc/fortran/ChangeLog:
* class.cc (gfc_is_class_scalar_expr): Coarray refs that ref
only self, aka this image, are regarded as scalar, too.
* resolve.cc (resolve_assoc_var): Ignore this image coarray refs
and do not build a new class type.
* trans-expr.cc (gfc_get_caf_token_offset): Get the caf token
from the descriptor for associated variables.
(gfc_conv_variable): Same.
(gfc_trans_pointer_assignment): Assign token to temporary
associate variable, too.
(gfc_trans_scalar_assign): Add flag that assign is for associate
and use it to assign the token.
(is_assoc_assign): Detect that expressions are for associate
assign.
(gfc_trans_assignment_1): Treat associate assigns like pointer
assignments where possible.
* trans-stmt.cc (trans_associate_var): Set same_class only for
class-targets.
* trans.h (gfc_trans_scalar_assign): Add flag to
trans_scalar_assign for marking associate assignments.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/associate_1.f90: New test.
---
gcc/fortran/class.cc | 38 ++++----
gcc/fortran/resolve.cc | 40 ++++++---
gcc/fortran/trans-expr.cc | 87 +++++++++++++++----
gcc/fortran/trans-stmt.cc | 2 +-
gcc/fortran/trans.h | 5 +-
.../gfortran.dg/coarray/associate_1.f90 | 30 +++++++
6 files changed, 157 insertions(+), 45 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/associate_1.f90
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 88fbba2818a..f9e0d416e48 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -379,27 +379,33 @@ gfc_is_class_scalar_expr (gfc_expr *e)
return false;
/* Is this a class object? */
- if (e->symtree
- && e->symtree->n.sym->ts.type == BT_CLASS
- && CLASS_DATA (e->symtree->n.sym)
- && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
- && (e->ref == NULL
- || (e->ref->type == REF_COMPONENT
- && strcmp (e->ref->u.c.component->name, "_data") == 0
- && e->ref->next == NULL)))
+ if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS
+ && CLASS_DATA (e->symtree->n.sym)
+ && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
+ && (e->ref == NULL
+ || (e->ref->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data") == 0
+ && (e->ref->next == NULL
+ || (e->ref->next->type == REF_ARRAY
+ && e->ref->next->u.ar.codimen > 0
+ && e->ref->next->u.ar.dimen == 0
+ && e->ref->next->next == NULL)))))
return true;
/* Or is the final reference BT_CLASS or _data? */
for (ref = e->ref; ref; ref = ref->next)
{
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (ref->u.c.component)
- && !CLASS_DATA (ref->u.c.component)->attr.dimension
- && (ref->next == NULL
- || (ref->next->type == REF_COMPONENT
- && strcmp (ref->next->u.c.component->name, "_data") == 0
- && ref->next->next == NULL)))
+ if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)
+ && !CLASS_DATA (ref->u.c.component)->attr.dimension
+ && (ref->next == NULL
+ || (ref->next->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0
+ && (ref->next->next == NULL
+ || (ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.codimen > 0
+ && ref->next->next->u.ar.dimen == 0
+ && ref->next->next->next == NULL)))))
return true;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b776d6149a7..423ce203123 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9750,6 +9750,9 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
correct this now. */
gfc_typespec *ts = &target->ts;
gfc_ref *ref;
+ /* Internal_ref is true, when this is ref'ing only _data and co-ref.
+ */
+ bool internal_ref = true;
for (ref = target->ref; ref != NULL; ref = ref->next)
{
@@ -9757,26 +9760,41 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
case REF_COMPONENT:
ts = &ref->u.c.component->ts;
+ internal_ref
+ = target->ref == ref && ref->next
+ && strncmp ("_data", ref->u.c.component->name, 5) == 0;
break;
case REF_ARRAY:
if (ts->type == BT_CLASS)
ts = &ts->u.derived->components->ts;
+ if (internal_ref && ref->u.ar.codimen > 0)
+ for (int i = ref->u.ar.dimen;
+ internal_ref
+ && i < ref->u.ar.dimen + ref->u.ar.codimen;
+ ++i)
+ internal_ref
+ = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
break;
default:
break;
}
}
- /* Create a scalar instance of the current class type. Because the
- rank of a class array goes into its name, the type has to be
- rebuilt. The alternative of (re-)setting just the attributes
- and as in the current type, destroys the type also in other
- places. */
- as = NULL;
- sym->ts = *ts;
- sym->ts.type = BT_CLASS;
- attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
- gfc_change_class (&sym->ts, &attr, as, 0, 0);
- sym->as = NULL;
+ /* Only rewrite the type of this symbol, when the refs are not the
+ internal ones for class and co-array this-image. */
+ if (!internal_ref)
+ {
+ /* Create a scalar instance of the current class type. Because
+ the rank of a class array goes into its name, the type has to
+ be rebuilt. The alternative of (re-)setting just the
+ attributes and as in the current type, destroys the type also
+ in other places. */
+ as = NULL;
+ sym->ts = *ts;
+ sym->ts.type = BT_CLASS;
+ attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+ gfc_change_class (&sym->ts, &attr, as, 0, 0);
+ sym->as = NULL;
+ }
}
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index dd89d9cb5ea..8801a15c3a8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2437,7 +2437,8 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
{
gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
== GFC_ARRAY_ALLOCATABLE
- || expr->symtree->n.sym->attr.select_type_temporary);
+ || expr->symtree->n.sym->attr.select_type_temporary
+ || expr->symtree->n.sym->assoc);
*token = gfc_conv_descriptor_token (caf_decl);
}
else if (DECL_LANG_SPECIFIC (caf_decl)
@@ -3256,6 +3257,13 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
else
se->string_length = sym->ts.u.cl->backend_decl;
gcc_assert (se->string_length);
+
+ /* For coarray strings return the pointer to the data and not the
+ descriptor. */
+ if (sym->attr.codimension && sym->attr.associate_var
+ && !se->descriptor_only
+ && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
+ se->expr = gfc_conv_descriptor_data_get (se->expr);
}
/* Some expressions leak through that haven't been fixed up. */
@@ -10536,10 +10544,25 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
- /* Also set the tokens for pointer components in derived typed
- coarrays. */
if (flag_coarray == GFC_FCOARRAY_LIB)
- trans_caf_token_assign (&lse, &rse, expr1, expr2);
+ {
+ if (expr1->ref)
+ /* Also set the tokens for pointer components in derived typed
+ coarrays. */
+ trans_caf_token_assign (&lse, &rse, expr1, expr2);
+ else if (gfc_caf_attr (expr1).codimension)
+ {
+ tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
+
+ lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
+ rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
+ gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
+ NULL_TREE, expr1);
+ gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
+ NULL_TREE, expr2);
+ gfc_add_modify (&block, lhs_tok, rhs_tok);
+ }
+ }
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
@@ -10981,8 +11004,9 @@ gfc_conv_string_parameter (gfc_se * se)
the assignment from the temporary to the lhs. */
tree
-gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool deep_copy, bool dealloc, bool in_coarray)
+gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
+ bool deep_copy, bool dealloc, bool in_coarray,
+ bool assoc_assign)
{
stmtblock_t block;
tree tmp;
@@ -11103,6 +11127,21 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ if (in_coarray)
+ {
+ if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
+ {
+ gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
+ TYPE_LANG_SPECIFIC (
+ TREE_TYPE (TREE_TYPE (rse->expr)))
+ ->caf_token);
+ }
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
+ lse->expr = gfc_conv_array_data (lse->expr);
+ if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
+ && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
+ rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
+ }
gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
@@ -12290,6 +12329,15 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
}
+bool
+is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
+{
+ if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
+ return false;
+
+ return lhs->symtree->n.sym->assoc
+ && lhs->symtree->n.sym->assoc->target == rhs;
+}
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
@@ -12323,6 +12371,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
bool realloc_flag;
+ bool assoc_assign = false;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -12378,6 +12427,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_class_scalar_expr (expr2))
&& lhs_attr.flavor != FL_PROCEDURE;
+ assoc_assign = is_assoc_assign (expr1, expr2);
+
realloc_flag = flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)
&& expr2->rank
@@ -12471,11 +12522,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
/* Translate the expression. */
- rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
- && lhs_caf_attr.codimension;
+ rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
+ && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
+ rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
gfc_conv_expr (&rse, expr2);
- /* Deal with the case of a scalar class function assigned to a derived type. */
+ /* Deal with the case of a scalar class function assigned to a derived type.
+ */
if (gfc_is_alloc_class_scalar_function (expr2)
&& expr1->ts.type == BT_DERIVED)
{
@@ -12690,15 +12743,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
else
gfc_add_block_to_block (&body, &rse.pre);
+ if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
+ && assoc_assign)
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
+
/* If nothing else works, do it the old fashioned way! */
if (tmp == NULL_TREE)
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- gfc_expr_is_variable (expr2)
- || scalar_to_array
+ tmp
+ = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ gfc_expr_is_variable (expr2) || scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
- !(l_is_temp || init_flag) && dealloc,
- expr1->symtree->n.sym->attr.codimension);
-
+ !(l_is_temp || init_flag) && dealloc,
+ expr1->symtree->n.sym->attr.codimension,
+ assoc_assign);
/* Add the lse pre block to the body */
gfc_add_block_to_block (&body, &lse.pre);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 807fa8c6351..3b09a139dc0 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1754,7 +1754,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
&& 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
+ same_class = class_target && sym->ts.type == BT_CLASS
&& strcmp (sym->ts.u.derived->name, e->ts.u.derived->name) == 0;
unlimited = UNLIMITED_POLY (e);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index fdcce206756..d67fbe36a24 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -570,8 +570,9 @@ void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool,
void gfc_conv_is_contiguous_expr (gfc_se *, gfc_expr *);
/* Generate code for a scalar assignment. */
-tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
- bool c = false);
+tree
+gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
+ bool = false, bool = false);
/* Translate COMMON blocks. */
void gfc_trans_common (gfc_namespace *);
diff --git a/gcc/testsuite/gfortran.dg/coarray/associate_1.f90 b/gcc/testsuite/gfortran.dg/coarray/associate_1.f90
new file mode 100644
index 00000000000..6eb55c91551
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/associate_1.f90
@@ -0,0 +1,30 @@
+!{ dg-do run }
+
+! Contributed by Neil Carlson <neil.n.carl...@gmail.com>
+! Check PR110033 is fixed.
+
+program coarray_associate_1
+ type t
+ integer :: b = -1
+ logical :: l = .FALSE.
+ end type
+
+ integer :: x[*] = 10
+ class(t), allocatable :: c[:]
+
+ associate (y => x)
+ y = -1
+ y[1] = 35
+ end associate
+ allocate(c[*])
+ associate (f => c)
+ f%b = 17
+ f[1]%l = .TRUE.
+ end associate
+
+ if (x /= 35) stop 1
+
+ if (c%b /= 17) stop 2
+ if (.NOT. c%l) stop 3
+end
+
--
2.46.0
