2014-05-24 Tobias Burnus <burnus@net-b.de>
* check.c (gfc_check_num_images): New.
(gfc_check_this_image): Handle distance argument.
* intrinsic.c (add_functions): Update this_image and num_images
for new distance and failed arguments.
* intrinsic.texi (THIS_IMAGE, NUM_IMAGES): Document the new
arguments.
* intrinsic.h (gfc_check_num_images): New.
(gfc_check_this_image, gfc_simplify_num_images,
gfc_simplify_this_image, gfc_resolve_this_image): Update prototype.
* iresolve.c (gfc_resolve_this_image): Handle distance argument.
* simplify.c (gfc_simplify_num_images, gfc_simplify_this_image):
Handle new arguments.
* trans-intrinsic.c (trans_this_image, trans_num_images): Ditto.
(gfc_conv_intrinsic_function): Update trans_num_images call.
2014-05-24 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_10.f90: Update dg-warning.
* gfortran.dg/coarray_this_image_1.f90: New.
* gfortran.dg/coarray_this_image_2.f90: New.
@@ -4552,7 +4552,7 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
bool
-gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
+gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
{
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
{
@@ -4560,16 +4560,96 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
return false;
}
- if (dim != NULL && coarray == NULL)
+ if (distance)
{
- gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
- "intrinsic at %L", &dim->where);
+ if (!type_check (distance, 0, BT_INTEGER))
+ return false;
+
+ if (!nonnegative_check ("DISTANCE", distance))
+ return false;
+
+ if (!scalar_check (distance, 0))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "DISTANCE= argument to "
+ "NUM_IMAGES at %L", &distance->where))
+ return false;
+ }
+
+ if (failed)
+ {
+ if (!type_check (failed, 1, BT_LOGICAL))
+ return false;
+
+ if (!scalar_check (failed, 1))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "FAILED= argument to "
+ "NUM_IMAGES at %L", &distance->where))
+ return false;
+ }
+
+ return true;
+}
+
+
+bool
+gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
+{
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
return false;
}
- if (coarray == NULL)
+ if (coarray == NULL && dim == NULL && distance == NULL)
return true;
+ if (dim != NULL && coarray == NULL)
+ {
+ gfc_error ("DIM argument without COARRAY argument not allowed for "
+ "THIS_IMAGE intrinsic at %L", &dim->where);
+ return false;
+ }
+
+ if (distance && (coarray || dim))
+ {
+ gfc_error ("The DISTANCE argument may not be specified together with the "
+ "COARRAY or DIM argument in intrinsic at %L",
+ &distance->where);
+ return false;
+ }
+
+ /* Assume that we have "this_image (distance)". */
+ if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
+ {
+ if (dim)
+ {
+ gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
+ &coarray->where);
+ return false;
+ }
+ distance = coarray;
+ }
+
+ if (distance)
+ {
+ if (!type_check (distance, 2, BT_INTEGER))
+ return false;
+
+ if (!nonnegative_check ("DISTANCE", distance))
+ return false;
+
+ if (!scalar_check (distance, 2))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "DISTANCE= argument to "
+ "THIS_IMAGE at %L", &distance->where))
+ return false;
+
+ return true;
+ }
+
if (!coarray_check (coarray, 0))
return false;
@@ -1205,7 +1205,7 @@ add_functions (void)
*z = "z", *ln = "len", *ut = "unit", *han = "handler",
*num = "number", *tm = "time", *nm = "name", *md = "mode",
*vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
- *ca = "coarray", *sub = "sub";
+ *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed";
int di, dr, dd, dl, dc, dz, ii;
@@ -2477,9 +2477,11 @@ add_functions (void)
make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
- add_sym_0 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
+ add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
- NULL, gfc_simplify_num_images, NULL);
+ gfc_check_num_images, gfc_simplify_num_images, NULL,
+ dist, BT_INTEGER, di, OPTIONAL,
+ failed, BT_LOGICAL, dl, OPTIONAL);
add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
@@ -2892,9 +2894,10 @@ add_functions (void)
make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
- add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+ add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
- ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
+ ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL,
+ dist, BT_INTEGER, di, OPTIONAL);
add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
@@ -117,6 +117,7 @@ bool gfc_check_nearest (gfc_expr *, gfc_expr *);
bool gfc_check_new_line (gfc_expr *);
bool gfc_check_norm2 (gfc_expr *, gfc_expr *);
bool gfc_check_null (gfc_expr *);
+bool gfc_check_num_images (gfc_expr *, gfc_expr *);
bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_parity (gfc_expr *, gfc_expr *);
bool gfc_check_precision (gfc_expr *);
@@ -212,7 +213,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_sleep_sub (gfc_expr *);
bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_system_sub (gfc_expr *, gfc_expr *);
-bool gfc_check_this_image (gfc_expr *, gfc_expr *);
+bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
bool gfc_check_umask_sub (gfc_expr *, gfc_expr *);
bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
@@ -343,7 +344,7 @@ gfc_expr *gfc_simplify_new_line (gfc_expr *);
gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_null (gfc_expr *);
-gfc_expr *gfc_simplify_num_images (void);
+gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_idnint (gfc_expr *);
gfc_expr *gfc_simplify_not (gfc_expr *);
gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
@@ -387,7 +388,7 @@ gfc_expr *gfc_simplify_sqrt (gfc_expr *);
gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_tan (gfc_expr *);
gfc_expr *gfc_simplify_tanh (gfc_expr *);
-gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_tiny (gfc_expr *);
gfc_expr *gfc_simplify_trailz (gfc_expr *);
gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -568,7 +569,7 @@ void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_system (gfc_expr *, gfc_expr *);
void gfc_resolve_tan (gfc_expr *, gfc_expr *);
void gfc_resolve_tanh (gfc_expr *, gfc_expr *);
-void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_time (gfc_expr *);
void gfc_resolve_time8 (gfc_expr *);
void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
@@ -9676,18 +9676,32 @@ REAL, POINTER, DIMENSION(:) :: VEC => NULL ()
Returns the number of images.
@item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument,
+Technical Specification (TS) 18508 or later
+
@item @emph{Class}:
Transformational function
@item @emph{Syntax}:
-@code{RESULT = NUM_IMAGES()}
+@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)}
-@item @emph{Arguments}: None.
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
+@item @var{FAILED} @tab (optional, intent(in)) Scalar logical expression
+@end multitable
@item @emph{Return value}:
-Scalar default-kind integer.
+Scalar default-kind integer. If @var{DISTANCE} is not present or has value 0,
+the number of images in the current team is returned. For values smaller or
+equal the distance to the initial team, it returns the number of images index
+on the anchestor team which has a distance of @var{DISTANCE} from the invoking
+team. If @var{DISTANCE} is larger than the distance to the initial team, the
+image index of the initial team is returned. If @var{FAILED} is not present
+the total number of images is returned; if it has the value @code{.TRUE.},
+the number of failed images in retured, otherwise, the number of images which
+have not the failed status.
@item @emph{Example}:
@smallexample
@@ -12422,7 +12436,8 @@ end program test_tanh
Returns the cosubscript for this image.
@item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later. With @var{DISTANCE} argument,
+Technical Specification (TS) 18508 or later
@item @emph{Class}:
Transformational function
@@ -12430,11 +12445,14 @@ Transformational function
@item @emph{Syntax}:
@multitable @columnfractions .80
@item @code{RESULT = THIS_IMAGE()}
+@item @code{RESULT = THIS_IMAGE(DISTANCE)}
@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
@end multitable
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
+@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
+(not permitted together with @var{COARRAY}).
@item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM}
present, required).
@item @var{DIM} @tab default integer scalar (optional). If present,
@@ -12443,12 +12461,17 @@ present, required).
@item @emph{Return value}:
-Default integer. If @var{COARRAY} is not present, it is scalar and its value
-is the index of the invoking image. Otherwise, if @var{DIM} is not present,
-a rank-1 array with corank elements is returned, containing the cosubscripts
-for @var{COARRAY} specifying the invoking image. If @var{DIM} is present,
-a scalar is returned, with the value of the @var{DIM} element of
-@code{THIS_IMAGE(COARRAY)}.
+Default integer. If @var{COARRAY} is not present, it is scalar; if
+@var{DISTANCE} is not present or has value 0, its value is the image index on
+the invoking image for the current team, for values smaller or equal the
+distance to the initial team, it returns the image index on the anchestor team
+which has a distance of @var{DISTANCE} from the invoking team. If
+@var{DISTANCE} is larger than the distance to the initial team, the image
+index of the initial team is returned. Otherwise when the @var{COARRAY} is
+present, if @var{DIM} is not present, a rank-1 array with corank elements is
+returned, containing the cosubscripts for @var{COARRAY} specifying the invoking
+image. If @var{DIM} is present, a scalar is returned, with the value of
+the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}.
@item @emph{Example}:
@smallexample
@@ -12461,6 +12484,10 @@ IF (THIS_IMAGE() == 1) THEN
WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
END DO
END IF
+
+! Check whether the current image is the initial image
+IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE())
+ error stop "something is rotten here"
@end smallexample
@item @emph{See also}:
@@ -2590,10 +2590,11 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
void
-gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *distance ATTRIBUTE_UNUSED)
{
static char this_image[] = "__this_image";
- if (array)
+ if (array && gfc_is_coarray (array))
resolve_bound (f, array, dim, NULL, "__this_image", true);
else
{
@@ -4601,7 +4601,7 @@ gfc_simplify_null (gfc_expr *mold)
gfc_expr *
-gfc_simplify_num_images (void)
+gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
{
gfc_expr *result;
@@ -4614,10 +4614,18 @@ gfc_simplify_num_images (void)
if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
return NULL;
+ if (failed && failed->expr_type != EXPR_CONSTANT)
+ return NULL;
+
/* FIXME: gfc_current_locus is wrong. */
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
- mpz_set_si (result->value.integer, 1);
+
+ if (failed && failed->value.logical != 0)
+ mpz_set_si (result->value.integer, 0);
+ else
+ mpz_set_si (result->value.integer, 1);
+
return result;
}
@@ -6389,12 +6397,15 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
gfc_expr *
-gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
+ gfc_expr *distance ATTRIBUTE_UNUSED)
{
if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
return NULL;
- if (coarray == NULL)
+ /* If no coarray argument has been passed or when the first argument
+ is actually a distance argment. */
+ if (coarray == NULL || !gfc_is_coarray (coarray))
{
gfc_expr *result;
/* FIXME: gfc_current_locus is wrong. */
@@ -934,15 +934,30 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
lbound, ubound, extent, ml;
gfc_se argse;
int rank, corank;
+ gfc_expr *distance = expr->value.function.actual->next->next->expr;
+
+ if (expr->value.function.actual->expr
+ && !gfc_is_coarray (expr->value.function.actual->expr))
+ distance = expr->value.function.actual->expr;
/* The case -fcoarray=single is handled elsewhere. */
gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
/* Argument-free version: THIS_IMAGE(). */
- if (expr->value.function.actual->expr == NULL)
+ if (distance || expr->value.function.actual->expr == NULL)
{
+ if (distance)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, distance);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ tmp = fold_convert (integer_type_node, argse.expr);
+ }
+ else
+ tmp = integer_zero_node;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- integer_zero_node);
+ tmp);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
tmp);
return;
@@ -1262,11 +1277,35 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
static void
-trans_num_images (gfc_se * se)
+trans_num_images (gfc_se * se, gfc_expr *expr)
{
- tree tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
- integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ tree tmp, distance, failed;
+ gfc_se argse;
+
+ if (expr->value.function.actual->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ distance = fold_convert (integer_type_node, argse.expr);
+ }
+ else
+ distance = integer_zero_node;
+
+ if (expr->value.function.actual->next->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ failed = fold_convert (integer_type_node, argse.expr);
+ }
+ else
+ failed = build_int_cst (integer_type_node, -1);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
+ distance, failed);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
}
@@ -7099,7 +7138,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_NUM_IMAGES:
- trans_num_images (se);
+ trans_num_images (se, expr);
break;
case GFC_ISYM_ACCESS:
@@ -21,7 +21,7 @@ subroutine this_image_check()
integer,save :: z(4)[*], i
j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" }
- j = this_image(dim=3) ! { dg-error "DIM argument without ARRAY argument" }
+ j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" }
i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" }
i = image_index(z, 2) ! { dg-error "must be a rank one array" }
end subroutine this_image_check
new file mode 100644
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=single" }
+!
+j1 = this_image(distance=4)
+j2 = this_image(5)
+k1 = num_images()
+k2 = num_images(6)
+k3 = num_images(distance=7)
+k4 = num_images(distance=8, failed=.true.)
+k5 = num_images(failed=.false.)
+end
+
+! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "j2 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k1 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k2 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k3 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k4 = 0;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k5 = 1;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
new file mode 100644
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+j1 = this_image(distance=4)
+j2 = this_image(5)
+k1 = num_images()
+k2 = num_images(6)
+k3 = num_images(distance=7)
+k4 = num_images(distance=8, failed=.true.)
+k5 = num_images(failed=.false.)
+end
+
+! { dg-final { scan-tree-dump-times "j1 = _gfortran_caf_this_image \\(4\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "j2 = _gfortran_caf_this_image \\(5\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k1 = _gfortran_caf_num_images \\(0, -1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k2 = _gfortran_caf_num_images \\(6, -1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k3 = _gfortran_caf_num_images \\(7, -1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k4 = _gfortran_caf_num_images \\(8, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "k5 = _gfortran_caf_num_images \\(0, 0\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }