Hi Harald,
I forgot to do the git add. Here it is.
Paul
On Wed, 11 Feb 2026 at 20:29, Harald Anlauf <[email protected]> wrote:
>
> Hi Paul,
>
> I do not see the promised updated patch here.
>
> Is it only me, or did you forget to attach it?
>
> Best,
> Harald
>
> Am 11.02.26 um 10:00 AM schrieb Paul Richard Thomas:
> > Hello Sandra and Harald,
> >
> > Many thanks for taking a look at the patch for PR99250. I admit that I
> > was in something of a rush to get it out of the door so that I could
> > return to the last few PDT problems.
> >
> > The use of the KIND argument now works correctly and the testcase has
> > been completely revamped to reflect this. The testcase runs correctly
> > using the shared memory gfortran, for which Jerry has just posted a
> > series of patches. Note that GFORTRAN_NUM_IMAGES=multiple_of_3 is
> > required.
> >
> > When converted to .html, intrinsic.texi looks OK and is now ordered
> > correctly.
> >
> > Regtests OK on FC43/x86_64 mainline. OK to push to mainline?
> >
> > Regards
> >
> > Paul
> >
> > On Mon, 9 Feb 2026 at 23:35, Sandra Loosemore <[email protected]>
> > wrote:
> >>
> >> On 2/9/26 09:54, Paul Richard Thomas wrote:
> >>> Hi All,
> >>>
> >>> This is a boilerplate implementation of the COSHAPE intrinsic. The
> >>> testcase is placed in the main gfortran.dg directory so that it can
> >>> make us of the option -fcoarry=lib to test the number of references to
> >>> _gfortran_caf_num_images (One to set no_images and to for the upper
> >>> bound of the last codimension).
> >>>
> >>> Regtests on FC43/x86_64. OK for mainline?
> >>>
> >>> Paul
> >>>
> >>> PS Could somebody please check the intrinsic.texi entries?
> >>
> >> Ack....
> >>
> >>> diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
> >>> index cf81791b8b3..accd7825e38 100644
> >>> --- a/gcc/fortran/intrinsic.texi
> >>> +++ b/gcc/fortran/intrinsic.texi
> >>> @@ -127,6 +127,7 @@ Some basic guidelines for editing this document:
> >>> * @code{COS}: COS, Cosine function
> >>> * @code{COSD}: COSD, Cosine function, degrees
> >>> * @code{COSH}: COSH, Hyperbolic cosine function
> >>> +* @code{COSHAPE}: COSHAPE, Determine the coshape of a array
> >>> * @code{COSPI}: COSPI, Circular cosine function
> >>> * @code{COTAN}: COTAN, Cotangent function
> >>> * @code{COTAND}: COTAND, Cotangent function, degrees
> >>> @@ -4635,6 +4636,34 @@ Inverse function: @*
> >>>
> >>>
> >>>
> >>> +@node COSHAPE
> >>> +@section @code{COSHAPE} --- Coshape of a coarray
> >>> +@fnindex COSHAPE
> >>> +@cindex coarray, coshape
> >>> +
> >>> +@table @asis
> >>> +@item @emph{Synopsis}:
> >>> +@code{RESULT = COSHAPE(COARRAY [, KIND])}
> >>> +
> >>> +@item @emph{Description}:
> >>> +Returns the shape of the cobounds of a coarray.
> >>> +
> >>> +@item @emph{Standard}:
> >>> +Fortran 2018
> >>> +
> >>
> >> The subheadings have been reordered in the Fortran intrinsics
> >> documentation. "Standard" now comes after "See also", or at the very
> >> end of the node if there's no "See also".
> >>
> >>> +@item @emph{Class}:
> >>> +Inquiry function
> >>> +
> >>> +@item @emph{Arguments}:
> >>> +@multitable @columnfractions .15 .70
> >>> +@item @var{COARRAY} @tab Shall be an coarray, of any type.
> >>
> >> s/an coarray/a coarray/
> >>
> >>> +@item @var{KIND} @tab (Optional) A scalar @code{INTEGER} constant
> >>> +expression indicating the kind parameter of the result.
> >>
> >> I think there should be
> >>
> >> @item @emph{Return value}:
> >> ...blah blah...
> >>
> >> after this. You could probably adapt the language from the SHAPE
> >> intrinsic.
> >>
> >> And, probably also add
> >>
> >> @item @emph{See also}:
> >>
> >> pointing at SHAPE.
> >>
> >>> +@end multitable
> >>> +@end table
> >>> +
> >>> +
> >>> +
> >>> @node COSPI
> >>> @section @code{COSPI} --- Circular cosine function
> >>> @fnindex COSPI
> >>
> >> -Sandra
> >>
> >
>
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index fae628bae40..528a9831005 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -2763,6 +2763,26 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y)
}
+bool
+gfc_check_coshape (gfc_expr *coarray, gfc_expr *kind)
+{
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
+ gfc_current_intrinsic_where);
+ return false;
+ }
+
+ if (!coarray_check (coarray, 0))
+ return false;
+
+ if (!kind_check (kind, 2, BT_INTEGER))
+ return false;
+
+ return true;
+}
+
+
bool
gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 848ad9ca1fa..9f7f5bd150c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -489,6 +489,7 @@ enum gfc_isym_id
GFC_ISYM_COS,
GFC_ISYM_COSD,
GFC_ISYM_COSH,
+ GFC_ISYM_COSHAPE,
GFC_ISYM_COTAN,
GFC_ISYM_COTAND,
GFC_ISYM_COUNT,
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index a422fc176b4..8638dd30c74 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -1840,6 +1840,13 @@ add_functions (void)
make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
+ add_sym_2 ("coshape", GFC_ISYM_COSHAPE, CLASS_INQUIRY, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_coshape, gfc_simplify_coshape, gfc_resolve_coshape,
+ ca, BT_REAL, dr, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("coshape", GFC_ISYM_COSHAPE, GFC_STD_F2018);
+
add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_count, gfc_simplify_count, gfc_resolve_count,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 048196d65c3..86a66dc4a0b 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -53,6 +53,7 @@ bool gfc_check_chdir (gfc_expr *);
bool gfc_check_chmod (gfc_expr *, gfc_expr *);
bool gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_complex (gfc_expr *, gfc_expr *);
+bool gfc_check_coshape (gfc_expr *, gfc_expr *);
bool gfc_check_co_broadcast (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_co_minmax (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_co_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
@@ -289,6 +290,7 @@ gfc_expr *gfc_simplify_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_compiler_options (void);
gfc_expr *gfc_simplify_compiler_version (void);
gfc_expr *gfc_simplify_complex (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_coshape (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_conjg (gfc_expr *);
gfc_expr *gfc_simplify_cos (gfc_expr *);
gfc_expr *gfc_simplify_cosd (gfc_expr *);
@@ -498,6 +500,7 @@ void gfc_resolve_complex (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_conjg (gfc_expr *, gfc_expr *);
void gfc_resolve_cos (gfc_expr *, gfc_expr *);
void gfc_resolve_cosh (gfc_expr *, gfc_expr *);
+void gfc_resolve_coshape (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_count (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_cshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ctime (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index a821332ecb2..49f7f3c17e3 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -732,6 +732,25 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
}
+void
+gfc_resolve_coshape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
+{
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+
+ f->value.function.name
+ = gfc_get_string ("__coshape_%c%d", gfc_type_letter (array->ts.type),
+ gfc_type_abi_kind (&array->ts));
+ f->rank = 1;
+ f->corank = 0;
+ f->shape = gfc_get_shape (1);
+ mpz_init_set_si (f->shape[0], array->corank);
+}
+
+
void
gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index b25cd2c2388..b398b1e343f 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -2400,6 +2400,130 @@ gfc_simplify_tanpi (gfc_expr *x)
return range_check (result, "TANPI");
}
+static gfc_expr *
+simplify_bound_dim (gfc_expr *, gfc_expr *, int, int,
+ gfc_array_spec *, gfc_ref *, bool);
+
+gfc_expr *
+gfc_simplify_coshape (gfc_expr *array, gfc_expr *kind)
+{
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS], *shapes[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+ int k;
+
+ 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;
+ for (ref = array->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ if (ref->u.ar.as->corank > 0)
+ {
+ gcc_assert (as == ref->u.ar.as);
+ goto done;
+ }
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ /* We're done because 'as' has already been set in the
+ previous iteration. */
+ goto done;
+
+ case AR_UNKNOWN:
+ return NULL;
+
+ case AR_SECTION:
+ as = ref->u.ar.as;
+ goto done;
+ }
+
+ gcc_unreachable ();
+
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ case REF_INQUIRY:
+ continue;
+ }
+ }
+
+ if (!as)
+ gcc_unreachable ();
+
+ done:
+
+ if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
+ return NULL;
+
+ /* Simplify the cobounds for each dimension. */
+ for (d = 0; d < as->corank; d++)
+ {
+ shapes[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
+ 1, as, ref, true);
+ if (shapes[d] == NULL || shapes[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (shapes[j]);
+ return shapes[d];
+ }
+
+ bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
+ 0, as, ref, true);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ return bounds[d];
+ }
+
+ mpz_sub (shapes[d]->value.integer, shapes[d]->value.integer, bounds[d]->value.integer);
+ mpz_add_ui (shapes[d]->value.integer, shapes[d]->value.integer, 1);
+ }
+
+ /* Allocate the result expression. */
+ e = gfc_get_expr ();
+ e->where = array->where;
+ e->expr_type = EXPR_ARRAY;
+ e->ts.type = BT_INTEGER;
+ k = get_kind (BT_INTEGER, kind, "COSHAPE", gfc_default_integer_kind);
+ if (k == -1)
+ {
+ gfc_free_expr (e);
+ return &gfc_bad_expr;
+ }
+ e->ts.kind = k;
+
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], as->corank);
+
+ /* Create the constructor for this array. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ shapes[d], &e->where);
+ return e;
+}
+
+
gfc_expr *
gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cd137212260..dd8c1545e0a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5252,6 +5252,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
{
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ case GFC_ISYM_COSHAPE:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_MAXLOC:
@@ -5343,6 +5344,7 @@ done:
/* Fall through. */
case GFC_ISYM_SHAPE:
+ case GFC_ISYM_COSHAPE:
{
gfc_expr *arg;
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index db4b1165781..0f8e31068ad 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2622,12 +2622,13 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
gfc_actual_arglist *arg;
gfc_actual_arglist *arg2;
gfc_se argse;
- tree bound, resbound, resbound2, desc, cond, tmp;
+ tree bound, lbound, resbound, resbound2, desc, cond, tmp;
tree type;
int corank;
gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
|| expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+ || expr->value.function.isym->id == GFC_ISYM_COSHAPE
|| expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
arg = expr->value.function.actual;
@@ -2708,8 +2709,13 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+ lbound = NULL_TREE;
+ if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
+ lbound = resbound;
+
/* Handle UCOBOUND with special handling of the last codimension. */
- if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
+ if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+ || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
{
/* Last codimension: For -fcoarray=single just return
the lcobound - otherwise add
@@ -2763,6 +2769,17 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
}
else
se->expr = resbound;
+
+ if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
+ {
+ gcc_assert (lbound != NULL_TREE);
+ se->expr = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ se->expr, lbound);
+ se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ se->expr, gfc_index_one_node);
+ }
}
else
se->expr = resbound;
@@ -11308,6 +11325,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_conjg (se, expr);
break;
+ case GFC_ISYM_COSHAPE:
+ conv_intrinsic_cobound (se, expr);
+ break;
+
case GFC_ISYM_COUNT:
gfc_conv_intrinsic_count (se, expr);
break;
@@ -12010,6 +12031,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
{
case GFC_ISYM_UBOUND:
case GFC_ISYM_LBOUND:
+ case GFC_ISYM_COSHAPE:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_MAXLOC:
@@ -12213,6 +12235,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
/* Special cases. */
switch (isym->id)
{
+ case GFC_ISYM_COSHAPE:
case GFC_ISYM_LBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UBOUND:
