+2018-01-26 Damian Rouson <damian@sourceryinstitute.org>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+ Soren Rasmussen <s.c.rasmussen@gmail.com>
+
+ Partial support for Fortran 2018 teams features.
+
+ * array.c (gfc_match_array_ref): add team attribute in coarray
+ transfers.
+ * check.c (gfc_check_get_team, gfc_check_team_number): add new
+ functions for get_team and team_number.
+ * dump-parse-tree.c (show_code_node): add new statements: form team,
+ change team, end team, and sync team.
+ * expr.c (gfc_find_team_co): add new function.
+ * gfortran.h: add new statements.
+ * intrinsic.c (add_functions): add get_team and team_number functions.
+ * intrinsic.h: add get_team and team_number prototypes for check,
+ simplify, and resolve.
+ * iresolve.c (gfc_resolve_get_team, gfc_resolve_team_number): add new
+ functions.
+ * iso-fortran-env.def: add the team_type derived type.
+ * match.c (gfc_match_if, gfc_match_form_team, gfc_match_team_number)
+ (gfc_match_end_team, gfc_match_sync_team, gfc_match_change_team):
+ add change team, end team, form team, sync team match and functions.
+ * match.h: add new prototypes for change team, end team, form team,
+ and sync team.
+ * parse.c (decode_statement): add cases for change team, end team,
+ form team, and sync team.
+ * resolve.c: add cases for exec form team, change team, end team, and
+ sync team.
+ * simplify.c (gfc_simplify_get_team): add new function for get team.
+ * st.c (gfc_free_statement): add cases exec for change team, end team,
+ form team, sync team.
+ * trans-decl.c (gfor_fndecl_caf_form_team)
+ (gfor_fndecl_caf_change_team, gfor_fndecl_caf_end_team)
+ (gfor_fndecl_caf_sync_team, gfor_fndecl_caf_get_team)
+ (gfor_fndecl_caf_team_number): add functions and definitions.
+ * trans-intrinsic.c (conv_caf_send, conv_intrinsic_team_number): add
+ new function and team_type argument support.
+ * trans-stmt.c (gfc_trans_form_team, gfc_trans_change_team)
+ (gfc_trans_end_team, gfc_trans_sync_team): add new functions.
+ * trans-stmt.h: add new prototypes.
+ * trans-types.c (gfc_get_derived_type): check condition for team_type.
+ * trans.c (trans_code): new exec cases for form team, change team, end
+ team, and sync team.
+ * trans.h: add new prototypes.
+
2018-01-26 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/83998
bool matched_bracket = false;
gfc_expr *tmp;
bool stat_just_seen = false;
+ bool team_just_seen = false;
memset (ar, '\0', sizeof (*ar));
if (m == MATCH_ERROR)
return MATCH_ERROR;
+ team_just_seen = false;
stat_just_seen = false;
- if (gfc_match(" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
+ if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL)
+ {
+ ar->team = tmp;
+ team_just_seen = true;
+ }
+
+ if (ar->team && !team_just_seen)
+ {
+ gfc_error ("TEAM= attribute in %C misplaced");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
{
ar->stat = tmp;
stat_just_seen = true;
}
+bool
+gfc_check_get_team (gfc_expr *level)
+{
+ 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;
+ }
+ return true;
+}
+
+
bool
gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
gfc_expr *new_val, gfc_expr *stat)
return false;
}
}
-
+
if (array->rank == 1 || boundary->rank == 0)
{
if (!scalar_check (boundary, 2))
case BT_COMPLEX:
case BT_CHARACTER:
break;
-
+
default:
gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
"of type %qs", gfc_current_intrinsic_arg[2]->name,
}
+bool
+gfc_check_team_number (gfc_expr *team)
+{
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ 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;
+}
+
+
bool
gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
{
fputs ("FAIL IMAGE ", dumpfile);
break;
+ case EXEC_CHANGE_TEAM:
+ fputs ("CHANGE TEAM", dumpfile);
+ break;
+
+ case EXEC_END_TEAM:
+ fputs ("END TEAM", dumpfile);
+ break;
+
+ case EXEC_FORM_TEAM:
+ fputs ("FORM TEAM", dumpfile);
+ break;
+
+ case EXEC_SYNC_TEAM:
+ fputs ("SYNC TEAM", dumpfile);
+ break;
+
case EXEC_SYNC_ALL:
fputs ("SYNC ALL ", dumpfile);
if (c->expr2 != NULL)
}
gfc_expr *
-gfc_find_stat_co(gfc_expr *e)
+gfc_find_team_co (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return ref->u.ar.team;
+
+ if (e->value.function.actual->expr)
+ for (ref = e->value.function.actual->expr->ref; ref;
+ ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return ref->u.ar.team;
+
+ return NULL;
+}
+
+gfc_expr *
+gfc_find_stat_co (gfc_expr *e)
{
gfc_ref *ref;
ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
- ST_EVENT_WAIT,ST_FAIL_IMAGE,ST_NONE
+ ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM,
+ ST_END_TEAM, ST_SYNC_TEAM, ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
GFC_ISYM_GETGID,
GFC_ISYM_GETLOG,
GFC_ISYM_GETPID,
+ GFC_ISYM_GET_TEAM,
GFC_ISYM_GETUID,
GFC_ISYM_GMTIME,
GFC_ISYM_HOSTNM,
GFC_ISYM_SYSTEM_CLOCK,
GFC_ISYM_TAN,
GFC_ISYM_TANH,
+ GFC_ISYM_TEAM_NUMBER,
GFC_ISYM_THIS_IMAGE,
GFC_ISYM_TIME,
GFC_ISYM_TIME8,
int dimen; /* # of components in the reference */
int codimen;
bool in_allocate; /* For coarray checks. */
+ gfc_expr *team;
gfc_expr *stat;
locus where;
gfc_array_spec *as;
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
+ EXEC_FORM_TEAM, EXEC_CHANGE_TEAM, EXEC_END_TEAM, EXEC_SYNC_TEAM,
EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT, EXEC_FAIL_IMAGE,
EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA,
int gfc_get_corank (gfc_expr *);
bool gfc_has_ultimate_allocatable (gfc_expr *);
bool gfc_has_ultimate_pointer (gfc_expr *);
+gfc_expr* gfc_find_team_co (gfc_expr *);
gfc_expr* gfc_find_stat_co (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
locus, unsigned, ...);
int kind3, int optional3, sym_intent intent3, const char *a4,
bt type4, int kind4, int optional4, sym_intent intent4,
const char *a5, bt type5, int kind5, int optional5,
- sym_intent intent5)
+ sym_intent intent5)
{
gfc_check_f cf;
gfc_simplify_f sf;
*num = "number", *tm = "time", *nm = "name", *md = "mode",
*vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
*ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed",
- *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", *back = "back";
+ *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", *back = "back",
+ *team = "team", *image = "image", *level = "level";
int di, dr, dd, dl, dc, dz, ii;
NULL, gfc_simplify_abs, gfc_resolve_abs,
a, BT_COMPLEX, dz, REQUIRED);
- add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
- NULL, gfc_simplify_abs, gfc_resolve_abs,
+ add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
+ NULL, gfc_simplify_abs, gfc_resolve_abs,
a, BT_COMPLEX, dd, REQUIRED);
make_alias ("cdabs", GFC_STD_GNU);
make_alias ("imag", GFC_STD_GNU);
make_alias ("imagpart", GFC_STD_GNU);
- add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
- NULL, gfc_simplify_aimag, gfc_resolve_aimag,
+ add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
+ NULL, gfc_simplify_aimag, gfc_resolve_aimag,
z, BT_COMPLEX, dd, REQUIRED);
make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
x, BT_REAL, dd, REQUIRED);
make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
-
+
add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh,
gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED);
y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
-
+
add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh,
gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED);
y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
-
+
/* Bessel and Neumann functions for G77 compatibility. */
add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
- add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY,
+ add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY,
ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL);
make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
z, BT_COMPLEX, dz, REQUIRED);
add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
- NULL, gfc_simplify_conjg, gfc_resolve_conjg,
+ NULL, gfc_simplify_conjg, gfc_resolve_conjg,
z, BT_COMPLEX, dd, REQUIRED);
make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
x, BT_COMPLEX, dz, REQUIRED);
add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
- NULL, gfc_simplify_cos, gfc_resolve_cos,
+ NULL, gfc_simplify_cos, gfc_resolve_cos,
x, BT_COMPLEX, dd, REQUIRED);
make_alias ("cdcos", GFC_STD_GNU);
x, BT_COMPLEX, dz, REQUIRED);
add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
- NULL, gfc_simplify_exp, gfc_resolve_exp,
+ NULL, gfc_simplify_exp, gfc_resolve_exp,
x, BT_COMPLEX, dd, REQUIRED);
make_alias ("cdexp", GFC_STD_GNU);
ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS,
gfc_check_failed_or_stopped_images,
gfc_simplify_failed_or_stopped_images,
- gfc_resolve_failed_images, "team", BT_VOID, di, OPTIONAL,
- "kind", BT_INTEGER, di, OPTIONAL);
+ gfc_resolve_failed_images, team, BT_VOID, di, OPTIONAL,
+ kind, BT_INTEGER, di, OPTIONAL);
add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
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_F2008_TS,
+ gfc_check_get_team, NULL, 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);
add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008_TS, gfc_check_image_status,
- gfc_simplify_image_status, gfc_resolve_image_status, "image",
- BT_INTEGER, di, REQUIRED, "team", BT_VOID, di, OPTIONAL);
+ gfc_simplify_image_status, gfc_resolve_image_status, image,
+ BT_INTEGER, di, REQUIRED, team, BT_VOID, di, OPTIONAL);
/* The resolution function for INDEX is called gfc_resolve_index_func
because the name gfc_resolve_index is already used in resolve.c. */
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
-
+
add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
x, BT_REAL, dr, REQUIRED);
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL,
back, BT_LOGICAL, dl, OPTIONAL);
-
+
make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
-
+
add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
- /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */
+ /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */
add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY,
ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
NULL, gfc_simplify_compiler_options, NULL);
ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS,
gfc_check_failed_or_stopped_images,
gfc_simplify_failed_or_stopped_images,
- gfc_resolve_stopped_images, "team", BT_VOID, di, OPTIONAL,
- "kind", BT_INTEGER, di, OPTIONAL);
+ gfc_resolve_stopped_images, team, BT_VOID, di, OPTIONAL,
+ kind, BT_INTEGER, di, OPTIONAL);
add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_resolve_storage_size,
a, BT_UNKNOWN, 0, REQUIRED,
kind, BT_INTEGER, di, OPTIONAL);
-
+
add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
+ add_sym_1 ("team_number", GFC_ISYM_TEAM_NUMBER, CLASS_TRANSFORMATIONAL,
+ ACTUAL_YES, BT_INTEGER, di, GFC_STD_F2008_TS,
+ gfc_check_team_number, NULL, gfc_resolve_team_number,
+ team, BT_DERIVED, di, OPTIONAL);
+
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,
bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
-
+
add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
x, BT_UNKNOWN, 0, REQUIRED);
-
+
make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
if (flag_dec_math)
first_expr = arg->expr;
for ( ; arg && arg->expr; arg = arg->next, n++)
- if (!gfc_check_conformance (first_expr, arg->expr,
+ if (!gfc_check_conformance (first_expr, arg->expr,
"arguments '%s' and '%s' for "
- "intrinsic '%s'",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[n]->name,
+ "intrinsic '%s'",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic))
return false;
}
/* Try to find an intrinsic of the same name. */
if (func)
isym = gfc_find_function (sym->name);
- else
+ else
isym = gfc_find_subroutine (sym->name);
/* If no intrinsic was found with this name or it's not included in the
selected standard, everything's fine. */
- if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true,
+ if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true,
sym->declared_at))
return;
bool gfc_check_fn_rc (gfc_expr *);
bool gfc_check_fn_rc2008 (gfc_expr *);
bool gfc_check_fnum (gfc_expr *);
+bool gfc_check_get_team (gfc_expr *);
bool gfc_check_hostnm (gfc_expr *);
bool gfc_check_huge (gfc_expr *);
bool gfc_check_hypot (gfc_expr *, gfc_expr *);
bool gfc_check_storage_size (gfc_expr *, gfc_expr *);
bool gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_symlnk (gfc_expr *, gfc_expr *);
+bool gfc_check_team_number (gfc_expr *);
bool gfc_check_transf_bit_intrins (gfc_actual_arglist *);
bool gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_transpose (gfc_expr *);
gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_fraction (gfc_expr *);
gfc_expr *gfc_simplify_gamma (gfc_expr *);
+gfc_expr *gfc_simplify_get_team (gfc_expr *);
gfc_expr *gfc_simplify_huge (gfc_expr *);
gfc_expr *gfc_simplify_hypot (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_iachar (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 *);
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_team_number (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 *);
#include "constructor.h"
#include "arith.h"
-/* Given printf-like arguments, return a stable version of the result string.
+/* Given printf-like arguments, return a stable version of the result string.
We already have a working, optimized string hashing table in the form of
- the identifier table. Reusing this table is likely not to be wasted,
+ the identifier table. Reusing this table is likely not to be wasted,
since if the function name makes it to the gimple output of the frontend,
we'll have to create the identifier anyway. */
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts.type = a->ts.type;
f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts.type = a->ts.type;
f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts = x->ts;
if (n->ts.kind != gfc_c_int_kind)
{
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts = x->ts;
f->rank = 1;
if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
m = gfc_default_integer_kind;
if (dim != NULL)
m = m < dim->ts.kind ? dim->ts.kind : m;
-
+
/* Convert shift to at least m, so we don't need
kind=1 and kind=2 versions of the library functions. */
if (shift->ts.kind < m)
ts.kind = m;
gfc_convert_type_warn (shift, &ts, 2, 0);
}
-
+
if (dim != NULL)
{
if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts.type = BT_CHARACTER;
f->ts.kind = gfc_default_character_kind;
m = gfc_default_integer_kind;
if (dim != NULL)
m = m < dim->ts.kind ? dim->ts.kind : m;
-
+
/* Convert shift to at least m, so we don't need
kind=1 and kind=2 versions of the library functions. */
if (shift->ts.kind < m)
ts.kind = m;
gfc_convert_type_warn (shift, &ts, 2, 0);
}
-
+
if (dim != NULL)
{
if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
- kinds to the largest value. The Fortran 95 standard requires the
+ kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
- kinds to the largest value. The Fortran 95 standard requires the
+ kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
- kinds to the largest value. The Fortran 95 standard requires the
+ kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts.type = BT_LOGICAL;
f->ts.kind = gfc_default_integer_kind;
if (u->ts.kind != gfc_c_int_kind)
mpz_init_set (f->shape[0], b->shape[1]);
}
}
- else
+ else
{
/* b->rank == 1 and a->rank == 2 here, all other cases have
been caught in check.c. */
}
+/* Resolve get_team (). */
+
+void
+gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
+{
+ static char get_team[] = "_gfortran_caf_get_team";
+ f->rank = 0;
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = get_team;
+}
+
+
/* Resolve image_index (...). */
void
}
+/* Resolve team_number (team). */
+
+void
+gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
+{
+ 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;
+}
+
+
void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *distance ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
f->ts.type = BT_CHARACTER;
f->ts.kind = gfc_default_character_kind;
name = gfc_get_string (PREFIX ("random_r%d"), kind);
else
name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
-
+
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
-
+
void
gfc_resolve_link_sub (gfc_code *c)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
/* ctime TIME argument is a INTEGER(KIND=8), says the doc */
if (c->ext.actual->expr->ts.kind != 8)
{
}
-void
+void
gfc_resolve_fseek_sub (gfc_code *c)
{
gfc_expr *unit;
{
gfc_typespec ts;
gfc_clear_ts (&ts);
-
+
if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
{
ts.type = BT_INTEGER;
? get_int_kind_from_node (ptr_type_node)
: gfc_default_integer_kind, GFC_STD_F2008_TS)
+NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \
+ flag_coarray == GFC_FCOARRAY_LIB
+ ? get_int_kind_from_node (ptr_type_node)
+ : gfc_default_integer_kind, GFC_STD_F2008_TS)
+
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
match ("backspace", gfc_match_backspace, ST_BACKSPACE)
match ("call", gfc_match_call, ST_CALL)
+ match ("change team", gfc_match_change_team, ST_CHANGE_TEAM)
match ("close", gfc_match_close, ST_CLOSE)
match ("continue", gfc_match_continue, ST_CONTINUE)
match ("cycle", gfc_match_cycle, ST_CYCLE)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
+ match ("end team", gfc_match_end_team, ST_END_TEAM)
match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
match ("event post", gfc_match_event_post, ST_EVENT_POST)
match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
+ match ("form team", gfc_match_form_team, ST_FORM_TEAM)
match ("go to", gfc_match_goto, ST_GOTO)
match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
match ("inquire", gfc_match_inquire, ST_INQUIRE)
match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
+ match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM)
match ("unlock", gfc_match_unlock, ST_UNLOCK)
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
return MATCH_ERROR;
}
+/* Match a FORM TEAM statement. */
+
+match
+gfc_match_form_team (void)
+{
+ match m;
+ gfc_expr *teamid,*team;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "FORM TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ goto syntax;
+
+ new_st.op = EXEC_FORM_TEAM;
+
+ if (gfc_match ("%e", &teamid) != MATCH_YES)
+ goto syntax;
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (gfc_match ("%e", &team) != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_char (')');
+ if (m == MATCH_NO)
+ goto syntax;
+
+ new_st.expr1 = teamid;
+ new_st.expr2 = team;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORM_TEAM);
+
+ return MATCH_ERROR;
+}
+
+/* Match a CHANGE TEAM statement. */
+
+match
+gfc_match_change_team (void)
+{
+ match m;
+ gfc_expr *team;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "CHANGE TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ goto syntax;
+
+ new_st.op = EXEC_CHANGE_TEAM;
+
+ if (gfc_match ("%e", &team) != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_char (')');
+ if (m == MATCH_NO)
+ goto syntax;
+
+ new_st.expr1 = team;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_CHANGE_TEAM);
+
+ return MATCH_ERROR;
+}
+
+/* Match a END TEAM statement. */
+
+match
+gfc_match_end_team (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "END TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_YES)
+ goto syntax;
+
+ new_st.op = EXEC_END_TEAM;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_END_TEAM);
+
+ return MATCH_ERROR;
+}
+
+/* Match a SYNC TEAM statement. */
+
+match
+gfc_match_sync_team (void)
+{
+ match m;
+ gfc_expr *team;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "SYNC TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ goto syntax;
+
+ new_st.op = EXEC_SYNC_TEAM;
+
+ if (gfc_match ("%e", &team) != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_char (')');
+ if (m == MATCH_NO)
+ goto syntax;
+
+ new_st.expr1 = team;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_SYNC_TEAM);
+
+ return MATCH_ERROR;
+}
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )
match gfc_match_event_wait (void);
match gfc_match_critical (void);
match gfc_match_fail_image (void);
+match gfc_match_change_team (void);
+match gfc_match_end_team (void);
+match gfc_match_form_team (void);
+match gfc_match_sync_team (void);
match gfc_match_block (void);
match gfc_match_associate (void);
match gfc_match_do (void);
case 'c':
match ("call", gfc_match_call, ST_CALL);
+ match ("change team", gfc_match_change_team, ST_CHANGE_TEAM);
match ("close", gfc_match_close, ST_CLOSE);
match ("continue", gfc_match_continue, ST_CONTINUE);
match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
case 'e':
match ("end file", gfc_match_endfile, ST_END_FILE);
+ match ("end team", gfc_match_end_team, ST_END_TEAM);
match ("exit", gfc_match_exit, ST_EXIT);
match ("else", gfc_match_else, ST_ELSE);
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
match ("final", gfc_match_final_decl, ST_FINAL);
match ("flush", gfc_match_flush, ST_FLUSH);
+ match ("form team", gfc_match_form_team, ST_FORM_TEAM);
match ("format", gfc_match_format, ST_FORMAT);
break;
match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
+ match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM);
break;
case 't':
case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
case ST_ERROR_STOP: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
+ case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
+ case ST_END_TEAM: case ST_SYNC_TEAM: \
case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
case ST_FAIL_IMAGE:
p = "FAIL IMAGE";
break;
+ case ST_CHANGE_TEAM:
+ p = "CHANGE TEAM";
+ break;
+ case ST_END_TEAM:
+ p = "END TEAM";
+ break;
+ case ST_FORM_TEAM:
+ p = "FORM TEAM";
+ break;
+ case ST_SYNC_TEAM:
+ p = "SYNC TEAM";
+ break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
break;
case EXEC_FAIL_IMAGE:
+ case EXEC_FORM_TEAM:
+ case EXEC_CHANGE_TEAM:
+ case EXEC_END_TEAM:
+ case EXEC_SYNC_TEAM:
break;
case EXEC_ENTRY:
}
+gfc_expr *
+gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
+{
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_current_locus = *gfc_current_intrinsic_where;
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return &gfc_bad_expr;
+ }
+
+ 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;
+ return result;
+ }
+
+ /* For fcoarray = lib no simplification is possible, because it is not known
+ what images failed or are stopped at compile time. */
+ return NULL;
+}
+
+
gfc_expr *
gfc_simplify_float (gfc_expr *a)
{
#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
- /* MPFR versions before 3.1.0 do not include mpfr_frexp.
+ /* MPFR versions before 3.1.0 do not include mpfr_frexp.
TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
if (mpfr_sgn (x->value.real) == 0)
|| !gfc_is_constant_expr (size))
return NULL;
- if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+ if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, &result_length))
return NULL;
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
case EXEC_FAIL_IMAGE:
+ case EXEC_CHANGE_TEAM:
+ case EXEC_END_TEAM:
+ case EXEC_FORM_TEAM:
+ case EXEC_SYNC_TEAM:
break;
case EXEC_BLOCK:
tree gfor_fndecl_caf_failed_images;
tree gfor_fndecl_caf_image_status;
tree gfor_fndecl_caf_stopped_images;
+tree gfor_fndecl_caf_form_team;
+tree gfor_fndecl_caf_change_team;
+tree gfor_fndecl_caf_end_team;
+tree gfor_fndecl_caf_sync_team;
+tree gfor_fndecl_caf_get_team;
+tree gfor_fndecl_caf_team_number;
tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
jtype = gfc_get_int_type (ikinds[jkind]);
if (itype && jtype)
{
- sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
+ sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
ikinds[jkind]);
gfor_fndecl_math_powi[jkind][ikind].integer =
gfc_build_library_function_decl (get_identifier (name),
rtype = gfc_get_real_type (rkinds[rkind]);
if (rtype && itype)
{
- sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
+ sprintf (name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
ikinds[ikind]);
gfor_fndecl_math_powi[rkind][ikind].real =
gfc_build_library_function_decl (get_identifier (name),
ctype = gfc_get_complex_type (rkinds[rkind]);
if (ctype && itype)
{
- sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
+ sprintf (name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
ikinds[ikind]);
gfor_fndecl_math_powi[rkind][ikind].cmplx =
gfc_build_library_function_decl (get_identifier (name),
boolean_type_node, pint_type);
gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_send")), ".R.RRRRRRW", void_type_node, 10,
+ get_identifier (PREFIX("caf_send")), ".R.RRRRRRWR", void_type_node, 11,
pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
- boolean_type_node, pint_type);
+ boolean_type_node, pint_type, pvoid_type_node);
gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
void_type_node, 3, pvoid_type_node, ppvoid_type_node,
integer_type_node);
+ gfor_fndecl_caf_form_team
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_form_team")), "RWR",
+ void_type_node, 3, integer_type_node, ppvoid_type_node,
+ integer_type_node);
+
+ gfor_fndecl_caf_change_team
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_change_team")), "RR",
+ void_type_node, 2, ppvoid_type_node,
+ integer_type_node);
+
+ gfor_fndecl_caf_end_team
+ = gfc_build_library_function_decl (
+ get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
+
+ gfor_fndecl_caf_get_team
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_get_team")), "R",
+ void_type_node, 1, integer_type_node);
+
+ gfor_fndecl_caf_sync_team
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_sync_team")), "RR",
+ void_type_node, 2, ppvoid_type_node,
+ integer_type_node);
+
+ gfor_fndecl_caf_team_number
+ = gfc_build_library_function_decl_with_spec (
+ 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")), "RR",
static tree
conv_caf_send (gfc_code *code) {
- gfc_expr *lhs_expr, *rhs_expr, *tmp_stat;
+ gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
gfc_se lhs_se, rhs_se;
stmtblock_t block;
tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
- tree may_require_tmp, src_stat, dst_stat;
+ tree may_require_tmp, src_stat, dst_stat, dst_team;
tree lhs_type = NULL_TREE;
tree vec = null_pointer_node, rhs_vec = null_pointer_node;
symbol_attribute lhs_caf_attr, rhs_caf_attr;
lhs_caf_attr = gfc_caf_attr (lhs_expr);
rhs_caf_attr = gfc_caf_attr (rhs_expr);
src_stat = dst_stat = null_pointer_node;
+ dst_team = null_pointer_node;
/* LHS. */
gfc_init_se (&lhs_se, NULL);
gfc_add_block_to_block (&block, &stat_se.post);
}
+ tmp_team = gfc_find_team_co (lhs_expr);
+
+ if (tmp_team)
+ {
+ gfc_se team_se;
+ gfc_init_se (&team_se, NULL);
+ gfc_conv_expr_reference (&team_se, tmp_team);
+ dst_team = team_se.expr;
+ gfc_add_block_to_block (&block, &team_se.pre);
+ gfc_add_block_to_block (&block, &team_se.post);
+ }
+
if (!gfc_is_coindexed (rhs_expr))
{
if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
may_require_tmp, dst_realloc, src_stat);
}
else
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10,
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
token, offset, image_index, lhs_se.expr, vec,
rhs_se.expr, lhs_kind, rhs_kind,
- may_require_tmp, src_stat);
+ may_require_tmp, src_stat, dst_team);
}
else
{
se->expr = tmp;
}
+static void
+conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
+{
+ unsigned int num_args;
+
+ tree *args, tmp;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, num_args);
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+
+ 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));
+ }
+ else if (flag_coarray == GFC_FCOARRAY_SINGLE)
+ {
+ // the value -1 represents that no team has been created yet
+ tmp = build_int_cst (integer_type_node, -1);
+ }
+ 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));
+ 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));
+ else
+ gcc_unreachable ();
+
+ se->expr = tmp;
+}
+
static void
trans_image_index (gfc_se * se, gfc_expr *expr)
build_int_cst (type, 0), tmp);
}
-
static void
trans_num_images (gfc_se * se, gfc_expr *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);
se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
}
-
static void
gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
{
/* Special case for character maxloc. Remove unneeded actual
arguments, then call a library function. */
-
+
if (arrayexpr->ts.type == BT_CHARACTER)
{
gfc_actual_arglist *a, *b;
gfc_free_symbol (sym);
}
-
/* The length of a character string. */
static void
gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
case GFC_ISYM_MINLOC:
gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
break;
-
+
case GFC_ISYM_MAXLOC:
gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
break;
gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
break;
+ case GFC_ISYM_TEAM_NUMBER:
+ conv_intrinsic_team_number (se, expr);
+ break;
+
case GFC_ISYM_TRANSFER:
if (se->ss && se->ss->info->useflags)
/* Access the previously obtained result. */
case GFC_ISYM_CSHIFT:
case GFC_ISYM_EOSHIFT:
+ case GFC_ISYM_GET_TEAM:
case GFC_ISYM_FAILED_IMAGES:
case GFC_ISYM_STOPPED_IMAGES:
case GFC_ISYM_PACK:
}
}
+/* Translate the FORM TEAM statement. */
+
+tree
+gfc_trans_form_team (gfc_code *code)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se argse;
+ tree team_id,team_type;
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_id = fold_convert (integer_type_node, argse.expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_form_team, 3,
+ team_id, team_type,
+ build_int_cst (integer_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the CHANGE TEAM statement. */
+
+tree
+gfc_trans_change_team (gfc_code *code)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se argse;
+ tree team_type;
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_change_team, 2, team_type,
+ build_int_cst (integer_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the END TEAM statement. */
+
+tree
+gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_end_team, 1,
+ build_int_cst (pchar_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the SYNC TEAM statement. */
+
+tree
+gfc_trans_sync_team (gfc_code *code)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se argse;
+ tree team_type;
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_sync_team, 2,
+ team_type,
+ build_int_cst (integer_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
tree
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
tree gfc_trans_fail_image (gfc_code *);
tree gfc_trans_forall (gfc_code *);
+tree gfc_trans_form_team (gfc_code *);
+tree gfc_trans_change_team (gfc_code *);
+tree gfc_trans_end_team (gfc_code *);
+tree gfc_trans_sync_team (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
tree gfc_trans_deallocate (gfc_code *);
|| (flag_coarray == GFC_FCOARRAY_LIB
&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
- || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
+ || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
+ || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
return ptr_type_node;
if (flag_coarray != GFC_FCOARRAY_LIB
&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
+ || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
return gfc_get_int_type (gfc_default_integer_kind);
if (derived && derived->attr.flavor == FL_PROCEDURE
res = gfc_trans_forall (code);
break;
+ case EXEC_FORM_TEAM:
+ res = gfc_trans_form_team (code);
+ break;
+
+ case EXEC_CHANGE_TEAM:
+ res = gfc_trans_change_team (code);
+ break;
+
+ case EXEC_END_TEAM:
+ res = gfc_trans_end_team (code);
+ break;
+
+ case EXEC_SYNC_TEAM:
+ res = gfc_trans_sync_team (code);
+ break;
+
case EXEC_WHERE:
res = gfc_trans_where (code);
break;
extern GTY(()) tree gfor_fndecl_caf_failed_images;
extern GTY(()) tree gfor_fndecl_caf_image_status;
extern GTY(()) tree gfor_fndecl_caf_stopped_images;
+extern GTY(()) tree gfor_fndecl_caf_form_team;
+extern GTY(()) tree gfor_fndecl_caf_change_team;
+extern GTY(()) tree gfor_fndecl_caf_end_team;
+extern GTY(()) tree gfor_fndecl_caf_get_team;
+extern GTY(()) tree gfor_fndecl_caf_sync_team;
+extern GTY(()) tree gfor_fndecl_caf_team_number;
extern GTY(()) tree gfor_fndecl_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
+2018-01-26 Damian Rouson <damian@sourceryinstitute.org>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+ Soren Rasmussen <s.c.rasmussen@gmail.com>
+
+ Fortran 2018 teams tests.
+
+ * gfortran.dg/team_number_1.f90: new test for team_number.
+ * gfortran.dg/team_change_1.f90: new test for change team.
+ * gfortran.dg/team_end_1.f90: new test for end team.
+ * gfortran.dg/team_form_1.f90: new test for form team.
+
2018-01-26 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/83998
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Tests if change team worked
+!
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) team
+ integer new_team
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+ change team (team)
+ if (team_number()/=new_team) call abort
+ end team
+
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Tests if team_number intrinsic fucntion works
+!
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) :: team
+ integer, parameter :: standard_initial_value=-1
+
+ associate(new_team => mod(this_image(),2)+1)
+ form team (new_team,team)
+ change team (team)
+ end team
+ end associate
+
+ if (team_number()/=standard_initial_value) call abort
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Tests if form team works
+!
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) :: team
+
+ form team (mod(this_image(),2)+1,team)
+
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Tests if team_number intrinsic fucntion works
+!
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) team
+ integer, parameter :: standard_initial_value=-1
+ integer new_team
+
+ if (team_number()/=standard_initial_value) call abort
+
+ new_team = mod(this_image(),2)+1
+ form team (new_team,team)
+ change team (team)
+ if (team_number()/=new_team) call abort
+ end team
+
+ if (team_number()/=standard_initial_value) call abort
+
+end
projects / thirdparty / gcc.git / commitdiff
