Skip to content

Commit

Permalink
[flang] Recognize and check EVENT_QUERY
Browse files Browse the repository at this point in the history 
Recognize the intrinsic subroutine EVENT_QUERY and enforce semantic
requirements on calls to it.
  • Loading branch information
@klausler
klausler committed Jan 18, 2025
1 parent 93fd72c commit f937627
Show file tree
Hide file tree
Showing 3 changed files with 71 additions and 10 deletions.
17 changes: 15 additions & 2 deletions flang/lib/Evaluate/intrinsics.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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};
Expand Down Expand Up @@ -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},
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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 &&
Expand Down Expand Up @@ -3233,7 +3246,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_and" || name == "atomic_or" ||
name == "atomic_xor") {
name == "atomic_xor" || name == "event_query") {
return CheckForCoindexedObject(
context.messages(), call.arguments[2], name, "stat");
} else if (name == "atomic_cas") {
Expand Down
32 changes: 32 additions & 0 deletions flang/lib/Semantics/check-call.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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) {
Expand Down Expand Up @@ -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") {
Expand Down
32 changes: 24 additions & 8 deletions flang/test/Semantics/event_query.f90
View file
Original file line number Diff line number Diff line change
@@ -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)
Expand All @@ -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

0 comments on commit f937627

Please sign in to comment.