[flang-commits] [flang] [flang] Recognize and check EVENT_QUERY (PR #123429)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Jan 27 08:53:35 PST 2025
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/123429
>From 24a13b72bdab820690a52859d83b579e0ac9228f Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 17 Jan 2025 16:16:26 -0800
Subject: [PATCH] [flang] Recognize and check EVENT_QUERY
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 77d37d40bbddc0..954581fd713a22 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<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 &&
@@ -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 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..f648462bc2090c 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
More information about the flang-commits
mailing list