[flang-commits] [flang] 4e3bf22 - [flang] Allow NULL() actual argument for procedure pointer dummy argument with unspecified intent
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Aug 25 16:23:26 PDT 2022
Author: Peter Klausler
Date: 2022-08-25T16:23:11-07:00
New Revision: 4e3bf225b7f8e540da3a96cf4f4001a68d8b2f57
URL: https://github.com/llvm/llvm-project/commit/4e3bf225b7f8e540da3a96cf4f4001a68d8b2f57
DIFF: https://github.com/llvm/llvm-project/commit/4e3bf225b7f8e540da3a96cf4f4001a68d8b2f57.diff
LOG: [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
Added:
Modified:
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/check-expression.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/data-to-inits.cpp
flang/test/Semantics/call09.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 7d521612e42a9..4f73aaad0c27c 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -939,6 +939,8 @@ bool IsProcedure(const Expr<SomeType> &);
bool IsFunction(const Expr<SomeType> &);
bool IsProcedurePointerTarget(const Expr<SomeType> &);
bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD=
+bool IsNullObjectPointer(const Expr<SomeType> &);
+bool IsNullProcedurePointer(const Expr<SomeType> &);
bool IsNullPointer(const Expr<SomeType> &);
bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 2071b12b1dcf9..f2486ef9666a8 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -98,7 +98,7 @@ template <bool INVARIANT>
bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
const Symbol &component, const Expr<SomeType> &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<SomeType> &expr) {
if (const auto *proc{std::get_if<ProcedureDesignator>(&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 9dbbdc6621ba9..4eb06669559f0 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 85aadeb3efcd9..43c4eb34980f2 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -771,7 +771,7 @@ inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
// IsObjectPointer()
bool IsObjectPointer(const Expr<SomeType> &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<SomeType> *expr) {
return expr && std::holds_alternative<NullPointer>(expr->u);
}
-// IsNullPointer()
-struct IsNullPointerHelper {
+// IsNullObjectPointetr, IsNullProcedurePointer(), IsNullPointer()
+template <bool IS_PROC_PTR> struct IsNullPointerHelper {
template <typename A> 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 <typename T> bool operator()(const FunctionRef<T> &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 <typename T> bool operator()(const Parentheses<T> &x) const {
@@ -806,8 +820,14 @@ struct IsNullPointerHelper {
}
};
+bool IsNullObjectPointer(const Expr<SomeType> &expr) {
+ return IsNullPointerHelper<false>{}(expr);
+}
+bool IsNullProcedurePointer(const Expr<SomeType> &expr) {
+ return IsNullPointerHelper<true>{}(expr);
+}
bool IsNullPointer(const Expr<SomeType> &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 d89bf93ce27a2..00636c052bfbf 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 a77ce605a97d3..281b8a3a93802 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 f3319898e6b84..36ab64ecce50d 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -29,6 +29,9 @@ subroutine s04(p)
!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 @@ subroutine test1 ! 15.5.2.9(5)
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
More information about the flang-commits
mailing list