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

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 6bba58e7d1c..52b66b7c799 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -2768,6 +2768,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..8828f69826e 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -1840,6 +1840,13 @@ 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_F2008,
+	     gfc_check_coshape, gfc_simplify_coshape, gfc_resolve_coshape,
+	     ca, BT_REAL, dr, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("coshape", GFC_ISYM_COSHAPE, GFC_STD_F2008);
+
   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..26787676b4d 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 *);
@@ -289,6 +290,7 @@ gfc_expr *gfc_simplify_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_compiler_options (void);
 gfc_expr *gfc_simplify_compiler_version (void);
 gfc_expr *gfc_simplify_complex (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_coshape (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_conjg (gfc_expr *);
 gfc_expr *gfc_simplify_cos (gfc_expr *);
 gfc_expr *gfc_simplify_cosd (gfc_expr *);
@@ -498,6 +500,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..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
+
+@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
+@end table
+
+
+
 @node COSPI
 @section @code{COSPI} --- Circular cosine function
 @fnindex COSPI
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/simplify.cc b/gcc/fortran/simplify.cc
index a3af457b5de..94c40cd7653 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -2400,6 +2400,130 @@ gfc_simplify_tanpi (gfc_expr *x)
   return range_check (result, "TANPI");
 }
 
+static gfc_expr *
+simplify_bound_dim (gfc_expr *, gfc_expr *, int, int,
+		    gfc_array_spec *, gfc_ref *, bool);
+
+gfc_expr *
+gfc_simplify_coshape (gfc_expr *array, gfc_expr *kind)
+{
+  gfc_expr *bounds[GFC_MAX_DIMENSIONS], *shapes[GFC_MAX_DIMENSIONS];
+  gfc_expr *e;
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+  int k;
+
+  if (array->expr_type != EXPR_VARIABLE)
+    return NULL;
+
+  /* Follow any component references.  */
+  as = (array->ts.type == BT_CLASS && CLASS_DATA (array))
+       ? CLASS_DATA (array)->as
+       : array->symtree->n.sym->as;
+  for (ref = array->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      if (ref->u.ar.as->corank > 0)
+		{
+		  gcc_assert (as == ref->u.ar.as);
+		  goto done;
+		}
+	      as = NULL;
+	      continue;
+
+	    case AR_FULL:
+	      /* We're done because 'as' has already been set in the
+		 previous iteration.  */
+	      goto done;
+
+	    case AR_UNKNOWN:
+	      return NULL;
+
+	    case AR_SECTION:
+	      as = ref->u.ar.as;
+	      goto done;
+	    }
+
+	  gcc_unreachable ();
+
+	case REF_COMPONENT:
+	  as = ref->u.c.component->as;
+	  continue;
+
+	case REF_SUBSTRING:
+	case REF_INQUIRY:
+	  continue;
+	}
+    }
+
+  if (!as)
+    gcc_unreachable ();
+
+ done:
+
+  if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
+    return NULL;
+
+  /* Simplify the cobounds for each dimension.  */
+  for (d = 0; d < as->corank; d++)
+	{
+	  shapes[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
+					  1, as, ref, true);
+	  if (shapes[d] == NULL || shapes[d] == &gfc_bad_expr)
+	{
+	  int j;
+
+	  for (j = 0; j < d; j++)
+		gfc_free_expr (shapes[j]);
+	  return shapes[d];
+	}
+
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
+					  0, as, ref, true);
+	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+	{
+	  int j;
+
+	  for (j = 0; j < d; j++)
+		gfc_free_expr (bounds[j]);
+	  return bounds[d];
+	}
+
+	  mpz_sub (shapes[d]->value.integer, shapes[d]->value.integer, bounds[d]->value.integer);
+	  mpz_add_ui (shapes[d]->value.integer, shapes[d]->value.integer, 1);
+	}
+
+  /* Allocate the result expression.  */
+  e = gfc_get_expr ();
+  e->where = array->where;
+  e->expr_type = EXPR_ARRAY;
+  e->ts.type = BT_INTEGER;
+  k = get_kind (BT_INTEGER, kind, "COSHAPE", gfc_default_integer_kind);
+  if (k == -1)
+	{
+	  gfc_free_expr (e);
+	  return &gfc_bad_expr;
+	}
+  e->ts.kind = k;
+
+  e->rank = 1;
+  e->shape = gfc_get_shape (1);
+  mpz_init_set_ui (e->shape[0], as->corank);
+
+  /* Create the constructor for this array.  */
+  for (d = 0; d < as->corank; d++)
+	gfc_constructor_append_expr (&e->value.constructor,
+				 shapes[d], &e->where);
+  return e;
+}
+
+
 gfc_expr *
 gfc_simplify_count (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..ce2d27cae14 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:
@@ -5350,6 +5351,7 @@ done:
 	      /* Fall through.  */
 
 	    case GFC_ISYM_SHAPE:
+	    case GFC_ISYM_COSHAPE:
 	      {
 		gfc_expr *arg;
 
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index ec98f967200..4c6c1057bfa 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;
@@ -2704,8 +2705,13 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
 
   resbound = gfc_conv_descriptor_lbound_get (desc, bound);
 
+  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 +2765,17 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
 	}
       else
 	se->expr = resbound;
+
+      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;
@@ -11311,6 +11328,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;
@@ -12013,6 +12034,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:
@@ -12216,6 +12238,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..c41880d775f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coshape_1.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Test the coshape intrinsic (PR99250)
+! 
+program coshape_1
+   real, codimension[*] :: cr
+   real, codimension[0:2,*] :: cr2
+   integer :: no_images, val(2)
+   logical :: error_flag = .false.
+
+   no_images = num_images()
+
+   if (this_image() == 1) then
+      val(1:1) = coshape(cr)
+      if (val(1) /= no_images) then
+      call error ("coshape fails for corank 1")
+      endif
+      if (mod (no_images,3) == 0) then
+         val(1:2) = coshape(cr2)
+         if (val(1) /= 3 .or. product (val(1:2)) /= no_images) then
+            call error ("coshape fails for corank 2")
+         else
+            call error ("No. images must be a multiple of 3 for the coshape test #", 2)
+         endif
+      endif
+   endif
+
+contains
+
+   subroutine error (msg, image)
+   character(*), intent(in) :: msg
+   integer, intent(in), optional :: image
+   if (present (image)) then
+      print *, msg, image          ! Do not stop
+   else
+      print *, msg
+      error_flag = .true.
+      call co_broadcast (error_flag, source_image=1)
+   endif
+   end subroutine error
+end program coshape_1
+! { dg-final { scan-tree-dump-times "_gfortran_caf_num_images" 3 "original" } }