diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 34119a55633..88c26ad3986 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2014-05-25 Tobias Burnus + + * 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 * gfc-internals.texi: Change URLs to HTTPS; fix broken links. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 9dd60718a33..20af75feb44 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 4c2eaa5f729..bf784b5e18f 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 162fa71b660..05cd1464182 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index b091ee4c9b4..776cb00bf11 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -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 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 @@ -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 +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 @@ -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}: diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 630d725e173..d029f720a8d 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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 { diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 1b6cd5bc4c1..d18bc081088 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index eaa56ed902d..a76d0f75cc1 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 018fe9e9568..49e4bb7826c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2014-05-25 Tobias Burnus + + * 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 PR libfortran/61173 diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90 index 78abb5ad191..53917b58ff3 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -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