From 1e9b60cfa4316246f9fe325ec57daf185120d34e Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Mon, 27 Jan 2025 11:56:41 -0800 Subject: [PATCH] [flang] Recognize and check EVENT_QUERY (#123429) Recognize the intrinsic subroutine EVENT_QUERY and enforce semantic requirements on calls to it. --- flang/lib/Evaluate/intrinsics.cpp | 17 +++++++++++++-- flang/lib/Semantics/check-call.cpp | 32 ++++++++++++++++++++++++++++ flang/test/Semantics/event_query.f90 | 32 +++++++++++++++++++++------- 3 files changed, 71 insertions(+), 10 deletions(-) diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 77d37d40bbdd..954581fd713a 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -96,6 +96,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind, typeless, // BOZ literals are INTEGER with this kind ieeeFlagType, // IEEE_FLAG_TYPE from ISO_FORTRAN_EXCEPTION ieeeRoundType, // IEEE_ROUND_TYPE from ISO_FORTRAN_ARITHMETIC + eventType, // EVENT_TYPE from module ISO_FORTRAN_ENV (for coarrays) teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays) kindArg, // this argument is KIND= effectiveKind, // for function results: "kindArg" value, possibly defaulted @@ -129,6 +130,7 @@ static constexpr TypePattern DefaultChar{CharType, KindCode::defaultCharKind}; static constexpr TypePattern DefaultLogical{ LogicalType, KindCode::defaultLogicalKind}; static constexpr TypePattern BOZ{IntType, KindCode::typeless}; +static constexpr TypePattern EventType{DerivedType, KindCode::eventType}; static constexpr TypePattern IeeeFlagType{DerivedType, KindCode::ieeeFlagType}; static constexpr TypePattern IeeeRoundType{ DerivedType, KindCode::ieeeRoundType}; @@ -1471,6 +1473,13 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"time", TypePattern{RealType, KindCode::exactKind, 4}, Rank::scalar, Optionality::required, common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"event_query", + {{"event", EventType, Rank::scalar}, + {"count", AnyInt, Rank::scalar, Optionality::required, + common::Intent::Out}, + {"stat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"execute_command_line", {{"command", DefaultChar, Rank::scalar}, {"wait", AnyLogical, Rank::scalar, Optionality::optional}, @@ -1592,7 +1601,6 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {}, Rank::elemental, IntrinsicClass::impureSubroutine}, }; -// TODO: Intrinsic subroutine EVENT_QUERY // TODO: Collective intrinsic subroutines: co_reduce // Finds a built-in derived type and returns it as a DynamicType. @@ -1968,6 +1976,11 @@ std::optional IntrinsicInterface::Match( case KindCode::typeless: argOk = false; break; + case KindCode::eventType: + argOk = !type->IsUnlimitedPolymorphic() && + type->category() == TypeCategory::Derived && + semantics::IsEventType(&type->GetDerivedTypeSpec()); + break; case KindCode::ieeeFlagType: argOk = !type->IsUnlimitedPolymorphic() && type->category() == TypeCategory::Derived && @@ -3239,7 +3252,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US); } } else if (name == "atomic_add" || name == "atomic_and" || - name == "atomic_or" || name == "atomic_xor") { + name == "atomic_or" || name == "atomic_xor" || name == "event_query") { return CheckForCoindexedObject( context.messages(), call.arguments[2], name, "stat"); } else if (name == "atomic_cas") { diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index e925e1c1c653..5db6b426810b 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1616,6 +1616,36 @@ static void CheckAssociated(evaluate::ActualArguments &arguments, } } +// EVENT_QUERY (F'2023 16.9.82) +static void CheckEvent_Query(evaluate::ActualArguments &arguments, + evaluate::FoldingContext &foldingContext) { + if (arguments.size() > 0 && arguments[0] && + ExtractCoarrayRef(*arguments[0]).has_value()) { + foldingContext.messages().Say(arguments[0]->sourceLocation(), + "EVENT= argument to EVENT_QUERY must not be coindexed"_err_en_US); + } + if (arguments.size() > 1 && arguments[1]) { + if (auto dyType{arguments[1]->GetType()}) { + int defaultInt{ + foldingContext.defaults().GetDefaultKind(TypeCategory::Integer)}; + if (dyType->category() == TypeCategory::Integer && + dyType->kind() < defaultInt) { + foldingContext.messages().Say(arguments[1]->sourceLocation(), + "COUNT= argument to EVENT_QUERY must be an integer with kind >= %d"_err_en_US, + defaultInt); + } + } + } + if (arguments.size() > 2 && arguments[2]) { + if (auto dyType{arguments[2]->GetType()}) { + if (dyType->category() == TypeCategory::Integer && dyType->kind() < 2) { + foldingContext.messages().Say(arguments[2]->sourceLocation(), + "STAT= argument to EVENT_QUERY must be an integer with kind >= 2 when present"_err_en_US); + } + } + } +} + // IMAGE_INDEX (F'2023 16.9.107) static void CheckImage_Index(evaluate::ActualArguments &arguments, parser::ContextualMessages &messages) { @@ -1952,6 +1982,8 @@ static void CheckSpecificIntrinsic(const characteristics::Procedure &proc, const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) { if (intrinsic.name == "associated") { CheckAssociated(arguments, context, scope); + } else if (intrinsic.name == "event_query") { + CheckEvent_Query(arguments, context.foldingContext()); } else if (intrinsic.name == "image_index") { CheckImage_Index(arguments, context.foldingContext().messages()); } else if (intrinsic.name == "max" || intrinsic.name == "min") { diff --git a/flang/test/Semantics/event_query.f90 b/flang/test/Semantics/event_query.f90 index 3f38e3dd3787..f648462bc209 100644 --- a/flang/test/Semantics/event_query.f90 +++ b/flang/test/Semantics/event_query.f90 @@ -1,14 +1,10 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in event_query() subroutine based on the ! statement specification in section 16.9.72 of the Fortran 2018 standard. program test_event_query use iso_fortran_env, only : event_type - implicit none - - ! event_type variables must be coarrays - type(event_type) non_coarray + implicit none(type,external) type(event_type) concert[*], occurrences(2)[*] integer non_event[*], counter, array(1), coarray[*], sync_status, coindexed[*], non_scalar(1) @@ -33,70 +29,90 @@ program test_event_query !___ non-standard-conforming calls _______ ! event-variable must be event_type + ! ERROR: Actual argument for 'event=' has bad type 'INTEGER(4)' call event_query(non_event, counter) - ! event-variable must be a coarray - call event_query(non_coarray, counter) - ! event-variable must be a scalar variable + ! ERROR: 'event=' argument has unacceptable rank 1 call event_query(occurrences, counter) ! event-variable must not be coindexed + ! ERROR: EVENT= argument to EVENT_QUERY must not be coindexed call event_query(concert[1], counter) ! event-variable has an unknown keyword argument + ! ERROR: unknown keyword argument to intrinsic 'event_query' call event_query(events=concert, count=counter) ! event-variable has an argument mismatch + ! ERROR: Actual argument for 'event=' has bad type 'INTEGER(4)' call event_query(event=non_event, count=counter) ! count must be an integer + ! ERROR: Actual argument for 'count=' has bad type 'LOGICAL(4)' call event_query(concert, non_integer) ! count must be an integer scalar + ! ERROR: 'count=' argument has unacceptable rank 1 call event_query(concert, non_scalar) ! count must be have a decimal exponent range ! no smaller than that of default integer + ! ERROR: COUNT= argument to EVENT_QUERY must be an integer with kind >= 4 call event_query(concert, non_default) ! count is an intent(out) argument + ! ERROR: Actual argument associated with INTENT(OUT) dummy argument 'count=' is not definable + ! ERROR: '4_4' is not a variable or pointer call event_query(concert, 4) ! count has an unknown keyword argument + ! ERROR: unknown keyword argument to intrinsic 'event_query' call event_query(concert, counts=counter) ! count has an argument mismatch + ! ERROR: Actual argument for 'count=' has bad type 'LOGICAL(4)' call event_query(concert, count=non_integer) ! stat must be an integer + ! ERROR: Actual argument for 'stat=' has bad type 'LOGICAL(4)' call event_query(concert, counter, non_integer) ! stat must be an integer scalar + ! ERROR: 'stat=' argument has unacceptable rank 1 call event_query(concert, counter, non_scalar) ! stat is an intent(out) argument + ! ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + ! ERROR: '8_4' is not a variable or pointer call event_query(concert, counter, 8) ! stat has an unknown keyword argument + ! ERROR: unknown keyword argument to intrinsic 'event_query' call event_query(concert, counter, status=sync_status) ! stat has an argument mismatch + ! ERROR: Actual argument for 'stat=' has bad type 'LOGICAL(4)' call event_query(concert, counter, stat=non_integer) ! stat must not be coindexed + ! ERROR: 'stat' argument to 'event_query' may not be a coindexed object call event_query(concert, counter, coindexed[1]) ! Too many arguments + ! ERROR: too many actual arguments for intrinsic 'event_query' call event_query(concert, counter, sync_status, array(1)) ! Repeated event keyword + ! ERROR: repeated keyword argument to intrinsic 'event_query' call event_query(event=concert, event=occurrences(1), count=counter) ! Repeated count keyword + ! ERROR: repeated keyword argument to intrinsic 'event_query' call event_query(event=concert, count=counter, count=array(1)) ! Repeated stat keyword + ! ERROR: repeated keyword argument to intrinsic 'event_query' call event_query(event=concert, count=counter, stat=sync_status, stat=array(1)) end program test_event_query