Skip to content

Commit f025e41

Browse files
klauslerklausler
authored
[flang] Accept pointer-valued function results as ASSOCIATED() arguments (#66238)
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.
1 parent 5aa8e43 commit f025e41

File tree

15 files changed

+191
-178
lines changed

15 files changed

+191
-178
lines changed

‎flang/include/flang/Evaluate/characteristics.h

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -349,6 +349,8 @@ struct Procedure {
349349
const ProcedureDesignator &, FoldingContext &);
350350
static std::optional<Procedure> Characterize(
351351
const ProcedureRef &, FoldingContext &);
352+
static std::optional<Procedure> Characterize(
353+
const Expr<SomeType> &, FoldingContext &);
352354
// Characterizes the procedure being referenced, deducing dummy argument
353355
// types from actual arguments in the case of an implicit interface.
354356
static std::optional<Procedure> FromActuals(

‎flang/include/flang/Evaluate/tools.h

Lines changed: 28 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -233,6 +233,29 @@ auto UnwrapConvertedExpr(B &x) -> common::Constify<A, B> * {
233233
return nullptr;
234234
}
235235

236+
// UnwrapProcedureRef() returns a pointer to a ProcedureRef when the whole
237+
// expression is a reference to a procedure.
238+
template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
239+
return nullptr;
240+
}
241+
242+
inline const ProcedureRef *UnwrapProcedureRef(const ProcedureRef &proc) {
243+
// Reference to subroutine or to a function that returns
244+
// an object pointer or procedure pointer
245+
return &proc;
246+
}
247+
248+
template <typename T>
249+
inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
250+
return &func; // reference to a function returning a non-pointer
251+
}
252+
253+
template <typename T>
254+
inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
255+
return common::visit(
256+
[](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
257+
}
258+
236259
// When an expression is a "bare" LEN= derived type parameter inquiry,
237260
// possibly wrapped in integer kind conversions &/or parentheses, return
238261
// a pointer to the Symbol with TypeParamDetails.
@@ -884,10 +907,6 @@ template <typename A> const Symbol *GetLastSymbol(const A &x) {
884907
}
885908
}
886909

887-
// If a function reference constitutes an entire expression, return a pointer
888-
// to its PrcedureRef.
889-
const ProcedureRef *GetProcedureRef(const Expr<SomeType> &);
890-
891910
// For everyday variables: if GetLastSymbol() succeeds on the argument, return
892911
// its set of attributes, otherwise the empty set. Also works on variables that
893912
// are pointer results of functions.
@@ -902,7 +921,7 @@ template <typename A> semantics::Attrs GetAttrs(const A &x) {
902921
template <>
903922
inline semantics::Attrs GetAttrs<Expr<SomeType>>(const Expr<SomeType> &x) {
904923
if (IsVariable(x)) {
905-
if (const auto *procRef{GetProcedureRef(x)}) {
924+
if (const auto *procRef{UnwrapProcedureRef(x)}) {
906925
if (const Symbol * interface{procRef->proc().GetInterfaceSymbol()}) {
907926
if (const auto *details{
908927
interface->detailsIf<semantics::SubprogramDetails>()}) {
@@ -953,24 +972,25 @@ std::optional<BaseObject> GetBaseObject(const std::optional<A> &x) {
953972

954973
// Like IsAllocatableOrPointer, but accepts pointer function results as being
955974
// pointers too.
956-
bool IsAllocatableOrPointerObject(const Expr<SomeType> &, FoldingContext &);
975+
bool IsAllocatableOrPointerObject(const Expr<SomeType> &);
957976

958977
bool IsAllocatableDesignator(const Expr<SomeType> &);
959978

960979
// Procedure and pointer detection predicates
961980
bool IsProcedure(const Expr<SomeType> &);
962981
bool IsFunction(const Expr<SomeType> &);
982+
bool IsPointer(const Expr<SomeType> &);
963983
bool IsProcedurePointer(const Expr<SomeType> &);
964984
bool IsProcedurePointerTarget(const Expr<SomeType> &);
965985
bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
966986
bool IsNullObjectPointer(const Expr<SomeType> &);
967987
bool IsNullProcedurePointer(const Expr<SomeType> &);
968988
bool IsNullPointer(const Expr<SomeType> &);
969-
bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
989+
bool IsObjectPointer(const Expr<SomeType> &);
970990

971991
// Can Expr be passed as absent to an optional dummy argument.
972992
// See 15.5.2.12 point 1 for more details.
973-
bool MayBePassedAsAbsentOptional(const Expr<SomeType> &, FoldingContext &);
993+
bool MayBePassedAsAbsentOptional(const Expr<SomeType> &);
974994

975995
// Extracts the chain of symbols from a designator, which has perhaps been
976996
// wrapped in an Expr<>, removing all of the (co)subscripts. The

‎flang/lib/Evaluate/characteristics.cpp

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1268,6 +1268,22 @@ std::optional<Procedure> Procedure::Characterize(
12681268
return std::nullopt;
12691269
}
12701270

1271+
std::optional<Procedure> Procedure::Characterize(
1272+
const Expr<SomeType> &expr, FoldingContext &context) {
1273+
if (const auto *procRef{UnwrapProcedureRef(expr)}) {
1274+
return Characterize(*procRef, context);
1275+
} else if (const auto *procDesignator{
1276+
std::get_if<ProcedureDesignator>(&expr.u)}) {
1277+
return Characterize(*procDesignator, context);
1278+
} else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
1279+
return Characterize(*symbol, context);
1280+
} else {
1281+
context.messages().Say(
1282+
"Expression '%s' is not a procedure"_err_en_US, expr.AsFortran());
1283+
return std::nullopt;
1284+
}
1285+
}
1286+
12711287
std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
12721288
const ActualArguments &args, FoldingContext &context) {
12731289
auto callee{Characterize(proc, context)};

‎flang/lib/Evaluate/fold-complex.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,7 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
4747
// into a complex constructor so that lowering can deal with the
4848
// optional aspect (there is no optional aspect with the complex
4949
// constructor).
50-
if (MayBePassedAsAbsentOptional(*args[1]->UnwrapExpr(), context)) {
50+
if (MayBePassedAsAbsentOptional(*args[1]->UnwrapExpr())) {
5151
return Expr<T>{std::move(funcRef)};
5252
}
5353
}

‎flang/lib/Evaluate/intrinsics.cpp

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2577,7 +2577,7 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
25772577
arguments[0]) {
25782578
if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
25792579
bool isProcPtrTarget{IsProcedurePointerTarget(*mold)};
2580-
if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold, context)) {
2580+
if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold)) {
25812581
characteristics::DummyArguments args;
25822582
std::optional<characteristics::FunctionResult> fResult;
25832583
if (isProcPtrTarget) {
@@ -2747,7 +2747,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
27472747
CheckForCoindexedObject(context, arguments[0], "c_loc", "x");
27482748
const auto *expr{arguments[0].value().UnwrapExpr()};
27492749
if (expr &&
2750-
!(IsObjectPointer(*expr, context) ||
2750+
!(IsObjectPointer(*expr) ||
27512751
(IsVariable(*expr) && GetLastTarget(GetSymbolVector(*expr))))) {
27522752
context.messages().Say(arguments[0]->sourceLocation(),
27532753
"C_LOC() argument must be a data pointer or target"_err_en_US);
@@ -3094,7 +3094,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
30943094
for (const auto &arg : arguments) {
30953095
if (const auto *expr{arg->UnwrapExpr()}) {
30963096
optionalCount +=
3097-
Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, context);
3097+
Fortran::evaluate::MayBePassedAsAbsentOptional(*expr);
30983098
}
30993099
}
31003100
if (arguments.size() - optionalCount > 1) {

‎flang/lib/Evaluate/tools.cpp

Lines changed: 24 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -826,16 +826,25 @@ bool IsFunction(const Expr<SomeType> &expr) {
826826
return designator && designator->GetType().has_value();
827827
}
828828

829+
bool IsPointer(const Expr<SomeType> &expr) {
830+
return IsObjectPointer(expr) || IsProcedurePointer(expr);
831+
}
832+
829833
bool IsProcedurePointer(const Expr<SomeType> &expr) {
830-
return common::visit(common::visitors{
831-
[](const NullPointer &) { return true; },
832-
[](const ProcedureRef &) { return false; },
833-
[&](const auto &) {
834-
const Symbol *last{GetLastSymbol(expr)};
835-
return last && IsProcedurePointer(*last);
836-
},
837-
},
838-
expr.u);
834+
if (IsNullProcedurePointer(expr)) {
835+
return true;
836+
} else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
837+
if (const Symbol * proc{funcRef->proc().GetSymbol()}) {
838+
const Symbol *result{FindFunctionResult(*proc)};
839+
return result && IsProcedurePointer(*result);
840+
} else {
841+
return false;
842+
}
843+
} else if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
844+
return IsProcedurePointer(proc->GetSymbol());
845+
} else {
846+
return false;
847+
}
839848
}
840849

841850
bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
@@ -851,23 +860,7 @@ bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
851860
expr.u);
852861
}
853862

854-
template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
855-
return nullptr;
856-
}
857-
858-
template <typename T>
859-
inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
860-
return &func;
861-
}
862-
863-
template <typename T>
864-
inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
865-
return common::visit(
866-
[](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
867-
}
868-
869-
// IsObjectPointer()
870-
bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
863+
bool IsObjectPointer(const Expr<SomeType> &expr) {
871864
if (IsNullObjectPointer(expr)) {
872865
return true;
873866
} else if (IsProcedurePointerTarget(expr)) {
@@ -881,10 +874,6 @@ bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
881874
}
882875
}
883876

884-
const ProcedureRef *GetProcedureRef(const Expr<SomeType> &expr) {
885-
return UnwrapProcedureRef(expr);
886-
}
887-
888877
// IsNullPointer() & variations
889878

890879
template <bool IS_PROC_PTR> struct IsNullPointerHelper {
@@ -958,7 +947,7 @@ bool IsBareNullPointer(const Expr<SomeType> *expr) {
958947
// GetSymbolVector()
959948
auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
960949
if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
961-
if (IsVariable(details->expr()) && !GetProcedureRef(*details->expr())) {
950+
if (IsVariable(details->expr()) && !UnwrapProcedureRef(*details->expr())) {
962951
// associate(x => variable that is not a pointer returned by a function)
963952
return (*this)(details->expr());
964953
}
@@ -1241,12 +1230,11 @@ std::optional<Expr<SomeType>> DataConstantConversionExtension(
12411230
return std::nullopt;
12421231
}
12431232

1244-
bool IsAllocatableOrPointerObject(
1245-
const Expr<SomeType> &expr, FoldingContext &context) {
1233+
bool IsAllocatableOrPointerObject(const Expr<SomeType> &expr) {
12461234
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
12471235
return (sym &&
12481236
semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
1249-
evaluate::IsObjectPointer(expr, context);
1237+
evaluate::IsObjectPointer(expr);
12501238
}
12511239

12521240
bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
@@ -1258,15 +1246,14 @@ bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
12581246
return false;
12591247
}
12601248

1261-
bool MayBePassedAsAbsentOptional(
1262-
const Expr<SomeType> &expr, FoldingContext &context) {
1249+
bool MayBePassedAsAbsentOptional(const Expr<SomeType> &expr) {
12631250
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
12641251
// 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
12651252
// may be passed to a non-allocatable/non-pointer optional dummy. Note that
12661253
// other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
12671254
// ignore this point in intrinsic contexts (e.g CMPLX argument).
12681255
return (sym && semantics::IsOptional(*sym)) ||
1269-
IsAllocatableOrPointerObject(expr, context);
1256+
IsAllocatableOrPointerObject(expr);
12701257
}
12711258

12721259
std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,

‎flang/lib/Lower/ConvertCall.cpp

Lines changed: 3 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1165,8 +1165,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
11651165
continue;
11661166
}
11671167
if (fir::isPointerType(argTy) &&
1168-
!Fortran::evaluate::IsObjectPointer(
1169-
*expr, callContext.converter.getFoldingContext())) {
1168+
!Fortran::evaluate::IsObjectPointer(*expr)) {
11701169
// Passing a non POINTER actual argument to a POINTER dummy argument.
11711170
// Create a pointer of the dummy argument type and assign the actual
11721171
// argument to it.
@@ -1814,13 +1813,11 @@ genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,
18141813
const Fortran::lower::SomeExpr &expr,
18151814
CallContext &callContext,
18161815
bool passAsAllocatableOrPointer) {
1817-
if (!Fortran::evaluate::MayBePassedAsAbsentOptional(
1818-
expr, callContext.converter.getFoldingContext()))
1816+
if (!Fortran::evaluate::MayBePassedAsAbsentOptional(expr))
18191817
return std::nullopt;
18201818
fir::FirOpBuilder &builder = callContext.getBuilder();
18211819
if (!passAsAllocatableOrPointer &&
1822-
Fortran::evaluate::IsAllocatableOrPointerObject(
1823-
expr, callContext.converter.getFoldingContext())) {
1820+
Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
18241821
// Passing Allocatable/Pointer to non-pointer/non-allocatable OPTIONAL.
18251822
// Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, it is
18261823
// as if the argument was absent. The main care here is to not do a

‎flang/lib/Lower/ConvertExpr.cpp

Lines changed: 13 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -1782,8 +1782,7 @@ class ScalarExprLowering {
17821782
/// Helper to lower intrinsic arguments for inquiry intrinsic.
17831783
ExtValue
17841784
lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
1785-
if (Fortran::evaluate::IsAllocatableOrPointerObject(
1786-
expr, converter.getFoldingContext()))
1785+
if (Fortran::evaluate::IsAllocatableOrPointerObject(expr))
17871786
return genMutableBoxValue(expr);
17881787
/// Do not create temps for array sections whose properties only need to be
17891788
/// inquired: create a descriptor that will be inquired.
@@ -1918,8 +1917,7 @@ class ScalarExprLowering {
19181917
fir::ArgLoweringRule argRules =
19191918
fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
19201919
if (argRules.handleDynamicOptional &&
1921-
Fortran::evaluate::MayBePassedAsAbsentOptional(
1922-
*expr, converter.getFoldingContext())) {
1920+
Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
19231921
ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
19241922
mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
19251923
switch (argRules.lowerAs) {
@@ -2392,8 +2390,7 @@ class ScalarExprLowering {
23922390
std::pair<ExtValue, mlir::Value>
23932391
prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) {
23942392
mlir::Location loc = getLoc();
2395-
if (Fortran::evaluate::IsAllocatableOrPointerObject(
2396-
expr, converter.getFoldingContext())) {
2393+
if (Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
23972394
// Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated,
23982395
// it is as if the argument was absent. The main care here is to
23992396
// not do a copy-in/copy-out because the temp address, even though
@@ -2496,8 +2493,8 @@ class ScalarExprLowering {
24962493
// not passed.
24972494
return {genTempExtAddr(expr), std::nullopt};
24982495
ExtValue baseAddr;
2499-
if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
2500-
expr, converter.getFoldingContext())) {
2496+
if (arg.isOptional() &&
2497+
Fortran::evaluate::MayBePassedAsAbsentOptional(expr)) {
25012498
auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr);
25022499
const ExtValue &actualArg = actualArgBind;
25032500
if (!needsCopy)
@@ -2631,8 +2628,7 @@ class ScalarExprLowering {
26312628
continue;
26322629
}
26332630
if (fir::isPointerType(argTy) &&
2634-
!Fortran::evaluate::IsObjectPointer(
2635-
*expr, converter.getFoldingContext())) {
2631+
!Fortran::evaluate::IsObjectPointer(*expr)) {
26362632
// Passing a non POINTER actual argument to a POINTER dummy argument.
26372633
// Create a pointer of the dummy argument type and assign the actual
26382634
// argument to it.
@@ -2759,8 +2755,7 @@ class ScalarExprLowering {
27592755
}
27602756

27612757
} else if (arg.isOptional() &&
2762-
Fortran::evaluate::IsAllocatableOrPointerObject(
2763-
*expr, converter.getFoldingContext())) {
2758+
Fortran::evaluate::IsAllocatableOrPointerObject(*expr)) {
27642759
// Before lowering to an address, handle the allocatable/pointer
27652760
// actual argument to optional fir.box dummy. It is legal to pass
27662761
// unallocated/disassociated entity to an optional. In this case, an
@@ -3355,8 +3350,7 @@ class ArrayExprLowering {
33553350
setPointerAssignmentBounds(lbounds, ubounds);
33563351
if (rhs.Rank() == 0 ||
33573352
(Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs) &&
3358-
Fortran::evaluate::IsAllocatableOrPointerObject(
3359-
rhs, converter.getFoldingContext()))) {
3353+
Fortran::evaluate::IsAllocatableOrPointerObject(rhs))) {
33603354
lowerScalarAssignment(lhs, rhs);
33613355
return;
33623356
}
@@ -4684,8 +4678,7 @@ class ArrayExprLowering {
46844678
fir::ArgLoweringRule argRules =
46854679
fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
46864680
if (argRules.handleDynamicOptional &&
4687-
Fortran::evaluate::MayBePassedAsAbsentOptional(
4688-
*expr, converter.getFoldingContext())) {
4681+
Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
46894682
// Currently, there is not elemental intrinsic that requires lowering
46904683
// a potentially absent argument to something else than a value (apart
46914684
// from character MAX/MIN that are handled elsewhere.)
@@ -4768,8 +4761,8 @@ class ArrayExprLowering {
47684761
LLVM_DEBUG(expr->AsFortran(llvm::dbgs()
47694762
<< "argument: " << arg.firArgument << " = [")
47704763
<< "]\n");
4771-
if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
4772-
*expr, converter.getFoldingContext()))
4764+
if (arg.isOptional() &&
4765+
Fortran::evaluate::MayBePassedAsAbsentOptional(*expr))
47734766
TODO(loc,
47744767
"passing dynamically optional argument to elemental procedures");
47754768
switch (arg.passBy) {
@@ -5925,8 +5918,8 @@ class ArrayExprLowering {
59255918
fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
59265919
mlir::Type baseType = fir::unwrapRefType(base.getType());
59275920
const bool isBox = baseType.isa<fir::BoxType>();
5928-
const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject(
5929-
expr, converter.getFoldingContext());
5921+
const bool isAllocOrPtr =
5922+
Fortran::evaluate::IsAllocatableOrPointerObject(expr);
59305923
mlir::Type arrType = fir::unwrapPassByRefType(baseType);
59315924
mlir::Type eleType = fir::unwrapSequenceType(arrType);
59325925
ExtValue exv = optionalArg;

‎flang/lib/Lower/ConvertVariable.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -251,7 +251,7 @@ mlir::Value Fortran::lower::genInitialDataTarget(
251251
// type. The return box is correctly created as a fir.box<fir.ptr<T>> where
252252
// T is extracted from the MOLD argument.
253253
if (const Fortran::evaluate::ProcedureRef *procRef =
254-
Fortran::evaluate::GetProcedureRef(initialTarget)) {
254+
Fortran::evaluate::UnwrapProcedureRef(initialTarget)) {
255255
const Fortran::evaluate::SpecificIntrinsic *intrinsic =
256256
procRef->proc().GetSpecificIntrinsic();
257257
if (intrinsic && intrinsic->name == "null") {

0 commit comments

Comments
 (0)