https://gcc.gnu.org/g:22d710cc5f40d79aab104ec5fb5fe97386d56d8a
commit r17-4205-g22d710cc5f40d79aab104ec5fb5fe97386d56d8a Author: Jerry DeLisle <[email protected]> Date: Sun Aug 9 20:22:58 2026 -0700 fortran: [PR103474] Fix ICEs for the cobounds of a subobject of a coarray F2018:5.4.7(5) makes a subobject of a coarray a coarray with the same codimensions, unless it is reached through a cosubscript, an image selector, or an allocatable or pointer component selector. Querying the cobounds of such a subobject, as in LCOBOUND (X%A), reached three places that were not prepared for it, and a coarray whose declaration had already been rejected reached a fourth. PR fortran/103474 gcc/fortran/ChangeLog: * simplify.cc (simplify_cobound): Take the array spec from the base symbol, using its class data for a CLASS coarray, so that a subobject of a coarray finds the codimensions. Return NULL for a symbol already flagged as erroneous and in place of the two gcc_unreachable calls reached on invalid code. * resolve.cc (gfc_expression_rank): Track the reference carrying the codimensions and take the corank from it rather than from the last array reference. Clear it at an allocatable or pointer component selector, which ends the coarray. * trans-intrinsic.cc (strip_subobject_of_coarray): New function. Return a copy of the expression cut back to the reference carrying the codimensions. (conv_intrinsic_cobound, trans_this_image, trans_image_index): Use it, so that the descriptor queried for the cobounds is that of the coarray and not that of a component of it. gcc/testsuite/ChangeLog: * gfortran.dg/coarray_52.f90: New test. * gfortran.dg/coarray/cobounds_subobject_1.f90: New test. Diff: --- gcc/fortran/resolve.cc | 46 +++++++++---- gcc/fortran/simplify.cc | 22 ++++--- gcc/fortran/trans-intrinsic.cc | 76 ++++++++++++++++++---- .../gfortran.dg/coarray/cobounds_subobject_1.f90 | 54 +++++++++++++++ gcc/testsuite/gfortran.dg/coarray_52.f90 | 17 +++++ 5 files changed, 179 insertions(+), 36 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 8db036a4ecf1..3a747aa5512b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -6344,7 +6344,7 @@ fail: void gfc_expression_rank (gfc_expr *e) { - gfc_ref *ref, *last_arr_ref = nullptr; + gfc_ref *ref, *coarray_ref = nullptr; int i, rank, corank; /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that @@ -6389,10 +6389,27 @@ gfc_expression_rank (gfc_expr *e) corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0; } + /* F2018:5.4.7(5): an allocatable or pointer component selector ends the + codimensions inherited from an enclosing coarray. */ + if (ref->type == REF_COMPONENT) + { + gfc_component *comp = ref->u.c.component; + + if (comp->ts.type == BT_CLASS && comp->attr.class_ok) + { + if (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable) + coarray_ref = nullptr; + } + else if (comp->attr.pointer || comp->attr.allocatable) + coarray_ref = nullptr; + } + if (ref->type != REF_ARRAY) continue; - last_arr_ref = ref; + if (!coarray_ref && ref->u.ar.as && ref->u.ar.as->corank > 0) + coarray_ref = ref; if (ref->u.ar.type == AR_FULL && ref->u.ar.as) { rank = ref->u.ar.as->rank; @@ -6413,25 +6430,26 @@ gfc_expression_rank (gfc_expr *e) break; } } - if (last_arr_ref && last_arr_ref->u.ar.as - && last_arr_ref->u.ar.as->rank != -1) + /* The codimensions come from the reference carrying them, which need not be + the last array reference: a subobject of a coarray is itself a coarray. */ + if (coarray_ref && coarray_ref->u.ar.as->rank != -1) { - 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 (i = coarray_ref->u.ar.as->rank; + i < coarray_ref->u.ar.as->rank + coarray_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)) + if (coarray_ref->u.ar.dimen_type[i] == DIMEN_STAR + || (coarray_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN + && !coarray_ref->u.ar.as->resolved)) { - corank = last_arr_ref->u.ar.as->corank; + corank = coarray_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) + else if (coarray_ref->u.ar.dimen_type[i] == DIMEN_RANGE + || coarray_ref->u.ar.dimen_type[i] == DIMEN_VECTOR + || coarray_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE) corank++; - else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) + else if (coarray_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) gfc_internal_error ("Illegal coarray index"); } } diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index ff13b5641952..f0b36c066876 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -4816,15 +4816,22 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) { gfc_ref *ref; gfc_array_spec *as; + gfc_symbol *sym; int d; if (array->expr_type != EXPR_VARIABLE) return NULL; - /* Follow any component references. */ - as = (array->ts.type == BT_CLASS && CLASS_DATA (array)) - ? CLASS_DATA (array)->as - : array->symtree->n.sym->as; + /* Do not attempt to resolve if an error has already been issued. */ + if (array->symtree->n.sym->error) + return NULL; + + /* Follow any component references, starting from the base symbol's array + spec; ARRAY itself may be a subobject of the coarray. */ + sym = array->symtree->n.sym; + as = (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym)) + ? CLASS_DATA (sym)->as + : sym->as; for (ref = array->ref; ref; ref = ref->next) { switch (ref->type) @@ -4835,7 +4842,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) case AR_ELEMENT: if (ref->u.ar.as->corank > 0) { - gcc_assert (as == ref->u.ar.as); + as = ref->u.ar.as; goto done; } as = NULL; @@ -4866,12 +4873,9 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) } } - if (!as) - gcc_unreachable (); - done: - if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) + if (!as || as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) return NULL; if (dim == NULL) diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 6666c46c1fea..fe271609671d 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -1820,12 +1820,50 @@ conv_caf_sendget (gfc_code *code) } +/* F2018:5.4.7(5): a subobject of a coarray is a coarray with the codimensions + of that coarray. Return a copy of E cut back to the reference carrying the + codimensions, so that the descriptor built for it holds the cobounds. */ + +static gfc_expr * +strip_subobject_of_coarray (gfc_expr *e) +{ + gfc_expr *coarray; + gfc_ref *ref; + gfc_typespec ts; + + ts = e->symtree->n.sym->ts; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + if (ref->type == REF_COMPONENT) + ts = ref->u.c.component->ts; + } + + coarray = gfc_copy_expr (e); + if (!ref || !ref->next) + return coarray; + + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + + gfc_free_ref_list (ref->next); + ref->next = NULL; + coarray->ts = ts; + gfc_expression_rank (coarray); + + return coarray; +} + + static void trans_this_image (gfc_se * se, gfc_expr *expr) { stmtblock_t loop; tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound, ubound, extent, ml, team; + gfc_expr *coarray; gfc_se argse; int rank, corank; @@ -1857,16 +1895,19 @@ 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 = expr->value.function.actual->expr->corank; - rank = expr->value.function.actual->expr->rank; + + coarray = strip_subobject_of_coarray (expr->value.function.actual->expr); + corank = coarray->corank; + rank = coarray->rank; /* Obtain the descriptor of the COARRAY. */ gfc_init_se (&argse, NULL); argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); + gfc_conv_expr_descriptor (&argse, coarray); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; + gfc_free_expr (coarray); if (se->ss) { @@ -2118,20 +2159,24 @@ trans_image_index (gfc_se * se, gfc_expr *expr) { tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp, invalid_bound, team = null_pointer_node, team_number = null_pointer_node; + gfc_expr *coarray; gfc_se argse, subse; int rank, corank, codim; type = gfc_get_int_type (gfc_default_integer_kind); - corank = expr->value.function.actual->expr->corank; - rank = expr->value.function.actual->expr->rank; + + coarray = strip_subobject_of_coarray (expr->value.function.actual->expr); + corank = coarray->corank; + rank = coarray->rank; /* Obtain the descriptor of the COARRAY. */ gfc_init_se (&argse, NULL); argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); + gfc_conv_expr_descriptor (&argse, coarray); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; + gfc_free_expr (coarray); /* Obtain a handle to the SUB argument. */ gfc_init_se (&subse, NULL); @@ -2639,6 +2684,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) { gfc_actual_arglist *arg; gfc_actual_arglist *arg2; + gfc_expr *coarray; gfc_se argse; tree bound, lbound, resbound, resbound2, desc, cond, tmp; tree type; @@ -2653,12 +2699,14 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) arg2 = arg->next; gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); - corank = arg->expr->corank; + + coarray = strip_subobject_of_coarray (arg->expr); + corank = coarray->corank; gfc_init_se (&argse, NULL); argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, arg->expr); + gfc_conv_expr_descriptor (&argse, coarray); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; @@ -2674,7 +2722,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) bound = fold_convert_loc (input_location, gfc_array_dim_rank_type, se->loop->loopvar[0]); - tree rank = gfc_rank_cst[arg->expr->rank]; + tree rank = gfc_rank_cst[coarray->rank]; bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_dim_rank_type, bound, rank); gfc_advance_se_ss_chain (se); @@ -2714,7 +2762,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) /* Subtract 1 to get to zero based and add dimensions. */ - switch (arg->expr->rank) + switch (coarray->rank) { case 0: bound = fold_build2_loc (input_location, MINUS_EXPR, @@ -2724,7 +2772,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) break; default: { - tree rank = gfc_rank_cst[arg->expr->rank - 1]; + tree rank = gfc_rank_cst[coarray->rank - 1]; bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_dim_rank_type, bound, rank); } @@ -2755,7 +2803,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) { tree cosize; - cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); + cosize = gfc_conv_descriptor_cosize (desc, coarray->rank, corank); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, @@ -2786,7 +2834,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, bound, build_int_cst (TREE_TYPE (bound), - arg->expr->rank + corank - 1)); + coarray->rank + corank - 1)); resbound2 = gfc_conv_descriptor_ubound_get (desc, bound); se->expr = fold_build3_loc (input_location, COND_EXPR, @@ -2813,6 +2861,8 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); + + gfc_free_expr (coarray); } diff --git a/gcc/testsuite/gfortran.dg/coarray/cobounds_subobject_1.f90 b/gcc/testsuite/gfortran.dg/coarray/cobounds_subobject_1.f90 new file mode 100644 index 000000000000..418c652bf124 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/cobounds_subobject_1.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! +! PR fortran/103474 +! +! F2018:5.4.7(5) - a subobject of a coarray is a coarray with the +! codimensions of that coarray. Check LCOBOUND, UCOBOUND, COSHAPE, +! THIS_IMAGE and IMAGE_INDEX applied to a component of a coarray. +! +! Contributed by G. Steinmetz <[email protected]> + +program cobounds_subobject_1 + type t + integer :: a + integer :: b(2) + integer :: c(1,2) + end type + + type(t), save :: u[2,3:*] + type(t), save :: v(4)[5:*] + type(t), allocatable :: y[:,:] + class(t), allocatable :: x[:] + class(t), allocatable :: z(:)[:] + + ! Explicit cobounds are simplified at compile time. + if (lcobound (u%a, dim=1) /= 1) stop 1 + if (lcobound (u%b, dim=2) /= 3) stop 2 + if (ucobound (u%b, dim=1) /= 2) stop 3 + if (lcobound (v(1)%b, dim=1) /= 5) stop 4 + + if (any (lcobound (u%c) /= lcobound (u))) stop 5 + if (any (lcobound (v(2)%b) /= lcobound (v))) stop 6 + if (any (ucobound (v(2)%b) /= ucobound (v))) stop 7 + if (any (this_image (u%b) /= this_image (u))) stop 8 + if (any (coshape (u%c) /= coshape (u))) stop 9 + + ! Deferred cobounds are resolved at run time. + allocate (x[3:*]) + allocate (y[2,3:*]) + allocate (z(2)[3:*]) + + if (any (lcobound (x%a) /= lcobound (x))) stop 10 + if (any (lcobound (x%b) /= [3])) stop 11 + if (any (ucobound (x%c) /= ucobound (x))) stop 12 + if (any (lcobound (y%b) /= lcobound (y))) stop 13 + if (any (ucobound (y%b) /= ucobound (y))) stop 14 + if (any (lcobound (z(1)%b) /= lcobound (z))) stop 15 + if (any (ucobound (z(1)%b) /= ucobound (z))) stop 16 + if (lcobound (y%c, dim=2) /= lcobound (y, dim=2)) stop 17 + if (ucobound (y%c, dim=1) /= ucobound (y, dim=1)) stop 18 + if (any (this_image (x%b) /= this_image (x))) stop 19 + if (any (this_image (y%c) /= this_image (y))) stop 20 + if (any (coshape (y%b) /= coshape (y))) stop 21 + if (image_index (y%b, [1,3]) /= image_index (y, [1,3])) stop 22 +end program diff --git a/gcc/testsuite/gfortran.dg/coarray_52.f90 b/gcc/testsuite/gfortran.dg/coarray_52.f90 new file mode 100644 index 000000000000..120062ab81e1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_52.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/103474 +! +! ICE in simplify_cobound on a coarray whose declaration was rejected. +! +! Contributed by G. Steinmetz <[email protected]> + +program p + type t + integer :: a + end type + class(t) :: x[:] ! { dg-error "shall not have codimensions with deferred shape" } + print *, ucobound (x) + if (any (lcobound (x) < 1)) stop +end
