[flang-commits] [flang] [flang] Accept pointer-valued function results as ASSOCIATED() arguments (PR #66238)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Sep 13 17:01:53 PDT 2023
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/66238:
>From 0b7af95808bd7e8ea40ff08206d058b77e2905ce Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 1 Sep 2023 15:28:01 -0700
Subject: [PATCH] [flang] Accept pointer-valued function results as
ASSOCIATED() arguments
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.
Pull request: https://github.com/llvm/llvm-project/pull/66238
---
.../include/flang/Evaluate/characteristics.h | 2 +
flang/include/flang/Evaluate/tools.h | 36 ++++--
flang/lib/Evaluate/characteristics.cpp | 16 +++
flang/lib/Evaluate/fold-complex.cpp | 2 +-
flang/lib/Evaluate/intrinsics.cpp | 6 +-
flang/lib/Evaluate/tools.cpp | 61 ++++-------
flang/lib/Lower/ConvertCall.cpp | 9 +-
flang/lib/Lower/ConvertExpr.cpp | 33 +++---
flang/lib/Lower/ConvertVariable.cpp | 2 +-
flang/lib/Lower/CustomIntrinsicCall.cpp | 28 ++---
flang/lib/Semantics/check-call.cpp | 103 +++++++-----------
flang/test/Semantics/associate01.f90 | 8 +-
flang/test/Semantics/associated.f90 | 47 ++++++--
flang/test/Semantics/call09.f90 | 14 +--
flang/test/Semantics/call24.f90 | 2 +-
15 files changed, 191 insertions(+), 178 deletions(-)
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 69730286767ce95..55262a912d95629 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -233,6 +233,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.
@@ -884,10 +907,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.
@@ -902,7 +921,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>()}) {
@@ -953,24 +972,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 7213482d9d798f3..19cb556c2380c62 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 a4afc3db06022e2..d5cdebd7e49f079 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -826,16 +826,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) {
@@ -851,23 +860,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)) {
@@ -881,10 +874,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 {
@@ -958,7 +947,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());
}
@@ -1241,12 +1230,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) {
@@ -1258,15 +1246,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(
- *expr, converter.getFoldingContext())) {
+ Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
// Currently, there is not elemental intrinsic that requires lowering
// a potentially absent argument to something else than a value (apart
// from character MAX/MIN that are handled elsewhere.)
@@ -4768,8 +4761,8 @@ class ArrayExprLowering {
LLVM_DEBUG(expr->AsFortran(llvm::dbgs()
<< "argument: " << arg.firArgument << " = [")
<< "]\n");
- if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
- *expr, converter.getFoldingContext()))
+ if (arg.isOptional() &&
+ Fortran::evaluate::MayBePassedAsAbsentOptional(*expr))
TODO(loc,
"passing dynamically optional argument to elemental procedures");
switch (arg.passBy) {
@@ -5925,8 +5918,8 @@ class ArrayExprLowering {
fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
mlir::Type baseType = fir::unwrapRefType(base.getType());
const bool isBox = baseType.isa<fir::BoxType>();
- const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject(
- expr, converter.getFoldingContext());
+ const bool isAllocOrPtr =
+ Fortran::evaluate::IsAllocatableOrPointerObject(expr);
mlir::Type arrType = fir::unwrapPassByRefType(baseType);
mlir::Type eleType = fir::unwrapSequenceType(arrType);
ExtValue exv = optionalArg;
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 03a7cca1ab69817..eeba4e94ac5a44d 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -251,7 +251,7 @@ mlir::Value Fortran::lower::genInitialDataTarget(
// type. The return box is correctly created as a fir.box<fir.ptr<T>> where
// T is extracted from the MOLD argument.
if (const Fortran::evaluate::ProcedureRef *procRef =
- Fortran::evaluate::GetProcedureRef(initialTarget)) {
+ Fortran::evaluate::UnwrapProcedureRef(initialTarget)) {
const Fortran::evaluate::SpecificIntrinsic *intrinsic =
procRef->proc().GetSpecificIntrinsic();
if (intrinsic && intrinsic->name == "null") {
diff --git a/flang/lib/Lower/CustomIntrinsicCall.cpp b/flang/lib/Lower/CustomIntrinsicCall.cpp
index 9cf93785d240e2e..439fc3d915b4e42 100644
--- a/flang/lib/Lower/CustomIntrinsicCall.cpp
+++ b/flang/lib/Lower/CustomIntrinsicCall.cpp
@@ -24,8 +24,7 @@
/// runtime? This is a special case because MIN and MAX can have any number of
/// arguments.
static bool isMinOrMaxWithDynamicallyOptionalArg(
- llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
- Fortran::evaluate::FoldingContext &foldingContext) {
+ llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
if (name != "min" && name != "max")
return false;
const auto &args = procRef.arguments();
@@ -35,7 +34,7 @@ static bool isMinOrMaxWithDynamicallyOptionalArg(
for (std::size_t i = 2; i < argSize; ++i) {
if (auto *expr =
Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(args[i]))
- if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContext))
+ if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr))
return true;
}
return false;
@@ -45,14 +44,12 @@ static bool isMinOrMaxWithDynamicallyOptionalArg(
/// at runtime? This is a special case because the SIZE value to be applied
/// when absent is not zero.
static bool isIshftcWithDynamicallyOptionalArg(
- llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
- Fortran::evaluate::FoldingContext &foldingContext) {
+ llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
if (name != "ishftc" || procRef.arguments().size() < 3)
return false;
auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
procRef.arguments()[2]);
- return expr &&
- Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContext);
+ return expr && Fortran::evaluate::MayBePassedAsAbsentOptional(*expr);
}
/// Is this a call to ASSOCIATED where the TARGET is an OPTIONAL (but not a
@@ -67,8 +64,7 @@ static bool isIshftcWithDynamicallyOptionalArg(
/// TARGET that are OPTIONAL get conditionally emboxed here to convey the
/// optional aspect to the runtime.
static bool isAssociatedWithDynamicallyOptionalArg(
- llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
- Fortran::evaluate::FoldingContext &foldingContext) {
+ llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
if (name != "associated" || procRef.arguments().size() < 2)
return false;
auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
@@ -84,10 +80,9 @@ bool Fortran::lower::intrinsicRequiresCustomOptionalHandling(
const Fortran::evaluate::SpecificIntrinsic &intrinsic,
AbstractConverter &converter) {
llvm::StringRef name = intrinsic.name;
- Fortran::evaluate::FoldingContext &fldCtx = converter.getFoldingContext();
- return isMinOrMaxWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
- isIshftcWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
- isAssociatedWithDynamicallyOptionalArg(name, procRef, fldCtx);
+ return isMinOrMaxWithDynamicallyOptionalArg(name, procRef) ||
+ isIshftcWithDynamicallyOptionalArg(name, procRef) ||
+ isAssociatedWithDynamicallyOptionalArg(name, procRef);
}
/// Generate the FIR+MLIR operations for the generic intrinsic \p name
@@ -130,8 +125,8 @@ static void prepareMinOrMaxArguments(
Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
if (!expr)
continue;
- if (arg.index() <= 1 || !Fortran::evaluate::MayBePassedAsAbsentOptional(
- *expr, converter.getFoldingContext())) {
+ if (arg.index() <= 1 ||
+ !Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
// Non optional arguments.
prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
} else {
@@ -204,8 +199,7 @@ static void prepareIshftcArguments(
Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
assert(expr && "expected all ISHFTC argument to be textually present here");
if (arg.index() == 2) {
- assert(Fortran::evaluate::MayBePassedAsAbsentOptional(
- *expr, converter.getFoldingContext()) &&
+ assert(Fortran::evaluate::MayBePassedAsAbsentOptional(*expr) &&
"expected ISHFTC SIZE arg to be dynamically optional");
prepareOptionalArgument(*expr);
} else {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 27abc9e2938af9f..ef05b2ab61e8bcd 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -462,7 +462,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
? actualLastSymbol->detailsIf<ObjectEntityDetails>()
: nullptr};
int actualRank{actualType.Rank()};
- bool actualIsPointer{evaluate::IsObjectPointer(actual, foldingContext)};
+ bool actualIsPointer{evaluate::IsObjectPointer(actual)};
if (dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)) {
// 15.5.2.4(16)
@@ -992,7 +992,7 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
// 15.5.2.9(5) -- dummy procedure POINTER
// Interface compatibility has already been checked above
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 must be a pointer unless INTENT(IN)"_err_en_US,
dummyName);
}
}
@@ -1243,12 +1243,9 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
if (const auto &pointerArg{arguments[0]}) {
if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
- const Symbol *pointerSymbol{GetLastSymbol(*pointerExpr)};
- if (pointerSymbol && !IsPointer(pointerSymbol->GetUltimate())) {
- evaluate::AttachDeclaration(
- context.messages().Say(pointerArg->sourceLocation(),
- "POINTER= argument of ASSOCIATED() must be a POINTER"_err_en_US),
- *pointerSymbol);
+ if (!IsPointer(*pointerExpr)) {
+ context.messages().Say(pointerArg->sourceLocation(),
+ "POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US);
return;
}
if (const auto &targetArg{arguments[1]}) {
@@ -1261,7 +1258,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
!evaluate::IsProcedurePointer(*pointerExpr)) {
context.messages().Say(pointerArg->sourceLocation(),
"POINTER= argument of ASSOCIATED() should be a pointer"_port_en_US);
- } else if (scope) {
+ } else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {
if (auto whyNot{WhyNotDefinable(pointerArg->sourceLocation().value_or(
context.messages().at()),
*scope,
@@ -1273,59 +1270,37 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
}
}
- if (const auto *targetExpr{targetArg->UnwrapExpr()};
- targetExpr && pointerSymbol) {
- if (IsProcedure(*pointerSymbol)) {
+ if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
+ if (IsProcedurePointer(*pointerExpr) &&
+ !IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure
if (auto pointerProc{characteristics::Procedure::Characterize(
- *pointerSymbol, context)}) {
- // Characterize the target procedure
- std::optional<characteristics::Procedure> targetProc;
- const auto *targetProcDesignator{
- evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
- *targetExpr)};
- bool isCall{false};
- std::string targetName;
- if (IsProcedure(*targetExpr) ||
- IsNullProcedurePointer(*targetExpr)) {
- if (const auto *targetProcRef{
- std::get_if<evaluate::ProcedureRef>(&targetExpr->u)}) {
- // target is a function call returning a procedure pointer
- targetProc = characteristics::Procedure::Characterize(
- *targetProcRef, context);
- isCall = true;
- targetName = targetProcRef->proc().GetName() + "()";
- } else if (targetProcDesignator) {
- targetProc = characteristics::Procedure::Characterize(
- *targetProcDesignator, context);
- targetName = targetProcDesignator->GetName();
- } else if (const Symbol * targSym{GetLastSymbol(*targetExpr)}) {
- targetProc = characteristics::Procedure::Characterize(
- *targSym, context);
- targetName = targSym->name().ToString();
- }
- }
- if (targetProc) {
- std::string whyNot;
- const evaluate::SpecificIntrinsic *specificIntrinsic{
- targetProcDesignator
- ? targetProcDesignator->GetSpecificIntrinsic()
- : nullptr};
- if (std::optional<parser::MessageFixedText> msg{
- CheckProcCompatibility(isCall, pointerProc,
- &*targetProc, specificIntrinsic, whyNot)}) {
- msg->set_severity(parser::Severity::Warning);
- evaluate::AttachDeclaration(
- context.messages().Say(std::move(*msg),
- "pointer '" + pointerSymbol->name().ToString() + "'",
- targetName, whyNot),
- *pointerSymbol);
+ *pointerExpr, context)}) {
+ if (IsBareNullPointer(targetExpr)) {
+ } else if (IsProcedurePointerTarget(*targetExpr)) {
+ if (auto targetProc{characteristics::Procedure::Characterize(
+ *targetExpr, context)}) {
+ bool isCall{!!UnwrapProcedureRef(*targetExpr)};
+ std::string whyNot;
+ const auto *targetProcDesignator{
+ evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
+ *targetExpr)};
+ const evaluate::SpecificIntrinsic *specificIntrinsic{
+ targetProcDesignator
+ ? targetProcDesignator->GetSpecificIntrinsic()
+ : nullptr};
+ if (std::optional<parser::MessageFixedText> msg{
+ CheckProcCompatibility(isCall, pointerProc,
+ &*targetProc, specificIntrinsic, whyNot)}) {
+ msg->set_severity(parser::Severity::Warning);
+ context.messages().Say(std::move(*msg),
+ "pointer '" + pointerExpr->AsFortran() + "'",
+ targetExpr->AsFortran(), whyNot);
+ }
}
} else if (!IsNullProcedurePointer(*targetExpr)) {
- evaluate::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(), targetExpr->AsFortran()),
- *pointerSymbol);
+ 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,
+ pointerExpr->AsFortran(), targetExpr->AsFortran());
}
}
} else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) {
@@ -1353,11 +1328,9 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
}
} else {
- evaluate::AttachDeclaration(
- context.messages().Say(
- "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
- pointerSymbol->name(), targetExpr->AsFortran()),
- *pointerSymbol);
+ context.messages().Say(
+ "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
+ pointerExpr->AsFortran(), targetExpr->AsFortran());
}
}
}
@@ -1368,7 +1341,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
if (!ok) {
context.messages().Say(
- "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
+ "Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US);
}
}
diff --git a/flang/test/Semantics/associate01.f90 b/flang/test/Semantics/associate01.f90
index 6f8e52077990e23..deafea695e84f24 100644
--- a/flang/test/Semantics/associate01.f90
+++ b/flang/test/Semantics/associate01.f90
@@ -23,24 +23,24 @@ subroutine test
integer, pointer :: ip
associate (sel => iptr(itarget))
ip => sel
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
if (.not. associated(sel)) stop
end associate
associate (sel => tv%iptr(itarget))
ip => sel
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
if (.not. associated(sel)) stop
end associate
associate (sel => (iptr(itarget)))
!ERROR: In assignment to object pointer 'ip', the target 'sel' is not an object with POINTER or TARGET attributes
ip => sel
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
if (.not. associated(sel)) stop
end associate
associate (sel => 0 + iptr(itarget))
!ERROR: In assignment to object pointer 'ip', the target 'sel' is not an object with POINTER or TARGET attributes
ip => sel
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
if (.not. associated(sel)) stop
end associate
end subroutine
diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
index 7229f8ad4ece09b..1737970ac3988d0 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -20,7 +20,7 @@ integer function abstractIntFunc(x)
type(t1), pointer :: t1ptr(:)
end type t2
- contains
+ contains
integer function intFunc(x)
integer, intent(in) :: x
intFunc = x
@@ -48,6 +48,17 @@ subroutine subrCannotBeCalledfromImplicit(i)
integer :: i(:)
end subroutine subrCannotBeCalledfromImplicit
+ function objPtrFunc(x)
+ integer, target :: x
+ integer, pointer :: objPtrFunc
+ objPtrFunc => x
+ end
+
+ function procPtrFunc
+ procedure(intFunc), pointer :: procPtrFunc
+ procPtrFunc => intFunc
+ end
+
subroutine test(assumedRank)
real, pointer, intent(in out) :: assumedRank(..)
integer :: intVar
@@ -116,16 +127,16 @@ subroutine test(assumedRank)
lVar = associated(null(), null(intPointerVar1)) !OK
!PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
lVar = associated(null(intPointerVar1), null()) !OK
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
lVar = associated(intVar)
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
lVar = associated(intVar, intVar)
- !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ !ERROR: POINTER= argument of ASSOCIATED() must be a pointer
lVar = associated(intAllocVar)
- !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
+ !ERROR: Arguments of ASSOCIATED() must be a pointer and an optional valid target
lVar = associated(intPointerVar1, targetRealVar)
lVar = associated(intPointerVar1, targetIntVar1) !OK
- !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
+ !ERROR: Arguments of ASSOCIATED() must be a pointer and an optional valid target
lVar = associated(intPointerVar1, targetIntVar2)
lVar = associated(intPointerVar1) !OK
lVar = associated(intPointerVar1, intPointerVar2) !OK
@@ -157,10 +168,30 @@ subroutine test(assumedRank)
intProcPointer1 => null(intProcPointer2) ! ok
lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
intProcPointer1 =>null() ! ok
- lvar = associated(intProcPointer1, null()) ! ok
+ lvar = associated(intProcPointer1, null())
intPointerVar1 => null(intPointerVar1) ! ok
lvar = associated (intPointerVar1, null(intPointerVar1)) ! ok
+ ! Functions (other than NULL) returning pointers
+ lVar = associated(objPtrFunc(targetIntVar1)) ! ok
+ !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ lVar = associated(objPtrFunc(targetIntVar1), targetIntVar1) ! ok
+ !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ lVar = associated(objPtrFunc(targetIntVar1), objPtrFunc(targetIntVar1)) ! ok
+ lVar = associated(procPtrFunc()) ! ok
+ lVar = associated(procPtrFunc(), intFunc) ! ok
+ lVar = associated(procPtrFunc(), procPtrFunc()) ! ok
+ !ERROR: POINTER= argument 'objptrfunc(targetintvar1)' is an object pointer but the TARGET= argument 'intfunc' is not a variable
+ !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ lVar = associated(objPtrFunc(targetIntVar1), intFunc)
+ !ERROR: POINTER= argument 'objptrfunc(targetintvar1)' is an object pointer but the TARGET= argument 'procptrfunc()' is not a variable
+ !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer
+ lVar = associated(objPtrFunc(targetIntVar1), procPtrFunc())
+ !ERROR: POINTER= argument 'procptrfunc()' is a procedure pointer but the TARGET= argument 'objptrfunc(targetintvar1)' is not a procedure or procedure pointer
+ lVar = associated(procPtrFunc(), objPtrFunc(targetIntVar1))
+ !ERROR: POINTER= argument 'procptrfunc()' is a procedure pointer but the TARGET= argument 'targetintvar1' is not a procedure or procedure pointer
+ lVar = associated(procPtrFunc(), targetIntVar1)
+
!ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
intprocPointer1 => intVar
!ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
@@ -180,7 +211,7 @@ subroutine test(assumedRank)
lvar = associated (intProcPointer1, targetIntVar1)
!ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)
intProcPointer1 => null(mold=realProcPointer1)
- !WARNING: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)
+ !WARNING: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null(mold=realprocpointer1)' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)
lvar = associated(intProcPointer1, null(mold=realProcPointer1))
!ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
pureFuncPointer => intProc
diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90
index 463f03bc62ff489..0c28e391c937007 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -82,27 +82,27 @@ 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=' must be a pointer unless INTENT(IN)
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)
+ !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)
+ !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
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=' must be a pointer unless INTENT(IN)
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=' must be a pointer unless INTENT(IN)
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)
+ !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
call s02b(procptr())
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=' must be a pointer unless INTENT(IN)
call s02b(sin)
end subroutine
diff --git a/flang/test/Semantics/call24.f90 b/flang/test/Semantics/call24.f90
index 7d2ba9ff80d4018..5fbb441908167f8 100644
--- a/flang/test/Semantics/call24.f90
+++ b/flang/test/Semantics/call24.f90
@@ -36,7 +36,7 @@ subroutine test()
!ERROR: References to the procedure 'bar' require an explicit interface
!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=' must be a pointer unless INTENT(IN)
call bar(sin)
!ERROR: References to the procedure 'baz' require an explicit interface
More information about the flang-commits
mailing list