[flang] Recognize and check EVENT_QUERY

[klausler]

Recognize the intrinsic subroutine EVENT_QUERY and enforce semantic requirements on calls to it.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

Recognize the intrinsic subroutine EVENT_QUERY and enforce semantic requirements on calls to it.

---

Full diff: https://github.com/llvm/llvm-project/pull/123429.diff

3 Files Affected:

• (modified) flang/lib/Evaluate/intrinsics.cpp (+14-1)
• (modified) flang/lib/Semantics/check-call.cpp (+32)
• (modified) flang/test/Semantics/event_query.f90 (+23-5)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index f234241cfe14a6..4be842ab061e96 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};
@@ -1463,6 +1465,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},
@@ -1584,7 +1593,6 @@ static const IntrinsicInterface intrinsicSubroutine[]{
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
 };
 
-// TODO: Intrinsic subroutine EVENT_QUERY
 // TODO: Atomic intrinsic subroutines: ATOMIC_ADD
 // TODO: Collective intrinsic subroutines: co_reduce
 
@@ -1960,6 +1968,11 @@ std::optional<SpecificCall> 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 &&
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index ba68a0f898d469..ba7e79df63335f 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 3f38e3dd378778..b67a82d520b085 100644
--- a/flang/test/Semantics/event_query.f90
+++ b/flang/test/Semantics/event_query.f90
@@ -1,11 +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
+  implicit none(type,external)
 
   ! event_type variables must be coarrays
   type(event_type) non_coarray
@@ -33,70 +32,89 @@ 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
   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