From: Paul Thomas Date: Sat, 14 Feb 2026 08:48:11 +0000 (+0000) Subject: Fortran: Implement the COSHAPE intrinsic [PR99250] X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=904b7a3010aaf2abe22643b92a1374ace40ec574;p=thirdparty%2Fgcc.git Fortran: Implement the COSHAPE intrinsic [PR99250] 2026-02-14 Paul Thomas 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 --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 4a4e1a8d21d..0ad954118bb 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 dda5b6262bf..109bf6a5c29 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 e211178c814..6ffd7237468 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 135fabef14e..0b520f03332 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 cf81791b8b3..1fffd74749b 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 335522aa3b9..833701da5df 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 8657101b89a..6cddd80b8ae 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 39ed230e874..c4d8d5c9728 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 00000000000..b6015a27edb --- /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" } }