[flang-commits] [flang] 77dc203 - [flang] Detect circularly defined procedures
Peter Steinfeld via flang-commits
flang-commits at lists.llvm.org
Tue Feb 16 14:40:51 PST 2021
Author: Peter Steinfeld
Date: 2021-02-16T14:40:35-08:00
New Revision: 77dc203cd0f65a8dbd71f3814e0cc3199c791980
URL: https://github.com/llvm/llvm-project/commit/77dc203cd0f65a8dbd71f3814e0cc3199c791980
DIFF: https://github.com/llvm/llvm-project/commit/77dc203cd0f65a8dbd71f3814e0cc3199c791980.diff
LOG: [flang] Detect circularly defined procedures
It's possible to define a procedure that has a procedure dummy argument which
names the procedure that contains it. This was causing the compiler to fall
into an infinite loop when characterizing a call to the procedure.
Following a suggestion from Peter, I fixed this be maintaining a set of
procedure symbols that had already been seen while characterizing a procedure.
This required passing a new parameter to the functions that characterized a
Procedure, a DummyArgument, and a DummyProcedure.
I also added several tests that will crash the compiler without this change.
Differential Revision: https://reviews.llvm.org/D96631
Added:
flang/test/Semantics/resolve102.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/lib/Evaluate/characteristics.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 7b37557fb24f..5ca85147ef0c 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -204,8 +204,6 @@ struct DummyProcedure {
explicit DummyProcedure(Procedure &&);
bool operator==(const DummyProcedure &) const;
bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
- static std::optional<DummyProcedure> Characterize(
- const semantics::Symbol &, FoldingContext &context);
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
CopyableIndirection<Procedure> procedure;
common::Intent intent{common::Intent::Default};
@@ -230,8 +228,6 @@ struct DummyArgument {
~DummyArgument();
bool operator==(const DummyArgument &) const;
bool operator!=(const DummyArgument &that) const { return !(*this == that); }
- static std::optional<DummyArgument> Characterize(
- const semantics::Symbol &, FoldingContext &);
static std::optional<DummyArgument> FromActual(
std::string &&, const Expr<SomeType> &, FoldingContext &);
bool IsOptional() const;
@@ -290,6 +286,7 @@ struct Procedure {
ENUM_CLASS(
Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, Subroutine)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
+ Procedure(){};
Procedure(FunctionResult &&, DummyArguments &&, Attrs);
Procedure(DummyArguments &&, Attrs); // for subroutines and NULL()
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
@@ -301,6 +298,7 @@ struct Procedure {
// "unrestricted specific intrinsic function".
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(
@@ -325,9 +323,6 @@ struct Procedure {
std::optional<FunctionResult> functionResult;
DummyArguments dummyArguments;
Attrs attrs;
-
-private:
- Procedure() {}
};
} // namespace Fortran::evaluate::characteristics
#endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 92b93e71c98b..6e41aa677570 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -341,9 +341,136 @@ bool DummyProcedure::operator==(const DummyProcedure &that) const {
procedure.value() == that.procedure.value();
}
-std::optional<DummyProcedure> DummyProcedure::Characterize(
- const semantics::Symbol &symbol, FoldingContext &context) {
- if (auto procedure{Procedure::Characterize(symbol, context)}) {
+static std::string GetSeenProcs(const semantics::SymbolSet &seenProcs) {
+ std::string result;
+ llvm::interleave(
+ seenProcs,
+ [&](const SymbolRef p) { result += '\'' + p->name().ToString() + '\''; },
+ [&]() { result += ", "; });
+ return result;
+}
+
+// These functions with arguments of type SymbolSet are used with mutually
+// recursive calls when characterizing a Procedure, a DummyArgument, or a
+// DummyProcedure to detect circularly defined procedures as required by
+// 15.4.3.6, paragraph 2.
+static std::optional<DummyArgument> CharacterizeDummyArgument(
+ const semantics::Symbol &symbol, FoldingContext &context,
+ semantics::SymbolSet &seenProcs);
+
+static std::optional<Procedure> CharacterizeProcedure(
+ const semantics::Symbol &original, FoldingContext &context,
+ semantics::SymbolSet &seenProcs) {
+ Procedure result;
+ const auto &symbol{original.GetUltimate()};
+ if (seenProcs.find(symbol) != seenProcs.end()) {
+ std::string procsList{GetSeenProcs(seenProcs)};
+ context.messages().Say(symbol.name(),
+ "Procedure '%s' is recursively defined. Procedures in the cycle:"
+ " '%s'"_err_en_US,
+ symbol.name(), procsList);
+ return std::nullopt;
+ }
+ seenProcs.insert(symbol);
+ CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
+ {
+ {semantics::Attr::PURE, Procedure::Attr::Pure},
+ {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
+ {semantics::Attr::BIND_C, Procedure::Attr::BindC},
+ });
+ if (result.attrs.test(Procedure::Attr::Elemental) &&
+ !symbol.attrs().test(semantics::Attr::IMPURE)) {
+ result.attrs.set(Procedure::Attr::Pure); // explicitly flag pure procedures
+ }
+ return std::visit(
+ common::visitors{
+ [&](const semantics::SubprogramDetails &subp)
+ -> std::optional<Procedure> {
+ if (subp.isFunction()) {
+ if (auto fr{
+ FunctionResult::Characterize(subp.result(), context)}) {
+ result.functionResult = std::move(fr);
+ } else {
+ return std::nullopt;
+ }
+ } else {
+ result.attrs.set(Procedure::Attr::Subroutine);
+ }
+ for (const semantics::Symbol *arg : subp.dummyArgs()) {
+ if (!arg) {
+ result.dummyArguments.emplace_back(AlternateReturn{});
+ } else if (auto argCharacteristics{CharacterizeDummyArgument(
+ *arg, context, seenProcs)}) {
+ result.dummyArguments.emplace_back(
+ std::move(argCharacteristics.value()));
+ } else {
+ return std::nullopt;
+ }
+ }
+ return result;
+ },
+ [&](const semantics::ProcEntityDetails &proc)
+ -> std::optional<Procedure> {
+ if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
+ return context.intrinsics().IsSpecificIntrinsicFunction(
+ symbol.name().ToString());
+ }
+ const semantics::ProcInterface &interface{proc.interface()};
+ if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
+ return CharacterizeProcedure(
+ *interfaceSymbol, context, seenProcs);
+ } else {
+ result.attrs.set(Procedure::Attr::ImplicitInterface);
+ const semantics::DeclTypeSpec *type{interface.type()};
+ if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
+ // ignore any implicit typing
+ result.attrs.set(Procedure::Attr::Subroutine);
+ } else if (type) {
+ if (auto resultType{DynamicType::From(*type)}) {
+ result.functionResult = FunctionResult{*resultType};
+ } else {
+ return std::nullopt;
+ }
+ } else if (symbol.test(semantics::Symbol::Flag::Function)) {
+ return std::nullopt;
+ }
+ // The PASS name, if any, is not a characteristic.
+ return result;
+ }
+ },
+ [&](const semantics::ProcBindingDetails &binding) {
+ if (auto result{CharacterizeProcedure(
+ binding.symbol(), context, seenProcs)}) {
+ if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
+ auto passName{binding.passName()};
+ for (auto &dummy : result->dummyArguments) {
+ if (!passName || dummy.name.c_str() == *passName) {
+ dummy.pass = true;
+ return result;
+ }
+ }
+ DIE("PASS argument missing");
+ }
+ return result;
+ } else {
+ return std::optional<Procedure>{};
+ }
+ },
+ [&](const semantics::UseDetails &use) {
+ return CharacterizeProcedure(use.symbol(), context, seenProcs);
+ },
+ [&](const semantics::HostAssocDetails &assoc) {
+ return CharacterizeProcedure(assoc.symbol(), context, seenProcs);
+ },
+ [](const auto &) { return std::optional<Procedure>{}; },
+ },
+ symbol.details());
+}
+
+static std::optional<DummyProcedure> CharacterizeDummyProcedure(
+ const semantics::Symbol &symbol, FoldingContext &context,
+ semantics::SymbolSet &seenProcs) {
+ if (auto procedure{CharacterizeProcedure(symbol, context, seenProcs)}) {
// Dummy procedures may not be elemental. Elemental dummy procedure
// interfaces are errors when the interface is not intrinsic, and that
// error is caught elsewhere. Elemental intrinsic interfaces are
@@ -381,14 +508,16 @@ bool DummyArgument::operator==(const DummyArgument &that) const {
return u == that.u; // name and passed-object usage are not characteristics
}
-std::optional<DummyArgument> DummyArgument::Characterize(
- const semantics::Symbol &symbol, FoldingContext &context) {
+static std::optional<DummyArgument> CharacterizeDummyArgument(
+ const semantics::Symbol &symbol, FoldingContext &context,
+ semantics::SymbolSet &seenProcs) {
auto name{symbol.name().ToString()};
if (symbol.has<semantics::ObjectEntityDetails>()) {
if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
return DummyArgument{std::move(name), std::move(obj.value())};
}
- } else if (auto proc{DummyProcedure::Characterize(symbol, context)}) {
+ } else if (auto proc{
+ CharacterizeDummyProcedure(symbol, context, seenProcs)}) {
return DummyArgument{std::move(name), std::move(proc.value())};
}
return std::nullopt;
@@ -644,99 +773,8 @@ bool Procedure::CanOverride(
std::optional<Procedure> Procedure::Characterize(
const semantics::Symbol &original, FoldingContext &context) {
- Procedure result;
- const auto &symbol{original.GetUltimate()};
- CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
- {
- {semantics::Attr::PURE, Procedure::Attr::Pure},
- {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
- {semantics::Attr::BIND_C, Procedure::Attr::BindC},
- });
- if (result.attrs.test(Attr::Elemental) &&
- !symbol.attrs().test(semantics::Attr::IMPURE)) {
- result.attrs.set(Attr::Pure); // explicitly flag pure procedures
- }
- return std::visit(
- common::visitors{
- [&](const semantics::SubprogramDetails &subp)
- -> std::optional<Procedure> {
- if (subp.isFunction()) {
- if (auto fr{
- FunctionResult::Characterize(subp.result(), context)}) {
- result.functionResult = std::move(fr);
- } else {
- return std::nullopt;
- }
- } else {
- result.attrs.set(Attr::Subroutine);
- }
- for (const semantics::Symbol *arg : subp.dummyArgs()) {
- if (!arg) {
- result.dummyArguments.emplace_back(AlternateReturn{});
- } else if (auto argCharacteristics{
- DummyArgument::Characterize(*arg, context)}) {
- result.dummyArguments.emplace_back(
- std::move(argCharacteristics.value()));
- } else {
- return std::nullopt;
- }
- }
- return result;
- },
- [&](const semantics::ProcEntityDetails &proc)
- -> std::optional<Procedure> {
- if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
- return context.intrinsics().IsSpecificIntrinsicFunction(
- symbol.name().ToString());
- }
- const semantics::ProcInterface &interface{proc.interface()};
- if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
- return Characterize(*interfaceSymbol, context);
- } else {
- result.attrs.set(Attr::ImplicitInterface);
- const semantics::DeclTypeSpec *type{interface.type()};
- if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
- // ignore any implicit typing
- result.attrs.set(Attr::Subroutine);
- } else if (type) {
- if (auto resultType{DynamicType::From(*type)}) {
- result.functionResult = FunctionResult{*resultType};
- } else {
- return std::nullopt;
- }
- } else if (symbol.test(semantics::Symbol::Flag::Function)) {
- return std::nullopt;
- }
- // The PASS name, if any, is not a characteristic.
- return result;
- }
- },
- [&](const semantics::ProcBindingDetails &binding) {
- if (auto result{Characterize(binding.symbol(), context)}) {
- if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
- auto passName{binding.passName()};
- for (auto &dummy : result->dummyArguments) {
- if (!passName || dummy.name.c_str() == *passName) {
- dummy.pass = true;
- return result;
- }
- }
- DIE("PASS argument missing");
- }
- return result;
- } else {
- return std::optional<Procedure>{};
- }
- },
- [&](const semantics::UseDetails &use) {
- return Characterize(use.symbol(), context);
- },
- [&](const semantics::HostAssocDetails &assoc) {
- return Characterize(assoc.symbol(), context);
- },
- [](const auto &) { return std::optional<Procedure>{}; },
- },
- symbol.details());
+ semantics::SymbolSet seenProcs;
+ return CharacterizeProcedure(original, context, seenProcs);
}
std::optional<Procedure> Procedure::Characterize(
diff --git a/flang/test/Semantics/resolve102.f90 b/flang/test/Semantics/resolve102.f90
new file mode 100644
index 000000000000..d6894dbd43ab
--- /dev/null
+++ b/flang/test/Semantics/resolve102.f90
@@ -0,0 +1,65 @@
+! RUN: %S/test_errors.sh %s %t %f18
+
+! Tests for circularly defined procedures
+!ERROR: Procedure 'sub' is recursively defined. Procedures in the cycle: ''sub', 'p2''
+subroutine sub(p2)
+ PROCEDURE(sub) :: p2
+
+ call sub()
+end subroutine
+
+subroutine circular
+ !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: ''p', 'sub', 'p2''
+ procedure(sub) :: p
+
+ call p(sub)
+
+ contains
+ subroutine sub(p2)
+ procedure(p) :: p2
+ end subroutine
+end subroutine circular
+
+program iface
+ !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: ''p', 'sub', 'p2''
+ procedure(sub) :: p
+ interface
+ subroutine sub(p2)
+ import p
+ procedure(p) :: p2
+ end subroutine
+ end interface
+ call p(sub)
+end program
+
+Program mutual
+ Procedure(sub1) :: p
+
+ Call p(sub)
+
+ contains
+ !ERROR: Procedure 'sub1' is recursively defined. Procedures in the cycle: ''p', 'sub1', 'arg''
+ Subroutine sub1(arg)
+ procedure(sub1) :: arg
+ End Subroutine
+
+ Subroutine sub(p2)
+ Procedure(sub1) :: p2
+ End Subroutine
+End Program
+
+Program mutual1
+ Procedure(sub1) :: p
+
+ Call p(sub)
+
+ contains
+ !ERROR: Procedure 'sub1' is recursively defined. Procedures in the cycle: ''p', 'sub1', 'arg', 'sub', 'p2''
+ Subroutine sub1(arg)
+ procedure(sub) :: arg
+ End Subroutine
+
+ Subroutine sub(p2)
+ Procedure(sub1) :: p2
+ End Subroutine
+End Program
More information about the flang-commits
mailing list