[flang] Add a derived type component visitor framework

After fixing 594, it appears there were issues in
FindUltimateComponent that was considering type bound
procedure as components.
This commit fixes and beef-up the component visitation by making a visitor
class for it. The main advantage of making it an class vs functions is that
it is possible to get the component chain to the result component for better
feedback for the user.
The framework allow a single place to define/handle what ultimate, direct and
potential components are.

Original-commit: flang-compiler/f18@d84821a1d6
Reviewed-on: https://github.com/flang-compiler/f18/pull/607
Tree-same-pre-rewrite: false

flang/lib/semantics/tools.cc

@@ -380,6 +380,13 @@ bool IsTeamType(const DerivedTypeSpec *derived) {
   return IsDerivedTypeFromModule(derived, "iso_fortran_env", "team_type");
 }
 
+const Symbol *FindUltimateComponent(const DerivedTypeSpec &derivedTypeSpec,
+    std::function<bool(const Symbol &)> predicate) {
+  return ComponentVisitor{std::move(predicate)}
+      .VisitUltimateComponents(derivedTypeSpec)
+      .Result();
+}
+
 const Symbol *HasCoarrayUltimateComponent(
     const DerivedTypeSpec &derivedTypeSpec) {
   return FindUltimateComponent(derivedTypeSpec, IsCoarray);
@@ -391,38 +398,12 @@ const bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
       IsDerivedTypeFromModule(derivedTypeSpec, "iso_fortran_env", "lock_type");
 }
 
-const Symbol *HasEventOrLockPotentialComponent(
-    const DerivedTypeSpec &derivedTypeSpec) {
-
-  const Symbol &symbol{derivedTypeSpec.typeSymbol()};
-  // TODO is it guaranteed that derived type symbol have a scope and is it the
-  // right scope to look into?
-  CHECK(symbol.scope());
-  for (const Symbol *componentSymbol :
-      symbol.get<DerivedTypeDetails>().OrderComponents(*symbol.scope())) {
-    CHECK(componentSymbol);
-    if (!IsPointer(*componentSymbol)) {
-      if (const DeclTypeSpec * declTypeSpec{componentSymbol->GetType()}) {
-        if (const DerivedTypeSpec *
-            componentDerivedTypeSpec{declTypeSpec->AsDerived()}) {
-          // Avoid infinite loop, that may happen if the component
-          // is an allocatable of the same type as the derived type.
-          // TODO: Is it legal to have longer type loops: i.e type B has a
-          // component of type A that has an allocatable component of type B?
-          if (&symbol != &componentDerivedTypeSpec->typeSymbol()) {
-            if (IsEventTypeOrLockType(componentDerivedTypeSpec)) {
-              return componentSymbol;
-            } else if (const Symbol *
-                subcomponent{HasEventOrLockPotentialComponent(
-                    *componentDerivedTypeSpec)}) {
-              return subcomponent;
-            }
-          }
-        }
-      }
-    }
+static const bool IsEventTypeOrLockTypeObjectEntity(const Symbol &symbol) {
+  if (symbol.has<ObjectEntityDetails>()) {
+    const DeclTypeSpec *type{symbol.GetType()};
+    return type && IsEventTypeOrLockType(type->AsDerived());
   }
-  return nullptr;
+  return false;
 }
 
 bool IsOrContainsEventOrLockComponent(const Symbol &symbol) {
@@ -439,25 +420,11 @@ bool IsOrContainsEventOrLockComponent(const Symbol &symbol) {
   return false;
 }
 
-const Symbol *FindUltimateComponent(const DerivedTypeSpec &derivedTypeSpec,
-    std::function<bool(const Symbol &)> predicate) {
-  const auto *scope{derivedTypeSpec.typeSymbol().scope()};
-  CHECK(scope);
-  for (const auto &pair : *scope) {
-    const Symbol &component{*pair.second};
-    const DeclTypeSpec *type{component.GetType()};
-    if (!type) {
-      continue;
-    }
-    const DerivedTypeSpec *derived{type->AsDerived()};
-    bool isUltimate{IsAllocatableOrPointer(component) || !derived};
-    if (const Symbol *
-        result{!isUltimate ? FindUltimateComponent(*derived, predicate)
-                           : predicate(component) ? &component : nullptr}) {
-      return result;
-    }
-  }
-  return nullptr;
+const Symbol *HasEventOrLockPotentialComponent(
+    const DerivedTypeSpec &derivedTypeSpec) {
+  return ComponentVisitor{IsEventTypeOrLockTypeObjectEntity}
+      .VisitPotentialComponents(derivedTypeSpec)
+      .Result();
 }
 
 bool IsFinalizable(const Symbol &symbol) {
@@ -790,4 +757,139 @@ static Symbol &InstantiateSymbol(
   return result;
 }
 
+enum class ComponentKind { Direct, Ultimate, Potential };
+
+template<ComponentKind componentKind> class ComponentVisitorImplementation {
+public:
+  ComponentVisitorImplementation(std::function<bool(const Symbol &)> &predicate)
+    : predicate_{predicate} {}
+  SymbolVector Visit(const DerivedTypeSpec &derived) {
+    TraverseDerivedType(derived);
+    return std::move(componentStack_);
+  }
+
+private:
+  const Symbol *TraverseDerivedType(const DerivedTypeSpec &derived) {
+    const Symbol &derivedTypeSymbol{derived.typeSymbol()};
+    // Avoid infinite loop if the type is already part of the types
+    // being visited. It is possible to have "loops in type" because
+    // C744 does not forbid to use not yet declared type for
+    // ALLOCATABLE or POINTER components.
+    // When looking for potential components, the search could fall
+    // in an infinite loop. Avoid these in other search for safety.
+    for (const Symbol *typeUnderVisit : typeStack_) {
+      if (typeUnderVisit == &derivedTypeSymbol) {
+        return nullptr;
+      }
+    }
+    typeStack_.push_back(&derivedTypeSymbol);
+    const Scope *scope{derivedTypeSymbol.scope()};
+    CHECK(scope);  // derived type symbol must have a scope
+    const Symbol *result{nullptr};
+    // Note: parent subcomponents are visited first, then the parent component
+    // (if any), then other components by order of declaration
+    SymbolVector orederedComponents{
+        derivedTypeSymbol.get<DerivedTypeDetails>().OrderComponents(*scope)};
+    for (const Symbol *component : orederedComponents) {
+      if (component->has<ProcEntityDetails>()) {
+        result = VisitProcedureComponent(*component);
+      } else if (component->has<ObjectEntityDetails>()) {
+        result = VisitDataComponent(*component);
+      }
+      if (result) {
+        return result;
+      }
+    }
+    typeStack_.pop_back();
+    return nullptr;
+  }
+
+  const Symbol *VisitProcedureComponent(const Symbol &component) {
+    // Procedure components are pointers (C756)
+    if constexpr (componentKind == ComponentKind::Ultimate ||
+        componentKind == ComponentKind::Direct) {
+      if (predicate_(component)) {
+        componentStack_.push_back(&component);
+        return &component;
+      }
+    }
+    return nullptr;
+  }
+
+  const Symbol *VisitDataComponent(const Symbol &component) {
+    const DeclTypeSpec *type{component.GetType()};
+    if (!type) {
+      return nullptr;  // error recovery ?
+    }
+    bool test{false}, descend{false};
+    if constexpr (componentKind == ComponentKind::Direct) {
+      test = true;
+      descend = !IsAllocatableOrPointer(component);
+    } else if constexpr (componentKind == ComponentKind::Ultimate) {
+      descend = !IsAllocatableOrPointer(component);
+      test = !descend || type->AsIntrinsic();
+    } else {  // Potential
+      test = descend = !IsPointer(component);
+    }
+
+    // Do not descend into parent components, their components were already
+    // included by DerivedTypeDetails::OrderComponents. However, parent
+    // components should still be checked against the predicate if relevant.
+    descend &= !component.test(Symbol::Flag::ParentComp);
+
+    if (test && predicate_(component)) {
+      componentStack_.push_back(&component);
+      return &component;
+    } else if (descend) {
+      if (const auto *derived{type->AsDerived()}) {
+        componentStack_.push_back(&component);
+        if (const Symbol * result{TraverseDerivedType(*derived)}) {
+          return result;
+        }
+        componentStack_.pop_back();
+      }
+    }
+    return nullptr;
+  }
+
+  std::vector<const Symbol *> componentStack_;  // to build message info
+  std::vector<const Symbol *> typeStack_;  // to avoid infinite loops
+  std::function<bool(const Symbol &)> &predicate_;
+};
+
+ComponentVisitor &ComponentVisitor::VisitPotentialComponents(
+    const DerivedTypeSpec &derived) {
+  componentStack_.clear();
+  componentStack_ =
+      ComponentVisitorImplementation<ComponentKind::Potential>{predicate_}
+          .Visit(derived);
+  return *this;
+}
+
+ComponentVisitor &ComponentVisitor::VisitUltimateComponents(
+    const DerivedTypeSpec &derived) {
+  componentStack_.clear();
+  componentStack_ =
+      ComponentVisitorImplementation<ComponentKind::Ultimate>{predicate_}.Visit(
+          derived);
+  return *this;
+}
+
+ComponentVisitor &ComponentVisitor::VisitDirectComponents(
+    const DerivedTypeSpec &derived) {
+  componentStack_.clear();
+  componentStack_ =
+      ComponentVisitorImplementation<ComponentKind::Direct>{predicate_}.Visit(
+          derived);
+  return *this;
+}
+
+std::string ComponentVisitor::BuildResultDesignatorName() const {
+  std::string designator{""};
+  for (const Symbol *component : componentStack_) {
+    designator += "%" + component->name().ToString();
+  }
+  return designator;
+}
+
 }

flang/lib/semantics/tools.h

@@ -209,5 +209,51 @@ template<typename T> std::optional<std::int64_t> GetIntValue(const T &x) {
   }
 }
 
+// Derived type component visitor that applies a predicate on all the direct,
+// ultimate or Potential components. It stops at the first component that
+// verifies the given predicate and keep the component path to the result
+// (included at the end of the path). If no component verifies the predicate
+// the path is empty.
+// The component tree is visited in component declaration order,
+// visiting the subcomponent of a component before visiting the next component.
+// Parent components and procedure pointer components are visited.
+// Note that it is made in such a way that one can easily test and build info
+// message in the following way:
+//    if (auto
+//      visitor{ComponentVisitor{predicate}.VisitDirectComponents(derived)}) {
+//       msg = visitor.BuildResultDesignatorName() + " verifies predicates";
+//       ....
+//    }
+// It is safe to re-use the same object several times, previous results are
+// cleared before each visit.
+class ComponentVisitor {
+public:
+  ComponentVisitor(std::function<bool(const Symbol &)> &&predicate)
+    : predicate_{std::move(predicate)} {}
+
+  // Object is updated with the result during visit and returned by ref
+  ComponentVisitor &VisitPotentialComponents(const DerivedTypeSpec &);
+  ComponentVisitor &VisitUltimateComponents(const DerivedTypeSpec &);
+  ComponentVisitor &VisitDirectComponents(const DerivedTypeSpec &);
+
+  // predefined common tests
+  static ComponentVisitor HasCoarrayUltimate(const DerivedTypeSpec &derived) {
+    return ComponentVisitor{IsCoarray}.VisitUltimateComponents(derived);
+  }
+
+  const Symbol *Result() const {
+    return componentStack_.empty() ? nullptr : componentStack_.back();
+  }
+
+  bool HasResult() const { return Result() != nullptr; }
+  explicit operator bool() const { return HasResult(); }
+  // build designator name for messages if there is a result
+  std::string BuildResultDesignatorName() const;
+
+private:
+  SymbolVector componentStack_;  // component path to result
+  std::function<bool(const Symbol &)> predicate_;
+};
+
 }
 #endif  // FORTRAN_SEMANTICS_TOOLS_H_