+2014-05-25 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-23 Tobias Burnus <burnus@net-b.de>
* gfc-internals.texi: Change URLs to HTTPS; fix broken links.
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)
{
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;
*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;
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,
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);
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 *);
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 *);
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 *);
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 *);
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 *);
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 distance to the initial team, it returns the number of images index
+on the ancestor 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
+number of images 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 is returned, otherwise, the number of images which
+do have not the failed status.
@item @emph{Example}:
@smallexample
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
@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,
@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
+distance to the initial team, it returns the image index on the ancestor 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
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}:
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
{
gfc_expr *
-gfc_simplify_num_images (void)
+gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
{
gfc_expr *result;
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;
}
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. */
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;
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);
}
break;
case GFC_ISYM_NUM_IMAGES:
- trans_num_images (se);
+ trans_num_images (se, expr);
break;
case GFC_ISYM_ACCESS:
+2014-05-25 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.
+
2014-05-24 Jerry DeLisle <jvdelisle@gcc.gnu>
PR libfortran/61173
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