[flang] Allow pure function references in expandable scalar
F18 disallows function references and coarray references from
appearing in scalar expressions that are to be expanded into
arrays to conform with other operands or actual arguments in
an elemental expression. This is too strong, as pure procedures
can be safely used.
Differential Revision: https://reviews.llvm.org/D131096
GitOrigin-RevId: 3f10091c04e1478e0e5b2deb7dd782ebca0d529c
diff --git a/include/flang/Evaluate/call.h b/include/flang/Evaluate/call.h
index 7866bab..3a083ab 100644
--- a/include/flang/Evaluate/call.h
+++ b/include/flang/Evaluate/call.h
@@ -199,6 +199,7 @@
std::optional<DynamicType> GetType() const;
int Rank() const;
bool IsElemental() const;
+ bool IsPure() const;
std::optional<Expr<SubscriptInteger>> LEN() const;
llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
diff --git a/include/flang/Evaluate/tools.h b/include/flang/Evaluate/tools.h
index fe8645b..7d52161 100644
--- a/include/flang/Evaluate/tools.h
+++ b/include/flang/Evaluate/tools.h
@@ -1007,17 +1007,25 @@
// Predicate: is a scalar expression suitable for naive scalar expansion
// in the flattening of an array expression?
// TODO: capture such scalar expansions in temporaries, flatten everything
-struct UnexpandabilityFindingVisitor
+class UnexpandabilityFindingVisitor
: public AnyTraverse<UnexpandabilityFindingVisitor> {
+public:
using Base = AnyTraverse<UnexpandabilityFindingVisitor>;
using Base::operator();
- UnexpandabilityFindingVisitor() : Base{*this} {}
- template <typename T> bool operator()(const FunctionRef<T> &) { return true; }
+ explicit UnexpandabilityFindingVisitor(bool admitPureCall)
+ : Base{*this}, admitPureCall_{admitPureCall} {}
+ template <typename T> bool operator()(const FunctionRef<T> &procRef) {
+ return !admitPureCall_ || !procRef.proc().IsPure();
+ }
bool operator()(const CoarrayRef &) { return true; }
+
+private:
+ bool admitPureCall_{false};
};
-template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
- return !UnexpandabilityFindingVisitor{}(expr);
+template <typename T>
+bool IsExpandableScalar(const Expr<T> &expr, bool admitPureCall = false) {
+ return !UnexpandabilityFindingVisitor{admitPureCall}(expr);
}
// Common handling for procedure pointer compatibility of left- and right-hand
diff --git a/lib/Evaluate/call.cpp b/lib/Evaluate/call.cpp
index 6b008cf..2ff4c31 100644
--- a/lib/Evaluate/call.cpp
+++ b/lib/Evaluate/call.cpp
@@ -145,6 +145,20 @@
return false;
}
+bool ProcedureDesignator::IsPure() const {
+ if (const Symbol * interface{GetInterfaceSymbol()}) {
+ return IsPureProcedure(*interface);
+ } else if (const Symbol * symbol{GetSymbol()}) {
+ return IsPureProcedure(*symbol);
+ } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
+ return intrinsic->characteristics.value().attrs.test(
+ characteristics::Procedure::Attr::Pure);
+ } else {
+ DIE("ProcedureDesignator::IsPure(): no case");
+ }
+ return false;
+}
+
const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {
return std::get_if<SpecificIntrinsic>(&u);
}
diff --git a/lib/Semantics/expression.cpp b/lib/Semantics/expression.cpp
index d4492d2..01bfea7 100644
--- a/lib/Semantics/expression.cpp
+++ b/lib/Semantics/expression.cpp
@@ -1833,7 +1833,7 @@
"component", "value")};
if (checked && *checked && GetRank(*componentShape) > 0 &&
GetRank(*valueShape) == 0 &&
- !IsExpandableScalar(*converted)) {
+ !IsExpandableScalar(*converted, true /*admit PURE call*/)) {
AttachDeclaration(
Say(expr.source,
"Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
