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

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index fae628bae40..528a9831005 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -2763,6 +2763,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 848ad9ca1fa..9f7f5bd150c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -489,6 +489,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 a422fc176b4..8638dd30c74 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_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 048196d65c3..86a66dc4a0b 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/iresolve.cc b/gcc/fortran/iresolve.cc
index a821332ecb2..49f7f3c17e3 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 b25cd2c2388..b398b1e343f 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 cd137212260..dd8c1545e0a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5252,6 +5252,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:
@@ -5343,6 +5344,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 db4b1165781..0f8e31068ad 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2622,12 +2622,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;
@@ -2708,8 +2709,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
@@ -2763,6 +2769,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;
@@ -11308,6 +11325,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;
@@ -12010,6 +12031,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:
@@ -12213,6 +12235,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: