Re: [Patch, fortran] PR99250 - [F2018] coshape intrinsic is missing

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" } }