diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -17,7 +17,7 @@ #include #include #include -#include +#include #include namespace llvm { @@ -38,6 +38,12 @@ using SymbolVector = std::vector; using MutableSymbolRef = common::Reference; using MutableSymbolVector = std::vector; +struct SymbolHash { + std::size_t operator()(SymbolRef symRef) const { + return (std::size_t)(&symRef.get()); + } +}; +using SymbolSet = std::unordered_set; // A module or submodule. class ModuleDetails { @@ -594,9 +600,10 @@ bool operator==(const Symbol &that) const { return this == &that; } bool operator!=(const Symbol &that) const { return !(*this == that); } + // For maps using symbols as keys and sorting symbols. Collate them by their + // position in the cooked character stream bool operator<(const Symbol &that) const { - // For sets of symbols: collate them by source location - return name_.begin() < that.name_.begin(); + return sortName_ < that.sortName_; } int Rank() const { @@ -653,6 +660,7 @@ private: const Scope *owner_; SourceName name_; + const char *sortName_; // used in the "<" operator for sorting symbols Attrs attrs_; Flags flags_; Scope *scope_{nullptr}; @@ -687,6 +695,7 @@ Symbol &symbol = Get(); symbol.owner_ = &owner; symbol.name_ = name; + symbol.sortName_ = name.begin(); symbol.attrs_ = attrs; symbol.details_ = std::move(details); return symbol; @@ -765,7 +774,6 @@ inline bool operator<(MutableSymbolRef x, MutableSymbolRef y) { return *x < *y; } -using SymbolSet = std::set; } // namespace Fortran::semantics 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 @@ -369,7 +369,7 @@ std::string procsList{GetSeenProcs(seenProcs)}; context.messages().Say(symbol.name(), "Procedure '%s' is recursively defined. Procedures in the cycle:" - " '%s'"_err_en_US, + " %s"_err_en_US, symbol.name(), procsList); return std::nullopt; } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1003,6 +1003,7 @@ context().SetError(symbol); return symbol; } + bool HasCycle(const Symbol &, const ProcInterface &); }; // Resolve construct entities and statement entities. @@ -2132,7 +2133,7 @@ void ScopeHandler::ApplyImplicitRules( Symbol &symbol, bool allowForwardReference) { - if (!NeedsType(symbol)) { + if (context().HasError(symbol) || !NeedsType(symbol)) { return; } if (const DeclTypeSpec * type{GetImplicitType(symbol)}) { @@ -2156,10 +2157,8 @@ if (allowForwardReference && ImplicitlyTypeForwardRef(symbol)) { return; } - if (!context().HasError(symbol)) { - Say(symbol.name(), "No explicit type declared for '%s'"_err_en_US); - context().SetError(symbol); - } + Say(symbol.name(), "No explicit type declared for '%s'"_err_en_US); + context().SetError(symbol); } // Extension: Allow forward references to scalar integer dummy arguments @@ -3641,6 +3640,35 @@ } } +bool DeclarationVisitor::HasCycle( + const Symbol &procSymbol, const ProcInterface &interface) { + SymbolSet procsInCycle; + procsInCycle.insert(procSymbol); + const ProcInterface *thisInterface{&interface}; + bool haveInterface{true}; + while (haveInterface) { + haveInterface = false; + if (const Symbol * interfaceSymbol{thisInterface->symbol()}) { + if (procsInCycle.count(*interfaceSymbol) > 0) { + for (const auto procInCycle : procsInCycle) { + Say(procInCycle->name(), + "The interface for procedure '%s' is recursively " + "defined"_err_en_US, + procInCycle->name()); + context().SetError(*procInCycle); + } + return true; + } else if (const auto *procDetails{ + interfaceSymbol->detailsIf()}) { + haveInterface = true; + thisInterface = &procDetails->interface(); + procsInCycle.insert(*interfaceSymbol); + } + } + } + return false; +} + Symbol &DeclarationVisitor::DeclareProcEntity( const parser::Name &name, Attrs attrs, const ProcInterface &interface) { Symbol &symbol{DeclareEntity(name, attrs)}; @@ -3650,20 +3678,20 @@ "The interface for procedure '%s' has already been " "declared"_err_en_US); context().SetError(symbol); - } else { - if (interface.type()) { + } else if (HasCycle(symbol, interface)) { + return symbol; + } else if (interface.type()) { + symbol.set(Symbol::Flag::Function); + } else if (interface.symbol()) { + if (interface.symbol()->test(Symbol::Flag::Function)) { symbol.set(Symbol::Flag::Function); - } else if (interface.symbol()) { - if (interface.symbol()->test(Symbol::Flag::Function)) { - symbol.set(Symbol::Flag::Function); - } else if (interface.symbol()->test(Symbol::Flag::Subroutine)) { - symbol.set(Symbol::Flag::Subroutine); - } + } else if (interface.symbol()->test(Symbol::Flag::Subroutine)) { + symbol.set(Symbol::Flag::Subroutine); } - details->set_interface(interface); - SetBindNameOn(symbol); - SetPassNameOn(symbol); } + details->set_interface(interface); + SetBindNameOn(symbol); + SetPassNameOn(symbol); } return symbol; } @@ -5005,7 +5033,7 @@ void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) { if (const Symbol * symbol{name.symbol}) { - if (!symbol->HasExplicitInterface()) { + if (!context().HasError(*symbol) && !symbol->HasExplicitInterface()) { Say(name, "'%s' must be an abstract interface or a procedure with " "an explicit interface"_err_en_US, diff --git a/flang/test/Semantics/resolve102.f90 b/flang/test/Semantics/resolve102.f90 --- a/flang/test/Semantics/resolve102.f90 +++ b/flang/test/Semantics/resolve102.f90 @@ -1,7 +1,7 @@ ! 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'' +!ERROR: Procedure 'sub' is recursively defined. Procedures in the cycle: 'p2', 'sub' subroutine sub(p2) PROCEDURE(sub) :: p2 @@ -9,7 +9,7 @@ end subroutine subroutine circular - !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: ''p', 'sub', 'p2'' + !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: 'p2', 'p', 'sub' procedure(sub) :: p call p(sub) @@ -21,7 +21,7 @@ end subroutine circular program iface - !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: ''p', 'sub', 'p2'' + !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: 'p2', 'p', 'sub' procedure(sub) :: p interface subroutine sub(p2) @@ -38,7 +38,7 @@ Call p(sub) contains - !ERROR: Procedure 'sub1' is recursively defined. Procedures in the cycle: ''p', 'sub1', 'arg'' + !ERROR: Procedure 'sub1' is recursively defined. Procedures in the cycle: 'arg', 'p', 'sub1' Subroutine sub1(arg) procedure(sub1) :: arg End Subroutine @@ -54,7 +54,7 @@ Call p(sub) contains - !ERROR: Procedure 'sub1' is recursively defined. Procedures in the cycle: ''p', 'sub1', 'arg', 'sub', 'p2'' + !ERROR: Procedure 'sub1' is recursively defined. Procedures in the cycle: 'p2', 'sub', 'arg', 'p', 'sub1' Subroutine sub1(arg) procedure(sub) :: arg End Subroutine @@ -63,3 +63,24 @@ Procedure(sub1) :: p2 End Subroutine End Program + +program twoCycle + !ERROR: The interface for procedure 'p1' is recursively defined + !ERROR: The interface for procedure 'p2' is recursively defined + procedure(p1) p2 + procedure(p2) p1 + call p1 + call p2 +end program + +program threeCycle + !ERROR: The interface for procedure 'p1' is recursively defined + !ERROR: The interface for procedure 'p2' is recursively defined + procedure(p1) p2 + !ERROR: The interface for procedure 'p3' is recursively defined + procedure(p2) p3 + procedure(p3) p1 + call p1 + call p2 + call p3 +end program