[flang-commits] [flang] [flang] Accept pointer-valued function results as ASSOCIATED() arguments (PR #66238)
via flang-commits
flang-commits at lists.llvm.org
Wed Sep 13 09:48:43 PDT 2023
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
<details>
<summary>Changes</summary>
The POINTER= and TARGET= arguments to the intrinsic function ASSOCIATED() can be the results of references to functions that return object pointers or procedure pointers. NULL() was working well but not program-defined pointer-valued functions. Correct the validation of ASSOCIATED() and extend the infrastructure used to detect and characterize procedures and pointers.
--
Patch is 45.72 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/66238.diff
15 Files Affected:
- (modified) flang/include/flang/Evaluate/characteristics.h (+2)
- (modified) flang/include/flang/Evaluate/tools.h (+28-8)
- (modified) flang/lib/Evaluate/characteristics.cpp (+16)
- (modified) flang/lib/Evaluate/fold-complex.cpp (+1-1)
- (modified) flang/lib/Evaluate/intrinsics.cpp (+3-3)
- (modified) flang/lib/Evaluate/tools.cpp (+24-37)
- (modified) flang/lib/Lower/ConvertCall.cpp (+3-6)
- (modified) flang/lib/Lower/ConvertExpr.cpp (+13-20)
- (modified) flang/lib/Lower/ConvertVariable.cpp (+1-1)
- (modified) flang/lib/Lower/CustomIntrinsicCall.cpp (+11-17)
- (modified) flang/lib/Semantics/check-call.cpp (+38-65)
- (modified) flang/test/Semantics/associate01.f90 (+4-4)
- (modified) flang/test/Semantics/associated.f90 (+39-8)
- (modified) flang/test/Semantics/call09.f90 (+7-7)
- (modified) flang/test/Semantics/call24.f90 (+1-1)
<pre>
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 932f3220c2bcbbb..20750dfad8ce06e 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -349,6 +349,8 @@ struct Procedure {
const ProcedureDesignator &, FoldingContext &);
static std::optional<Procedure> Characterize(
const ProcedureRef &, FoldingContext &);
+ static std::optional<Procedure> Characterize(
+ const Expr<SomeType> &, FoldingContext &);
// Characterizes the procedure being referenced, deducing dummy argument
// types from actual arguments in the case of an implicit interface.
static std::optional<Procedure> FromActuals(
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index b3f8f4a67a7b5dd..6caad5db4b39b2d 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -243,6 +243,29 @@ auto UnwrapConvertedExpr(B &x) -> common::Constify<A, B> * {
return nullptr;
}
+// UnwrapProcedureRef() returns a pointer to a ProcedureRef when the whole
+// expression is a reference to a procedure.
+template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
+ return nullptr;
+}
+
+inline const ProcedureRef *UnwrapProcedureRef(const ProcedureRef &proc) {
+ // Reference to subroutine or to a function that returns
+ // an object pointer or procedure pointer
+ return &proc;
+}
+
+template <typename T>
+inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
+ return &func; // reference to a function returning a non-pointer
+}
+
+template <typename T>
+inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
+ return common::visit(
+ [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
+}
+
// When an expression is a "bare" LEN= derived type parameter inquiry,
// possibly wrapped in integer kind conversions &/or parentheses, return
// a pointer to the Symbol with TypeParamDetails.
@@ -894,10 +917,6 @@ template <typename A> const Symbol *GetLastSymbol(const A &x) {
}
}
-// If a function reference constitutes an entire expression, return a pointer
-// to its PrcedureRef.
-const ProcedureRef *GetProcedureRef(const Expr<SomeType> &);
-
// For everyday variables: if GetLastSymbol() succeeds on the argument, return
// its set of attributes, otherwise the empty set. Also works on variables that
// are pointer results of functions.
@@ -912,7 +931,7 @@ template <typename A> semantics::Attrs GetAttrs(const A &x) {
template <>
inline semantics::Attrs GetAttrs<Expr<SomeType>>(const Expr<SomeType> &x) {
if (IsVariable(x)) {
- if (const auto *procRef{GetProcedureRef(x)}) {
+ if (const auto *procRef{UnwrapProcedureRef(x)}) {
if (const Symbol * interface{procRef->proc().GetInterfaceSymbol()}) {
if (const auto *details{
interface->detailsIf<semantics::SubprogramDetails>()}) {
@@ -963,24 +982,25 @@ std::optional<BaseObject> GetBaseObject(const std::optional<A> &x) {
// Like IsAllocatableOrPointer, but accepts pointer function results as being
// pointers too.
-bool IsAllocatableOrPointerObject(const Expr<SomeType> &, FoldingContext &);
+bool IsAllocatableOrPointerObject(const Expr<SomeType> &);
bool IsAllocatableDesignator(const Expr<SomeType> &);
// Procedure and pointer detection predicates
bool IsProcedure(const Expr<SomeType> &);
bool IsFunction(const Expr<SomeType> &);
+bool IsPointer(const Expr<SomeType> &);
bool IsProcedurePointer(const Expr<SomeType> &);
bool IsProcedurePointerTarget(const Expr<SomeType> &);
bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
bool IsNullObjectPointer(const Expr<SomeType> &);
bool IsNullProcedurePointer(const Expr<SomeType> &);
bool IsNullPointer(const Expr<SomeType> &);
-bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
+bool IsObjectPointer(const Expr<SomeType> &);
// Can Expr be passed as absent to an optional dummy argument.
// See 15.5.2.12 point 1 for more details.
-bool MayBePassedAsAbsentOptional(const Expr<SomeType> &, FoldingContext &);
+bool MayBePassedAsAbsentOptional(const Expr<SomeType> &);
// Extracts the chain of symbols from a designator, which has perhaps been
// wrapped in an Expr<>, removing all of the (co)subscripts. The
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 8d52eabc16d502b..6daa113abe64255 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -1268,6 +1268,22 @@ std::optional<Procedure> Procedure::Characterize(
return std::nullopt;
}
+std::optional<Procedure> Procedure::Characterize(
+ const Expr<SomeType> &expr, FoldingContext &context) {
+ if (const auto *procRef{UnwrapProcedureRef(expr)}) {
+ return Characterize(*procRef, context);
+ } else if (const auto *procDesignator{
+ std::get_if<ProcedureDesignator>(&expr.u)}) {
+ return Characterize(*procDesignator, context);
+ } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
+ return Characterize(*symbol, context);
+ } else {
+ context.messages().Say(
+ "Expression '%s' is not a procedure"_err_en_US, expr.AsFortran());
+ return std::nullopt;
+ }
+}
+
std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
const ActualArguments &args, FoldingContext &context) {
auto callee{Characterize(proc, context)};
diff --git a/flang/lib/Evaluate/fold-complex.cpp b/flang/lib/Evaluate/fold-complex.cpp
index 520121ad254de77..e40e3a37df14948 100644
--- a/flang/lib/Evaluate/fold-complex.cpp
+++ b/flang/lib/Evaluate/fold-complex.cpp
@@ -47,7 +47,7 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
// into a complex constructor so that lowering can deal with the
// optional aspect (there is no optional aspect with the complex
// constructor).
- if (MayBePassedAsAbsentOptional(*args[1]->UnwrapExpr(), context)) {
+ if (MayBePassedAsAbsentOptional(*args[1]->UnwrapExpr())) {
return Expr<T>{std::move(funcRef)};
}
}
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 030e5b2fd2c6d9d..448e9aae6d5403e 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2577,7 +2577,7 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
arguments[0]) {
if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
bool isProcPtrTarget{IsProcedurePointerTarget(*mold)};
- if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold, context)) {
+ if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold)) {
characteristics::DummyArguments args;
std::optional<characteristics::FunctionResult> fResult;
if (isProcPtrTarget) {
@@ -2747,7 +2747,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
CheckForCoindexedObject(context, arguments[0], "c_loc", "x");
const auto *expr{arguments[0].value().UnwrapExpr()};
if (expr &&
- !(IsObjectPointer(*expr, context) ||
+ !(IsObjectPointer(*expr) ||
(IsVariable(*expr) && GetLastTarget(GetSymbolVector(*expr))))) {
context.messages().Say(arguments[0]->sourceLocation(),
"C_LOC() argument must be a data pointer or target"_err_en_US);
@@ -3094,7 +3094,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
for (const auto &arg : arguments) {
if (const auto *expr{arg->UnwrapExpr()}) {
optionalCount +=
- Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, context);
+ Fortran::evaluate::MayBePassedAsAbsentOptional(*expr);
}
}
if (arguments.size() - optionalCount > 1) {
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index d2fa5c9b5f36be6..0392adc60adb4e6 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -740,16 +740,25 @@ bool IsFunction(const Expr<SomeType> &expr) {
return designator && designator->GetType().has_value();
}
+bool IsPointer(const Expr<SomeType> &expr) {
+ return IsObjectPointer(expr) || IsProcedurePointer(expr);
+}
+
bool IsProcedurePointer(const Expr<SomeType> &expr) {
- return common::visit(common::visitors{
- [](const NullPointer &) { return true; },
- [](const ProcedureRef &) { return false; },
- [&](const auto &) {
- const Symbol *last{GetLastSymbol(expr)};
- return last && IsProcedurePointer(*last);
- },
- },
- expr.u);
+ if (IsNullProcedurePointer(expr)) {
+ return true;
+ } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
+ if (const Symbol * proc{funcRef->proc().GetSymbol()}) {
+ const Symbol *result{FindFunctionResult(*proc)};
+ return result && IsProcedurePointer(*result);
+ } else {
+ return false;
+ }
+ } else if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
+ return IsProcedurePointer(proc->GetSymbol());
+ } else {
+ return false;
+ }
}
bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
@@ -765,23 +774,7 @@ bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
expr.u);
}
-template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
- return nullptr;
-}
-
-template <typename T>
-inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
- return &func;
-}
-
-template <typename T>
-inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
- return common::visit(
- [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
-}
-
-// IsObjectPointer()
-bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
+bool IsObjectPointer(const Expr<SomeType> &expr) {
if (IsNullObjectPointer(expr)) {
return true;
} else if (IsProcedurePointerTarget(expr)) {
@@ -795,10 +788,6 @@ bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
}
}
-const ProcedureRef *GetProcedureRef(const Expr<SomeType> &expr) {
- return UnwrapProcedureRef(expr);
-}
-
// IsNullPointer() & variations
template <bool IS_PROC_PTR> struct IsNullPointerHelper {
@@ -872,7 +861,7 @@ bool IsBareNullPointer(const Expr<SomeType> *expr) {
// GetSymbolVector()
auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
- if (IsVariable(details->expr()) && !GetProcedureRef(*details->expr())) {
+ if (IsVariable(details->expr()) && !UnwrapProcedureRef(*details->expr())) {
// associate(x => variable that is not a pointer returned by a function)
return (*this)(details->expr());
}
@@ -1155,12 +1144,11 @@ std::optional<Expr<SomeType>> DataConstantConversionExtension(
return std::nullopt;
}
-bool IsAllocatableOrPointerObject(
- const Expr<SomeType> &expr, FoldingContext &context) {
+bool IsAllocatableOrPointerObject(const Expr<SomeType> &expr) {
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
return (sym &&
semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
- evaluate::IsObjectPointer(expr, context);
+ evaluate::IsObjectPointer(expr);
}
bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
@@ -1172,15 +1160,14 @@ bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
return false;
}
-bool MayBePassedAsAbsentOptional(
- const Expr<SomeType> &expr, FoldingContext &context) {
+bool MayBePassedAsAbsentOptional(const Expr<SomeType> &expr) {
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
// 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
// may be passed to a non-allocatable/non-pointer optional dummy. Note that
// other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
// ignore this point in intrinsic contexts (e.g CMPLX argument).
return (sym && semantics::IsOptional(*sym)) ||
- IsAllocatableOrPointerObject(expr, context);
+ IsAllocatableOrPointerObject(expr);
}
std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 15915b02aebaa70..fbf8eac642af2a7 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -1165,8 +1165,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
continue;
}
if (fir::isPointerType(argTy) &&
- !Fortran::evaluate::IsObjectPointer(
- *expr, callContext.converter.getFoldingContext())) {
+ !Fortran::evaluate::IsObjectPointer(*expr)) {
// Passing a non POINTER actual argument to a POINTER dummy argument.
// Create a pointer of the dummy argument type and assign the actual
// argument to it.
@@ -1814,13 +1813,11 @@ genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,
const Fortran::lower::SomeExpr &expr,
CallContext &callContext,
bool passAsAllocatableOrPointer) {
- if (!Fortran::evaluate::MayBePassedAsAbsentOptional(
- expr, callContext.converter.getFoldingContext()))
+ if (!Fortran::evaluate::MayBePassedAsAbsentOptional(expr))
return std::nullopt;
fir::FirOpBuilder &builder = callContext.getBuilder();
if (!passAsAllocatableOrPointer &&
- Fortran::evaluate::IsAllocatableOrPointerObject(
- expr, callContext.converter.getFoldingContext())) {
+ Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
// Passing Allocatable/Pointer to non-pointer/non-allocatable OPTIONAL.
// Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, it is
// as if the argument was absent. The main care here is to not do a
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index a9298be5532d905..26519d204460c67 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -1782,8 +1782,7 @@ class ScalarExprLowering {
/// Helper to lower intrinsic arguments for inquiry intrinsic.
ExtValue
lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
- if (Fortran::evaluate::IsAllocatableOrPointerObject(
- expr, converter.getFoldingContext()))
+ if (Fortran::evaluate::IsAllocatableOrPointerObject(expr))
return genMutableBoxValue(expr);
/// Do not create temps for array sections whose properties only need to be
/// inquired: create a descriptor that will be inquired.
@@ -1918,8 +1917,7 @@ class ScalarExprLowering {
fir::ArgLoweringRule argRules =
fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
if (argRules.handleDynamicOptional &&
- Fortran::evaluate::MayBePassedAsAbsentOptional(
- *expr, converter.getFoldingContext())) {
+ Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
switch (argRules.lowerAs) {
@@ -2392,8 +2390,7 @@ class ScalarExprLowering {
std::pair<ExtValue, mlir::Value>
prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) {
mlir::Location loc = getLoc();
- if (Fortran::evaluate::IsAllocatableOrPointerObject(
- expr, converter.getFoldingContext())) {
+ if (Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
// Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated,
// it is as if the argument was absent. The main care here is to
// not do a copy-in/copy-out because the temp address, even though
@@ -2496,8 +2493,8 @@ class ScalarExprLowering {
// not passed.
return {genTempExtAddr(expr), std::nullopt};
ExtValue baseAddr;
- if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
- expr, converter.getFoldingContext())) {
+ if (arg.isOptional() &&
+ Fortran::evaluate::MayBePassedAsAbsentOptional(expr)) {
auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr);
const ExtValue &actualArg = actualArgBind;
if (!needsCopy)
@@ -2631,8 +2628,7 @@ class ScalarExprLowering {
continue;
}
if (fir::isPointerType(argTy) &&
- !Fortran::evaluate::IsObjectPointer(
- *expr, converter.getFoldingContext())) {
+ !Fortran::evaluate::IsObjectPointer(*expr)) {
// Passing a non POINTER actual argument to a POINTER dummy argument.
// Create a pointer of the dummy argument type and assign the actual
// argument to it.
@@ -2759,8 +2755,7 @@ class ScalarExprLowering {
}
} else if (arg.isOptional() &&
- Fortran::evaluate::IsAllocatableOrPointerObject(
- *expr, converter.getFoldingContext())) {
+ Fortran::evaluate::IsAllocatableOrPointerObject(*expr)) {
// Before lowering to an address, handle the allocatable/pointer
// actual argument to optional fir.box dummy. It is legal to pass
// unallocated/disassociated entity to an optional. In this case, an
@@ -3355,8 +3350,7 @@ class ArrayExprLowering {
setPointerAssignmentBounds(lbounds, ubounds);
if (rhs.Rank() == 0 ||
(Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs) &&
- Fortran::evaluate::IsAllocatableOrPointerObject(
- rhs, converter.getFoldingContext()))) {
+ Fortran::evaluate::IsAllocatableOrPointerObject(rhs))) {
lowerScalarAssignment(lhs, rhs);
return;
}
@@ -4684,8 +4678,7 @@ class ArrayExprLowering {
fir::ArgLoweringRule argRules =
fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
if (argRules.handleDynamicOptional &&
- Fortran::evaluate::MayBePassedAsAbsentOptional(
- *e...
<truncated>
</pre>
</details>
https://github.com/llvm/llvm-project/pull/66238
More information about the flang-commits
mailing list