https://gcc.gnu.org/g:904b7a3010aaf2abe22643b92a1374ace40ec574
commit r16-7512-g904b7a3010aaf2abe22643b92a1374ace40ec574 Author: Paul Thomas <[email protected]> Date: Sat Feb 14 08:48:11 2026 +0000 Fortran: Implement the COSHAPE intrinsic [PR99250] 2026-02-14 Paul Thomas <[email protected]> gcc/fortran PR fortran/99250 * check.cc (gfc_check_coshape): New function. * gfortran.h: Add GFC_ISYM_COSHAPE to gfc_isym_id. * intrinsic.cc (add_functions): Add the coshape prototype and its 'make_generic'. * intrinsic.h: Add prototypes for gfc_check_coshape and gfc_resolve_coshape. * intrinsic.texi : Add entries for coshape. * iresolve.cc (gfc_resolve_coshape): New function. * trans-array.cc (gfc_conv_ss_startstride): Add 'case GFC_ISYM_COSHAPE' in two places. * trans-intrinsic.cc (conv_intrinsic_cobound): Modify assert in scalarized section for lbound. Set bound to zero for scalar case of coshape. Keep the lbound and use it together with the scalarized ubound to obtain the coshape. (gfc_conv_intrinsic_function, gfc_add_intrinsic_ss_code and gfc_walk_intrinsic_function): Add 'case GFC_ISYM_COSHAPE' as appropriate. gcc/testsuite/ PR fortran/99250 * gfortran.dg/coshape_1.f90: New test. Diff: --- gcc/fortran/check.cc | 20 ++++++++++++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/intrinsic.cc | 8 ++++++ gcc/fortran/intrinsic.h | 2 ++ gcc/fortran/intrinsic.texi | 44 ++++++++++++++++++++++++++++++ gcc/fortran/iresolve.cc | 19 +++++++++++++ gcc/fortran/trans-array.cc | 2 ++ gcc/fortran/trans-intrinsic.cc | 37 +++++++++++++++++++++++--- gcc/testsuite/gfortran.dg/coshape_1.f90 | 47 +++++++++++++++++++++++++++++++++ 9 files changed, 176 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 4a4e1a8d21d2..0ad954118bb1 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -2771,6 +2771,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 dda5b6262bfb..109bf6a5c294 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -490,6 +490,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 e211178c8140..6ffd7237468e 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -1840,6 +1840,14 @@ 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_F2018, + gfc_check_coshape, NULL , gfc_resolve_coshape, + ca, BT_REAL, dr, REQUIRED, + 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 135fabef14e7..0b520f033322 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 *); @@ -498,6 +499,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/intrinsic.texi b/gcc/fortran/intrinsic.texi index cf81791b8b30..1fffd74749b8 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 coarray * @code{COSPI}: COSPI, Circular cosine function * @code{COTAN}: COTAN, Cotangent function * @code{COTAND}: COTAND, Cotangent function, degrees @@ -4635,6 +4636,48 @@ Inverse function: @* +@node COSHAPE +@section @code{COSHAPE} --- Determine the 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{Class}: +Inquiry function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{COARRAY} @tab Shall be an coarray, of any type. +@item @var{KIND} @tab (Optional) A scalar @code{INTEGER} constant +expression indicating the kind parameter of the result. +@end multitable + + +@item @emph{Example}: + +@smallexample +program test_cosh + real(8) :: x[*] + integer, allocatable :: csh (:) + csh = coshape(x, kind = kind(csh)) +end program test_cosh +@end smallexample + +@item @emph{Standard}: +Fortran 2018 + +@item @emph{See also}: +@ref{SHAPE} +@end table + + + @node COSPI @section @code{COSPI} --- Circular cosine function @fnindex COSPI @@ -13563,6 +13606,7 @@ END PROGRAM Fortran 90 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{See also}: +@ref{COSHAPE}, @* @ref{RESHAPE}, @* @ref{SIZE} @end table diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 335522aa3b9d..833701da5df4 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/trans-array.cc b/gcc/fortran/trans-array.cc index 8657101b89a9..6cddd80b8ae8 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -5259,6 +5259,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: @@ -5385,6 +5386,7 @@ done: /* Otherwise fall through GFC_SS_FUNCTION. */ gcc_fallthrough (); } + case GFC_ISYM_COSHAPE: case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 39ed230e874d..c4d8d5c9728c 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2618,12 +2618,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; @@ -2643,7 +2644,8 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) if (se->ss) { /* Create an implicit second parameter from the loop variable. */ - gcc_assert (!arg2->expr); + gcc_assert (!arg2->expr + || expr->value.function.isym->id == GFC_ISYM_COSHAPE); gcc_assert (corank > 0); gcc_assert (se->loop->dimen == 1); gcc_assert (se->ss->info->expr == expr); @@ -2653,9 +2655,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) bound, gfc_rank_cst[arg->expr->rank]); gfc_advance_se_ss_chain (se); } + else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE) + bound = gfc_index_zero_node; else { - /* use the passed argument. */ gcc_assert (arg2->expr); gfc_init_se (&argse, NULL); gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); @@ -2704,8 +2707,15 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) resbound = gfc_conv_descriptor_lbound_get (desc, bound); + /* COSHAPE needs the lower cobound and so it is stashed here before resbound + is overwritten. */ + 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 @@ -2759,6 +2769,18 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) } else se->expr = resbound; + + /* Get the coshape for this dimension. */ + 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; @@ -11319,6 +11341,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; @@ -12021,6 +12047,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: @@ -12046,6 +12073,7 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) /* The two argument version returns a scalar. */ if (expr->value.function.isym->id != GFC_ISYM_SHAPE + && expr->value.function.isym->id != GFC_ISYM_COSHAPE && expr->value.function.actual->next->expr) return ss; @@ -12224,6 +12252,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: diff --git a/gcc/testsuite/gfortran.dg/coshape_1.f90 b/gcc/testsuite/gfortran.dg/coshape_1.f90 new file mode 100644 index 000000000000..b6015a27edb7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coshape_1.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Test the coshape intrinsic (PR99250) +! +program coshape_1 + integer, Parameter :: i4 = kind (1_4), i8 = kind (1_8) + real, codimension[-1:*] :: cr + real, dimension(4,4), codimension[0:2,*] :: cr2 + integer(i4) :: no_images, val4(2) + integer(i8), allocatable :: val8(:) + + no_images = num_images() + + if (this_image() == 1) then + +! First without the KIND argument... + val4(1:1) = coshape(cr) + if (val4(1) /= no_images) stop 1 + if (val4(1) /= 1 + ucobound (cr, 1, i4) - lcobound (cr, 1, i4)) stop 2 + if (mod (no_images,3) == 0) then + val4 = coshape(cr2) + if (val4(1) /= 3 .or. product (val4(1:2)) /= no_images) stop 3 + if (val4(2) /= 1 + ucobound (cr2, 2, i4) - lcobound (cr2, 2, i4)) stop 4 + else + print *, "No. images must be a multiple of 3 for the coshape test #" + endif + +! ...then with it + if (kind (coshape(cr, kind = i4)) /= i4) stop 5 + if (kind (coshape(cr, kind = i8)) /= i8) stop 6 + + val8 = coshape(cr, kind = i8) + if (val8(1) /= 1 + ucobound (cr, 1, i8) - lcobound (cr, 1, i8)) stop 7 + if (val8(1) /= no_images) stop 8 + if (mod (no_images,3) == 0) then + val8 = coshape(cr2, kind = i8) + if (val8(1) /= 3 .or. product (val8(1:2)) /= no_images) stop 9 + if (val8(2) /= 1 + ucobound (cr2, 2, i8) - lcobound (cr2, 2, i8)) stop 10 + else + print *, "No. images must be a multiple of 3 for the coshape test #" + endif + if (any (shape(cr2) /= [4,4])) stop 11 + endif + +end program coshape_1 +! { dg-final { scan-tree-dump-times "_gfortran_caf_num_images" 9 "original" } }
