[flang] Ensure pointer function results are acceptable variables
Fortran permits a reference to a function whose result is a pointer
to be used as a definable variable in any context where a
designator could appear. This patch wrings out remaining bugs
with such usage and adds more testing.
The utility predicate IsProcedurePointer(expr) had a misleading
name which has been corrected to IsProcedurePointerTarget(expr).
Differential Revision: https://reviews.llvm.org/D98555
GitOrigin-RevId: bbd0dc3d6506542ac53b171c982eab84d8e7cef0
diff --git a/include/flang/Evaluate/tools.h b/include/flang/Evaluate/tools.h
index 5ad999c..afa70fd 100644
--- a/include/flang/Evaluate/tools.h
+++ b/include/flang/Evaluate/tools.h
@@ -806,7 +806,7 @@
// Procedure and pointer detection predicates
bool IsProcedure(const Expr<SomeType> &);
bool IsFunction(const Expr<SomeType> &);
-bool IsProcedurePointer(const Expr<SomeType> &);
+bool IsProcedurePointerTarget(const Expr<SomeType> &);
bool IsNullPointer(const Expr<SomeType> &);
bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
@@ -963,6 +963,7 @@
int CountLenParameters(const DerivedTypeSpec &);
int CountNonConstantLenParameters(const DerivedTypeSpec &);
const Symbol &GetUsedModule(const UseDetails &);
+const Symbol *FindFunctionResult(const Symbol &);
} // namespace Fortran::semantics
diff --git a/lib/Evaluate/intrinsics.cpp b/lib/Evaluate/intrinsics.cpp
index b54ff78..8636c9e 100644
--- a/lib/Evaluate/intrinsics.cpp
+++ b/lib/Evaluate/intrinsics.cpp
@@ -1255,7 +1255,7 @@
}
} else {
// NULL(), procedure, or procedure pointer
- CHECK(IsProcedurePointer(expr));
+ CHECK(IsProcedurePointerTarget(expr));
if (d.typePattern.kindCode == KindCode::addressable ||
d.rank == Rank::reduceOperation) {
continue;
@@ -1851,7 +1851,7 @@
if (IsAllocatableOrPointer(*mold)) {
characteristics::DummyArguments args;
std::optional<characteristics::FunctionResult> fResult;
- if (IsProcedurePointer(*mold)) {
+ if (IsProcedurePointerTarget(*mold)) {
// MOLD= procedure pointer
const Symbol *last{GetLastSymbol(*mold)};
CHECK(last);
diff --git a/lib/Evaluate/tools.cpp b/lib/Evaluate/tools.cpp
index d06463e..0685f14 100644
--- a/lib/Evaluate/tools.cpp
+++ b/lib/Evaluate/tools.cpp
@@ -52,10 +52,12 @@
// IsVariable()
auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
- return !symbol.attrs().test(semantics::Attr::PARAMETER);
+ const Symbol &root{GetAssociationRoot(symbol)};
+ return !IsNamedConstant(root) && root.has<semantics::ObjectEntityDetails>();
}
auto IsVariableHelper::operator()(const Component &x) const -> Result {
- return (*this)(x.base());
+ const Symbol &comp{x.GetLastSymbol()};
+ return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
}
auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
return (*this)(x.base());
@@ -65,8 +67,11 @@
}
auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
-> Result {
- const Symbol *symbol{x.GetSymbol()};
- return symbol && IsPointer(*symbol);
+ if (const Symbol * symbol{x.GetSymbol()}) {
+ const Symbol *result{FindFunctionResult(*symbol)};
+ return result && IsPointer(*result) && !IsProcedurePointer(*result);
+ }
+ return false;
}
// Conversions of COMPLEX component expressions to REAL.
@@ -686,12 +691,15 @@
return designator && designator->GetType().has_value();
}
-bool IsProcedurePointer(const Expr<SomeType> &expr) {
+bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
return std::visit(common::visitors{
[](const NullPointer &) { return true; },
[](const ProcedureDesignator &) { return true; },
[](const ProcedureRef &) { return true; },
- [](const auto &) { return false; },
+ [&](const auto &) {
+ const Symbol *last{GetLastSymbol(expr)};
+ return last && IsProcedurePointer(*last);
+ },
},
expr.u);
}
@@ -715,14 +723,10 @@
bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
if (IsNullPointer(expr)) {
return true;
- } else if (IsProcedurePointer(expr)) {
+ } else if (IsProcedurePointerTarget(expr)) {
return false;
- } else if (const auto *procRef{UnwrapProcedureRef(expr)}) {
- auto proc{
- characteristics::Procedure::Characterize(procRef->proc(), context)};
- return proc && proc->functionResult &&
- proc->functionResult->attrs.test(
- characteristics::FunctionResult::Attr::Pointer);
+ } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
+ return IsVariable(*funcRef);
} else if (const Symbol * symbol{GetLastSymbol(expr)}) {
return IsPointer(symbol->GetUltimate());
} else {
@@ -1089,7 +1093,7 @@
}
bool IsProcedurePointer(const Symbol &original) {
- const Symbol &symbol{original.GetUltimate()};
+ const Symbol &symbol{GetAssociationRoot(original)};
return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
}
@@ -1172,4 +1176,31 @@
return DEREF(details.symbol().owner().symbol());
}
+static const Symbol *FindFunctionResult(
+ const Symbol &original, SymbolSet &seen) {
+ const Symbol &root{GetAssociationRoot(original)};
+ ;
+ if (!seen.insert(root).second) {
+ return nullptr; // don't loop
+ }
+ return std::visit(
+ common::visitors{[](const SubprogramDetails &subp) {
+ return subp.isFunction() ? &subp.result() : nullptr;
+ },
+ [&](const ProcEntityDetails &proc) {
+ const Symbol *iface{proc.interface().symbol()};
+ return iface ? FindFunctionResult(*iface, seen) : nullptr;
+ },
+ [&](const ProcBindingDetails &binding) {
+ return FindFunctionResult(binding.symbol(), seen);
+ },
+ [](const auto &) -> const Symbol * { return nullptr; }},
+ root.details());
+}
+
+const Symbol *FindFunctionResult(const Symbol &symbol) {
+ SymbolSet seen;
+ return FindFunctionResult(symbol, seen);
+}
+
} // namespace Fortran::semantics
diff --git a/lib/Semantics/check-call.cpp b/lib/Semantics/check-call.cpp
index 924b7c8..bf04091 100644
--- a/lib/Semantics/check-call.cpp
+++ b/lib/Semantics/check-call.cpp
@@ -578,27 +578,27 @@
"Actual argument associated with procedure %s is not a procedure"_err_en_US,
dummyName);
}
- } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
+ } else if (IsNullPointer(*expr)) {
+ if (!dummyIsPointer) {
+ messages.Say(
+ "Actual argument associated with procedure %s is a null pointer"_err_en_US,
+ dummyName);
+ }
+ } else {
messages.Say(
- "Actual argument associated with procedure %s is not a procedure"_err_en_US,
+ "Actual argument associated with procedure %s is typeless"_err_en_US,
dummyName);
}
}
- if (interface.HasExplicitInterface()) {
- if (dummyIsPointer) {
+ if (interface.HasExplicitInterface() && dummyIsPointer &&
+ proc.intent != common::Intent::In) {
+ const Symbol *last{GetLastSymbol(*expr)};
+ if (!(last && IsProcedurePointer(*last))) {
// 15.5.2.9(5) -- dummy procedure POINTER
// Interface compatibility has already been checked above by comparison.
- if (proc.intent != common::Intent::In && !IsVariable(*expr)) {
- messages.Say(
- "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
- dummyName);
- }
- } else { // 15.5.2.9(4) -- dummy procedure is not POINTER
- if (!argProcDesignator) {
- messages.Say(
- "Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US,
- dummyName);
- }
+ messages.Say(
+ "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
+ dummyName);
}
}
} else {
diff --git a/lib/Semantics/check-io.cpp b/lib/Semantics/check-io.cpp
index de19ed4..c6b67a5 100644
--- a/lib/Semantics/check-io.cpp
+++ b/lib/Semantics/check-io.cpp
@@ -550,7 +550,8 @@
flags_.set(Flag::DataList);
if (const auto *x{std::get_if<parser::Expr>(&item.u)}) {
if (const auto *expr{GetExpr(*x)}) {
- if (IsProcedurePointer(*expr)) {
+ const Symbol *last{GetLastSymbol(*expr)};
+ if (last && IsProcedurePointer(*last)) {
context_.Say(parser::FindSourceLocation(*x),
"Output item must not be a procedure pointer"_err_en_US); // C1233
}
@@ -925,15 +926,18 @@
template <typename A>
void IoChecker::CheckForDefinableVariable(
- const A &var, const std::string &s) const {
- const Symbol *sym{
- GetFirstName(*parser::Unwrap<parser::Variable>(var)).symbol};
- if (auto whyNot{
- WhyNotModifiable(*sym, context_.FindScope(*context_.location()))}) {
- auto at{parser::FindSourceLocation(var)};
- context_
- .Say(at, "%s variable '%s' must be definable"_err_en_US, s, sym->name())
- .Attach(at, std::move(*whyNot), sym->name());
+ const A &variable, const std::string &s) const {
+ if (const auto *var{parser::Unwrap<parser::Variable>(variable)}) {
+ if (auto expr{AnalyzeExpr(context_, *var)}) {
+ auto at{var->GetSource()};
+ if (auto whyNot{WhyNotModifiable(at, *expr, context_.FindScope(at))}) {
+ const Symbol *base{GetFirstSymbol(*expr)};
+ context_
+ .Say(at, "%s variable '%s' must be definable"_err_en_US, s,
+ (base ? base->name() : at).ToString())
+ .Attach(std::move(*whyNot));
+ }
+ }
}
}
diff --git a/lib/Semantics/expression.cpp b/lib/Semantics/expression.cpp
index 2c4ce6a..3413a75 100644
--- a/lib/Semantics/expression.cpp
+++ b/lib/Semantics/expression.cpp
@@ -1859,7 +1859,7 @@
},
[&](const characteristics::DummyProcedure &) {
const auto *expr{actual.UnwrapExpr()};
- return expr && IsProcedurePointer(*expr);
+ return expr && IsProcedurePointerTarget(*expr);
},
[&](const characteristics::AlternateReturn &) {
return actual.isAlternateReturn();
diff --git a/lib/Semantics/tools.cpp b/lib/Semantics/tools.cpp
index d93cb74..7680d67 100644
--- a/lib/Semantics/tools.cpp
+++ b/lib/Semantics/tools.cpp
@@ -841,9 +841,7 @@
// Modifiability checks for a data-ref
std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) {
- if (!evaluate::IsVariable(expr)) {
- return parser::Message{at, "Expression is not a variable"_en_US};
- } else if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) {
if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) {
return parser::Message{at, "Variable has a vector subscript"_en_US};
}
@@ -865,6 +863,9 @@
std::move(*maybeWhyFirst), first.name()}};
}
}
+ } else if (!evaluate::IsVariable(expr)) {
+ return parser::Message{
+ at, "'%s' is not a variable"_en_US, expr.AsFortran()};
} else {
// reference to function returning POINTER
}
diff --git a/test/Semantics/call02.f90 b/test/Semantics/call02.f90
index 4418837..1b0701a 100644
--- a/test/Semantics/call02.f90
+++ b/test/Semantics/call02.f90
@@ -19,11 +19,9 @@
call subr(cos) ! not an error
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
call subr(elem) ! C1533
- !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
- !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+ !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is a null pointer
call subr(null())
- !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
- !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+ !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is typeless
call subr(B"1010")
end subroutine
diff --git a/test/Semantics/call09.f90 b/test/Semantics/call09.f90
index 9db5887..6f55470 100644
--- a/test/Semantics/call09.f90
+++ b/test/Semantics/call09.f90
@@ -76,7 +76,7 @@
call s01(sin) ! ok
!ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
call s01(null(intPtr))
- !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
+ !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless
call s01(B"0101")
!ERROR: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
call s01(extfunc)
diff --git a/test/Semantics/call18.f90 b/test/Semantics/call18.f90
new file mode 100644
index 0000000..95c850d
--- /dev/null
+++ b/test/Semantics/call18.f90
@@ -0,0 +1,26 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Ensure that references to functions that return pointers can serve as
+! "variables" in actual arguments. All of these uses are conforming and
+! no errors should be reported.
+module m
+ integer, target :: x = 1
+ contains
+ function get() result(p)
+ integer, pointer :: p
+ p => x
+ end function get
+ subroutine increment(n)
+ integer, intent(inout) :: n
+ n = n + 1
+ end subroutine increment
+end module m
+
+use m
+integer, pointer :: q
+get() = 2
+call increment(get())
+q => get()
+read(*) get()
+open(file='file',newunit=get())
+allocate(q,stat=get())
+end
diff --git a/test/Semantics/modifiable01.f90 b/test/Semantics/modifiable01.f90
index dfa9396..ad81e02 100644
--- a/test/Semantics/modifiable01.f90
+++ b/test/Semantics/modifiable01.f90
@@ -46,7 +46,7 @@
read(internal,*) a ! ok
end associate
!CHECK: error: Input variable 'j3' must be definable
- !CHECK: 'j3' is not a variable
+ !CHECK: '666_4' is not a variable
read(internal,*) j3
!CHECK: error: Left-hand side of assignment is not modifiable
!CHECK: 't2var' is an entity with either an EVENT_TYPE or LOCK_TYPE
