[flang] Complain about more cases of calls to insufficiently defined procedures
When a function is called in a specification expression, it must be
sufficiently defined, and cannot be a recursive call (10.1.11(5)).
The best fix for this is to change the contract for the procedure
characterization infrastructure to catch and report such errors,
and to guarantee that it does emit errors on failed characterizations.
Some call sites were adjusted to avoid cascades.
Differential Revision: https://reviews.llvm.org/D104330
GitOrigin-RevId: 562bfe1274a17698c445ee3d7bb4a7911d74f657
diff --git a/include/flang/Evaluate/characteristics.h b/include/flang/Evaluate/characteristics.h
index 8006f7a..619f3c9 100644
--- a/include/flang/Evaluate/characteristics.h
+++ b/include/flang/Evaluate/characteristics.h
@@ -295,11 +295,11 @@
bool operator==(const Procedure &) const;
bool operator!=(const Procedure &that) const { return !(*this == that); }
- // Characterizes the procedure represented by a symbol, which may be an
+ // Characterizes a procedure. If a Symbol, it may be an
// "unrestricted specific intrinsic function".
+ // Error messages are produced when a procedure cannot be characterized.
static std::optional<Procedure> Characterize(
const semantics::Symbol &, FoldingContext &);
- // This function is the initial point of entry for characterizing procedure
static std::optional<Procedure> Characterize(
const ProcedureDesignator &, FoldingContext &);
static std::optional<Procedure> Characterize(
diff --git a/lib/Evaluate/characteristics.cpp b/lib/Evaluate/characteristics.cpp
index 80f5f23..3fd0025 100644
--- a/lib/Evaluate/characteristics.cpp
+++ b/lib/Evaluate/characteristics.cpp
@@ -468,7 +468,23 @@
[&](const semantics::HostAssocDetails &assoc) {
return CharacterizeProcedure(assoc.symbol(), context, seenProcs);
},
- [](const auto &) { return std::optional<Procedure>{}; },
+ [&](const semantics::EntityDetails &) {
+ context.messages().Say(
+ "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
+ symbol.name());
+ return std::optional<Procedure>{};
+ },
+ [&](const semantics::SubprogramNameDetails &) {
+ context.messages().Say(
+ "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
+ symbol.name());
+ return std::optional<Procedure>{};
+ },
+ [&](const auto &) {
+ context.messages().Say(
+ "'%s' is not a procedure"_err_en_US, symbol.name());
+ return std::optional<Procedure>{};
+ },
},
symbol.details());
}
diff --git a/lib/Evaluate/intrinsics.cpp b/lib/Evaluate/intrinsics.cpp
index a63f845..c8d8b02 100644
--- a/lib/Evaluate/intrinsics.cpp
+++ b/lib/Evaluate/intrinsics.cpp
@@ -1863,8 +1863,9 @@
// MOLD= procedure pointer
const Symbol *last{GetLastSymbol(*mold)};
CHECK(last);
- auto procPointer{
- characteristics::Procedure::Characterize(*last, context)};
+ auto procPointer{IsProcedure(*last)
+ ? characteristics::Procedure::Characterize(*last, context)
+ : std::nullopt};
// procPointer is null if there was an error with the analysis
// associated with the procedure pointer
if (procPointer) {
@@ -2000,12 +2001,9 @@
"POINTER"_err_en_US),
*pointerSymbol);
} else {
- const auto pointerProc{characteristics::Procedure::Characterize(
- *pointerSymbol, context)};
if (const auto &targetArg{call.arguments[1]}) {
if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
- std::optional<characteristics::Procedure> targetProc{
- std::nullopt};
+ std::optional<characteristics::Procedure> pointerProc, targetProc;
const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
bool isCall{false};
std::string targetName;
@@ -2018,13 +2016,18 @@
targetName = targetProcRef->proc().GetName() + "()";
isCall = true;
}
- } else if (targetSymbol && !targetProc) {
+ } else if (targetSymbol) {
// proc that's not a call
- targetProc = characteristics::Procedure::Characterize(
- *targetSymbol, context);
+ if (IsProcedure(*targetSymbol)) {
+ targetProc = characteristics::Procedure::Characterize(
+ *targetSymbol, context);
+ }
targetName = targetSymbol->name().ToString();
}
-
+ if (IsProcedure(*pointerSymbol)) {
+ pointerProc = characteristics::Procedure::Characterize(
+ *pointerSymbol, context);
+ }
if (pointerProc) {
if (targetProc) {
// procedure pointer and procedure target
diff --git a/lib/Semantics/check-declarations.cpp b/lib/Semantics/check-declarations.cpp
index 56c126b..ddf0a01 100644
--- a/lib/Semantics/check-declarations.cpp
+++ b/lib/Semantics/check-declarations.cpp
@@ -822,7 +822,9 @@
} else if (FindSeparateModuleSubprogramInterface(subprogram)) {
error = "ENTRY may not appear in a separate module procedure"_err_en_US;
} else if (subprogramDetails && details.isFunction() &&
- subprogramDetails->isFunction()) {
+ subprogramDetails->isFunction() &&
+ !context_.HasError(details.result()) &&
+ !context_.HasError(subprogramDetails->result())) {
auto result{FunctionResult::Characterize(
details.result(), context_.foldingContext())};
auto subpResult{FunctionResult::Characterize(
diff --git a/lib/Semantics/expression.cpp b/lib/Semantics/expression.cpp
index 42d6a2a..95943b3 100644
--- a/lib/Semantics/expression.cpp
+++ b/lib/Semantics/expression.cpp
@@ -1860,6 +1860,7 @@
Say(sc.component.source, "'%s' is not a procedure"_err_en_US,
sc.component.source),
*sym);
+ return std::nullopt;
}
if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
if (sym->has<semantics::GenericDetails>()) {
diff --git a/lib/Semantics/pointer-assignment.cpp b/lib/Semantics/pointer-assignment.cpp
index 171e2ba..afa1552 100644
--- a/lib/Semantics/pointer-assignment.cpp
+++ b/lib/Semantics/pointer-assignment.cpp
@@ -44,11 +44,13 @@
: context_{context}, source_{source}, description_{description} {}
PointerAssignmentChecker(evaluate::FoldingContext &context, const Symbol &lhs)
: context_{context}, source_{lhs.name()},
- description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs},
- procedure_{Procedure::Characterize(lhs, context)} {
+ description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs} {
set_lhsType(TypeAndShape::Characterize(lhs, context));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ if (IsProcedure(lhs)) {
+ procedure_ = Procedure::Characterize(lhs, context);
+ }
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
diff --git a/lib/Semantics/resolve-names.cpp b/lib/Semantics/resolve-names.cpp
index efba039..5ab4d39 100644
--- a/lib/Semantics/resolve-names.cpp
+++ b/lib/Semantics/resolve-names.cpp
@@ -3102,6 +3102,7 @@
Say2(effectiveResultName.source,
"'%s' was previously declared as an item that may not be used as a function result"_err_en_US,
resultSymbol->name(), "Previous declaration of '%s'"_en_US);
+ context().SetError(*resultSymbol);
}},
resultSymbol->details());
} else if (inExecutionPart_) {
diff --git a/test/Semantics/resolve102.f90 b/test/Semantics/resolve102.f90
index aae461d..77b5e10 100644
--- a/test/Semantics/resolve102.f90
+++ b/test/Semantics/resolve102.f90
@@ -85,3 +85,18 @@
call p2
call p3
end program
+
+module mutualSpecExprs
+contains
+ pure integer function f(n)
+ integer, intent(in) :: n
+ real arr(g(n))
+ f = size(arr)
+ end function
+ pure integer function g(n)
+ integer, intent(in) :: n
+ !ERROR: Procedure 'f' is referenced before being sufficiently defined in a context where it must be so
+ real arr(f(n))
+ g = size(arr)
+ end function
+end
