diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -52,6 +52,10 @@ // values for explicit dimensions when constant. bool ShapesAreCompatible(const Shape &, const Shape &); +// Used to track potential circularly defined procedures. Needed to enforce +// 15.4.3.6 paragraph 2 +using SeenProcs = std::set; + class TypeAndShape { public: ENUM_CLASS( @@ -205,7 +209,7 @@ bool operator==(const DummyProcedure &) const; bool operator!=(const DummyProcedure &that) const { return !(*this == that); } static std::optional Characterize( - const semantics::Symbol &, FoldingContext &context); + const semantics::Symbol &, FoldingContext &context, SeenProcs &); llvm::raw_ostream &Dump(llvm::raw_ostream &) const; CopyableIndirection procedure; common::Intent intent{common::Intent::Default}; @@ -231,7 +235,7 @@ bool operator==(const DummyArgument &) const; bool operator!=(const DummyArgument &that) const { return !(*this == that); } static std::optional Characterize( - const semantics::Symbol &, FoldingContext &); + const semantics::Symbol &, FoldingContext &, SeenProcs &); static std::optional FromActual( std::string &&, const Expr &, FoldingContext &); bool IsOptional() const; @@ -301,8 +305,14 @@ // "unrestricted specific intrinsic function". static std::optional Characterize( const semantics::Symbol &, FoldingContext &); + // This function is the initial point of entry for characterizing procedure static std::optional Characterize( const ProcedureDesignator &, FoldingContext &); + // This one is used with mutually recursive calls when characterizing + // a Procedure, a DummyArgument, or a DummyProcedure to detect + // circularly defined procedures + static std::optional Characterize( + const semantics::Symbol &, FoldingContext &, SeenProcs &); static std::optional Characterize( const ProcedureRef &, FoldingContext &); diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -342,8 +342,9 @@ } std::optional DummyProcedure::Characterize( - const semantics::Symbol &symbol, FoldingContext &context) { - if (auto procedure{Procedure::Characterize(symbol, context)}) { + const semantics::Symbol &symbol, FoldingContext &context, + SeenProcs &seenProcs) { + if (auto procedure{Procedure::Characterize(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 @@ -382,13 +383,15 @@ } std::optional DummyArgument::Characterize( - const semantics::Symbol &symbol, FoldingContext &context) { + const semantics::Symbol &symbol, FoldingContext &context, + SeenProcs &seenProcs) { auto name{symbol.name().ToString()}; if (symbol.has()) { 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{ + DummyProcedure::Characterize(symbol, context, seenProcs)}) { return DummyArgument{std::move(name), std::move(proc.value())}; } return std::nullopt; @@ -642,10 +645,34 @@ return true; } +static std::string GetSeenProcs(SeenProcs &seenProcs) { + std::string result; + bool firstTime{true}; + for (auto &procPtr : seenProcs) { + if (!firstTime) { + result = result + ", "; + } else { + firstTime = false; + } + result = result + procPtr->name().ToString(); + } + return result; +} + std::optional Procedure::Characterize( - const semantics::Symbol &original, FoldingContext &context) { + const semantics::Symbol &original, FoldingContext &context, + SeenProcs &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(symbol, result, { {semantics::Attr::PURE, Procedure::Attr::Pure}, @@ -673,8 +700,8 @@ for (const semantics::Symbol *arg : subp.dummyArgs()) { if (!arg) { result.dummyArguments.emplace_back(AlternateReturn{}); - } else if (auto argCharacteristics{ - DummyArgument::Characterize(*arg, context)}) { + } else if (auto argCharacteristics{DummyArgument::Characterize( + *arg, context, seenProcs)}) { result.dummyArguments.emplace_back( std::move(argCharacteristics.value())); } else { @@ -691,7 +718,7 @@ } const semantics::ProcInterface &interface{proc.interface()}; if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) { - return Characterize(*interfaceSymbol, context); + return Characterize(*interfaceSymbol, context, seenProcs); } else { result.attrs.set(Attr::ImplicitInterface); const semantics::DeclTypeSpec *type{interface.type()}; @@ -712,7 +739,8 @@ } }, [&](const semantics::ProcBindingDetails &binding) { - if (auto result{Characterize(binding.symbol(), context)}) { + if (auto result{ + Characterize(binding.symbol(), context, seenProcs)}) { if (!symbol.attrs().test(semantics::Attr::NOPASS)) { auto passName{binding.passName()}; for (auto &dummy : result->dummyArguments) { @@ -729,16 +757,22 @@ } }, [&](const semantics::UseDetails &use) { - return Characterize(use.symbol(), context); + return Characterize(use.symbol(), context, seenProcs); }, [&](const semantics::HostAssocDetails &assoc) { - return Characterize(assoc.symbol(), context); + return Characterize(assoc.symbol(), context, seenProcs); }, [](const auto &) { return std::optional{}; }, }, symbol.details()); } +std::optional Procedure::Characterize( + const semantics::Symbol &original, FoldingContext &context) { + SeenProcs seenProcs; + return Procedure::Characterize(original, context, seenProcs); +} + std::optional Procedure::Characterize( const ProcedureDesignator &proc, FoldingContext &context) { if (const auto *symbol{proc.GetSymbol()}) { diff --git a/flang/test/Semantics/resolve100.f90 b/flang/test/Semantics/resolve100.f90 --- a/flang/test/Semantics/resolve100.f90 +++ b/flang/test/Semantics/resolve100.f90 @@ -1,14 +1,65 @@ -!RUN: %f18 -fdebug-dump-symbols -fsyntax-only %s | FileCheck %s - -program p - ! CHECK: a size=4 offset=0: ObjectEntity type: LOGICAL(4) - ! CHECK: b size=4 offset=4: ObjectEntity type: REAL(4) - logical :: a = .false. - real :: b = 9.73 - ! CHECK: a: AssocEntity type: REAL(4) expr:b - ! CHECK: b: AssocEntity type: LOGICAL(4) expr:a - associate (b => a, a => b) - print*, a, b - end associate - print*, a, b -end +! 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: 'sub, p, 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: 'sub, p, 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: 'sub1, p, 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: 'sub1, sub, p, arg, p2' + Subroutine sub1(arg) + procedure(sub) :: arg + End Subroutine + + Subroutine sub(p2) + Procedure(sub1) :: p2 + End Subroutine +End Program