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?
Change.Logs
Description: Binary data
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" } }
