Hello Harald and All, Gosh! As I explained to you off-list, I am trying to do too much at once. Please accept my apologies for the cock-ups.
Regtests on FC43/x86_64. OK for mainline. Regards Paul PS pault@fedora:~/gitsources/gcc$ texi2html $FORT/intrinsic.texi /home/pault/gitsources/gcc/gcc/fortran/intrinsic.texi:46: warning: No node following `Intrinsic Procedures' in menu, but `Intrinsic Modules' follows in sectioning /home/pault/gitsources/gcc/gcc/fortran/intrinsic.texi:15934: warning: unreferenced node `Intrinsic Modules' warning: Must specify a title with a title command or @top /home/pault/gitsources/gcc/gcc/fortran/intrinsic.texi:3085: @pxref reference to nonexistent node `Unsigned integers' ...last line repeats dozens of times... On Thu, 12 Feb 2026 at 19:25, Harald Anlauf <[email protected]> wrote: > > Paul, > > Am 11.02.26 um 11:36 PM schrieb Paul Richard Thomas: > > Hi Harald, > > > > I forgot to do the git add. Here it is. > > this looks to me like the same as the previous one > minus the intrinsic.texi part and minus the testcase. > > Can you please check? > > Harald > > > 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 > >>>> > >>> > >> >
Change.Logs
Description: Binary data
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..32c976f2313 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);
@@ -2668,7 +2671,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
|| wi::gtu_p (wi::to_wide (bound),
GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
- "dimension index", expr->value.function.isym->name,
+ "dimension index [1]", expr->value.function.isym->name,
&expr->where);
}
else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
@@ -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:
! { 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" } }
