[flang] Infrastructure improvements in utility routines

* 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.

Differential Revision: https://reviews.llvm.org/D95011

flang/include/flang/Evaluate/call.h

@@ -111,12 +111,18 @@ public:
   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_; }

flang/include/flang/Evaluate/tools.h

@@ -235,11 +235,14 @@ 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};
-    while (const Component * component{std::get_if<Component>(&ref->u)}) {
+    if (skipComponents) {
-      ref = &component->base();
+      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();
@@ -789,6 +792,7 @@ 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
@@ -913,12 +917,13 @@ 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 &);

flang/include/flang/Evaluate/traverse.h

@@ -50,7 +50,7 @@ public:
   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 {

flang/lib/Evaluate/characteristics.cpp

@@ -100,6 +100,9 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
           [&](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
@@ -178,6 +181,12 @@ std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
   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(

flang/lib/Evaluate/tools.cpp

@@ -66,7 +66,7 @@ auto IsVariableHelper::operator()(const Substring &x) const -> Result {
 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.
@@ -696,6 +696,40 @@ bool IsProcedurePointer(const Expr<SomeType> &expr) {
       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>;
@@ -1026,6 +1060,11 @@ bool IsFunction(const Symbol &symbol) {
       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; },
@@ -1038,8 +1077,14 @@ bool IsProcedure(const Symbol &symbol) {
       symbol.GetUltimate().details());
 }
 
-const Symbol *FindCommonBlockContaining(const Symbol &object) {
+bool IsProcedure(const Scope &scope) {
-  const auto *details{object.detailsIf<ObjectEntityDetails>()};
+  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;
 }
 

flang/lib/Semantics/tools.cpp

@@ -330,15 +330,22 @@ 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) ||
+  const Symbol &ultimate{GetAssociationRoot(object)};
-      (IsPureProcedure(scope) && IsPointerDummy(object)) ||
+  if (IsDummy(ultimate)) {
-      (IsIntentIn(object) && IsDummy(object))) {
+    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(

flang/test/Semantics/structconst03.f90

@@ -71,7 +71,6 @@ module module1
     !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
@@ -106,9 +105,7 @@ module module1
       !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
@@ -123,6 +120,22 @@ module module1
     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

flang/test/Semantics/structconst04.f90

@@ -66,7 +66,6 @@ module module1
     !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
@@ -101,9 +100,7 @@ module module1
       !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
@@ -118,6 +115,21 @@ module module1
     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