procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

check.c (gfc_check_num_images): New.

Browse source 
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-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.

From-SVN: r210909
This commit is contained in:
Tobias Burnus 2014-05-25 07:24:12 +02:00 • committed by Tobias Burnus
parent fd1e930270
commit 05fc16dde9
10 changed files with 224 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View file

@ -1,3 +1,20 @@
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.

90
gcc/fortran/check.c
View file

@ -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;

13
gcc/fortran/intrinsic.c
View file

@ -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);

9
gcc/fortran/intrinsic.h
View file

@ -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 *);

49
gcc/fortran/intrinsic.texi
View file

@ -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}:

5
gcc/fortran/iresolve.c
View file

@ -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
{

19
gcc/fortran/simplify.c
View file

@ -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. */

53
gcc/fortran/trans-intrinsic.c
View file

@ -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:

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
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

2
gcc/testsuite/gfortran.dg/coarray_10.f90
View file

@ -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