bool
-gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
+gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub,
+ gfc_expr *team_or_team_number)
{
mpz_t nelems;
return false;
}
- if (sub->ts.type != BT_INTEGER)
- {
- gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
- gfc_current_intrinsic_arg[1]->name, &sub->where);
- return false;
- }
+ if (!type_check (sub, 1, BT_INTEGER))
+ return false;
if (gfc_array_size (sub, &nelems))
{
mpz_clear (nelems);
}
+ if (team_or_team_number)
+ {
+ if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER)
+ || !scalar_check (team_or_team_number, 2))
+ return false;
+
+ /* Check team is of team_type. */
+ if (team_or_team_number->ts.type == BT_DERIVED
+ && !team_type_check (team_or_team_number, 2))
+ return false;
+ }
+
return true;
}
-
bool
-gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
+gfc_check_num_images (gfc_expr *team_or_team_number)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
return false;
}
- if (distance)
- {
- 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_F2018, "DISTANCE= argument to "
- "NUM_IMAGES at %L", &distance->where))
- return false;
- }
+ if (!team_or_team_number)
+ return true;
- if (failed)
- {
- if (!type_check (failed, 1, BT_LOGICAL))
- return false;
+ if (!gfc_notify_std (GFC_STD_F2008,
+ "%<team%> or %<team_number%> argument to %qs at %L",
+ gfc_current_intrinsic, &team_or_team_number->where))
+ return false;
- if (!scalar_check (failed, 1))
- return false;
+ if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER)
+ || !scalar_check (team_or_team_number, 0))
+ return false;
- if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
- "NUM_IMAGES at %L", &failed->where))
- return false;
- }
+ if (team_or_team_number->ts.type == BT_DERIVED
+ && !team_type_check (team_or_team_number, 0))
+ return false;
return true;
}
@table @asis
@item @emph{Synopsis}:
-@code{int _gfortran_caf_num_images(int distance, int failed)}
+@code{int _gfortran_caf_num_images (caf_team_t team, int32_t *team_number)}
@item @emph{Description}:
-This function returns the number of images in the current team, if
-@var{distance} is 0 or the number of images in the parent team at the specified
-distance. If @var{failed} is -1, the function returns the number of all images at
-the specified distance; if it is 0, the function returns the number of
-nonfailed images, and if it is 1, it returns the number of failed images.
+This function returns the number of images in the team given by @var{team} or
+@var{team_number}, if either one is present. If both are null, then the number
+of images in the current team is returned.
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{distance} @tab the distance from this image to the ancestor.
-Shall be positive.
-@item @var{failed} @tab shall be -1, 0, or 1
+@item @var{team} @tab intent(in), optional; The team the number of images is
+requested for. If null, the number of images in the current team is returned.
+@item @var{team_number} @tab intent(in), optional; The team id for which the
+number of teams is requested; if unset, then number of images in the current
+team is returned.
@end multitable
@item @emph{Notes}:
-This function follows TS18508. If the num_image intrinsic has no arguments,
-then the compiler passes @code{distance=0} and @code{failed=-1} to the function.
+When both argument are given, then it is caf-library dependent which argument
+is examined first. Current implementations prioritize the @var{team} argument,
+because it is easier to retrive the number of images from it.
+
+Fortran 2008 or later, with no arguments; Fortran 2018 or later with two
+arguments.
@end table
{
/* Argument names. These are used as argument keywords and so need to
match the documentation. Please keep this list in sorted order. */
- const char
- *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b",
- *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1",
- *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command",
- *dist = "distance", *dm = "dim", *f = "field", *failed="failed",
- *fs = "fsource", *han = "handler", *i = "i",
- *idy = "identity", *image = "image", *j = "j", *kind = "kind",
- *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a",
- *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask",
- *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number",
- *op = "operation", *ord = "order", *odd = "ordered", *p = "p",
- *p1 = "path1", *p2 = "path2", *pad = "pad", *pid = "pid", *pos = "pos",
- *pt = "pointer", *r = "r", *rd = "round",
- *s = "s", *set = "set", *sh = "shift", *shp = "shape",
- *sig = "sig", *src = "source", *ssg = "substring",
- *sta = "string_a", *stb = "string_b", *stg = "string",
- *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time",
- *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a",
- *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y",
- *z = "z";
+ const char *a
+ = "a",
+ *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", *bck = "back",
+ *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2",
+ *ca = "coarray", *com = "command", *dm = "dim", *f = "field",
+ *fs = "fsource", *han = "handler", *i = "i", *idy = "identity",
+ *image = "image", *j = "j", *kind = "kind", *l = "l", *ln = "len",
+ *level = "level", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
+ *md = "mode", *mo = "mold", *msk = "mask", *n = "n", *ncopies = "ncopies",
+ *nm = "name", *num = "number", *op = "operation", *ord = "order",
+ *odd = "ordered", *p = "p", *p1 = "path1", *p2 = "path2", *pad = "pad",
+ *pid = "pid", *pos = "pos", *pt = "pointer", *r = "r", *rd = "round",
+ *s = "s", *set = "set", *sh = "shift", *shp = "shape", *sig = "sig",
+ *src = "source", *ssg = "substring", *sta = "string_a", *stb = "string_b",
+ *stg = "string", *sub = "sub", *sz = "size", *tg = "target", *team = "team",
+ *team_or_team_number = "team/team_number", *tm = "time", *ts = "tsource",
+ *ut = "unit", *v = "vector", *va = "vector_a", *vb = "vector_b",
+ *vl = "values", *val = "value", *x = "x", *y = "y", *z = "z";
int di, dr, dd, dl, dc, dz, ii;
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
- add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
- ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
+ add_sym_3 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_TRANSFORMATIONAL,
+ ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_image_index,
+ gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr,
+ REQUIRED, sub, BT_INTEGER, ii, REQUIRED, team_or_team_number,
+ BT_VOID, di, OPTIONAL);
add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status,
make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
- add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL,
- ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_num_images, gfc_simplify_num_images, NULL,
- dist, BT_INTEGER, di, OPTIONAL,
- failed, BT_LOGICAL, dl, OPTIONAL);
+ add_sym_1 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL,
+ ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images,
+ gfc_simplify_num_images, NULL, team_or_team_number, BT_VOID, di,
+ OPTIONAL);
add_sym_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2018,
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_num_images (gfc_expr *);
bool gfc_check_out_of_range (gfc_expr *, 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_ftell_sub (gfc_expr *, gfc_expr *);
bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
-bool gfc_check_image_index (gfc_expr *, gfc_expr *);
+bool gfc_check_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_itime_idate (gfc_expr *);
bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *);
-gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int (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 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_num_images (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 *);
void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
-void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
@table @asis
@item @emph{Synopsis}:
-@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)}
+@multitable @columnfractions .80
+@item @code{RESULT = NUM_IMAGES([TEAM])}
+@item @code{RESULT = NUM_IMAGES(TEAM_NUMBER)}
+@end multitable
@item @emph{Description}:
-Returns the number of images.
+Returns the number of images in the current team or the given team.
@item @emph{Class}:
Transformational function
@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
+@item @var{TEAM} @tab (optional, intent(in)) If present, return the number of
+images in the given team; if absent, return the number of images in the
+current team.
+@item @var{TEAM_NUMBER} @tab (intent(in)) The number as given in the
+@code{FORM TEAM} statement.
@end multitable
@item @emph{Return value}:
-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 that 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 that
-do have not the failed status.
+Scalar default-kind integer. Can be called without any arguments or a team
+type argument or a team_number argument.
@item @emph{Example}:
@smallexample
+use, intrinsic :: iso_fortran_env
INTEGER :: value[*]
INTEGER :: i
-value = THIS_IMAGE()
-SYNC ALL
-IF (THIS_IMAGE() == 1) THEN
- DO i = 1, NUM_IMAGES()
- WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
- END DO
-END IF
+type(team_type) :: t
+
+! When running with 4 images
+print *, num_images() ! 4
+
+form team (mod(this_image(), 2), t)
+print *, num_images(t) ! 2
+print *, num_images(-1) ! 4
@end smallexample
@item @emph{Standard}:
-Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument,
-Technical Specification (TS) 18508 or later
+Fortran 2008 and later. With @var{TEAM} or @var{TEAM_NUMBER} argument,
+Fortran 2018 and later.
@item @emph{See also}:
@ref{THIS_IMAGE}, @*
void
gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
- gfc_expr *sub ATTRIBUTE_UNUSED)
+ gfc_expr *sub ATTRIBUTE_UNUSED,
+ gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
{
static char image_index[] = "__image_index";
f->ts.type = BT_INTEGER;
gfc_expr *
-gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
+gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
{
gfc_expr *result;
if (flag_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);
-
- 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_image_index (gfc_expr *coarray, gfc_expr *sub)
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub,
+ gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
{
gfc_expr *result;
gfc_ref *ref;
gfc_se team_se;
gfc_init_se (&team_se, NULL);
gfc_conv_expr_reference (&team_se, team_e);
- *team = team_se.expr;
+ *team
+ = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
+ team_se.expr));
gfc_add_block_to_block (block, &team_se.pre);
gfc_add_block_to_block (block, &team_se.post);
}
gfc_se team_se;
gfc_init_se (&team_se, NULL);
gfc_conv_expr_reference (&team_se, team_e);
- *team_no = team_se.expr;
+ *team_no = gfc_build_addr_expr (
+ NULL_TREE,
+ gfc_trans_force_lval (&team_se.pre,
+ fold_convert (integer_type_node, team_se.expr)));
gfc_add_block_to_block (block, &team_se.pre);
gfc_add_block_to_block (block, &team_se.post);
}
++caf_call_cnt;
tmp = build_call_expr_loc (
- input_location, gfor_fndecl_caf_transfer_between_remotes, 20, lhs_token,
+ input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
rhs_add_data_size, rhs_size,
transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
- lhs_team, lhs_team_no, rhs_stat, rhs_team, rhs_team_no);
+ rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &lhs_se.post);
static void
trans_image_index (gfc_se * se, gfc_expr *expr)
{
- tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
- tmp, invalid_bound;
+ tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
+ invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
gfc_se argse, subse;
int rank, corank, codim;
subdesc = build_fold_indirect_ref_loc (input_location,
gfc_conv_descriptor_data_get (subse.expr));
+ if (expr->value.function.actual->next->next->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_descriptor (&argse,
+ expr->value.function.actual->next->next->expr);
+ if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
+ team = argse.expr;
+ else
+ team_number = gfc_build_addr_expr (
+ NULL_TREE,
+ gfc_trans_force_lval (&argse.pre,
+ fold_convert (integer_type_node, argse.expr)));
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ }
+
/* Fortran 2008 does not require that the values remain in the cobounds,
thus we need explicitly check this - and return 0 if they are exceeded. */
else
{
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
- integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ team, team_number);
num_images = fold_convert (type, tmp);
}
static void
trans_num_images (gfc_se * se, gfc_expr *expr)
{
- tree tmp, distance, failed;
+ tree tmp, team = null_pointer_node, team_number = null_pointer_node;
gfc_se argse;
if (expr->value.function.actual->expr)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
+ if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
+ team = argse.expr;
+ else
+ team_number = gfc_build_addr_expr (
+ NULL_TREE,
+ gfc_trans_force_lval (&se->pre,
+ fold_convert (integer_type_node, argse.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);
+ team, team_number);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
}
cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
- 2, integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ 2, null_pointer_node, null_pointer_node);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
fold_convert (gfc_array_index_type, tmp),
{
/* ubound = lbound + num_images() - 1. */
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
- 2, integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ 2, null_pointer_node, null_pointer_node);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
fold_convert (gfc_array_index_type, tmp),
{
tree cond2;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
- 2, integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ 2, null_pointer_node, null_pointer_node);
cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
images2, tmp);
cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
program p
integer :: x[*]
- print *, image_index (x, [1.0]) ! { dg-error "shall be INTEGER" }
+ print *, image_index (x, [1.0]) ! { dg-error "must be INTEGER" }
end
call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3)
end program test
-! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 6\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } }
end function hc
end program test
-! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(real\\(kind=4\\)\\\[2\\\] \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } }
! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0B, 0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(struct array02_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } }
! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0B, 0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } }
associate(me => this_image())
end associate
k1 = num_images()
-k2 = num_images(6)
-k3 = num_images(distance=7)
-k4 = num_images(distance=8, failed=.true.)
-k5 = num_images(failed=.false.)
+k2 = num_images(team)
+k3 = num_images(-1)
end
! { dg-final { scan-tree-dump-times "j\[1-4\] = 1;" 4 "original" } }
! { dg-final { scan-tree-dump-times "A\\.\[0-9\]+\\\[2\\\] = \\\{1, 1\\\};" 4 "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 { scan-tree-dump "k1 = 1;" "original" } }
+! { dg-final { scan-tree-dump "k2 = 1;" "original" } }
+! { dg-final { scan-tree-dump "k3 = 1;" "original" } }
endif
end associate
k1 = num_images()
-k2 = num_images(6)
-k3 = num_images(distance=7)
-k4 = num_images(distance=8, failed=.true.)
-k5 = num_images(failed=.false.)
+k2 = num_images(team)
+k3 = num_images(-1)
+k4 = num_images(1)
end
! { dg-final { scan-tree-dump "j1 = _gfortran_caf_this_image \\(0B\\);" "original" } }
! { dg-final { scan-tree-dump "j3 = _gfortran_caf_this_image \\(team\\);" "original" } }
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(team\\) \\+ -1;" 2 "original" } }
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(0B\\) \\+ -1;" 2 "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 { scan-tree-dump "k1 = _gfortran_caf_num_images \\(0B, 0B\\);" "original" } }
+! { dg-final { scan-tree-dump "k2 = _gfortran_caf_num_images \\(team, 0B\\);" "original" } }
+! { dg-final { scan-tree-dump "k3 = _gfortran_caf_num_images \\(0B, &D\\.\[0-9\]+\\);" "original" } }
+! { dg-final { scan-tree-dump "k4 = _gfortran_caf_num_images \\(0B, &D\\.\[0-9\]+\\);" "original" } }
j5 = this_image(caf, 1, team, 'baz') !{ dg-error "Too many arguments in call" }
j6 = this_image(dim=1, team=team, coarray=caf)
-!k1 = num_images()
-
-!k2 = num_images(6)
-
-!k3 = num_images(distance=7)
-
-!k4 = num_images(distance=8, failed=.true.)
-
-!k5 = num_images(failed=.false.)
+k1 = num_images() ! ok
+k2 = num_images(team) ! ok
+k3 = num_images(team, 2) !{ dg-error "Too many arguments in call to" }
+k4 = num_images(1) ! ok
+k5 = num_images('abc') !{ dg-error "'team/team_number' argument of 'num_images' intrinsic" }
+k6 = num_images(1, team) !{ dg-error "Too many arguments in call to" }
end
program foo
implicit none
integer k5
- k5 = num_images(failed=.false.) ! { dg-error "argument to NUM_IMAGES" }
+ k5 = num_images(failed=.false.) ! { dg-error "Cannot find keyword named 'failed' in call to 'num_images'" }
end program foo
void _gfortran_caf_finalize (void);
int _gfortran_caf_this_image (caf_team_t);
-int _gfortran_caf_num_images (int, int);
+int _gfortran_caf_num_images (caf_team_t, int32_t *);
void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *,
gfc_descriptor_t *, int *, char *, size_t);
}
int
-_gfortran_caf_num_images (int distance __attribute__ ((unused)),
- int failed __attribute__ ((unused)))
+_gfortran_caf_num_images (caf_team_t team __attribute__ ((unused)),
+ int32_t *team_number __attribute__ ((unused)))
{
return 1;
}
projects / thirdparty / gcc.git / commitdiff
