* [Fortran, Patch, PR110033, v1] Fix associate for coarrays
@ 2024-08-12 12:11 Andre Vehreschild
2024-08-14 10:51 ` Paul Richard Thomas
2024-08-14 19:21 ` Harald Anlauf
0 siblings, 2 replies; 11+ messages in thread
From: Andre Vehreschild @ 2024-08-12 12:11 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML; +Cc: Paul Richard Thomas
[-- Attachment #1: Type: text/plain, Size: 1231 bytes --]
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr110033p1_1.patch --]
[-- Type: text/x-patch, Size: 66400 bytes --]
From 7b7f2bad87e1c10b2addc54b1e6746cb56de0c78 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: pr110033p2_1.patch --]
[-- Type: text/x-patch, Size: 15288 bytes --]
From 95a2a34ce314e1a1b8f8d531035622a64ac707f8 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@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.carlson@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
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-12 12:11 [Fortran, Patch, PR110033, v1] Fix associate for coarrays Andre Vehreschild
@ 2024-08-14 10:51 ` Paul Richard Thomas
2024-08-14 19:21 ` Harald Anlauf
1 sibling, 0 replies; 11+ messages in thread
From: Paul Richard Thomas @ 2024-08-14 10:51 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 1687 bytes --]
Hi Andre,
From a very rapid scan(in the style of somebody on vacation :-) ) of the
two patches, it all looks good to me. Adding the corank structure to
gfc_expr is long overdue. Thanks also for rolling select type into the
second patch. It would be good if you would check if PRs 46371 and 56496
are fixed by the patch.
Regards
Paul
On Mon, 12 Aug 2024 at 13:11, Andre Vehreschild <vehre@gmx.de> wrote:
> 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
>
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-12 12:11 [Fortran, Patch, PR110033, v1] Fix associate for coarrays Andre Vehreschild
2024-08-14 10:51 ` Paul Richard Thomas
@ 2024-08-14 19:21 ` Harald Anlauf
2024-08-14 19:21 ` Harald Anlauf
2024-08-15 15:35 ` Andre Vehreschild
1 sibling, 2 replies; 11+ messages in thread
From: Harald Anlauf @ 2024-08-14 19:21 UTC (permalink / raw)
To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML; +Cc: Paul Richard Thomas
Hi Andre,
Am 12.08.24 um 14:11 schrieb Andre Vehreschild:
> 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?
Paul already gave a basic OK, and I won't object.
However, the testcase should be fixed. It is only correct for
single-image runs! (Verified with Intel ifx).
You have:
associate (y => x)
y = -1
y[1] = 35
end associate
and check:
if (x /= 35) stop 1
This should rather be
if (x[1] /= 35) stop 1
or for number of images > 1:
if (this_image() == 1) then
if (x /= 35) stop 1
else
if (x /= -1) stop 99
end if
and similarly
if (.NOT. c%l) stop 3
needs to be adjusted accordingly.
Thanks,
Harald
> Regards,
> Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-14 19:21 ` Harald Anlauf
@ 2024-08-14 19:21 ` Harald Anlauf
2024-08-15 15:35 ` Andre Vehreschild
1 sibling, 0 replies; 11+ messages in thread
From: Harald Anlauf @ 2024-08-14 19:21 UTC (permalink / raw)
To: gcc-patches; +Cc: fortran
Hi Andre,
Am 12.08.24 um 14:11 schrieb Andre Vehreschild:
> 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?
Paul already gave a basic OK, and I won't object.
However, the testcase should be fixed. It is only correct for
single-image runs! (Verified with Intel ifx).
You have:
associate (y => x)
y = -1
y[1] = 35
end associate
and check:
if (x /= 35) stop 1
This should rather be
if (x[1] /= 35) stop 1
or for number of images > 1:
if (this_image() == 1) then
if (x /= 35) stop 1
else
if (x /= -1) stop 99
end if
and similarly
if (.NOT. c%l) stop 3
needs to be adjusted accordingly.
Thanks,
Harald
> Regards,
> Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-14 19:21 ` Harald Anlauf
2024-08-14 19:21 ` Harald Anlauf
@ 2024-08-15 15:35 ` Andre Vehreschild
2024-08-15 17:39 ` Harald Anlauf
1 sibling, 1 reply; 11+ messages in thread
From: Andre Vehreschild @ 2024-08-15 15:35 UTC (permalink / raw)
To: Harald Anlauf; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Paul Richard Thomas
Hi Harald, hi Paul,
thanks for the ok and the suggestions/recommendations on the testcase. I added
that and commit as: gcc-15-2935-gdbf4c574b92
@Paul: At the moment I am taking a look at 46371. The patch makes that proceed
a bit more, but still ICEing. I will address it and then check 56496.
Thanks again,
Andre
On Wed, 14 Aug 2024 21:21:17 +0200
Harald Anlauf <anlauf@gmx.de> wrote:
> Hi Andre,
>
> Am 12.08.24 um 14:11 schrieb Andre Vehreschild:
> > 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?
>
> Paul already gave a basic OK, and I won't object.
>
> However, the testcase should be fixed. It is only correct for
> single-image runs! (Verified with Intel ifx).
>
> You have:
>
> associate (y => x)
> y = -1
> y[1] = 35
> end associate
>
> and check:
>
> if (x /= 35) stop 1
>
> This should rather be
>
> if (x[1] /= 35) stop 1
>
> or for number of images > 1:
>
> if (this_image() == 1) then
> if (x /= 35) stop 1
> else
> if (x /= -1) stop 99
> end if
>
> and similarly
>
> if (.NOT. c%l) stop 3
>
> needs to be adjusted accordingly.
>
> Thanks,
> Harald
>
> > Regards,
> > Andre
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-15 15:35 ` Andre Vehreschild
@ 2024-08-15 17:39 ` Harald Anlauf
2024-08-15 17:39 ` Harald Anlauf
2024-08-15 18:30 ` Andre Vehreschild
0 siblings, 2 replies; 11+ messages in thread
From: Harald Anlauf @ 2024-08-15 17:39 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Paul Richard Thomas
Hi Andre,
Am 15.08.24 um 17:35 schrieb Andre Vehreschild:
> Hi Harald, hi Paul,
>
> thanks for the ok and the suggestions/recommendations on the testcase. I added
> that and commit as: gcc-15-2935-gdbf4c574b92
I didn't notice this while skimming over the patch, but
gcc-testresults has:
../../src-master/gcc/fortran/resolve.cc: In function ‘bool
resolve_operator(gfc_expr*)’:
../../src-master/gcc/fortran/resolve.cc:4649:22: error: too many
arguments for format [-Werror=format-extra-args]
4649 | gfc_error ("Inconsistent coranks for operator at %%L
and %%L",
|
^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The format strings should have contained %L's, not %%L.
A follow-up fix is pre-approved.
Cheers,
Harald
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-15 17:39 ` Harald Anlauf
@ 2024-08-15 17:39 ` Harald Anlauf
2024-08-15 18:30 ` Andre Vehreschild
1 sibling, 0 replies; 11+ messages in thread
From: Harald Anlauf @ 2024-08-15 17:39 UTC (permalink / raw)
To: gcc-patches; +Cc: fortran
Hi Andre,
Am 15.08.24 um 17:35 schrieb Andre Vehreschild:
> Hi Harald, hi Paul,
>
> thanks for the ok and the suggestions/recommendations on the testcase. I added
> that and commit as: gcc-15-2935-gdbf4c574b92
I didn't notice this while skimming over the patch, but
gcc-testresults has:
../../src-master/gcc/fortran/resolve.cc: In function ‘bool
resolve_operator(gfc_expr*)’:
../../src-master/gcc/fortran/resolve.cc:4649:22: error: too many
arguments for format [-Werror=format-extra-args]
4649 | gfc_error ("Inconsistent coranks for operator at %%L
and %%L",
|
^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The format strings should have contained %L's, not %%L.
A follow-up fix is pre-approved.
Cheers,
Harald
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-15 17:39 ` Harald Anlauf
2024-08-15 17:39 ` Harald Anlauf
@ 2024-08-15 18:30 ` Andre Vehreschild
2024-08-15 18:50 ` Jakub Jelinek
1 sibling, 1 reply; 11+ messages in thread
From: Andre Vehreschild @ 2024-08-15 18:30 UTC (permalink / raw)
To: Harald Anlauf; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Paul Richard Thomas, jakub
Hi Harald,
whoopsie, I am sorry for that.
What I don't get is, why this has not been reported during my bootstrap. I am
doing this to bootstrap:
LANG=C "${SRCPATH}/configure" \
--disable-multilib\
--enable-languages=c,fortran,c++\
--prefix="${INSTALLPATH}"
LANG=C make -j ${NOPARALLEL} bootstrap
What is wrong with that?
Er, Jakub, do you do the patch, as you have assigned yourself?
- Andre
On Thu, 15 Aug 2024 19:39:54 +0200
Harald Anlauf <anlauf@gmx.de> wrote:
> Hi Andre,
>
> Am 15.08.24 um 17:35 schrieb Andre Vehreschild:
> > Hi Harald, hi Paul,
> >
> > thanks for the ok and the suggestions/recommendations on the testcase. I
> > added that and commit as: gcc-15-2935-gdbf4c574b92
>
> I didn't notice this while skimming over the patch, but
> gcc-testresults has:
>
> ../../src-master/gcc/fortran/resolve.cc: In function ‘bool
> resolve_operator(gfc_expr*)’:
> ../../src-master/gcc/fortran/resolve.cc:4649:22: error: too many
> arguments for format [-Werror=format-extra-args]
> 4649 | gfc_error ("Inconsistent coranks for operator at %%L
> and %%L",
> |
> ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>
>
> The format strings should have contained %L's, not %%L.
>
> A follow-up fix is pre-approved.
>
> Cheers,
> Harald
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-15 18:30 ` Andre Vehreschild
@ 2024-08-15 18:50 ` Jakub Jelinek
2024-08-15 19:01 ` Andre Vehreschild
2024-08-15 20:52 ` [committed] fortran: Fix bootstrap in resolve.cc [PR116387] Jakub Jelinek
0 siblings, 2 replies; 11+ messages in thread
From: Jakub Jelinek @ 2024-08-15 18:50 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Harald Anlauf, GCC-Patches-ML, GCC-Fortran-ML,
Paul Richard Thomas, jakub
On Thu, Aug 15, 2024 at 08:30:12PM +0200, Andre Vehreschild wrote:
> Hi Harald,
>
> whoopsie, I am sorry for that.
>
> What I don't get is, why this has not been reported during my bootstrap. I am
> doing this to bootstrap:
>
> LANG=C "${SRCPATH}/configure" \
> --disable-multilib\
> --enable-languages=c,fortran,c++\
> --prefix="${INSTALLPATH}"
> LANG=C make -j ${NOPARALLEL} bootstrap
>
> What is wrong with that?
That should just work and catch it IMHO.
> Er, Jakub, do you do the patch, as you have assigned yourself?
I'm just 40 minutes into bootstrapping/regtesting that patch
on x86_64-linux and i686-linux, usually bootstrap takes ~ 50 minutes
and regtest ~ 65 minutes on the latter and ~ 85 minutes + ~ 70 minutes
on the former, so if you can get it tested faster than that, go ahead and
commit it, if not, I'll commit it when I'm done with testing.
It certainly got past the point of the failed bootstraps already.
Jakub
^ permalink raw reply [flat|nested] 11+ messages in thread* Re: [Fortran, Patch, PR110033, v1] Fix associate for coarrays
2024-08-15 18:50 ` Jakub Jelinek
@ 2024-08-15 19:01 ` Andre Vehreschild
2024-08-15 20:52 ` [committed] fortran: Fix bootstrap in resolve.cc [PR116387] Jakub Jelinek
1 sibling, 0 replies; 11+ messages in thread
From: Andre Vehreschild @ 2024-08-15 19:01 UTC (permalink / raw)
To: Jakub Jelinek
Cc: Harald Anlauf, GCC-Patches-ML, GCC-Fortran-ML,
Paul Richard Thomas, jakub
Hi Jakub,
I will not be faster by far. I have just started and am still in stage 1. So
please you go ahead.
And thank you very much for the help.
- Andre
On Thu, 15 Aug 2024 20:50:38 +0200
Jakub Jelinek <jakub@redhat.com> wrote:
> On Thu, Aug 15, 2024 at 08:30:12PM +0200, Andre Vehreschild wrote:
> > Hi Harald,
> >
> > whoopsie, I am sorry for that.
> >
> > What I don't get is, why this has not been reported during my bootstrap. I
> > am doing this to bootstrap:
> >
> > LANG=C "${SRCPATH}/configure" \
> > --disable-multilib\
> > --enable-languages=c,fortran,c++\
> > --prefix="${INSTALLPATH}"
> > LANG=C make -j ${NOPARALLEL} bootstrap
> >
> > What is wrong with that?
>
> That should just work and catch it IMHO.
>
> > Er, Jakub, do you do the patch, as you have assigned yourself?
>
> I'm just 40 minutes into bootstrapping/regtesting that patch
> on x86_64-linux and i686-linux, usually bootstrap takes ~ 50 minutes
> and regtest ~ 65 minutes on the latter and ~ 85 minutes + ~ 70 minutes
> on the former, so if you can get it tested faster than that, go ahead and
> commit it, if not, I'll commit it when I'm done with testing.
> It certainly got past the point of the failed bootstraps already.
>
> Jakub
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 11+ messages in thread* [committed] fortran: Fix bootstrap in resolve.cc [PR116387]
2024-08-15 18:50 ` Jakub Jelinek
2024-08-15 19:01 ` Andre Vehreschild
@ 2024-08-15 20:52 ` Jakub Jelinek
1 sibling, 0 replies; 11+ messages in thread
From: Jakub Jelinek @ 2024-08-15 20:52 UTC (permalink / raw)
To: Andre Vehreschild, Harald Anlauf, GCC-Patches-ML, GCC-Fortran-ML,
Paul Richard Thomas
Hi!
On Thu, Aug 15, 2024 at 08:50:38PM +0200, Jakub Jelinek wrote:
> > whoopsie, I am sorry for that.
> >
> > What I don't get is, why this has not been reported during my bootstrap. I am
> > doing this to bootstrap:
> >
> > LANG=C "${SRCPATH}/configure" \
> > --disable-multilib\
> > --enable-languages=c,fortran,c++\
> > --prefix="${INSTALLPATH}"
> > LANG=C make -j ${NOPARALLEL} bootstrap
> >
> > What is wrong with that?
>
> That should just work and catch it IMHO.
>
> > Er, Jakub, do you do the patch, as you have assigned yourself?
>
> I'm just 40 minutes into bootstrapping/regtesting that patch
> on x86_64-linux and i686-linux, usually bootstrap takes ~ 50 minutes
> and regtest ~ 65 minutes on the latter and ~ 85 minutes + ~ 70 minutes
> on the former, so if you can get it tested faster than that, go ahead and
> commit it, if not, I'll commit it when I'm done with testing.
> It certainly got past the point of the failed bootstraps already.
Here is what I've committed after successful x86_64-linux and i686-linux
bootstraps and regtests:
2024-08-15 Jakub Jelinek <jakub@redhat.com>
PR bootstrap/116387
* resolve.cc (resolve_operator): Use %L rather than %%L in format
string.
--- gcc/fortran/resolve.cc.jj 2024-08-15 19:14:25.700837372 +0200
+++ gcc/fortran/resolve.cc 2024-08-15 19:58:04.512851806 +0200
@@ -4646,7 +4646,7 @@ resolve_operator (gfc_expr *e)
}
else
{
- gfc_error ("Inconsistent coranks for operator at %%L and %%L",
+ gfc_error ("Inconsistent coranks for operator at %L and %L",
&op1->where, &op2->where);
return false;
}
Jakub
^ permalink raw reply [flat|nested] 11+ messages in thread
end of thread, other threads:[~2024-08-15 20:52 UTC | newest]
Thread overview: 11+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-08-12 12:11 [Fortran, Patch, PR110033, v1] Fix associate for coarrays Andre Vehreschild
2024-08-14 10:51 ` Paul Richard Thomas
2024-08-14 19:21 ` Harald Anlauf
2024-08-14 19:21 ` Harald Anlauf
2024-08-15 15:35 ` Andre Vehreschild
2024-08-15 17:39 ` Harald Anlauf
2024-08-15 17:39 ` Harald Anlauf
2024-08-15 18:30 ` Andre Vehreschild
2024-08-15 18:50 ` Jakub Jelinek
2024-08-15 19:01 ` Andre Vehreschild
2024-08-15 20:52 ` [committed] fortran: Fix bootstrap in resolve.cc [PR116387] Jakub Jelinek
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).