[flang] Detect circularly defined procedures

[PeteSteinfeld]

Summary

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.

[klausler]

flang/include/flang/Evaluate/characteristics.h

206–207

As a convenience to external clients, this new argument could be either a pointer that default to nullptr, or there could be an overload without the set argument that declares one and passes it onward (my preference).

flang/lib/Evaluate/characteristics.cpp

778

Please clarify this message so that the user can tell that the circular dependence is in the specification of the procedure's interface or characteristics.

[PeteSteinfeld]

flang/include/flang/Evaluate/characteristics.h

206–207

I'm not sure if I understand your comment. There are no external clients for the Characterize() functions for a DummyProcedure or a DummyArgument. Rather, all of the calls to them happen in .../Evaluate/characteristics.cpp. There are external clients for Procedure::Characterize(). For this function, I did as you recommend -- the version without the set argument creates one and passes it on to the overload that contains the set argument.

flang/lib/Evaluate/characteristics.cpp

778

I'll take a crack at it.

[PeteSteinfeld]

Responding to Peter's feedback -- an attempt to clarify the error message.

[klausler]

I think there's ways by which the characteristics of a procedure could be self-dependent besides the use of a dummy procedure, so you might want a less specific error. But that's probably the most common way that a user can get themselves into trouble with this sort of thing, so you might be okay. Improve or change the message as you like, or not. Maybe Tim can suggest better wording.

[PeteSteinfeld]

In D96631#2561336, @klausler wrote:

I think there's ways by which the characteristics of a procedure could be self-dependent besides the use of a dummy procedure, so you might want a less specific error. But that's probably the most common way that a user can get themselves into trouble with this sort of thing, so you might be okay. Improve or change the message as you like, or not. Maybe Tim can suggest better wording.

Thanks, Peter. It occurred to me that I can also improve the message by including the names of all of the procedures in the cycle as part of the error message. I'll be producing another update that does that. Let me know what you think when I update the commit.

[PeteSteinfeld]

Trying to improve the error message when a circularity is detected. I added a
list of the procedures in the cycle.

[PeteSteinfeld]

Added a reference to the standard.

[tskeith]

flang/include/flang/Evaluate/characteristics.h

57

symbol.h defines SymbolSet which you could use here.

206–207

The new overloads that include SeenProcs aren't used by external clients so perhaps they can be static non-member functions in characteristics.cpp. Then the external API won't change at all.

flang/lib/Evaluate/characteristics.cpp

774

This could be const SeenProcs &.

777

clang-tidy says this should be const auto &procPtr. But const auto *procPtr would be better.

flang/test/Semantics/resolve100.f90

4 ↗

(On Diff #323635)

I think the procedure names should be quoted individually, i.e. 'sub', 'p2'.

[tskeith]

flang/lib/Evaluate/characteristics.cpp

785

FYI, llvm has utility functions in llvm/ADT/STLExtras.h that simplify this kind of thing. If you take my suggestion of enclosing each procedure name in quotes you could implement this function as:

llvm::interleave(
    seenProcs,
    [&](const Symbol *p) { result += '\'' + p->name().ToString() + '\''; },
    [&]() { result += ", "; });

[PeteSteinfeld]

flang/include/flang/Evaluate/characteristics.h

57

Thanks, I'll do that.

206–207

Good suggestion. And even though the Characterize() methods of DummyArgument and DummyProcedure aren't overloads, It seems to me that they should also be made static in characteristics.cpp.

flang/lib/Evaluate/characteristics.cpp

777

Or const SymbolRef.

785

How do you find this stuff? I'll do it.

flang/test/Semantics/resolve100.f90

4 ↗

(On Diff #323635)

Will do.

[PeteSteinfeld]

Responding to comments from Tim. I made the functions that characterize
Procedure, DummyArgument, and DummyProcedure that are mutually recursive all be
static and reside completely in characteristics.cpp. I also started using the
type SymbolSet and recoded the function to create a string of comma separated
names to use a utility from LLVM.

[tskeith]

LGTM

flang/test/Semantics/resolve100.f90

4 ↗

(On Diff #323635)

There are extra quotes around the whole list.

flang/include/flang/Evaluate/characteristics.h

 
 // Shapes of function results and dummy arguments have to have
 // the same rank, the same deferred dimensions, and the same
 // values for explicit dimensions when constant.
 bool ShapesAreCompatible(const Shape &, const Shape &);
 
 class TypeAndShape {
 public:
   ENUM_CLASS(
       Attr, AssumedRank, AssumedShape, AssumedSize, DeferredShape, Coarray)
   using Attrs = common::EnumSet<Attr, Attr_enumSize>;
 
   explicit TypeAndShape(DynamicType t) : type_{t} { AcquireLEN(); }
   TypeAndShape(DynamicType t, int rank) : type_{t}, shape_(rank) {
     AcquireLEN();
   }
   TypeAndShape(DynamicType t, Shape &&s) : type_{t}, shape_{std::move(s)} {

 
 // 15.3.2.3
 struct DummyProcedure {
   ENUM_CLASS(Attr, Pointer, Optional)
   using Attrs = common::EnumSet<Attr, Attr_enumSize>;
   DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(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};
   Attrs attrs;
 };
 
 // 15.3.2.4
 struct AlternateReturn {
   bool operator==(const AlternateReturn &) const { return true; }
   bool operator!=(const AlternateReturn &) const { return false; }
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 };
 
 // 15.3.2.1
 struct DummyArgument {
   DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
   DummyArgument(std::string &&name, DummyDataObject &&x)
       : name{std::move(name)}, u{std::move(x)} {}
   DummyArgument(std::string &&name, DummyProcedure &&x)
       : name{std::move(name)}, u{std::move(x)} {}
   explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {}
   ~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;
   void SetOptional(bool = true);
   common::Intent GetIntent() const;
   void SetIntent(common::Intent);
   bool CanBePassedViaImplicitInterface() const;
   bool IsTypelessIntrinsicDummy() const;
struct FunctionResult {
   std::variant<TypeAndShape, CopyableIndirection<Procedure>> u;
 };
 
 // 15.3.1
 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)
   ~Procedure();
   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
   // "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(
       const ProcedureRef &, FoldingContext &);
 
   // At most one of these will return true.
   // For "EXTERNAL P" with no type for or calls to P, both will be false.
   bool IsFunction() const { return functionResult.has_value(); }
   bool IsSubroutine() const { return attrs.test(Attr::Subroutine); }
 
   bool IsPure() const { return attrs.test(Attr::Pure); }
   bool IsElemental() const { return attrs.test(Attr::Elemental); }
   bool IsBindC() const { return attrs.test(Attr::BindC); }
   bool HasExplicitInterface() const {
     return !attrs.test(Attr::ImplicitInterface);
   }
   int FindPassIndex(std::optional<parser::CharBlock>) const;
   bool CanBeCalledViaImplicitInterface() const;
   bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   std::optional<FunctionResult> functionResult;
   DummyArguments dummyArguments;
   Attrs attrs;
-
-private:
-  Procedure() {}
 };
 } // namespace Fortran::evaluate::characteristics
 #endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_

flang/lib/Evaluate/characteristics.cpp

 DummyProcedure::DummyProcedure(Procedure &&p)
     : procedure{new Procedure{std::move(p)}} {}
 
 bool DummyProcedure::operator==(const DummyProcedure &that) const {
   return attrs == that.attrs && intent == that.intent &&
       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
     // made non-elemental.
     procedure->attrs.reset(Procedure::Attr::Elemental);
     DummyProcedure result{std::move(procedure.value())};
     CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
         {

 }
 
 DummyArgument::~DummyArgument() {}
 
 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;
 }
 
 std::optional<DummyArgument> DummyArgument::FromActual(
     std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
   return std::visit(
for (int j{0}; j < argCount; ++j) {
     if ((!passIndex || j != *passIndex) &&
         dummyArguments[j] != that.dummyArguments[j]) {
       return false;
     }
   }
   return true;
 }
 
 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(
     const ProcedureDesignator &proc, FoldingContext &context) {
   if (const auto *symbol{proc.GetSymbol()}) {
     if (auto result{characteristics::Procedure::Characterize(
             symbol->GetUltimate(), context)}) {
       return result;
     }
   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
     return intrinsic->characteristics.value();
   }
   return std::nullopt;
 }
 
 std::optional<Procedure> Procedure::Characterize(

flang/test/Semantics/resolve102.f90

+! 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