diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md new file mode 100644 index 0000000000000..9f5edd5efa733 --- /dev/null +++ b/.github/ISSUE_TEMPLATE.md @@ -0,0 +1,54 @@ + + + + + + + + + + +Please make sure to put any logs, terminal output, or code in +[fenced code blocks]. + +# Defect/Bug Report # + + +The title of the issue should start with `Defect:` followed by a +succinct title. + + + +- GCC fork release tag or git hash: +- GCC version used to build this fork: +- Output of `uname -a`: +- Machine architecture and number of physical cores: + +## Observed Behavior ## + +## Expected Behavior ## + +## Steps to Reproduce ## + +# Question # + + +The title of the issue should start with `Question:` followed by a +succinct title. Add the text of your question here. Be specific. Search for +answers on [Google] and [Stack Overflow] +before asking a new question + +# Request for Enhancement (RFE) # + + +The title of the issue should start with `RFE:` followed by a succinct +title. If you are willing to help out, please review the [Contributing to GCC] +page. + +[links]:# +[Google]: https://www.google.com +[Stack Overflow]: https://stackoverflow.com +[fenced codeblocks]: https://help.github.com/articles/creating-and-highlighting-code-blocks/ +[CONTRIBUTING.md]: https://github.com/sourceryinstitute/OpenCoarrays/blob/master/CONTRIBUTING.md +[Helping Out]: https://github.com/sourceryinstitute/OpenCoarrays/blob/master/CONTRIBUTING.md#helping-out +[Contributing to GCC]: https://gcc.gnu.org/contribute.html diff --git a/README.md b/README.md new file mode 100644 index 0000000000000..3ed4d841f724d --- /dev/null +++ b/README.md @@ -0,0 +1,101 @@ +Overview +======== +This repository exists as a staging ground for developing candidate +contributions to the GNU Compiler Collection ([GCC]). + +Candidate features currently on this site are listed below. The checked items indicate features +that have been submitted to the relevant GCC developer mailing list for review. We welcome user +feedback from testing these features. Unchecked items are insufficiently mature to submit to GCC. + +- [X] The [teams branch] with experimental support for Fortran 2015 teams. +- [X] The [download-opencoarrays-mpich branch] modifying GCC's prequisites download script + to add [OpenCoarrays] and [MPICH] to the list of downloade software. +- [ ] The [issue-#6-iso-fortran-binding-h branch] providing the Fortran 2015 `iso_fortran_binding.h` file. + +We welcome code contributions via [pull request] for any listed features or other unsupported +features of the [draft Fortran 2015 standard]: + +Installation +============ +This fork's [releases] are produced from the [teams branch], which we expect will be of +most interest to users. We recommend building the [latest release] using the [OpenCoarrays] +`install.sh` script as follows: +```bash +# Install a teams-branch release of this GCC fork +git clone https://github.com/sourceryinstitute/opencoarrays +cd oppencoarrays +./install.sh --package gcc \ + --from-url https://github.com/sourceryinstitute/gcc/archive/.tar.gz \ + --install-version +``` +where `` must be replaced with the appropriate string such as teams-20170921. The final +command above peforms the safest but slowest build, which could take several hours to complete. +For a speedier build, add the `--disable-bootstrap`, which might fail if the GCC you are using +to build is too old. Also, for an interactive build, add `--yes-to-all` to instruct the +installer to assume affirmative answers to any queries. If successful, the above steps will +install GCC in the `prerequisites/installations` subdirectory. To see additional installation +options, including choosing another installation path, execute `./install.sh --help`. + +Next use the resulting compilers to build [MPICH] 3.2 or later: +```bash + +# Install MPICH 3.2 or later using the GCC that was installed above: +export LD_LIBRARY_PATH="${PWD}"/prerequisites/installations/gcc/teams-/lib64 + +./install.sh --package mpich \ + --with-fortran "${PWD}"/prerequisites/installations/gcc//bin/gfortarn \ + --with-c "${PWD}"/prerequisites/installations/gcc//bin/gcc \ + --with-cpp "${PWD}"/prerequisites/installations/gcc/bin/g++ + +``` + +Next use the resulting [MPICH] installation to build the [opencoarrays-teams branch] of OpenCoarrays. +```bash +# Install OpenCoarrays using the MPICH just installed: +git checkout opencoarrays-teams +./install.sh \ + --with-mpi "${PWD}"/prerequisites/installations/mpich// +``` +after replacing `` with... wait for it... the MPI version number (3.2 or later). :) +Please report any problems with the above steps on our [issues page]. + + +[GCC mirror] README +=================== + +This directory contains the GNU Compiler Collection (GCC). + +The GNU Compiler Collection is free software. See the files whose +names start with COPYING for copying permission. The manuals, and +some of the runtime libraries, are under different terms; see the +individual source files for details. + +The directory INSTALL contains copies of the installation information +as HTML and plain text. The source of this information is +gcc/doc/install.texi. The installation information includes details +of what is included in the GCC sources and what files GCC installs. + +See the file gcc/doc/gcc.texi (together with other files that it +includes) for usage and porting information. An online readable +version of the manual is in the files gcc/doc/gcc.info*. + +See http://gcc.gnu.org/bugs/ for how to report bugs usefully. + +Copyright years on GCC source files may be listed using range +notation, e.g., 1987-2012, indicating that every year in the range, +inclusive, is a copyrightable year that could otherwise be listed +individually. + +[GCC mirror]: https://github.com/gcc-mirror/gcc +[GCC]: https://gcc.gnu.org/gcc +[OpenCoarrays]: https://www.opendcoarrays.org +[MPICH]: https://www.mpich.org +[teams branch]: https://github.com/sourceryinstitute/gcc/tree/teams +[issue-#6-iso-fortran-binding-h branch]: https://github.com/sourceryinstitute/gcc/tree/issue-#6-iso-fortran-binding-h +[download-opencoarrays-mpich branch]: https://github.com/sourceryinstitute/gcc/tree/download-opencoarrays-mpich +[releases]: https://github.com/sourceryinstitute/gcc/releases/ +[issues page]: https://github.com/sourceryinstitute/gcc/issues/ +[opencoarrays-teams branch]: https://github.com/sourceryinstitute/opencoarrays/tree/opencoarrays-teams +[pull request]: https://github.com/sourceryinstitute/gcc/pulls +[draft Fortran 2015 standard]: https://bit.ly/fortran-2015-draft +[latest release]: https://github.com/sourceryinstitute/gcc/releases/latest diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0806ecd2ec76e..7a5b00a8d792a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,48 @@ +2018-01-18 Damian Rouson + Alessandro Fanfarillo + + 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-15 Louis Krupp PR fortran/82257 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 882fe577b7661..b4baf5be55458 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -158,6 +158,7 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, bool matched_bracket = false; gfc_expr *tmp; bool stat_just_seen = false; + bool team_just_seen = false; memset (ar, '\0', sizeof (*ar)); @@ -230,8 +231,21 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, 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->stat == 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; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a2c8b520d8016..b73b3f76e0ac9 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1252,6 +1252,20 @@ gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) } +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) @@ -2264,7 +2278,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, return false; } } - + if (array->rank == 1 || boundary->rank == 0) { if (!scalar_check (boundary, 2)) @@ -2313,7 +2327,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, 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, @@ -5274,6 +5288,33 @@ gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) } +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) + { + /* TODO: this works on any derived type when + it should only work with team_type. */ + if (team->ts.type != BT_DERIVED) + { + 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) { diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 5ff531682e3c2..0de2a0f1d6a25 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1868,6 +1868,22 @@ show_code_node (int level, gfc_code *c) 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) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 45ccc184fc18a..1708487cdf82e 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -5065,7 +5065,25 @@ gfc_ref_this_image (gfc_ref *ref) } 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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6ddf450ad2edf..f35430dcd2077 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -263,7 +263,8 @@ enum gfc_statement 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 @@ -455,6 +456,7 @@ enum gfc_isym_id GFC_ISYM_GETGID, GFC_ISYM_GETLOG, GFC_ISYM_GETPID, + GFC_ISYM_GET_TEAM, GFC_ISYM_GETUID, GFC_ISYM_GMTIME, GFC_ISYM_HOSTNM, @@ -597,6 +599,7 @@ enum gfc_isym_id GFC_ISYM_SYSTEM_CLOCK, GFC_ISYM_TAN, GFC_ISYM_TANH, + GFC_ISYM_TEAM_NUMBER, GFC_ISYM_THIS_IMAGE, GFC_ISYM_TIME, GFC_ISYM_TIME8, @@ -1913,6 +1916,7 @@ typedef struct gfc_array_ref 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; @@ -2497,6 +2501,7 @@ enum gfc_exec_op 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, @@ -3223,6 +3228,7 @@ bool gfc_is_coarray (gfc_expr *); 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, ...); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 4844cee0c3466..a47de4131389f 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -860,7 +860,7 @@ add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, 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; @@ -1246,7 +1246,8 @@ add_functions (void) *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; @@ -1282,8 +1283,8 @@ add_functions (void) 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); @@ -1344,8 +1345,8 @@ add_functions (void) 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); @@ -1397,7 +1398,7 @@ add_functions (void) 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); @@ -1428,7 +1429,7 @@ add_functions (void) 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); @@ -1448,7 +1449,7 @@ add_functions (void) 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, @@ -1613,7 +1614,7 @@ add_functions (void) 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, @@ -1639,7 +1640,7 @@ add_functions (void) 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); @@ -1657,7 +1658,7 @@ add_functions (void) 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); @@ -1826,7 +1827,7 @@ add_functions (void) 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); @@ -1850,8 +1851,8 @@ add_functions (void) 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); @@ -1944,6 +1945,11 @@ add_functions (void) 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); @@ -2096,8 +2102,8 @@ add_functions (void) 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. */ @@ -2345,7 +2351,7 @@ add_functions (void) 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); @@ -2543,7 +2549,7 @@ add_functions (void) 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, @@ -2747,7 +2753,7 @@ add_functions (void) 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); @@ -2957,7 +2963,7 @@ add_functions (void) 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); @@ -3013,8 +3019,8 @@ add_functions (void) 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, @@ -3022,7 +3028,7 @@ add_functions (void) 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, @@ -3062,6 +3068,11 @@ add_functions (void) 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, @@ -3158,11 +3169,11 @@ add_functions (void) 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) @@ -4544,11 +4555,11 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) 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; } @@ -5153,12 +5164,12 @@ gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) /* 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; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 7615dd1e6115a..a483bfa0c7b2b 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -83,6 +83,7 @@ bool gfc_check_fn_r (gfc_expr *); 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 *); @@ -169,6 +170,7 @@ bool gfc_check_stat (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 *); @@ -300,6 +302,7 @@ gfc_expr *gfc_simplify_float (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 *); @@ -498,6 +501,7 @@ void gfc_resolve_gamma (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 *); @@ -595,6 +599,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_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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 9a4e199d01e4d..db514b77344ef 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -23,7 +23,7 @@ along with GCC; see the file COPYING3. If not see first argument to a resolution function is an expression pointer to the original function node and the rest are pointers to the arguments of the function call. For subroutines, a pointer to the - code node is passed. The result type and library subroutine name + code ndoe is passed. The result type and library subroutine name are generally set according to the function arguments. */ #include "config.h" @@ -36,10 +36,10 @@ along with GCC; see the file COPYING3. If not see #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. */ @@ -316,7 +316,7 @@ gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) { 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); @@ -363,7 +363,7 @@ gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) { 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); @@ -458,7 +458,7 @@ gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts = x->ts; if (n->ts.kind != gfc_c_int_kind) { @@ -475,7 +475,7 @@ gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x) { 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) @@ -811,7 +811,7 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, 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) @@ -822,7 +822,7 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, ts.kind = m; gfc_convert_type_warn (shift, &ts, 2, 0); } - + if (dim != NULL) { if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL @@ -861,7 +861,7 @@ gfc_resolve_ctime (gfc_expr *f, gfc_expr *time) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = BT_CHARACTER; f->ts.kind = gfc_default_character_kind; @@ -976,7 +976,7 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, 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) @@ -987,7 +987,7 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, ts.kind = m; gfc_convert_type_warn (shift, &ts, 2, 0); } - + if (dim != NULL) { if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL @@ -1225,7 +1225,7 @@ void 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) { @@ -1316,7 +1316,7 @@ void 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) { @@ -1335,7 +1335,7 @@ void 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) { @@ -1435,7 +1435,7 @@ gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) { 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) @@ -1642,7 +1642,7 @@ gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b) 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. */ @@ -2961,6 +2961,19 @@ gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED, } +/* 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 @@ -2991,6 +3004,19 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, } +/* 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) @@ -3180,7 +3206,7 @@ gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = BT_CHARACTER; f->ts.kind = gfc_default_character_kind; @@ -3399,7 +3425,7 @@ gfc_resolve_random_number (gfc_code *c) 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); } @@ -3444,7 +3470,7 @@ gfc_resolve_kill_sub (gfc_code *c) 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) @@ -3777,7 +3803,7 @@ gfc_resolve_ctime_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) { @@ -3961,7 +3987,7 @@ gfc_resolve_fput_sub (gfc_code *c) } -void +void gfc_resolve_fseek_sub (gfc_code *c) { gfc_expr *unit; @@ -4035,7 +4061,7 @@ gfc_resolve_ttynam_sub (gfc_code *c) { gfc_typespec ts; gfc_clear_ts (&ts); - + if (c->ext.actual->expr->ts.kind != gfc_c_int_kind) { ts.type = BT_INTEGER; diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index b150e49f2228c..25f9e0991ba39 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -128,6 +128,11 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \ ? 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 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 320a0d8af553d..c822f2436e315 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1596,11 +1596,13 @@ gfc_match_if (gfc_statement *if_type) 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) @@ -1608,6 +1610,7 @@ gfc_match_if (gfc_statement *if_type) 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) @@ -1624,6 +1627,7 @@ gfc_match_if (gfc_statement *if_type) 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) @@ -3348,6 +3352,131 @@ gfc_match_fail_image (void) 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 ] ) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 2e04b3e22ac67..65c6744a16e5c 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -74,6 +74,10 @@ match gfc_match_event_post (void); 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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index d63d7bc989fa1..a3693a192f0e3 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -451,6 +451,7 @@ decode_statement (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); @@ -470,6 +471,7 @@ decode_statement (void) 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); @@ -491,6 +493,7 @@ decode_statement (void) 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; @@ -558,6 +561,7 @@ decode_statement (void) 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': @@ -1503,6 +1507,8 @@ next_statement (void) 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 @@ -1834,6 +1840,18 @@ gfc_ascii_statement (gfc_statement st) 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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1ecfe05ed797e..23f92da96ed8b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11102,6 +11102,10 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) 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: diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index b7c6b02081f87..6577101874c78 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2890,6 +2890,30 @@ gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, } +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) { @@ -3056,7 +3080,7 @@ gfc_simplify_fraction (gfc_expr *x) #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) @@ -7333,7 +7357,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) || !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; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 1de7de7de5aea..7603cbd94adcb 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -121,6 +121,10 @@ gfc_free_statement (gfc_code *p) 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: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 144a3447769f4..9b0b2a14b8db4 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -157,6 +157,12 @@ tree gfor_fndecl_caf_fail_image; 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; @@ -3363,7 +3369,7 @@ gfc_build_intrinsic_function_decls (void) 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), @@ -3378,7 +3384,7 @@ gfc_build_intrinsic_function_decls (void) 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), @@ -3390,7 +3396,7 @@ gfc_build_intrinsic_function_decls (void) 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), @@ -3642,10 +3648,10 @@ gfc_build_builtin_function_decls (void) 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", @@ -3769,6 +3775,38 @@ gfc_build_builtin_function_decls (void) 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", diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index f4defb079b400..4d06996550569 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1846,11 +1846,11 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, 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; @@ -1866,6 +1866,7 @@ conv_caf_send (gfc_code *code) { 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); @@ -2077,6 +2078,18 @@ conv_caf_send (gfc_code *code) { 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) @@ -2092,10 +2105,10 @@ conv_caf_send (gfc_code *code) { 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 { @@ -2432,6 +2445,48 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) 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) @@ -2553,7 +2608,6 @@ 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) { @@ -2581,7 +2635,6 @@ 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); @@ -2998,7 +3051,6 @@ conv_intrinsic_stride (gfc_se * se, gfc_expr * expr) se->expr = gfc_conv_descriptor_stride_get (desc, tmp); } - static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { @@ -4582,7 +4634,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* 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; @@ -6097,7 +6149,6 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, gfc_free_symbol (sym); } - /* The length of a character string. */ static void gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) @@ -8656,7 +8707,7 @@ gfc_conv_intrinsic_function (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; @@ -9184,6 +9235,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) 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. */ @@ -9581,6 +9636,7 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) 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: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index ff6e591431930..0fa69c071a938 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -696,6 +696,110 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) } } +/* 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) diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 130058dd01e63..c798c80e7a7e3 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -58,6 +58,10 @@ tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_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 *); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index abcbf957e5dd8..e8583d5fd38e3 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2501,12 +2501,14 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) || (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 diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 9ce7debb1e46b..aa10fbb405a12 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1972,6 +1972,22 @@ trans_code (gfc_code * code, tree cond) 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; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 31b0930350d9d..1785936696a85 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -837,6 +837,12 @@ extern GTY(()) tree gfor_fndecl_caf_fail_image; 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b29c659ba5179..bdbb398d47757 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2018-01-18 Damian Rouson + Alessandro Fanfarillo + + 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-15 Martin Sebor PR c++/83588 diff --git a/gcc/testsuite/gfortran.dg/team_change_1.f90 b/gcc/testsuite/gfortran.dg/team_change_1.f90 new file mode 100644 index 0000000000000..1dd42082b04a4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_change_1.f90 @@ -0,0 +1,18 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/team_end_1.f90 b/gcc/testsuite/gfortran.dg/team_end_1.f90 new file mode 100644 index 0000000000000..5a05b7fc87dda --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_end_1.f90 @@ -0,0 +1,18 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/team_form_1.f90 b/gcc/testsuite/gfortran.dg/team_form_1.f90 new file mode 100644 index 0000000000000..63cabfaf1994d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_form_1.f90 @@ -0,0 +1,14 @@ +! { 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 + + + diff --git a/gcc/testsuite/gfortran.dg/team_number_1.f90 b/gcc/testsuite/gfortran.dg/team_number_1.f90 new file mode 100644 index 0000000000000..77a18527e0aa4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_number_1.f90 @@ -0,0 +1,21 @@ +! { 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