return gfc_check_atomic (atom, 1, value, 0, stat, 2);
}
+bool
+team_type_check (gfc_expr *e, int n)
+{
+ if (e->ts.type != BT_DERIVED || !e->ts.u.derived
+ || e->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || e->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
+ "%<team_type%> from the intrinsic module "
+ "%<ISO_FORTRAN_ENV%>",
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
+ return false;
+ }
+
+ return true;
+}
bool
gfc_check_image_status (gfc_expr *image, gfc_expr *team)
|| !positive_check (0, image))
return false;
- if (team)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &team->where);
- return false;
- }
- return true;
+ return !team || (scalar_check (team, 0) && team_type_check (team, 0));
}
{
if (level)
{
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &level->where);
- return false;
+ int l;
+
+ if (!type_check (level, 0, BT_INTEGER) || !scalar_check (level, 0))
+ return false;
+
+ /* When level is a constant, try to extract it. If not, the runtime has
+ to check. */
+ if (gfc_extract_int (level, &l, 0))
+ return true;
+
+ if (l < GFC_CAF_INITIAL_TEAM || l > GFC_CAF_CURRENT_TEAM)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall specify one of "
+ "the INITIAL_TEAM, PARENT_TEAM or CURRENT_TEAM constants "
+ "from the intrinsic module ISO_FORTRAN_ENV",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &level->where);
+ return false;
+ }
}
return true;
}
return false;
}
- if (team)
- {
- if (team->ts.type != BT_DERIVED
- || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
- {
- gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
- "shall be of type TEAM_TYPE", &team->where);
- return false;
- }
- }
- else
- return true;
-
- return true;
+ return !team || (scalar_check (team, 0) && team_type_check (team, 0));
}
if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return true;
- else
+ /* Prevent the following error message for caf-single mode, because there
+ are no teams in single mode and the simplify returns a null then. */
+ else if (!(flag_coarray == GFC_FCOARRAY_SINGLE
+ && rvalue->ts.type == BT_DERIVED
+ && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && rvalue->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_TEAM_TYPE))
{
gfc_error ("NULL appears on right-hand side in assignment at %L",
&rvalue->where);
* _gfortran_caf_change_team:: Team activation function
* _gfortran_caf_end_team:: Team termination function
* _gfortran_caf_sync_team:: Synchronize all images of a given team
+* _gfortran_caf_get_team:: Get the opaque handle of the specified team
+* _gfortran_caf_team_number:: Get the unique id of the given team
@end menu
@end table
+
+@node _gfortran_caf_get_team
+@subsection @code{_gfortran_caf_get_team} --- Get the opaque handle of the specified team
+@cindex Coarray, _gfortran_caf_get_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{caf_team_t _gfortran_caf_get_team (int32_t *level)}
+
+@item @emph{Description}:
+Get the current team, when @var{level} is null, or the team specified by
+@var{level} set to @code{INITIAL_TEAM}, @code{PARENT_TEAM} or
+@code{CURRENT_TEAM} from the @code{ISO_FORTRAN_ENV} intrinsic module. When
+being on the @code{INITIAL_TEAM} and requesting its @code{PARENT_TEAM}, then
+the initial team is returned.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{level} @tab intent(in) If set to one of the levels specified in
+the @code{ISO_FORTRAN_ENV} module, the function returns the handle of the given
+team. Values different from the allowed ones lead to a runtime error.
+@end multitable
+@end table
+
+
+
+@node _gfortran_caf_team_number
+@subsection @code{_gfortran_caf_team_number} --- Get the unique id of the given team
+@cindex Coarray, _gfortran_caf_team_number
+
+@table @asis
+@item @emph{Synopsis}:
+@code{int _gfortran_caf_team_number (caf_team_t team)}
+
+@item @emph{Description}:
+The team id given when forming the team @ref{_gfortran_caf_form_team} of the
+team specified by @var{team}, if given, or of the current team, if @var{team}
+is absent. It is a runtime error to specify a non-existing team.
+The team has to be formed, i.e., it is not necessary that it is changed
+into to get the team number. The initial team has the team number @code{-1}.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(in) The team for which the team id is desired.
+@end multitable
+@end table
+
+
@c Intrinsic Procedures
@c ---------------------------------------------------------------------
make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
- add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL,
- ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018,
- gfc_check_get_team, NULL, gfc_resolve_get_team,
- level, BT_INTEGER, di, OPTIONAL);
+ add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+ BT_DERIVED, di, GFC_STD_F2018, gfc_check_get_team,
+ gfc_simplify_get_team, gfc_resolve_get_team, level, BT_INTEGER, di,
+ OPTIONAL);
add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_c_loc (gfc_expr *, gfc_expr *);
void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *);
+void gfc_resolve_get_team (gfc_expr *, gfc_expr *);
void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
void gfc_resolve_getgid (gfc_expr *);
void gfc_resolve_getpid (gfc_expr *);
-void gfc_resolve_get_team (gfc_expr *, gfc_expr *);
void gfc_resolve_getuid (gfc_expr *);
void gfc_resolve_hostnm (gfc_expr *, gfc_expr *);
void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *);
* @code{GETGID}: GETGID, Group ID function
* @code{GETLOG}: GETLOG, Get login name
* @code{GETPID}: GETPID, Process ID function
+* @code{GET_TEAM}: GET_TEAM, Get the handle of a team
* @code{GETUID}: GETUID, User ID function
* @code{GMTIME}: GMTIME, Convert time to GMT info
* @code{HOSTNM}: HOSTNM, Get system host name
* @code{TAN}: TAN, Tangent function
* @code{TAND}: TAND, Tangent function, degrees
* @code{TANH}: TANH, Hyperbolic tangent function
+* @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team
* @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image
* @code{TIME}: TIME, Time function
* @code{TIME8}: TIME8, Time function (64-bit)
+@node GET_TEAM
+@section @code{GET_TEAM} --- Get the handle of a team
+@fnindex GET_TEAM
+@cindex coarray, @code{GET_TEAM}
+@cindex images, get a handle to a team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{RESULT = GET_TEAM([LEVEL])}
+
+@item @emph{Description}:
+Returns the handle of the current team, if @var{LEVEL} is not given. Or the
+team specified by @var{LEVEL}, where @var{LEVEL} is one of the constants
+@code{INITIAL_TEAM}, @code{PARENT_TEAM} or @code{CURRENT_TEAM} from the
+intrinsic module @code{ISO_FORTRAN_ENV}. Calling the function with
+@code{PARENT_TEAM} while being on the initial team, returns a handle to the
+initial team. This ensures that always a valid team is returned, given that
+team handles can neither be checked for validity nor compared with each other
+or null.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Return value}:
+An opaque handle of @code{TEAM_TYPE} from the intrinsic module
+@code{ISO_FORTRAN_ENV}.
+
+@item @emph{Example}:
+@smallexample
+program info
+ use, intrinsic :: iso_fortran_env
+ type(team_type) :: init, curr, par, nt
+
+ init = get_team()
+ curr = get_team(current_team) ! init equals curr here
+ form team(1, nt)
+ change team(nt)
+ curr = get_team() ! or get_team(current_team)
+ par = get_team(parent_team) ! par equals init here
+ end team
+end program info
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 or later
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @*
+@ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
@node GETUID
@section @code{GETUID} --- User ID function
@fnindex GETUID
+@node TEAM_NUMBER
+@section @code{TEAM_NUMBER} --- Retrieve team id of given team
+@fnindex TEAM_NUMBER
+@cindex coarray, @code{TEAM_NUMBER}
+@cindex teams, index of given team
+
+@table @asis
+@item @emph{Synopsis}:
+@item @code{RESULT = TEAM_NUMBER([TEAM])}
+
+@item @emph{Description}:
+Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}.
+If @var{TEAM} is absent, returns the team number of the current team.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which
+the number, aka id, is desired.
+@end multitable
+
+@item @emph{Return value}:
+Default integer. The id as given in a call @code{FORM TEAM}. Applying
+@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned.
+Returns the id of the current team, if @var{TEAM} is null.
+
+@item @emph{Example}:
+@smallexample
+use, intrinsic :: iso_fortran_env
+type(team_type) :: t
+
+print *, team_number() ! -1
+form team (99, t)
+print *, team_number(t) ! 99
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 and later.
+
+@item @emph{See also}:
+@ref{GET_TEAM}, @*
+@ref{TEAM_NUMBER}
+@end table
+
+
+
@node THIS_IMAGE
@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
@fnindex THIS_IMAGE
@item @code{CHARACTER_STORAGE_SIZE}:
Size in bits of the character storage unit.
+@item @code{CURRENT_TEAM}:
+The argument to @ref{GET_TEAM} to retrieve a handle of the current team.
+
@item @code{ERROR_UNIT}:
Identifies the preconnected unit used for error reporting.
@item @code{FILE_STORAGE_SIZE}:
Size in bits of the file-storage unit.
+@item @code{INTIAL_TEAM}:
+Argument to @ref{GET_TEAM} to retrieve a handle of the initial team.
+
@item @code{INPUT_UNIT}:
Identifies the preconnected unit identified by the asterisk
(@code{*}) in @code{READ} statement.
Identifies the preconnected unit identified by the asterisk
(@code{*}) in @code{WRITE} statement.
+@item @code{PARENT_TEAM}:
+Argument to @ref{GET_TEAM} to retrieve a handle to the parent team.
+
@item @code{REAL32}, @code{REAL64}, @code{REAL128}:
Kind type parameters to specify a REAL type with a storage
size of 32, 64, and 128 bits. It is negative if a target platform
{
static char get_team[] = "_gfortran_caf_get_team";
f->rank = 0;
- f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ f->ts.type = BT_DERIVED;
+ gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived);
+ if (!f->ts.u.derived
+ || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV)
+ {
+ gfc_error (
+ "GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV "
+ "to define its result type TEAM_TYPE",
+ &f->where);
+ f->ts.type = BT_UNKNOWN;
+ }
f->value.function.name = get_team;
-}
+ /* No requirements to resolve for level argument now. */
+}
/* Resolve image_index (...). */
/* Resolve team_number (team). */
void
-gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
+gfc_resolve_team_number (gfc_expr *f, gfc_expr *team)
{
static char team_number[] = "_gfortran_caf_team_number";
f->rank = 0;
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = team_number;
-}
+ if (team)
+ gfc_resolve_expr (team);
+}
void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \
gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \
+NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED, "stat_locked", \
GFC_STAT_LOCKED, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \
+NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED_OTHER_IMAGE, \
"stat_locked_other_image", \
GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \
- GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \
- GFC_STAT_FAILED_IMAGE, GFC_STD_F2018)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \
- GFC_STAT_UNLOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_STAT_STOPPED_IMAGE, "stat_stopped_image", \
+ GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_STAT_FAILED_IMAGE, "stat_failed_image", \
+ GFC_STAT_FAILED_IMAGE, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_STAT_UNLOCKED, "stat_unlocked", \
+ GFC_STAT_UNLOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INITIAL_TEAM, "initial_team", \
+ GFC_CAF_INITIAL_TEAM, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_PARENT_TEAM, "parent_team", \
+ GFC_CAF_PARENT_TEAM, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_CURRENT_TEAM, "current_team", \
+ GFC_CAF_CURRENT_TEAM, GFC_STD_F2018)
/* The arguments to NAMED_KINDARRAY are:
GFC_STAT_LOCKED,
GFC_STAT_LOCKED_OTHER_IMAGE,
GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
- GFC_STAT_FAILED_IMAGE = 6001
+ GFC_STAT_FAILED_IMAGE = 6001,
+ GFC_STAT_UNLOCKED_FAILED_IMAGE = 6002
}
libgfortran_stat_codes;
+typedef enum
+{
+ GFC_CAF_INITIAL_TEAM = 0,
+ GFC_CAF_PARENT_TEAM,
+ GFC_CAF_CURRENT_TEAM
+} libgfortran_team_levels;
+
typedef enum
{
GFC_CAF_ATOMIC_ADD = 1,
if (flag_coarray == GFC_FCOARRAY_SINGLE)
{
gfc_expr *result;
- result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
- result->rank = 0;
+ result = gfc_get_null_expr (&gfc_current_locus);
+ result->ts.type = BT_DERIVED;
+ gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived);
+
return result;
}
get_identifier (PREFIX ("caf_end_team")), ". w w w ", void_type_node, 3,
pint_type, pchar_type_node, size_type_node);
- gfor_fndecl_caf_get_team
- = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_get_team")),
- void_type_node, 1, integer_type_node);
+ gfor_fndecl_caf_get_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_get_team")), ". r ", pvoid_type_node, 1,
+ pint_type);
gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node,
get_identifier (PREFIX("caf_team_number")), ". r ",
integer_type_node, 1, integer_type_node);
- gfor_fndecl_caf_image_status
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_image_status")), ". . r ",
- integer_type_node, 2, integer_type_node, ppvoid_type_node);
+ gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_image_status")), ". r r ",
+ integer_type_node, 2, integer_type_node, ppvoid_type_node);
gfor_fndecl_caf_stopped_images
= gfc_build_library_function_decl_with_spec (
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
- args[0], build_int_cst (integer_type_node, -1));
+ args[0],
+ num_args < 2 ? null_pointer_node : args[1]);
else
gcc_unreachable ();
if (flag_coarray ==
GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
- {
- tree arg;
-
- arg = gfc_evaluate_now (args[0], &se->pre);
- tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- fold_convert (integer_type_node, arg),
- integer_one_node);
- tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
- tmp, integer_zero_node,
- build_int_cst (integer_type_node,
- GFC_STAT_STOPPED_IMAGE));
- }
+ tmp = gfc_evaluate_now (args[0], &se->pre);
else if (flag_coarray == GFC_FCOARRAY_SINGLE)
{
// the value -1 represents that no team has been created yet
}
else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
- args[0], build_int_cst (integer_type_node, -1));
+ args[0]);
else if (flag_coarray == GFC_FCOARRAY_LIB)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
- integer_zero_node, build_int_cst (integer_type_node, -1));
+ null_pointer_node);
else
gcc_unreachable ();
case GFC_ISYM_GETGID:
case GFC_ISYM_GETPID:
case GFC_ISYM_GETUID:
+ case GFC_ISYM_GET_TEAM:
case GFC_ISYM_HOSTNM:
case GFC_ISYM_IERRNO:
case GFC_ISYM_IRAND:
--- /dev/null
+!{ dg-do compile }
+
+! PR 97210
+! Tests get_team syntax
+
+ use iso_fortran_env
+ implicit none
+ type(team_type) :: team, ret
+ integer :: level
+
+ ret = get_team()
+ ret = get_team('abc') !{ dg-error "must be INTEGER" }
+ ret = get_team(level, 'abc') !{ dg-error "Too many arguments" }
+ ret = get_team([1,2]) !{ dg-error "must be a scalar" }
+ ret = get_team(team) !{ dg-error "must be INTEGER" }
+
+ ret = get_team(INITIAL_TEAM)
+ ret = get_team(CURRENT_TEAM)
+ ret = get_team(PARENT_TEAM)
+ ret = get_team(INITIAL_TEAM, CURRENT_TEAM) !{ dg-error "Too many arguments" }
+
+ level = INITIAL_TEAM
+ ret = get_team(level)
+ ret = get_team(99) !{ dg-error "specify one of the INITIAL_TEAM, PARENT_TEAM" }
+ level = 99
+ ret = get_team(level)
+ level = get_team() !{ dg-error "Cannot convert TYPE\\(team_type\\)" }
+end
+
isv = image_status(k2) ! Ok
isv = image_status(k4) ! Ok
isv = image_status(k8) ! Ok
- isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) not yet supported" }
+ isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" }
isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
program p
block
- integer :: a(get_team()) = 1 ! { dg-error "Automatic array" }
+ integer :: a(get_team()) = 1 ! { dg-error "Automatic array | ISO_FORTRAN_ENV | must be of INTEGER" }
print *, a
end block
end
--- /dev/null
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original" }
+
+! PR 87939
+! Tests get_team
+
+ use iso_fortran_env
+ implicit none
+ type(team_type) :: team, ret
+ integer :: new_team, level
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+
+ ret = get_team()
+ ret = get_team(INITIAL_TEAM)
+ ret = get_team(PARENT_TEAM)
+ ret = get_team(CURRENT_TEAM)
+ level = INITIAL_TEAM
+ ret = get_team(level)
+
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(0B\\)" "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get_team \\(&C\.\[0-9\]+\\)" 3 "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(&level\\)" "original" } }
! { dg-do run }
! { dg-options "-fcoarray=single" }
!
-! Tests if team_number intrinsic fucntion works
+! Tests if team_number intrinsic function works
!
use iso_fortran_env, only : team_type
implicit none
- type(team_type) team
+ type(team_type) :: team
integer, parameter :: standard_initial_value=-1
- integer new_team
+ integer :: new_team
if (team_number()/=standard_initial_value) STOP 1
CAF_STAT_LOCKED,
CAF_STAT_LOCKED_OTHER_IMAGE,
CAF_STAT_STOPPED_IMAGE = 6000,
- CAF_STAT_FAILED_IMAGE = 6001
+ CAF_STAT_FAILED_IMAGE = 6001,
+ CAF_STAT_UNLOCKED_FAILED_IMAGE = 6002
}
caf_stat_codes_t;
+/* Definitions of the Fortran 2018 standard; need to kept in sync with
+ ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */
+typedef enum
+{
+ CAF_INITIAL_TEAM = 0,
+ CAF_PARENT_TEAM,
+ CAF_CURRENT_TEAM
+} caf_team_level_t;
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
void _gfortran_caf_change_team (caf_team_t, int *, char *, size_t);
void _gfortran_caf_end_team (int *, char *, size_t);
void _gfortran_caf_sync_team (caf_team_t, int *, char *, size_t);
+int _gfortran_caf_team_number (caf_team_t);
+caf_team_t _gfortran_caf_get_team (int32_t *);
#endif /* LIBCAF_H */
if (stat)
*stat = 0;
}
+
+int
+_gfortran_caf_team_number (caf_team_t team)
+{
+ return ((caf_single_team_t) team)->team_no;
+}
+
+caf_team_t
+_gfortran_caf_get_team (int32_t *level)
+{
+ if (!level)
+ return caf_team_stack;
+
+ switch ((caf_team_level_t) *level)
+ {
+ case CAF_INITIAL_TEAM:
+ return caf_initial_team;
+ case CAF_PARENT_TEAM:
+ return caf_team_stack->parent ? caf_team_stack->parent : caf_team_stack;
+ case CAF_CURRENT_TEAM:
+ return caf_team_stack;
+ default:
+ caf_runtime_error ("Illegal value for GET_TEAM");
+ }
+ return NULL; /* To prevent any warnings. */
+}
projects / thirdparty / gcc.git / commitdiff
