From 4e3bf225b7f8e540da3a96cf4f4001a68d8b2f57 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 25 Aug 2022 10:27:32 -0700 Subject: [PATCH] [flang] Allow NULL() actual argument for procedure pointer dummy argument with unspecified intent A NULL() pointer is a valid actual argument for a procedure pointer dummy argument whose intent is INTENT(IN); it should also be acceptable for a procedure pointer dummy argument with unspecified intent. Also make it possible to discern null object pointers from null procedure pointers, so that an attempt to use one in place of the other in a context where the distinction matters will still elicit an error. Differential Revision: https://reviews.llvm.org/D132687 --- flang/include/flang/Evaluate/tools.h | 2 ++ flang/lib/Evaluate/check-expression.cpp | 4 ++-- flang/lib/Evaluate/intrinsics.cpp | 18 ++++++++--------- flang/lib/Evaluate/tools.cpp | 36 +++++++++++++++++++++++++-------- flang/lib/Semantics/check-call.cpp | 8 +++++--- flang/lib/Semantics/data-to-inits.cpp | 2 +- flang/test/Semantics/call09.f90 | 8 +++++--- 7 files changed, 51 insertions(+), 27 deletions(-) diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 7d52161..4f73aaa 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -939,6 +939,8 @@ bool IsProcedure(const Expr &); bool IsFunction(const Expr &); bool IsProcedurePointerTarget(const Expr &); bool IsBareNullPointer(const Expr *); // NULL() w/o MOLD= +bool IsNullObjectPointer(const Expr &); +bool IsNullProcedurePointer(const Expr &); bool IsNullPointer(const Expr &); bool IsObjectPointer(const Expr &, FoldingContext &); diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 2071b12..f2486ef 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -98,7 +98,7 @@ template bool IsConstantExprHelper::IsConstantStructureConstructorComponent( const Symbol &component, const Expr &expr) const { if (IsAllocatable(component)) { - return IsNullPointer(expr); + return IsNullObjectPointer(expr); } else if (IsPointer(component)) { return IsNullPointer(expr) || IsInitialDataTarget(expr) || IsInitialProcedureTarget(expr); @@ -358,7 +358,7 @@ bool IsInitialProcedureTarget(const Expr &expr) { if (const auto *proc{std::get_if(&expr.u)}) { return IsInitialProcedureTarget(*proc); } else { - return IsNullPointer(expr); + return IsNullProcedurePointer(expr); } } diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 9dbbdc6..4eb0666 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2281,17 +2281,15 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) { targetName, whyNot), *pointerSymbol); } - } else { + } else if (!IsNullProcedurePointer(*targetExpr)) { // procedure pointer and object target - if (!IsNullPointer(*targetExpr)) { - AttachDeclaration( - context.messages().Say( - "POINTER= argument '%s' is a procedure " - "pointer but the TARGET= argument '%s' is not a " - "procedure or procedure pointer"_err_en_US, - pointerSymbol->name(), targetName), - *pointerSymbol); - } + AttachDeclaration( + context.messages().Say( + "POINTER= argument '%s' is a procedure " + "pointer but the TARGET= argument '%s' is not a " + "procedure or procedure pointer"_err_en_US, + pointerSymbol->name(), targetName), + *pointerSymbol); } } else if (targetProc) { // object pointer and procedure target diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 85aadeb..43c4eb3 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -771,7 +771,7 @@ inline const ProcedureRef *UnwrapProcedureRef(const Expr &expr) { // IsObjectPointer() bool IsObjectPointer(const Expr &expr, FoldingContext &context) { - if (IsNullPointer(expr)) { + if (IsNullObjectPointer(expr)) { return true; } else if (IsProcedurePointerTarget(expr)) { return false; @@ -788,14 +788,28 @@ bool IsBareNullPointer(const Expr *expr) { return expr && std::holds_alternative(expr->u); } -// IsNullPointer() -struct IsNullPointerHelper { +// IsNullObjectPointetr, IsNullProcedurePointer(), IsNullPointer() +template struct IsNullPointerHelper { template bool operator()(const A &) const { return false; } + bool operator()(const ProcedureRef &call) const { + if constexpr (IS_PROC_PTR) { + const auto *intrinsic{call.proc().GetSpecificIntrinsic()}; + return intrinsic && + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullPointer); + } else { + return false; + } + } template bool operator()(const FunctionRef &call) const { - const auto *intrinsic{call.proc().GetSpecificIntrinsic()}; - return intrinsic && - intrinsic->characteristics.value().attrs.test( - characteristics::Procedure::Attr::NullPointer); + if constexpr (IS_PROC_PTR) { + return false; + } else { + const auto *intrinsic{call.proc().GetSpecificIntrinsic()}; + return intrinsic && + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullPointer); + } } bool operator()(const NullPointer &) const { return true; } template bool operator()(const Parentheses &x) const { @@ -806,8 +820,14 @@ struct IsNullPointerHelper { } }; +bool IsNullObjectPointer(const Expr &expr) { + return IsNullPointerHelper{}(expr); +} +bool IsNullProcedurePointer(const Expr &expr) { + return IsNullPointerHelper{}(expr); +} bool IsNullPointer(const Expr &expr) { - return IsNullPointerHelper{}(expr); + return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr); } // GetSymbolVector() diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index d89bf93..00636c0 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -661,7 +661,9 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, if (interface.HasExplicitInterface() && dummyIsPointer && dummy.intent != common::Intent::In) { const Symbol *last{GetLastSymbol(*expr)}; - if (!(last && IsProcedurePointer(*last))) { + if (!(last && IsProcedurePointer(*last)) && + !(dummy.intent == common::Intent::Default && + IsNullProcedurePointer(*expr))) { // 15.5.2.9(5) -- dummy procedure POINTER // Interface compatibility has already been checked above messages.Say( @@ -729,13 +731,13 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, IsBOZLiteral(*expr)) { // ok } else if (object.type.type().IsTypelessIntrinsicArgument() && - evaluate::IsNullPointer(*expr)) { + evaluate::IsNullObjectPointer(*expr)) { // ok, ASSOCIATED(NULL()) } else if ((object.attrs.test(characteristics::DummyDataObject:: Attr::Pointer) || object.attrs.test(characteristics:: DummyDataObject::Attr::Optional)) && - evaluate::IsNullPointer(*expr)) { + evaluate::IsNullObjectPointer(*expr)) { // ok, FOO(NULL()) } else if (object.attrs.test(characteristics::DummyDataObject:: Attr::Allocatable) && diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp index a77ce60..281b8a3a 100644 --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -862,7 +862,7 @@ void ConstructInitializer(const Symbol &symbol, CHECK(!procDesignator->GetComponent()); mutableProc.set_init(DEREF(procDesignator->GetSymbol())); } else { - CHECK(evaluate::IsNullPointer(*expr)); + CHECK(evaluate::IsNullProcedurePointer(*expr)); mutableProc.set_init(nullptr); } } else { diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90 index f331989..36ab64e 100644 --- a/flang/test/Semantics/call09.f90 +++ b/flang/test/Semantics/call09.f90 @@ -29,6 +29,9 @@ module m !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute procedure(realfunc), intent(in) :: p end subroutine + subroutine s05(p) + procedure(realfunc), pointer, intent(in out) :: p + end subroutine subroutine selemental1(p) procedure(cos) :: p ! ok @@ -82,10 +85,9 @@ module m 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(null()) ! ok !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) - call s02(null()) - !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) - call s02(null(p)) + call s05(null()) !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) call s02(sin) end subroutine -- 2.7.4