[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

Author: psteinfeld

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_

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(

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