diff options
| author | Harald Anlauf <anlauf@gmx.de> | 2022-05-09 22:14:21 +0200 |
|---|---|---|
| committer | Harald Anlauf <anlauf@gmx.de> | 2022-05-10 19:10:05 +0200 |
| commit | 5edd0802696f94012731306c704eaf61d184e09c (patch) | |
| tree | dae931fd86955347e30ac63d3c0bc6fca9b9ad51 /gcc/fortran/resolve.cc | |
| parent | 71eae0fd3dd7a5f30067ea26a06a8774355fd5cc (diff) | |
| download | gcc-5edd0802696f94012731306c704eaf61d184e09c.zip gcc-5edd0802696f94012731306c704eaf61d184e09c.tar.gz gcc-5edd0802696f94012731306c704eaf61d184e09c.tar.bz2 | |
Fortran: check TEAM arguments to coarray intrinsics
TEAM arguments to coarray intrinsics must be scalar expressions of type
TEAM_TYPE of intrinsic module ISO_FORTRAN_ENV.
gcc/fortran/ChangeLog:
PR fortran/105526
* resolve.cc (check_team): New.
(gfc_resolve_code): Add checks for arguments to coarray intrinsics
FORM TEAM, CHANGE TEAM, and SYNC TEAM.
gcc/testsuite/ChangeLog:
PR fortran/105526
* gfortran.dg/coarray_50.f90: New test.
Diffstat (limited to 'gcc/fortran/resolve.cc')
| -rw-r--r-- | gcc/fortran/resolve.cc | 32 |
1 files changed, 32 insertions, 0 deletions
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 29df531..c8335f9 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11831,6 +11831,23 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns) } +static bool +check_team (gfc_expr *team, const char *intrinsic) +{ + if (team->rank != 0 + || 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 to %qs at %L must be a scalar expression " + "of type TEAM_TYPE", intrinsic, &team->where); + return false; + } + + return true; +} + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -11999,10 +12016,25 @@ start: break; case EXEC_FAIL_IMAGE: + break; + case EXEC_FORM_TEAM: + if (code->expr1 != NULL + && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) + gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be " + "a scalar INTEGER", &code->expr1->where); + check_team (code->expr2, "FORM TEAM"); + break; + case EXEC_CHANGE_TEAM: + check_team (code->expr1, "CHANGE TEAM"); + break; + case EXEC_END_TEAM: + break; + case EXEC_SYNC_TEAM: + check_team (code->expr1, "SYNC TEAM"); break; case EXEC_ENTRY: |