[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

211

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

655

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

211

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

655

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.

211

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

648

This could be const SeenProcs &.

651

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

flang/test/Semantics/resolve100.f90

4

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

[tskeith]

flang/lib/Evaluate/characteristics.cpp

659

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.

211

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

651

Or const SymbolRef.

659

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

flang/test/Semantics/resolve100.f90

4

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

There are extra quotes around the whole list.

flang/include/flang/Evaluate/characteristics.h

 // Are these procedures distinguishable for a generic operator or assignment?
 bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
 
 // 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 &);
 
+// Used to track potential circularly defined procedures
+using SeenProcs = std::set<const semantics::Symbol *>;
+
 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) {

 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);
+      const semantics::Symbol &, FoldingContext &context, SeenProcs &);
   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 {
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 &);
+      const semantics::Symbol &, FoldingContext &, SeenProcs &);
   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 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 &);
+  // 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<Procedure> Characterize(
+      const semantics::Symbol &, FoldingContext &, SeenProcs &);
   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); }
 

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)}) {
+    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
     // 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) {
+    const semantics::Symbol &symbol, FoldingContext &context,
+    SeenProcs &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{
+                 DummyProcedure::Characterize(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) {
+    const semantics::Symbol &original, FoldingContext &context,
+    SeenProcs &seenProcs) {
   Procedure result;
   const auto &symbol{original.GetUltimate()};
+  if (seenProcs.find(&symbol) != seenProcs.end()) {
+    context.messages().Say(symbol.name(),
+        "Procedure '%s' depends on itself"_err_en_US, symbol.name());
+    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(Attr::Elemental) &&
       !symbol.attrs().test(semantics::Attr::IMPURE)) {
     result.attrs.set(Attr::Pure); // explicitly flag pure procedures
return std::visit(
                 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)}) {
+              } else if (auto argCharacteristics{DummyArgument::Characterize(
+                             *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 Characterize(*interfaceSymbol, context);
+              return Characterize(*interfaceSymbol, context, seenProcs);
             } 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 (auto result{
+                    Characterize(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 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<Procedure>{}; },
       },
       symbol.details());
 }
 
 std::optional<Procedure> Procedure::Characterize(
+    const semantics::Symbol &original, FoldingContext &context) {
+  SeenProcs seenProcs;
+  return Procedure::Characterize(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();

flang/test/Semantics/resolve100.f90

-!RUN: %f18 -fdebug-dump-symbols -fsyntax-only %s | FileCheck %s
+! RUN: %S/test_errors.sh %s %t %f18
 
-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
+! Tests for circularly defined procedures
+!ERROR: Procedure 'sub' depends on itself
+subroutine sub(p2)
+  PROCEDURE(sub) :: p2
+
+  call sub()
+end subroutine
+
+subroutine circular
+  !ERROR: Procedure 'p' depends on itself
+  procedure(sub) :: p
+
+  call p(sub)
+
+  contains 
+    subroutine sub(p2)
+      procedure(p) :: p2
+    end subroutine
+end subroutine circular
+
+program iface
+  !ERROR: Procedure 'p' depends on itself
+  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' depends on itself
+    Subroutine sub1(arg)
+      procedure(sub1) :: arg
+    End Subroutine
+
+    Subroutine sub(p2)
+      Procedure(sub1) :: p2
+    End Subroutine
+End Program