Fortran: Implement the COSHAPE intrinsic [PR99250]

2026-02-14  Paul Thomas  <pault@gcc.gnu.org>

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 4a4e1a8d21d20deaf1154ea30207c68a4b802ab0..0ad954118bb114b1e2158a34202e54a5db05cbc1 100644 (file)
--- 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 dda5b6262bfbe7920d2812543a2402291faa2686..109bf6a5c294c0493e85adee6a8bad688bb576b8 100644 (file)
--- 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 e211178c814012d4481813e9c85cd6557d957567..6ffd7237468ed818fe3420a9218b4a7ac432c6f6 100644 (file)
--- 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 135fabef14e7cfe8094f0d56da533ccd70854285..0b520f0333220191c4b1b4e679e0e0b840915a30 100644 (file)
--- 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 cf81791b8b30f81d6ce5e002d3e5ad6b5d328b2c..1fffd74749b8074f691b828ccd653895d0cc5fb8 100644 (file)
--- 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 335522aa3b9d0ca984976940e237249bd2450211..833701da5df41784dc2caba101ee33e2570cae53 100644 (file)
--- 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 8657101b89a98c0119bd05d7d7f3ea9efc236af9..6cddd80b8ae89f7ef3115a5dd748020e26a40ed0 100644 (file)
--- 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 39ed230e874deb61788ee2603d369c0b4478db1f..c4d8d5c9728cced1bbc584949df8dc655c5acf04 100644 (file)
--- 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 (file)
index 0000000..b6015a2
--- /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" } }