[flang] Infrastructure improvements in utility routines

[klausler]

Summary

• IsArrayElement() needs another option to control whether it should ignore trailing component references.
• Add IsObjectPointer().
• Add const Scope& variants of IsFunction() and IsProcedure().
• Make TypeAndShape::Characterize() work with procedure bindings.
• Handle CHARACTER length in MeasureSizeInBytes().
• Fine-tune FindExternallyVisibleObject()'s handling of dummy arguments to conform with Fortran 2018: only INTENT(IN) and dummy pointers in pure functions signify; update two tests accordingly.

Also: resolve some stylistic inconsistencies and add a missing
"const" in the expression traversal template framework.

[PeteSteinfeld]

All builds, tests, and looks good.

[MaskRay]

In your commit the message does not include Reviewed by:. Many people agree that both Reviewed by: & Differential Revision: should be present. The Reviewed by: list indicates people who acknowledged the patch. (The Reviewers: list does not necessarily mean all the people on the list have acknowledged the patch so Reviewers: is mostly useless.)

arc amend can fetch the Phabricator summary and amend the local description.

You can install llvm/utils/git/pre-push.py to prevent accidental Summary:, Reviewers:, Subscribers: and Tags: in the presence of Differential Revision:.

flang/include/flang/Evaluate/call.h

public:
   common::Label GetLabel() const { return std::get<common::Label>(u_); }
 
   std::optional<DynamicType> GetType() const;
   int Rank() const;
   bool operator==(const ActualArgument &) const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
   std::optional<parser::CharBlock> keyword() const { return keyword_; }
-  void set_keyword(parser::CharBlock x) { keyword_ = x; }
+  ActualArgument &set_keyword(parser::CharBlock x) {
+    keyword_ = x;
+    return *this;
+  }
   bool isAlternateReturn() const {
     return std::holds_alternative<common::Label>(u_);
   }
   bool isPassedObject() const { return isPassedObject_; }
-  void set_isPassedObject(bool yes = true) { isPassedObject_ = yes; }
+  ActualArgument &set_isPassedObject(bool yes = true) {
+    isPassedObject_ = yes;
+    return *this;
+  }
 
   bool Matches(const characteristics::DummyArgument &) const;
   common::Intent dummyIntent() const { return dummyIntent_; }
   ActualArgument &set_dummyIntent(common::Intent intent) {
     dummyIntent_ = intent;
     return *this;
   }
 

flang/include/flang/Evaluate/tools.h

std::optional<DataRef> ExtractDataRef(const A *p, bool intoSubstring = false) {
   } else {
     return std::nullopt;
   }
 }
 std::optional<DataRef> ExtractSubstringBase(const Substring &);
 
 // Predicate: is an expression is an array element reference?
 template <typename T>
-bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = false) {
+bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = true,
+    bool skipComponents = false) {
   if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) {
     const DataRef *ref{&*dataRef};
+    if (skipComponents) {
       while (const Component * component{std::get_if<Component>(&ref->u)}) {
         ref = &component->base();
       }
+    }
     if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
       return !coarrayRef->subscript().empty();
     } else {
       return std::holds_alternative<ArrayRef>(ref->u);
     }
   } else {
     return false;
   }
return GetAttrs(x).HasAny(
       semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
 }
 
 // Procedure and pointer detection predicates
 bool IsProcedure(const Expr<SomeType> &);
 bool IsFunction(const Expr<SomeType> &);
 bool IsProcedurePointer(const Expr<SomeType> &);
 bool IsNullPointer(const Expr<SomeType> &);
+bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
 
 // Extracts the chain of symbols from a designator, which has perhaps been
 // wrapped in an Expr<>, removing all of the (co)subscripts.  The
 // base object will be the first symbol in the result vector.
 struct GetSymbolVectorHelper
     : public Traverse<GetSymbolVectorHelper, SymbolVector> {
   using Result = SymbolVector;
   using Base = Traverse<GetSymbolVectorHelper, Result>;

 
 namespace Fortran::semantics {
 
 class Scope;
 
 // These functions are used in Evaluate so they are defined here rather than in
 // Semantics to avoid a link-time dependency on Semantics.
 // All of these apply GetUltimate() or ResolveAssociations() to their arguments.
-
 bool IsVariableName(const Symbol &);
 bool IsPureProcedure(const Symbol &);
 bool IsPureProcedure(const Scope &);
 bool IsFunction(const Symbol &);
+bool IsFunction(const Scope &);
 bool IsProcedure(const Symbol &);
+bool IsProcedure(const Scope &);
 bool IsProcedurePointer(const Symbol &);
 bool IsSaved(const Symbol &); // saved implicitly or explicitly
 bool IsDummy(const Symbol &);
 bool IsFunctionResult(const Symbol &);
 bool IsKindTypeParameter(const Symbol &);
 bool IsLenTypeParameter(const Symbol &);
 
 // ResolveAssociations() traverses use associations and host associations

flang/include/flang/Evaluate/traverse.h

 public:
   explicit Traverse(Visitor &v) : visitor_{v} {}
 
   // Packaging
   template <typename A, bool C>
   Result operator()(const common::Indirection<A, C> &x) const {
     return visitor_(x.value());
   }
-  template <typename A> Result operator()(SymbolRef x) const {
+  template <typename A> Result operator()(const SymbolRef x) const {
     return visitor_(*x);
   }
   template <typename A> Result operator()(const std::unique_ptr<A> &x) const {
     return visitor_(x.get());
   }
   template <typename A> Result operator()(const std::shared_ptr<A> &x) const {
     return visitor_(x.get());
   }

flang/lib/Evaluate/characteristics.cpp

return std::visit(
               return std::optional<TypeAndShape>{std::move(*type)};
             } else {
               return std::optional<TypeAndShape>{};
             }
           },
           [&](const semantics::AssocEntityDetails &assoc) {
             return Characterize(assoc, context);
           },
+          [&](const semantics::ProcBindingDetails &binding) {
+            return Characterize(binding.symbol(), context);
+          },
           [](const auto &) { return std::optional<TypeAndShape>{}; },
       },
       // GetUltimate() used here, not ResolveAssociations(), because
       // we need the type/rank of an associate entity from TYPE IS,
       // CLASS IS, or RANK statement.
       symbol.GetUltimate().details());
 }
 
return isElemental ||
           thatIsDeferredShape);
 }
 
 std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
     FoldingContext &foldingContext) const {
   if (auto elements{GetSize(Shape{shape_})}) {
     // Sizes of arrays (even with single elements) are multiples of
     // their alignments.
+    if (LEN_) {
+      CHECK(type_.category() == TypeCategory::Character);
+      return Fold(foldingContext,
+          std::move(*elements) * Expr<SubscriptInteger>{type_.kind()} *
+              Expr<SubscriptInteger>{*LEN_});
+    }
     if (auto elementBytes{
             type_.MeasureSizeInBytes(foldingContext, GetRank(shape_) > 0)}) {
       return Fold(
           foldingContext, std::move(*elements) * std::move(*elementBytes));
     }
   }
   return std::nullopt;
 }

flang/lib/Evaluate/tools.cpp

auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
   return (*this)(x.base());
 }
 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
   return (*this)(x.GetBaseObject());
 }
 auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
     -> Result {
   const Symbol *symbol{x.GetSymbol()};
-  return symbol && symbol->attrs().test(semantics::Attr::POINTER);
+  return symbol && IsPointer(*symbol);
 }
 
 // Conversions of COMPLEX component expressions to REAL.
 ConvertRealOperandsResult ConvertRealOperands(
     parser::ContextualMessages &messages, Expr<SomeType> &&x,
     Expr<SomeType> &&y, int defaultRealKind) {
   return std::visit(
       common::visitors{
return std::visit(common::visitors{
                         [](const NullPointer &) { return true; },
                         [](const ProcedureDesignator &) { return true; },
                         [](const ProcedureRef &) { return true; },
                         [](const auto &) { return false; },
                     },
       expr.u);
 }
 
+template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
+  return nullptr;
+}
+
+template <typename T>
+inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
+  return &func;
+}
+
+template <typename T>
+inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
+  return std::visit(
+      [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
+}
+
+// IsObjectPointer()
+bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
+  if (IsNullPointer(expr)) {
+    return true;
+  } else if (IsProcedurePointer(expr)) {
+    return false;
+  } else if (const auto *procRef{UnwrapProcedureRef(expr)}) {
+    auto proc{
+        characteristics::Procedure::Characterize(procRef->proc(), context)};
+    return proc && proc->functionResult &&
+        proc->functionResult->attrs.test(
+            characteristics::FunctionResult::Attr::Pointer);
+  } else if (const Symbol * symbol{GetLastSymbol(expr)}) {
+    return IsPointer(symbol->GetUltimate());
+  } else {
+    return false;
+  }
+}
+
 // IsNullPointer()
 struct IsNullPointerHelper : public AllTraverse<IsNullPointerHelper, false> {
   using Base = AllTraverse<IsNullPointerHelper, false>;
   IsNullPointerHelper() : Base(*this) {}
   using Base::operator();
   bool operator()(const ProcedureRef &call) const {
     auto *intrinsic{call.proc().GetSpecificIntrinsic()};
     return intrinsic &&
return std::visit(
             return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
           },
           [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
           [](const auto &) { return false; },
       },
       symbol.GetUltimate().details());
 }
 
+bool IsFunction(const Scope &scope) {
+  const Symbol *symbol{scope.GetSymbol()};
+  return symbol && IsFunction(*symbol);
+}
+
 bool IsProcedure(const Symbol &symbol) {
   return std::visit(common::visitors{
                         [](const SubprogramDetails &) { return true; },
                         [](const SubprogramNameDetails &) { return true; },
                         [](const ProcEntityDetails &) { return true; },
                         [](const GenericDetails &) { return true; },
                         [](const ProcBindingDetails &) { return true; },
                         [](const auto &) { return false; },
                     },
       symbol.GetUltimate().details());
 }
 
-const Symbol *FindCommonBlockContaining(const Symbol &object) {
-  const auto *details{object.detailsIf<ObjectEntityDetails>()};
+bool IsProcedure(const Scope &scope) {
+  const Symbol *symbol{scope.GetSymbol()};
+  return symbol && IsProcedure(*symbol);
+}
+
+const Symbol *FindCommonBlockContaining(const Symbol &original) {
+  const Symbol &root{GetAssociationRoot(original)};
+  const auto *details{root.detailsIf<ObjectEntityDetails>()};
   return details ? details->commonBlock() : nullptr;
 }
 
 bool IsProcedurePointer(const Symbol &original) {
   const Symbol &symbol{original.GetUltimate()};
   return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
 }
 

flang/lib/Semantics/tools.cpp

const Symbol *FindPointerComponent(const Symbol &symbol) {
   return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType());
 }
 
 // C1594 specifies several ways by which an object might be globally visible.
 const Symbol *FindExternallyVisibleObject(
     const Symbol &object, const Scope &scope) {
   // TODO: Storage association with any object for which this predicate holds,
   // once EQUIVALENCE is supported.
-  if (IsUseAssociated(object, scope) || IsHostAssociated(object, scope) ||
-      (IsPureProcedure(scope) && IsPointerDummy(object)) ||
-      (IsIntentIn(object) && IsDummy(object))) {
+  const Symbol &ultimate{GetAssociationRoot(object)};
+  if (IsDummy(ultimate)) {
+    if (IsIntentIn(ultimate)) {
+      return &ultimate;
+    }
+    if (IsPointer(ultimate) && IsPureProcedure(ultimate.owner()) &&
+        IsFunction(ultimate.owner())) {
+      return &ultimate;
+    }
+  } else if (&GetProgramUnitContaining(ultimate) !=
+      &GetProgramUnitContaining(scope)) {
     return &object;
-  } else if (const Symbol * block{FindCommonBlockContaining(object)}) {
+  } else if (const Symbol * block{FindCommonBlockContaining(ultimate)}) {
     return block;
-  } else {
-    return nullptr;
   }
+  return nullptr;
 }
 
 bool ExprHasTypeCategory(
     const SomeExpr &expr, const common::TypeCategory &type) {
   auto dynamicType{expr.GetType()};
   return dynamicType && dynamicType->category() == type;
 }
 

flang/test/Semantics/structconst03.f90

pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     x1 = t1(0)(usedfrom1)
     !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(0)(modulevar1)
     !ERROR: Externally visible object 'cblock' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(0)(commonvar1)
     !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(0)(dummy1)
     x1 = t1(0)(dummy2)
-    !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(0)(dummy3)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1 = t1(0)(dummy4[0])
     x1 = t1(0)(dummy4)
     !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
     x2 = t2(0)(modulevar2)
     !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       x1a = t1(0)(modulevar1)
       !ERROR: Externally visible object 'commonvar1' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(0)(commonvar1)
       !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(0)(dummy1)
       !ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(0)(dummy1a)
       x1a = t1(0)(dummy2a)
-      !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(0)(dummy3)
-      !ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(0)(dummy3a)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1a = t1(0)(dummy4a[0])
       x1a = t1(0)(dummy4a)
       !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
       x2a = t2(0)(modulevar2)
       !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
       x3a = t3(0)(modulevar3)
       !ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
       x4a = t4(0)(modulevar4)
     end subroutine subr
   end subroutine
 
+  pure integer function pf1(dummy3)
+    real, pointer :: dummy3
+    type(t1(0)) :: x1
+    pf1 = 0
+    !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
+    x1 = t1(0)(dummy3)
+   contains
+    pure subroutine subr(dummy3a)
+      real, pointer :: dummy3a
+      type(t1(0)) :: x1a
+      !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
+      x1a = t1(0)(dummy3)
+      x1a = t1(0)(dummy3a)
+    end subroutine
+  end function
+
   impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
     real, target :: local1
     type(t1(0)) :: x1
     type(t2(0)) :: x2
     type(t3(0)) :: x3
     type(t4(0)) :: x4
     real, intent(in), target :: dummy1
     real, intent(inout), target :: dummy2

flang/test/Semantics/structconst04.f90

pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     x1 = t1(usedfrom1)
     !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(modulevar1)
     !ERROR: Externally visible object 'cblock' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(commonvar1)
     !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(dummy1)
     x1 = t1(dummy2)
-    !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(dummy3)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1 = t1(dummy4[0])
     x1 = t1(dummy4)
     !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
     x2 = t2(modulevar2)
     !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       x1a = t1(modulevar1)
       !ERROR: Externally visible object 'commonvar1' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(commonvar1)
       !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(dummy1)
       !ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(dummy1a)
       x1a = t1(dummy2a)
-      !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(dummy3)
-      !ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(dummy3a)
 ! TODO when semantics handles coindexing:
 ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
 ! TODO x1a = t1(dummy4a[0])
       x1a = t1(dummy4a)
       !ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
       x2a = t2(modulevar2)
       !ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
       x3a = t3(modulevar3)
       !ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
       x4a = t4(modulevar4)
     end subroutine subr
   end subroutine
 
+  pure integer function pf1(dummy3)
+    real, pointer :: dummy3
+    type(t1) :: x1
+    !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
+    x1 = t1(dummy3)
+   contains
+    pure subroutine subr(dummy3a)
+      real, pointer :: dummy3a
+      type(t1) :: x1a
+      !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
+      x1a = t1(dummy3)
+      x1a = t1(dummy3a)
+    end subroutine
+  end function
+
   impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
     real, target :: local1
     type(t1) :: x1
     type(t2) :: x2
     type(t3) :: x3
     type(t4) :: x4
     real, intent(in), target :: dummy1
     real, intent(inout), target :: dummy2