From 49c438f6a4b9c32eed4878461dce577e947c4076 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Tue, 25 Feb 2025 12:51:20 -0800 Subject: [PATCH] [flang] Accept proc ptr function result as actual argument without INTENT A dummy procedure pointer with no INTENT attribute may associate with an actual argument that is the result of a reference to a function that returns a procedure pointer, we think. Fixes https://github.com/llvm/llvm-project/issues/126950. --- flang/lib/Semantics/check-call.cpp | 40 +++++++++++++++++----------- flang/test/Semantics/call09.f90 | 17 ++++++------ flang/test/Semantics/call24.f90 | 2 +- flang/test/Semantics/definable01.f90 | 3 ++- 4 files changed, 35 insertions(+), 27 deletions(-) diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index e396ece303103..433e56da6a6cb 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1049,8 +1049,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, SemanticsContext &context, bool ignoreImplicitVsExplicit) { evaluate::FoldingContext &foldingContext{context.foldingContext()}; parser::ContextualMessages &messages{foldingContext.messages()}; - auto restorer{ - messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; + parser::CharBlock location{arg.sourceLocation().value_or(messages.at())}; + auto restorer{messages.SetLocation(location)}; const characteristics::Procedure &interface { dummy.procedure.value() }; if (const auto *expr{arg.UnwrapExpr()}) { bool dummyIsPointer{ @@ -1175,22 +1175,30 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, dummyName); } } - if (dummyIsPointer && dummy.intent != common::Intent::In) { - const Symbol *last{GetLastSymbol(*expr)}; - if (last && IsProcedurePointer(*last)) { - if (dummy.intent != common::Intent::Default && - IsIntentIn(last->GetUltimate())) { // 19.6.8 - messages.Say( - "Actual argument associated with procedure pointer %s may not be INTENT(IN)"_err_en_US, - dummyName); - } - } else if (!(dummy.intent == common::Intent::Default && - IsNullProcedurePointer(*expr))) { - // 15.5.2.9(5) -- dummy procedure POINTER - // Interface compatibility has already been checked above + if (dummyIsPointer) { + if (dummy.intent == common::Intent::In) { + // need not be definable, can be a target + } else if (!IsProcedurePointer(*expr)) { messages.Say( - "Actual argument associated with procedure pointer %s must be a pointer unless INTENT(IN)"_err_en_US, + "Actual argument associated with procedure pointer %s is not a procedure pointer"_err_en_US, dummyName); + } else if (dummy.intent == common::Intent::Default) { + // ok, needs to be definable only if defined at run time + } else { + DefinabilityFlags flags{DefinabilityFlag::PointerDefinition}; + if (dummy.intent != common::Intent::Out) { + flags.set(DefinabilityFlag::DoNotNoteDefinition); + } + if (auto whyNot{WhyNotDefinable( + location, context.FindScope(location), flags, *expr)}) { + if (auto *msg{messages.Say( + "Actual argument associated with INTENT(%s) procedure pointer %s is not definable"_err_en_US, + dummy.intent == common::Intent::Out ? "OUT" : "IN OUT", + dummyName)}) { + msg->Attach( + std::move(whyNot->set_severity(parser::Severity::Because))); + } + } } } } else { diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90 index b8583ba4a4907..58b2382f600ef 100644 --- a/flang/test/Semantics/call09.f90 +++ b/flang/test/Semantics/call09.f90 @@ -82,27 +82,26 @@ subroutine test1 ! 15.5.2.9(5) call s01(null(intPtr)) !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless call s01(B"0101") - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer call s02(realfunc) call s02(p) ! ok !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have distinct types: REAL(4) vs INTEGER(4) call s02(ip) - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) - call s02(procptr()) + call s02(procptr()) ! believed to be ok call s02(null()) ! ok - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) + !ERROR: Actual argument associated with INTENT(IN OUT) procedure pointer dummy argument 'p=' is not definable + !BECAUSE: 'NULL()' is a null pointer call s05(null()) - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer call s02(sin) - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer call s02b(realfunc) call s02b(p) ! ok !ERROR: Actual argument function associated with procedure dummy argument 'p=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4) call s02b(ip) - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) - call s02b(procptr()) + call s02b(procptr()) ! believed to be ok call s02b(null()) - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer call s02b(sin) end subroutine diff --git a/flang/test/Semantics/call24.f90 b/flang/test/Semantics/call24.f90 index 78ee17b488676..c1053db93648f 100644 --- a/flang/test/Semantics/call24.f90 +++ b/flang/test/Semantics/call24.f90 @@ -39,7 +39,7 @@ subroutine test() !ERROR: References to the procedure 'bar' require an explicit interface !BECAUSE: a dummy procedure is optional or a pointer !WARNING: If the procedure's interface were explicit, this reference would be in error - !BECAUSE: Actual argument associated with procedure pointer dummy argument 'a_pointer=' must be a pointer unless INTENT(IN) + !BECAUSE: Actual argument associated with procedure pointer dummy argument 'a_pointer=' is not a procedure pointer call bar(sin) !ERROR: References to the procedure 'baz' require an explicit interface diff --git a/flang/test/Semantics/definable01.f90 b/flang/test/Semantics/definable01.f90 index d3b31ee38b2a3..5af7e954e4171 100644 --- a/flang/test/Semantics/definable01.f90 +++ b/flang/test/Semantics/definable01.f90 @@ -77,7 +77,8 @@ subroutine test3(objp, procp) !CHECK: error: Actual argument associated with INTENT(IN OUT) dummy argument 'op=' is not definable !CHECK: because: 'objp' is an INTENT(IN) dummy argument call test3a(objp) - !CHECK: error: Actual argument associated with procedure pointer dummy argument 'pp=' may not be INTENT(IN) + !CHECK: error: Actual argument associated with INTENT(IN OUT) procedure pointer dummy argument 'pp=' is not definable + !CHECK: because: 'procp' is an INTENT(IN) dummy argument call test3b(procp) end subroutine subroutine test3a(op)