diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp index e69a73c7837ce..0b57197fb8db8 100644 --- a/flang/lib/Semantics/assignment.cpp +++ b/flang/lib/Semantics/assignment.cpp @@ -66,8 +66,13 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) { const SomeExpr &rhs{assignment->rhs}; auto lhsLoc{std::get(stmt.t).GetSource()}; const Scope &scope{context_.FindScope(lhsLoc)}; - if (auto whyNot{WhyNotDefinable(lhsLoc, scope, - DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk}, lhs)}) { + DefinabilityFlags flags{DefinabilityFlag::VectorSubscriptIsOk}; + bool isDefinedAssignment{ + std::holds_alternative(assignment->u)}; + if (isDefinedAssignment) { + flags.set(DefinabilityFlag::AllowEventLockOrNotifyType); + } + if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) { if (whyNot->IsFatal()) { if (auto *msg{Say(lhsLoc, "Left-hand side of assignment is not definable"_err_en_US)}) { @@ -79,9 +84,7 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) { } } auto rhsLoc{std::get(stmt.t).source}; - if (std::holds_alternative(assignment->u)) { - // it's a defined ASSIGNMENT(=) - } else { + if (!isDefinedAssignment) { CheckForPureContext(rhs, rhsLoc); } if (whereDepth_ > 0) { diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 597c280a6df8b..8631789b9f526 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -703,12 +703,14 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, // Problems with polymorphism are caught in the callee's definition. if (scope) { std::optional undefinableMessage; - if (dummy.intent == common::Intent::Out) { - undefinableMessage = - "Actual argument associated with INTENT(OUT) %s is not definable"_err_en_US; - } else if (dummy.intent == common::Intent::InOut) { + DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure}; + if (dummy.intent == common::Intent::InOut) { + flags.set(DefinabilityFlag::AllowEventLockOrNotifyType); undefinableMessage = "Actual argument associated with INTENT(IN OUT) %s is not definable"_err_en_US; + } else if (dummy.intent == common::Intent::Out) { + undefinableMessage = + "Actual argument associated with INTENT(OUT) %s is not definable"_err_en_US; } else if (context.ShouldWarn(common::LanguageFeature:: UndefinableAsynchronousOrVolatileActual)) { if (dummy.attrs.test( @@ -722,7 +724,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } if (undefinableMessage) { - DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure}; if (isElemental) { // 15.5.2.4(21) flags.set(DefinabilityFlag::VectorSubscriptIsOk); } diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp index 88f9463e35c78..6d0155c24c31a 100644 --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -204,7 +204,8 @@ static std::optional WhyNotDefinableLast(parser::CharBlock at, } return std::nullopt; // pointer assignment - skip following checks } - if (IsOrContainsEventOrLockComponent(ultimate)) { + if (!flags.test(DefinabilityFlag::AllowEventLockOrNotifyType) && + IsOrContainsEventOrLockComponent(ultimate)) { return BlameSymbol(at, "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US, original); diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h index 709bbba494d10..902702dbccbf3 100644 --- a/flang/lib/Semantics/definable.h +++ b/flang/lib/Semantics/definable.h @@ -32,7 +32,8 @@ ENUM_CLASS(DefinabilityFlag, AcceptAllocatable, // treat allocatable as if it were a pointer SourcedAllocation, // ALLOCATE(a,SOURCE=) PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram - DoNotNoteDefinition) // context does not imply definition + DoNotNoteDefinition, // context does not imply definition + AllowEventLockOrNotifyType) using DefinabilityFlags = common::EnumSet; diff --git a/flang/test/Semantics/definable01.f90 b/flang/test/Semantics/definable01.f90 index ff71b419fa971..d3b31ee38b2a3 100644 --- a/flang/test/Semantics/definable01.f90 +++ b/flang/test/Semantics/definable01.f90 @@ -109,7 +109,29 @@ pure function test6(lp) end pure subroutine test7(lp) type(list), pointer :: lp - !CHECK-NOT: error: - lp%next%next => null() + lp%next%next => null() ! ok end end module +program main + use iso_fortran_env, only: lock_type + type(lock_type) lock + interface + subroutine inlock(lock) + import lock_type + type(lock_type), intent(in) :: lock + end + subroutine outlock(lock) + import lock_type + !CHECK: error: An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE + type(lock_type), intent(out) :: lock + end + subroutine inoutlock(lock) + import lock_type + type(lock_type), intent(in out) :: lock + end + end interface + call inlock(lock) ! ok + call inoutlock(lock) ! ok + !CHECK: error: Actual argument associated with INTENT(OUT) dummy argument 'lock=' is not definable + call outlock(lock) +end