diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1201,6 +1201,8 @@ bool IsExtensibleType(const DerivedTypeSpec *); bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name); bool IsBuiltinCPtr(const Symbol &); +bool IsEventType(const DerivedTypeSpec *); +bool IsLockType(const DerivedTypeSpec *); // Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV? bool IsTeamType(const DerivedTypeSpec *); // Is this derived type TEAM_TYPE, C_PTR, or C_FUNPTR? diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1568,6 +1568,14 @@ IsBuiltinDerivedType(derived, "c_funptr"); } +bool IsEventType(const DerivedTypeSpec *derived) { + return IsBuiltinDerivedType(derived, "event_type"); +} + +bool IsLockType(const DerivedTypeSpec *derived) { + return IsBuiltinDerivedType(derived, "lock_type"); +} + bool IsTeamType(const DerivedTypeSpec *derived) { return IsBuiltinDerivedType(derived, "team_type"); } @@ -1577,8 +1585,7 @@ } bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) { - return IsBuiltinDerivedType(derivedTypeSpec, "event_type") || - IsBuiltinDerivedType(derivedTypeSpec, "lock_type"); + return IsEventType(derivedTypeSpec) || IsLockType(derivedTypeSpec); } int CountLenParameters(const DerivedTypeSpec &type) { diff --git a/flang/lib/Semantics/check-coarray.h b/flang/lib/Semantics/check-coarray.h --- a/flang/lib/Semantics/check-coarray.h +++ b/flang/lib/Semantics/check-coarray.h @@ -17,6 +17,8 @@ class MessageFixedText; struct ChangeTeamStmt; struct CoarrayAssociation; +struct EventPostStmt; +struct EventWaitStmt; struct FormTeamStmt; struct ImageSelector; struct SyncAllStmt; @@ -35,6 +37,8 @@ void Leave(const parser::SyncImagesStmt &); void Leave(const parser::SyncMemoryStmt &); void Leave(const parser::SyncTeamStmt &); + void Leave(const parser::EventPostStmt &); + void Leave(const parser::EventWaitStmt &); void Leave(const parser::ImageSelector &); void Leave(const parser::FormTeamStmt &); diff --git a/flang/lib/Semantics/check-coarray.cpp b/flang/lib/Semantics/check-coarray.cpp --- a/flang/lib/Semantics/check-coarray.cpp +++ b/flang/lib/Semantics/check-coarray.cpp @@ -124,6 +124,19 @@ } } +static void CheckEventVariable( + SemanticsContext &context, const parser::EventVariable &eventVar) { + if (const auto *expr{GetExpr(context, eventVar)}) { + if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176 + context.Say(parser::FindSourceLocation(eventVar), + "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US); + } else if (!evaluate::IsCoarray(*expr)) { // C1604 + context.Say(parser::FindSourceLocation(eventVar), + "The event-variable must be a coarray"_err_en_US); + } + } +} + void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) { CheckNamesAreDistinct(std::get>(x.t)); CheckTeamType(context_, std::get(x.t)); @@ -156,6 +169,64 @@ CheckSyncStatList(context_, std::get>(x.t)); } +void CoarrayChecker::Leave(const parser::EventPostStmt &x) { + CheckSyncStatList(context_, std::get>(x.t)); + CheckEventVariable(context_, std::get(x.t)); +} + +void CoarrayChecker::Leave(const parser::EventWaitStmt &x) { + const auto &eventVar{std::get(x.t)}; + + if (const auto *expr{GetExpr(context_, eventVar)}) { + if (ExtractCoarrayRef(expr)) { + context_.Say(parser::FindSourceLocation(eventVar), // C1177 + "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US); + } else { + CheckEventVariable(context_, eventVar); + } + } + + bool gotStat{false}, gotMsg{false}, gotUntil{false}; + using EventWaitSpec = parser::EventWaitStmt::EventWaitSpec; + for (const EventWaitSpec &eventWaitSpec : + std::get>(x.t)) { + common::visit( + common::visitors{ + [&](const parser::ScalarIntExpr &untilCount) { + if (gotUntil) { + context_.Say( // C1178 + "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US); + } + gotUntil = true; + }, + [&](const parser::StatOrErrmsg &statOrErrmsg) { + common::visit( + common::visitors{ + [&](const parser::StatVariable &stat) { + if (gotStat) { + context_.Say( // C1178 + "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US); + } + gotStat = true; + }, + [&](const parser::MsgVariable &errmsg) { + if (gotMsg) { + context_.Say( // C1178 + "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US); + } + gotMsg = true; + }, + }, + statOrErrmsg.u); + CheckCoindexedStatOrErrmsg( + context_, statOrErrmsg, "event-wait-spec-list"); + }, + + }, + eventWaitSpec.u); + } +} + void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) { haveStat_ = false; haveTeam_ = false; diff --git a/flang/test/Lower/pre-fir-tree04.f90 b/flang/test/Lower/pre-fir-tree04.f90 --- a/flang/test/Lower/pre-fir-tree04.f90 +++ b/flang/test/Lower/pre-fir-tree04.f90 @@ -6,8 +6,8 @@ Subroutine test_coarray use iso_fortran_env, only: team_type, event_type, lock_type type(team_type) :: t - type(event_type) :: done - type(lock_type) :: alock + type(event_type) :: done[*] + type(lock_type) :: alock[*] real :: y[10,*] integer :: counter[*] logical :: is_square diff --git a/flang/test/Semantics/critical02.f90 b/flang/test/Semantics/critical02.f90 --- a/flang/test/Semantics/critical02.f90 +++ b/flang/test/Semantics/critical02.f90 @@ -61,7 +61,7 @@ subroutine test7() use iso_fortran_env - type(event_type) :: x, y + type(event_type) :: x[*], y[*] critical !ERROR: An image control statement is not allowed in a CRITICAL construct event post (x) diff --git a/flang/test/Semantics/doconcurrent01.f90 b/flang/test/Semantics/doconcurrent01.f90 --- a/flang/test/Semantics/doconcurrent01.f90 +++ b/flang/test/Semantics/doconcurrent01.f90 @@ -66,7 +66,7 @@ subroutine s1() use iso_fortran_env - type(event_type) :: x + type(event_type) :: x[*] do concurrent (i = 1:n) !ERROR: An image control statement is not allowed in DO CONCURRENT event post (x) @@ -75,7 +75,7 @@ subroutine s2() use iso_fortran_env - type(event_type) :: x + type(event_type) :: x[*] do concurrent (i = 1:n) !ERROR: An image control statement is not allowed in DO CONCURRENT event wait (x) diff --git a/flang/test/Semantics/event01b.f90 b/flang/test/Semantics/event01b.f90 --- a/flang/test/Semantics/event01b.f90 +++ b/flang/test/Semantics/event01b.f90 @@ -22,9 +22,11 @@ !______ invalid event-variable ____________________________ ! event-variable must be event_type + !ERROR: The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV event post(non_event) ! event-variable must be a coarray + !ERROR: The event-variable must be a coarray event post(non_coarray) !ERROR: Must be a scalar value, but is a rank-1 array @@ -48,18 +50,50 @@ !______ invalid sync-stat-lists: redundant sync-stat-list ____________ - ! No specifier shall appear more than once in a given sync-stat-list + !ERROR: The stat-variable in a sync-stat-list may not be repeated event post(concert, stat=sync_status, stat=superfluous_stat) - ! No specifier shall appear more than once in a given sync-stat-list + !ERROR: The stat-variable in a sync-stat-list may not be repeated + event post(concert, errmsg=error_message, stat=sync_status, stat=superfluous_stat) + + !ERROR: The stat-variable in a sync-stat-list may not be repeated + event post(concert, stat=sync_status, errmsg=error_message, stat=superfluous_stat) + + !ERROR: The stat-variable in a sync-stat-list may not be repeated + event post(concert, stat=sync_status, stat=superfluous_stat, errmsg=error_message) + + !ERROR: The errmsg-variable in a sync-stat-list may not be repeated event post(concert, errmsg=error_message, errmsg=superfluous_errmsg) - !______ invalid sync-stat-lists: coindexed stat-variable ____________ + !ERROR: The errmsg-variable in a sync-stat-list may not be repeated + event post(concert, stat=sync_status, errmsg=error_message, errmsg=superfluous_errmsg) + + !ERROR: The errmsg-variable in a sync-stat-list may not be repeated + event post(concert, errmsg=error_message, stat=sync_status, errmsg=superfluous_errmsg) + + !ERROR: The errmsg-variable in a sync-stat-list may not be repeated + event post(concert, errmsg=error_message, errmsg=superfluous_errmsg, stat=sync_status) - ! Check constraint C1173 from the Fortran 2018 standard + !______ invalid sync-stat-lists: coindexed stat-variable - C1173____________ + + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object event post(concert, stat=co_indexed_integer[1]) - ! Check constraint C1173 from the Fortran 2018 standard + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object event post(concert, errmsg=co_indexed_character[1]) + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object + event post(concert, stat=co_indexed_integer[1], errmsg=error_message) + + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object + event post(concert, stat=sync_status, errmsg=co_indexed_character[1]) + + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object + event post(concert, stat=co_indexed_integer[1], errmsg=co_indexed_character[1]) + + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object + !ERROR: The stat-variable or errmsg-variable in a sync-stat-list may not be a coindexed object + event post(concert, errmsg=co_indexed_character[1], stat=co_indexed_integer[1]) + end program test_event_post diff --git a/flang/test/Semantics/event02b.f90 b/flang/test/Semantics/event02b.f90 --- a/flang/test/Semantics/event02b.f90 +++ b/flang/test/Semantics/event02b.f90 @@ -21,16 +21,16 @@ !_________________________ invalid event-variable ________________________________ - ! event-variable must be event_type + !ERROR: The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV event wait(non_event) - ! event-variable must be a coarray + !ERROR: The event-variable must be a coarray event wait(non_coarray) - ! event-variable must not be coindexed + !ERROR: A event-variable in a EVENT WAIT statement may not be a coindexed object event wait(concert[1]) - ! event-variable must not be coindexed + !ERROR: A event-variable in a EVENT WAIT statement may not be a coindexed object event wait(occurrences(1)[1]) !ERROR: Must be a scalar value, but is a rank-1 array @@ -62,21 +62,62 @@ !______ invalid event-wait-spec-lists: redundant event-wait-spec-list ____________ - ! No specifier shall appear more than once in a given event-wait-spec-list + !ERROR: Until-spec in a event-wait-spec-list may not be repeated event wait(concert, until_count=threshold, until_count=indexed(1)) - ! No specifier shall appear more than once in a given event-wait-spec-list + !ERROR: Until-spec in a event-wait-spec-list may not be repeated + event wait(concert, until_count=threshold, stat=sync_status, until_count=indexed(1)) + + !ERROR: Until-spec in a event-wait-spec-list may not be repeated + event wait(concert, until_count=threshold, errmsg=error_message, until_count=indexed(1)) + + !ERROR: Until-spec in a event-wait-spec-list may not be repeated + event wait(concert, until_count=threshold, stat=sync_status, errmsg=error_message, until_count=indexed(1)) + + !ERROR: A stat-variable in a event-wait-spec-list may not be repeated event wait(concert, stat=sync_status, stat=superfluous_stat) - ! No specifier shall appear more than once in a given event-wait-spec-list + !ERROR: A stat-variable in a event-wait-spec-list may not be repeated + event wait(concert, stat=sync_status, until_count=threshold, stat=superfluous_stat) + + !ERROR: A stat-variable in a event-wait-spec-list may not be repeated + event wait(concert, stat=sync_status, errmsg=error_message, stat=superfluous_stat) + + !ERROR: A stat-variable in a event-wait-spec-list may not be repeated + event wait(concert, stat=sync_status, until_count=threshold, errmsg=error_message, stat=superfluous_stat) + + !ERROR: A errmsg-variable in a event-wait-spec-list may not be repeated event wait(concert, errmsg=error_message, errmsg=superfluous_errmsg) - !_____________ invalid sync-stat-lists: coindexed stat-variable __________________ + !ERROR: A errmsg-variable in a event-wait-spec-list may not be repeated + event wait(concert, errmsg=error_message, until_count=threshold, errmsg=superfluous_errmsg) + + !ERROR: A errmsg-variable in a event-wait-spec-list may not be repeated + event wait(concert, errmsg=error_message, stat=superfluous_stat, errmsg=superfluous_errmsg) - ! Check constraint C1173 from the Fortran 2018 standard + !ERROR: A errmsg-variable in a event-wait-spec-list may not be repeated + event wait(concert, errmsg=error_message, until_count=threshold, stat=superfluous_stat, errmsg=superfluous_errmsg) + + !_____________ invalid sync-stat-lists: coindexed stat-variable - C1173 __________________ + + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object event wait(concert, stat=co_indexed_integer[1]) - ! Check constraint C1173 from the Fortran 2018 standard + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object event wait(concert, errmsg=co_indexed_character[1]) + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object + event wait(concert, stat=co_indexed_integer[1], errmsg=error_message) + + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object + event wait(concert, stat=sync_status, errmsg=co_indexed_character[1]) + + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object + event wait(concert, stat=co_indexed_integer[1], errmsg=co_indexed_character[1]) + + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object + !ERROR: The stat-variable or errmsg-variable in a event-wait-spec-list may not be a coindexed object + event wait(concert, errmsg=co_indexed_character[1], stat=co_indexed_integer[1]) + end program test_event_wait