[flang] Check procedure pointer initializations; clean up ELEMENTAL

[klausler]

Summary

Implements compatibility checking for initializers in procedure pointer
declarations. This work exposed some inconsistency in how ELEMENTAL
interfaces were handled and checked, from both unrestricted intrinsic
functions and others, and some refinements needed for function result
compatbility checking; these have also been ironed out. Some new
warnings are now emitted, and this affected a dozen or so tests.

[klausler]

Try a different version of clang-format.

flang/include/flang/Evaluate/characteristics.h

TypeAndShape(DynamicType t, std::optional<Shape> &&s) : type_{t} {
     AcquireLEN();
   }
   DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(TypeAndShape)
 
   bool operator==(const TypeAndShape &) const;
   bool operator!=(const TypeAndShape &that) const { return !(*this == that); }
 
   static std::optional<TypeAndShape> Characterize(
-      const semantics::Symbol &, FoldingContext &);
+      const semantics::Symbol &, FoldingContext &, bool invariantOnly = false);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::DeclTypeSpec &, FoldingContext &);
+      const semantics::DeclTypeSpec &, FoldingContext &,
+      bool invariantOnly = false);
   static std::optional<TypeAndShape> Characterize(
-      const ActualArgument &, FoldingContext &);
+      const ActualArgument &, FoldingContext &, bool invariantOnly = false);
 
   // General case for Expr<T>, ActualArgument, &c.
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
-      const A &x, FoldingContext &context) {
+      const A &x, FoldingContext &context, bool invariantOnly = false) {
     if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
-      if (auto result{Characterize(*symbol, context)}) {
+      if (auto result{Characterize(*symbol, context, invariantOnly)}) {
         return result;
       }
     }
     if (auto type{x.GetType()}) {
-      TypeAndShape result{*type, GetShape(context, x)};
+      TypeAndShape result{*type, GetShape(context, x, invariantOnly)};
       if (type->category() == TypeCategory::Character) {
         if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
           if (auto length{chExpr->LEN()}) {
             result.set_LEN(std::move(*length));
           }
         }
       }
       return std::move(result.Rewrite(context));
     }
     return std::nullopt;
   }
 
   // Specialization for character designators
   template <int KIND>
   static std::optional<TypeAndShape> Characterize(
       const Designator<Type<TypeCategory::Character, KIND>> &x,
-      FoldingContext &context) {
+      FoldingContext &context, bool invariantOnly = true) {
     if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
-      if (auto result{Characterize(*symbol, context)}) {
+      if (auto result{Characterize(*symbol, context, invariantOnly)}) {
         return result;
       }
     }
     if (auto type{x.GetType()}) {
-      TypeAndShape result{*type, GetShape(context, x)};
+      TypeAndShape result{*type, GetShape(context, x, invariantOnly)};
       if (auto length{x.LEN()}) {
         result.set_LEN(std::move(*length));
       }
       return std::move(result.Rewrite(context));
     }
     return std::nullopt;
   }
 
   template <typename A>
-  static std::optional<TypeAndShape> Characterize(
-      const std::optional<A> &x, FoldingContext &context) {
+  static std::optional<TypeAndShape> Characterize(const std::optional<A> &x,
+      FoldingContext &context, bool invariantOnly = false) {
     if (x) {
-      return Characterize(*x, context);
+      return Characterize(*x, context, invariantOnly);
     } else {
       return std::nullopt;
     }
   }
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
-      A *ptr, FoldingContext &context) {
+      A *ptr, FoldingContext &context, bool invariantOnly = false) {
     if (ptr) {
-      return Characterize(std::as_const(*ptr), context);
+      return Characterize(std::as_const(*ptr), context, invariantOnly);
     } else {
       return std::nullopt;
     }
   }
 
   DynamicType type() const { return type_; }
   TypeAndShape &set_type(DynamicType t) {
     type_ = t;
public:
   // called by Fold() to rewrite in place
   TypeAndShape &Rewrite(FoldingContext &);
 
   std::string AsFortran() const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   static std::optional<TypeAndShape> Characterize(
-      const semantics::AssocEntityDetails &, FoldingContext &);
+      const semantics::AssocEntityDetails &, FoldingContext &,
+      bool invariantOnly = true);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcEntityDetails &, FoldingContext &);
   void AcquireAttrs(const semantics::Symbol &);
   void AcquireLEN();
   void AcquireLEN(const semantics::Symbol &);
 
 protected:
   DynamicType type_;

flang/include/flang/Evaluate/shape.h

 Shape AsShape(const ConstantSubscripts &);
 std::optional<Shape> AsShape(const std::optional<ConstantSubscripts> &);
 
 inline int GetRank(const Shape &s) { return static_cast<int>(s.size()); }
 
 Shape Fold(FoldingContext &, Shape &&);
 std::optional<Shape> Fold(FoldingContext &, std::optional<Shape> &&);
 
+// Computes shapes in terms of expressions that are scope-invariant, by
+// default, which is nearly always what one wants outside of procedure
+// characterization.
 template <typename A>
-std::optional<Shape> GetShape(FoldingContext &, const A &);
-template <typename A> std::optional<Shape> GetShape(const A &);
+std::optional<Shape> GetShape(
+    FoldingContext &, const A &, bool invariantOnly = true);
+template <typename A>
+std::optional<Shape> GetShape(const A &, bool invariantOnly = true);
 
 // The dimension argument to these inquiries is zero-based,
 // unlike the DIM= arguments to many intrinsics.
 //
 // GetRawLowerBound() returns a lower bound expression, which may
 // not be suitable for all purposes; specifically, it might not be invariant
 // in its scope, and it will not have been forced to 1 on an empty dimension.
 // GetLBOUND()'s result is safer, but it is optional because it does fail
 // in those circumstances.
 // Similarly, GetUBOUND result will be forced to 0 on an empty dimension,
 // but will fail if the extent is not a compile time constant.
-ExtentExpr GetRawLowerBound(const NamedEntity &, int dimension);
 ExtentExpr GetRawLowerBound(
-    FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetLBOUND(const NamedEntity &, int dimension);
-MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetRawUpperBound(const NamedEntity &, int dimension);
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+ExtentExpr GetRawLowerBound(FoldingContext &, const NamedEntity &,
+    int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetLBOUND(
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
 MaybeExtentExpr GetRawUpperBound(
-    FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetUBOUND(const NamedEntity &, int dimension);
-MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension);
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetRawUpperBound(FoldingContext &, const NamedEntity &,
+    int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetUBOUND(
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
 MaybeExtentExpr ComputeUpperBound(ExtentExpr &&lower, MaybeExtentExpr &&extent);
 MaybeExtentExpr ComputeUpperBound(
     FoldingContext &, ExtentExpr &&lower, MaybeExtentExpr &&extent);
-Shape GetRawLowerBounds(const NamedEntity &);
-Shape GetRawLowerBounds(FoldingContext &, const NamedEntity &);
-Shape GetLBOUNDs(const NamedEntity &);
-Shape GetLBOUNDs(FoldingContext &, const NamedEntity &);
-Shape GetUBOUNDs(const NamedEntity &);
-Shape GetUBOUNDs(FoldingContext &, const NamedEntity &);
-MaybeExtentExpr GetExtent(const NamedEntity &, int dimension);
-MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetExtent(
-    const Subscript &, const NamedEntity &, int dimension);
+Shape GetRawLowerBounds(const NamedEntity &, bool invariantOnly = true);
+Shape GetRawLowerBounds(
+    FoldingContext &, const NamedEntity &, bool invariantOnly = true);
+Shape GetLBOUNDs(const NamedEntity &, bool invariantOnly = true);
+Shape GetLBOUNDs(
+    FoldingContext &, const NamedEntity &, bool invariantOnly = true);
+Shape GetUBOUNDs(const NamedEntity &, bool invariantOnly = true);
+Shape GetUBOUNDs(
+    FoldingContext &, const NamedEntity &, bool invariantOnly = true);
 MaybeExtentExpr GetExtent(
-    FoldingContext &, const Subscript &, const NamedEntity &, int dimension);
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
+MaybeExtentExpr GetExtent(const Subscript &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
+MaybeExtentExpr GetExtent(FoldingContext &, const Subscript &,
+    const NamedEntity &, int dimension, bool invariantOnly = true);
 
 // Compute an element count for a triplet or trip count for a DO.
 ExtentExpr CountTrips(
     ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride);
 ExtentExpr CountTrips(
     const ExtentExpr &lower, const ExtentExpr &upper, const ExtentExpr &stride);
 MaybeExtentExpr CountTrips(
     MaybeExtentExpr &&lower, MaybeExtentExpr &&upper, MaybeExtentExpr &&stride);
 
 // Computes SIZE() == PRODUCT(shape)
 MaybeExtentExpr GetSize(Shape &&);
 ConstantSubscript GetSize(const ConstantSubscripts &);
 
 // Utility predicate: does an expression reference any implied DO index?
 bool ContainsAnyImpliedDoIndex(const ExtentExpr &);
 
 class GetShapeHelper
     : public AnyTraverse<GetShapeHelper, std::optional<Shape>> {
 public:
   using Result = std::optional<Shape>;
   using Base = AnyTraverse<GetShapeHelper, Result>;
   using Base::operator();
-  GetShapeHelper() : Base{*this} {}
-  explicit GetShapeHelper(FoldingContext &c) : Base{*this}, context_{&c} {}
-  explicit GetShapeHelper(FoldingContext &c, bool useResultSymbolShape)
-      : Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape} {
-  }
+  explicit GetShapeHelper(bool invariantOnly)
+      : Base{*this}, invariantOnly_{invariantOnly} {}
+  explicit GetShapeHelper(FoldingContext &c, bool invariantOnly)
+      : Base{*this}, context_{&c}, invariantOnly_{invariantOnly} {}
+  explicit GetShapeHelper(
+      FoldingContext &c, bool useResultSymbolShape, bool invariantOnly)
+      : Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape},
+        invariantOnly_{invariantOnly} {}
 
   Result operator()(const ImpliedDoIndex &) const { return ScalarShape(); }
   Result operator()(const DescriptorInquiry &) const { return ScalarShape(); }
   Result operator()(const TypeParamInquiry &) const { return ScalarShape(); }
   Result operator()(const BOZLiteralConstant &) const { return ScalarShape(); }
   Result operator()(const StaticDataObject::Pointer &) const {
     return ScalarShape();
   }
if (operation.right().Rank() > 0) {
       return (*this)(operation.left());
     }
   }
 
 private:
   static Result ScalarShape() { return Shape{}; }
   static Shape ConstantShape(const Constant<ExtentType> &);
   Result AsShapeResult(ExtentExpr &&) const;
-  static Shape CreateShape(int rank, NamedEntity &);
+  Shape CreateShape(int rank, NamedEntity &) const;
 
   template <typename T>
   MaybeExtentExpr GetArrayConstructorValueExtent(
       const ArrayConstructorValue<T> &value) const {
     return common::visit(
         common::visitors{
             [&](const Expr<T> &x) -> MaybeExtentExpr {
               if (auto xShape{!useResultSymbolShape_ ? (*this)(x)
MaybeExtentExpr GetArrayConstructorExtent(
     return result;
   }
 
   // Add an extent to another, with folding
   void AccumulateExtent(ExtentExpr &, ExtentExpr &&) const;
 
   FoldingContext *context_{nullptr};
   bool useResultSymbolShape_{true};
+  // When invariantOnly=false, the returned shape need not be invariant
+  // in its scope; in particular, it may contain references to dummy arguments.
+  bool invariantOnly_{true};
 };
 
 template <typename A>
-std::optional<Shape> GetShape(FoldingContext &context, const A &x) {
-  if (auto shape{GetShapeHelper{context}(x)}) {
+std::optional<Shape> GetShape(
+    FoldingContext &context, const A &x, bool invariantOnly) {
+  if (auto shape{GetShapeHelper{context, invariantOnly}(x)}) {
     return Fold(context, std::move(shape));
   } else {
     return std::nullopt;
   }
 }
 
-template <typename A> std::optional<Shape> GetShape(const A &x) {
-  return GetShapeHelper{}(x);
+template <typename A>
+std::optional<Shape> GetShape(const A &x, bool invariantOnly) {
+  return GetShapeHelper{invariantOnly}(x);
 }
 
 template <typename A>
-std::optional<Shape> GetShape(FoldingContext *context, const A &x) {
+std::optional<Shape> GetShape(
+    FoldingContext *context, const A &x, bool invariantOnly = true) {
   if (context) {
-    return GetShape(*context, x);
+    return GetShape(*context, x, invariantOnly);
   } else {
-    return GetShapeHelper{}(x);
+    return GetShapeHelper{invariantOnly}(x);
   }
 }
 
 template <typename A>
 std::optional<Constant<ExtentType>> GetConstantShape(
     FoldingContext &context, const A &x) {
-  if (auto shape{GetShape(context, x)}) {
+  if (auto shape{GetShape(context, x, /*invariantonly=*/true)}) {
     return AsConstantShape(context, *shape);
   } else {
     return std::nullopt;
   }
 }
 
 template <typename A>
 std::optional<ConstantSubscripts> GetConstantExtents(
     FoldingContext &context, const A &x) {
-  if (auto shape{GetShape(context, x)}) {
+  if (auto shape{GetShape(context, x, /*invariantOnly=*/true)}) {
     return AsConstantExtents(context, *shape);
   } else {
     return std::nullopt;
   }
 }
 
 // Get shape that does not depends on callee scope symbols if the expression
 // contains calls. Return std::nullopt if it is not possible to build such shape
 // (e.g. for calls to array functions whose result shape depends on the
 // arguments).
 template <typename A>
 std::optional<Shape> GetContextFreeShape(FoldingContext &context, const A &x) {
-  return GetShapeHelper{context, false}(x);
+  return GetShapeHelper{
+      context, /*useResultSymbolShape=*/false, /*invariantOnly=*/true}(x);
 }
 
 // Compilation-time shape conformance checking, when corresponding extents
 // are or should be known.  The result is an optional Boolean:
 //  - nullopt: no error found or reported, but conformance cannot
 //    be guaranteed during compilation; this result is possible only
 //    when one or both arrays are allowed to have deferred shape
 //  - true: no error found or reported, arrays conform

flang/include/flang/Evaluate/tools.h

 const Symbol *GetMainEntry(const Symbol *);
 
 // 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 IsExplicitlyImpureProcedure(const Symbol &);
 bool IsElementalProcedure(const Symbol &);
 bool IsFunction(const Symbol &);
 bool IsFunction(const Scope &);
 bool IsProcedure(const Symbol &);
 bool IsProcedure(const Scope &);
 bool IsProcedurePointer(const Symbol *);
 bool IsProcedurePointer(const Symbol &);
 bool IsObjectPointer(const Symbol *);

flang/lib/Evaluate/characteristics.cpp

if (auto n{ToInt64(*LEN_)}) {
       type_ = DynamicType{type_.kind(), *n};
     }
   }
   shape_ = Fold(context, std::move(shape_));
   return *this;
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::Symbol &symbol, FoldingContext &context) {
+    const semantics::Symbol &symbol, FoldingContext &context,
+    bool invariantOnly) {
   const auto &ultimate{symbol.GetUltimate()};
   return common::visit(
       common::visitors{
           [&](const semantics::ProcEntityDetails &proc) {
             if (proc.procInterface()) {
-              return Characterize(*proc.procInterface(), context);
+              return Characterize(
+                  *proc.procInterface(), context, invariantOnly);
             } else if (proc.type()) {
-              return Characterize(*proc.type(), context);
+              return Characterize(*proc.type(), context, invariantOnly);
             } else {
               return std::optional<TypeAndShape>{};
             }
           },
           [&](const semantics::AssocEntityDetails &assoc) {
-            return Characterize(assoc, context);
+            return Characterize(assoc, context, invariantOnly);
           },
           [&](const semantics::ProcBindingDetails &binding) {
-            return Characterize(binding.symbol(), context);
+            return Characterize(binding.symbol(), context, invariantOnly);
           },
           [&](const auto &x) -> std::optional<TypeAndShape> {
             using Ty = std::decay_t<decltype(x)>;
             if constexpr (std::is_same_v<Ty, semantics::EntityDetails> ||
                 std::is_same_v<Ty, semantics::ObjectEntityDetails> ||
                 std::is_same_v<Ty, semantics::TypeParamDetails>) {
               if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
                 if (auto dyType{DynamicType::From(*type)}) {
-                  TypeAndShape result{
-                      std::move(*dyType), GetShape(context, ultimate)};
+                  TypeAndShape result{std::move(*dyType),
+                      GetShape(context, ultimate, invariantOnly)};
                   result.AcquireAttrs(ultimate);
                   result.AcquireLEN(ultimate);
                   return std::move(result.Rewrite(context));
                 }
               }
             }
             return std::nullopt;
           },
       },
       // GetUltimate() used here, not ResolveAssociations(), because
       // we need the type/rank of an associate entity from TYPE IS,
       // CLASS IS, or RANK statement.
       ultimate.details());
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
+    const semantics::AssocEntityDetails &assoc, FoldingContext &context,
+    bool invariantOnly) {
   std::optional<TypeAndShape> result;
   if (auto type{DynamicType::From(assoc.type())}) {
     if (auto rank{assoc.rank()}) {
       if (*rank >= 0 && *rank <= common::maxRank) {
         result = TypeAndShape{std::move(*type), Shape(*rank)};
       }
-    } else if (auto shape{GetShape(context, assoc.expr())}) {
+    } else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) {
       result = TypeAndShape{std::move(*type), std::move(*shape)};
     }
     if (result && type->category() == TypeCategory::Character) {
       if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) {
         if (auto len{chExpr->LEN()}) {
           result->set_LEN(std::move(*len));
         }
       }
     }
   }
   return Fold(context, std::move(result));
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::DeclTypeSpec &spec, FoldingContext &context) {
+    const semantics::DeclTypeSpec &spec, FoldingContext &context,
+    bool /*invariantOnly=*/) {
   if (auto type{DynamicType::From(spec)}) {
     return Fold(context, TypeAndShape{std::move(*type)});
   } else {
     return std::nullopt;
   }
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const ActualArgument &arg, FoldingContext &context) {
+    const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
   if (const auto *expr{arg.UnwrapExpr()}) {
-    return Characterize(*expr, context);
+    return Characterize(*expr, context, invariantOnly);
   } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
-    return Characterize(*assumed, context);
+    return Characterize(*assumed, context, invariantOnly);
   } else {
     return std::nullopt;
   }
 }
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     const TypeAndShape &that, const char *thisIs, const char *thatIs,
     bool omitShapeConformanceCheck,
if (attrs.test(semantics::Attr::INTENT_IN)) {
     return common::Intent::Default;
   }
 }
 
 std::optional<DummyDataObject> DummyDataObject::Characterize(
     const semantics::Symbol &symbol, FoldingContext &context) {
   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
       object || symbol.has<semantics::EntityDetails>()) {
-    if (auto type{TypeAndShape::Characterize(symbol, context)}) {
+    if (auto type{TypeAndShape::Characterize(
+            symbol, context, /*invariantOnly=*/false)}) {
       std::optional<DummyDataObject> result{std::move(*type)};
       using semantics::Attr;
       CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
           {
               {Attr::OPTIONAL, DummyDataObject::Attr::Optional},
               {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
               {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous},
               {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous},
static std::optional<DummyArgument> CharacterizeDummyArgument(
     semantics::UnorderedSymbolSet seenProcs);
 static std::optional<FunctionResult> CharacterizeFunctionResult(
     const semantics::Symbol &symbol, FoldingContext &context,
     semantics::UnorderedSymbolSet seenProcs);
 
 static std::optional<Procedure> CharacterizeProcedure(
     const semantics::Symbol &original, FoldingContext &context,
     semantics::UnorderedSymbolSet seenProcs) {
-  Procedure result;
   const auto &symbol{ResolveAssociations(original)};
   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);
-  if (IsElementalProcedure(symbol)) {
-    result.attrs.set(Procedure::Attr::Elemental);
-  }
-  CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
-      {
-          {semantics::Attr::BIND_C, Procedure::Attr::BindC},
-      });
-  if (IsPureProcedure(symbol) || // works for ENTRY too
-      (!symbol.attrs().test(semantics::Attr::IMPURE) &&
-          result.attrs.test(Procedure::Attr::Elemental))) {
-    result.attrs.set(Procedure::Attr::Pure);
-  }
-  return common::visit(
+  auto result{common::visit(
       common::visitors{
           [&](const semantics::SubprogramDetails &subp)
               -> std::optional<Procedure> {
+            Procedure result;
             if (subp.isFunction()) {
               if (auto fr{CharacterizeFunctionResult(
                       subp.result(), context, seenProcs)}) {
                 result.functionResult = std::move(fr);
               } else {
                 return std::nullopt;
               }
             } else {
auto result{common::visit(
                              *arg, context, seenProcs)}) {
                 result.dummyArguments.emplace_back(
                     std::move(argCharacteristics.value()));
               } else {
                 return std::nullopt;
               }
             }
             result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs();
-            return result;
+            return std::move(result);
           },
           [&](const semantics::ProcEntityDetails &proc)
               -> std::optional<Procedure> {
             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
               // Fails when the intrinsic is not a specific intrinsic function
               // from F'2018 table 16.2.  In order to handle forward references,
               // attempts to use impermissible intrinsic procedures as the
               // interfaces of procedure pointers are caught and flagged in
               // declaration checking in Semantics.
               auto intrinsic{context.intrinsics().IsSpecificIntrinsicFunction(
                   symbol.name().ToString())};
               if (intrinsic && intrinsic->isRestrictedSpecific) {
                 intrinsic.reset(); // Exclude intrinsics from table 16.3.
               }
               return intrinsic;
             }
             if (const semantics::Symbol *
                 interfaceSymbol{proc.procInterface()}) {
-              auto interface {
-                CharacterizeProcedure(*interfaceSymbol, context, seenProcs)
-              };
-              if (interface && IsPointer(symbol)) {
-                interface->attrs.reset(Procedure::Attr::Elemental);
+              auto result{
+                  CharacterizeProcedure(*interfaceSymbol, context, seenProcs)};
+              if (result && (IsDummy(symbol) || IsPointer(symbol))) {
+                // Dummy procedures and procedure pointers may not be
+                // ELEMENTAL, but we do accept the use of elemental intrinsic
+                // functions as their interfaces.
+                result->attrs.reset(Procedure::Attr::Elemental);
               }
-              return interface;
+              return result;
             } else {
+              Procedure result;
               result.attrs.set(Procedure::Attr::ImplicitInterface);
               const semantics::DeclTypeSpec *type{proc.type()};
               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
                 // ignore any implicit typing
                 result.attrs.set(Procedure::Attr::Subroutine);
                 if (proc.isCUDAKernel()) {
                   result.cudaSubprogramAttrs =
                       common::CUDASubprogramAttrs::Global;
                 }
               } 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;
+              return std::move(result);
             }
           },
           [&](const semantics::ProcBindingDetails &binding) {
             if (auto result{CharacterizeProcedure(
                     binding.symbol(), context, seenProcs)}) {
               if (binding.symbol().attrs().test(semantics::Attr::INTRINSIC)) {
                 result->attrs.reset(Procedure::Attr::Elemental);
               }
auto result{common::visit(
             return std::optional<Procedure>{};
           },
           [&](const auto &) {
             context.messages().Say(
                 "'%s' is not a procedure"_err_en_US, symbol.name());
             return std::optional<Procedure>{};
           },
       },
-      symbol.details());
+      symbol.details())};
+  if (result && !symbol.has<semantics::ProcBindingDetails>()) {
+    CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result,
+        {
+            {semantics::Attr::BIND_C, Procedure::Attr::BindC},
+            {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
+        });
+    if (IsPureProcedure(symbol) || // works for ENTRY too
+        (!IsExplicitlyImpureProcedure(symbol) &&
+            result->attrs.test(Procedure::Attr::Elemental))) {
+      result->attrs.set(Procedure::Attr::Pure);
+    }
+  }
+  return result;
 }
 
 static std::optional<DummyProcedure> CharacterizeDummyProcedure(
     const semantics::Symbol &symbol, FoldingContext &context,
     semantics::UnorderedSymbolSet 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
bool FunctionResult::operator==(const FunctionResult &that) const {
   return attrs == that.attrs && cudaDataAttr == that.cudaDataAttr &&
       u == that.u;
 }
 
 static std::optional<FunctionResult> CharacterizeFunctionResult(
     const semantics::Symbol &symbol, FoldingContext &context,
     semantics::UnorderedSymbolSet seenProcs) {
   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (auto type{TypeAndShape::Characterize(symbol, context)}) {
+    if (auto type{TypeAndShape::Characterize(
+            symbol, context, /*invariantOnly=*/false)}) {
       FunctionResult result{std::move(*type)};
       CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
           {
               {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
               {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
               {semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
           });
       result.cudaDataAttr = object->cudaDataAttr();
if (typeAndShape->Rank() > 0) {
         return true;
       }
     }
   } else {
     return false; // 15.4.2.2(4)(b) - procedure pointer
   }
 }
 
-static bool AreCompatibleFunctionResultShapes(const Shape &x, const Shape &y) {
+static std::optional<std::string> AreIncompatibleFunctionResultShapes(
+    const Shape &x, const Shape &y) {
   int rank{GetRank(x)};
-  if (GetRank(y) != rank) {
-    return false;
+  if (int yrank{GetRank(y)}; yrank != rank) {
+    return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank);
   }
   for (int j{0}; j < rank; ++j) {
-    if (auto xDim{ToInt64(x[j])}) {
-      if (auto yDim{ToInt64(y[j])}) {
-        if (*xDim != *yDim) {
-          return false;
-        }
-      }
-    }
-  }
-  return true;
+    if (x[j] && y[j] && !(*x[j] == *y[j])) {
+      return x[j]->AsFortran() + " vs " + y[j]->AsFortran();
+  return std::nullopt;
 }
 
 bool FunctionResult::IsCompatibleWith(
     const FunctionResult &actual, std::string *whyNot) const {
   Attrs actualAttrs{actual.attrs};
   if (!attrs.test(Attr::Contiguous)) {
     actualAttrs.reset(Attr::Contiguous);
   }
   if (attrs != actualAttrs) {
     if (whyNot) {
       *whyNot = "function results have incompatible attributes";
     }
   } else if (cudaDataAttr != actual.cudaDataAttr) {
     if (whyNot) {
       *whyNot = "function results have incompatible CUDA data attributes";
     }
   } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
     if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
+      std::optional<std::string> details;
       if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
         if (whyNot) {
           *whyNot = "function results have distinct ranks";
         }
       } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
-          !AreCompatibleFunctionResultShapes(
-              ifaceTypeShape->shape(), actualTypeShape->shape())) {
+          (details = AreIncompatibleFunctionResultShapes(
+               ifaceTypeShape->shape(), actualTypeShape->shape()))) {
         if (whyNot) {
-          *whyNot = "function results have distinct constant extents";
+          *whyNot = "function results have distinct extents (" + *details + ')';
         }
       } else if (ifaceTypeShape->type() != actualTypeShape->type()) {
-        if (ifaceTypeShape->type().category() ==
+        if (ifaceTypeShape->type().category() !=
             actualTypeShape->type().category()) {
-          if (ifaceTypeShape->type().category() == TypeCategory::Character) {
-            if (ifaceTypeShape->type().kind() ==
-                actualTypeShape->type().kind()) {
-              auto ifaceLen{ifaceTypeShape->type().knownLength()};
-              auto actualLen{actualTypeShape->type().knownLength()};
-              if (!ifaceLen || !actualLen || *ifaceLen == *actualLen) {
+        } else if (ifaceTypeShape->type().category() ==
+            TypeCategory::Character) {
+          if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) {
+            if (IsAssumedLengthCharacter() ||
+                actual.IsAssumedLengthCharacter()) {
+              return true;
+            } else {
+              const auto *ifaceLenParam{
+                  ifaceTypeShape->type().charLengthParamValue()};
+              const auto *actualLenParam{
+                  actualTypeShape->type().charLengthParamValue()};
+              if (ifaceLenParam && actualLenParam &&
+                  *ifaceLenParam == *actualLenParam) {
                 return true;
               }
             }
-          } else if (ifaceTypeShape->type().category() ==
-              TypeCategory::Derived) {
-            if (ifaceTypeShape->type().IsPolymorphic() ==
-                    actualTypeShape->type().IsPolymorphic() &&
-                !ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
-                !actualTypeShape->type().IsUnlimitedPolymorphic() &&
-                AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
-                    actualTypeShape->type().GetDerivedTypeSpec())) {
-              return true;
-            }
-          }
-        }
+          }
+        } else if (ifaceTypeShape->type().category() == TypeCategory::Derived) {
         if (whyNot) {
           *whyNot = "function results have distinct types: "s +
               ifaceTypeShape->type().AsFortran() + " vs "s +
               actualTypeShape->type().AsFortran();
         }
       } else {
         return true;
       }

flang/lib/Evaluate/intrinsics.cpp

if (!arrayType || !procChars) {
                 !data[j]->attrs.test(
                     characteristics::DummyDataObject::Attr::Pointer) &&
                 data[j]->type.Rank() == 0 &&
                 !data[j]->type.type().IsPolymorphic() &&
                 data[j]->type.type().IsTkCompatibleWith(*arrayType);
           }
           if (!ok) {
             context.messages().Say(at,
-                "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US);
+                "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
           } else if (data[0]->attrs.test(characteristics::DummyDataObject::
                              Attr::Asynchronous) !=
                   data[1]->attrs.test(
                       characteristics::DummyDataObject::Attr::Asynchronous) ||
               data[0]->attrs.test(
                   characteristics::DummyDataObject::Attr::Volatile) !=
                   data[1]->attrs.test(
                       characteristics::DummyDataObject::Attr::Volatile) ||

flang/lib/Evaluate/shape.cpp

for (auto &value : *constructor) {
       }
     }
     return result;
   } else {
     return std::nullopt;
   }
 }
 
-Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) {
+Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) const {
   Shape shape;
   for (int dimension{0}; dimension < rank; ++dimension) {
-    shape.emplace_back(GetExtent(base, dimension));
+    shape.emplace_back(GetExtent(base, dimension, invariantOnly_));
   }
   return shape;
 }
 
 std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {
   ArrayConstructorValues<ExtentType> values;
   for (const auto &dim : shape) {
     if (dim) {

 // ASSOCIATE construct entities may require traversal of their referents.
 template <typename RESULT, bool LBOUND_SEMANTICS>
 class GetLowerBoundHelper
     : public Traverse<GetLowerBoundHelper<RESULT, LBOUND_SEMANTICS>, RESULT> {
 public:
   using Result = RESULT;
   using Base = Traverse<GetLowerBoundHelper, RESULT>;
   using Base::operator();
-  explicit GetLowerBoundHelper(int d, FoldingContext *context)
-      : Base{*this}, dimension_{d}, context_{context} {}
+  explicit GetLowerBoundHelper(
+      int d, FoldingContext *context, bool invariantOnly)
+      : Base{*this}, dimension_{d}, context_{context},
+        invariantOnly_{invariantOnly} {}
   static Result Default() { return Result{1}; }
   static Result Combine(Result &&, Result &&) {
     // Operator results and array references always have lower bounds == 1
     return Result{1};
   }
 
   Result GetLowerBound(const Symbol &symbol0, NamedEntity &&base) const {
     const Symbol &symbol{symbol0.GetUltimate()};
     if (const auto *details{
             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
       int rank{details->shape().Rank()};
       if (dimension_ < rank) {
         const semantics::ShapeSpec &shapeSpec{details->shape()[dimension_]};
         if (shapeSpec.lbound().isExplicit()) {
           if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
             if constexpr (LBOUND_SEMANTICS) {
               bool ok{false};
               auto lbValue{ToInt64(*lbound)};
               if (dimension_ == rank - 1 && details->IsAssumedSize()) {
                 // last dimension of assumed-size dummy array: don't worry
                 // about handling an empty dimension
-                ok = IsScopeInvariantExpr(*lbound);
+                ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
               } else if (lbValue.value_or(0) == 1) {
                 // Lower bound is 1, regardless of extent
                 ok = true;
               } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
                 // If we can't prove that the dimension is nonempty,
                 // we must be conservative.
                 // TODO: simple symbolic math in expression rewriting to
                 // cope with cases like A(J:J)
template <typename T> Result operator()(const Expr<T> &expr) const {
     } else {
       return Result{1};
     }
   }
 
 private:
   int dimension_; // zero-based
   FoldingContext *context_{nullptr};
+  bool invariantOnly_{false};
 };
 
-ExtentExpr GetRawLowerBound(const NamedEntity &base, int dimension) {
-  return GetLowerBoundHelper<ExtentExpr, false>{dimension, nullptr}(base);
+ExtentExpr GetRawLowerBound(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return GetLowerBoundHelper<ExtentExpr, false>{
+      dimension, nullptr, invariantOnly}(base);
 }
 
-ExtentExpr GetRawLowerBound(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
+ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
   return Fold(context,
-      GetLowerBoundHelper<ExtentExpr, false>{dimension, &context}(base));
+      GetLowerBoundHelper<ExtentExpr, false>{
+          dimension, &context, invariantOnly}(base));
 }
 
-MaybeExtentExpr GetLBOUND(const NamedEntity &base, int dimension) {
-  return GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, nullptr}(base);
+MaybeExtentExpr GetLBOUND(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return GetLowerBoundHelper<MaybeExtentExpr, true>{
+      dimension, nullptr, invariantOnly}(base);
 }
 
-MaybeExtentExpr GetLBOUND(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetLBOUND(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
   return Fold(context,
-      GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, &context}(base));
+      GetLowerBoundHelper<MaybeExtentExpr, true>{
+          dimension, &context, invariantOnly}(base));
 }
 
-Shape GetRawLowerBounds(const NamedEntity &base) {
+Shape GetRawLowerBounds(const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetRawLowerBound(base, dim));
+    result.emplace_back(GetRawLowerBound(base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetRawLowerBounds(FoldingContext &context, const NamedEntity &base) {
+Shape GetRawLowerBounds(
+    FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetRawLowerBound(context, base, dim));
+    result.emplace_back(GetRawLowerBound(context, base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetLBOUNDs(const NamedEntity &base) {
+Shape GetLBOUNDs(const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetLBOUND(base, dim));
+    result.emplace_back(GetLBOUND(base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetLBOUNDs(FoldingContext &context, const NamedEntity &base) {
+Shape GetLBOUNDs(
+    FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetLBOUND(context, base, dim));
+    result.emplace_back(GetLBOUND(context, base, dim, invariantOnly));
   }
   return result;
 }
 
 // If the upper and lower bounds are constant, return a constant expression for
 // the extent.  In particular, if the upper bound is less than the lower bound,
 // return zero.
 static MaybeExtentExpr GetNonNegativeExtent(
-    const semantics::ShapeSpec &shapeSpec) {
+    const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
   const auto &ubound{shapeSpec.ubound().GetExplicit()};
   const auto &lbound{shapeSpec.lbound().GetExplicit()};
   std::optional<ConstantSubscript> uval{ToInt64(ubound)};
   std::optional<ConstantSubscript> lval{ToInt64(lbound)};
   if (uval && lval) {
     if (*uval < *lval) {
       return ExtentExpr{0};
     } else {
       return ExtentExpr{*uval - *lval + 1};
     }
-  } else if (lbound && ubound && IsScopeInvariantExpr(*lbound) &&
-      IsScopeInvariantExpr(*ubound)) {
+  } else if (lbound && ubound &&
+      (!invariantOnly ||
+          (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) {
     // Apply effective IDIM (MAX calculation with 0) so thet the
     // result is never negative
     if (lval.value_or(0) == 1) {
       return ExtentExpr{Extremum<SubscriptInteger>{
           Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}};
     } else {
       return ExtentExpr{
           Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
if (dimension < static_cast<int>(shape->size())) {
         return ExtentExpr{DescriptorInquiry{
             NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
       }
     }
   }
   return std::nullopt;
 }
 
-MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetExtent(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
   CHECK(dimension >= 0);
   const Symbol &last{base.GetLastSymbol()};
   const Symbol &symbol{ResolveAssociationsExceptSelectRank(last)};
   if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
     if (assoc->rank()) { // SELECT RANK case
       if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
         return ExtentExpr{DescriptorInquiry{
             NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
       }
     } else {
       return GetAssociatedExtent(base, *assoc, dimension);
     }
   }
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     if (IsImpliedShape(symbol) && details->init()) {
       if (auto shape{GetShape(symbol)}) {
         if (dimension < static_cast<int>(shape->size())) {
           return std::move(shape->at(dimension));
         }
       }
     } else {
       int j{0};
       for (const auto &shapeSpec : details->shape()) {
         if (j++ == dimension) {
-          if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
+          if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
             return extent;
           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
             return std::nullopt;
           } else if (semantics::IsDescriptor(symbol)) {
             return ExtentExpr{DescriptorInquiry{NamedEntity{base},
                 DescriptorInquiry::Field::Extent, dimension}};
           } else {
             break;
           }
         }
       }
     }
   }
   return std::nullopt;
 }
 
-MaybeExtentExpr GetExtent(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
-  return Fold(context, GetExtent(base, dimension));
+MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
+  return Fold(context, GetExtent(base, dimension, invariantOnly));
 }
 
-MaybeExtentExpr GetExtent(
-    const Subscript &subscript, const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
   return common::visit(
       common::visitors{
           [&](const Triplet &triplet) -> MaybeExtentExpr {
             MaybeExtentExpr upper{triplet.upper()};
             if (!upper) {
-              upper = GetUBOUND(base, dimension);
+              upper = GetUBOUND(base, dimension, invariantOnly);
             }
             MaybeExtentExpr lower{triplet.lower()};
             if (!lower) {
-              lower = GetLBOUND(base, dimension);
+              lower = GetLBOUND(base, dimension, invariantOnly);
             }
             return CountTrips(std::move(lower), std::move(upper),
                 MaybeExtentExpr{triplet.stride()});
           },
           [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {
             if (auto shape{GetShape(subs.value())}) {
               if (GetRank(*shape) > 0) {
                 CHECK(GetRank(*shape) == 1); // vector-valued subscript
                 return std::move(shape->at(0));
               }
             }
             return std::nullopt;
           },
       },
       subscript.u);
 }
 
 MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
-    const NamedEntity &base, int dimension) {
-  return Fold(context, GetExtent(subscript, base, dimension));
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return Fold(context, GetExtent(subscript, base, dimension, invariantOnly));
 }
 
 MaybeExtentExpr ComputeUpperBound(
     ExtentExpr &&lower, MaybeExtentExpr &&extent) {
   if (extent) {
     if (ToInt64(lower).value_or(0) == 1) {
       return std::move(*extent);
     } else {
       return std::move(*extent) + std::move(lower) - ExtentExpr{1};
     }
   } else {
     return std::nullopt;
   }
 }
 
 MaybeExtentExpr ComputeUpperBound(
     FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
   return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
 }
 
-MaybeExtentExpr GetRawUpperBound(const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetRawUpperBound(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
   const Symbol &symbol{
       ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int rank{details->shape().Rank()};
     if (dimension < rank) {
       const auto &bound{details->shape()[dimension].ubound().GetExplicit()};
-      if (bound && IsScopeInvariantExpr(*bound)) {
+      if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) {
         return *bound;
       } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
         return std::nullopt;
       } else {
         return ComputeUpperBound(
             GetRawLowerBound(base, dimension), GetExtent(base, dimension));
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
     if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
       return ComputeUpperBound(
           GetRawLowerBound(base, dimension), std::move(extent));
     }
   }
   return std::nullopt;
 }
 
-MaybeExtentExpr GetRawUpperBound(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
-  return Fold(context, GetRawUpperBound(base, dimension));
+MaybeExtentExpr GetRawUpperBound(FoldingContext &context,
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return Fold(context, GetRawUpperBound(base, dimension, invariantOnly));
 }
 
-static MaybeExtentExpr GetExplicitUBOUND(
-    FoldingContext *context, const semantics::ShapeSpec &shapeSpec) {
+static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
+    const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
   const auto &ubound{shapeSpec.ubound().GetExplicit()};
-  if (ubound && IsScopeInvariantExpr(*ubound)) {
-    if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
+  if (ubound && (!invariantOnly || IsScopeInvariantExpr(*ubound))) {
+    if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
       if (auto cstExtent{ToInt64(
               context ? Fold(*context, std::move(*extent)) : *extent)}) {
         if (cstExtent > 0) {
           return *ubound;
         } else if (cstExtent == 0) {
           return ExtentExpr{0};
         }
       }
     }
   }
   return std::nullopt;
 }
 
-static MaybeExtentExpr GetUBOUND(
-    FoldingContext *context, const NamedEntity &base, int dimension) {
+static MaybeExtentExpr GetUBOUND(FoldingContext *context,
+    const NamedEntity &base, int dimension, bool invariantOnly) {
   const Symbol &symbol{
       ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int rank{details->shape().Rank()};
     if (dimension < rank) {
       const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]};
-      if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) {
+      if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) {
         return *ubound;
       } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
         return std::nullopt; // UBOUND() folding replaces with -1
-      } else if (auto lb{GetLBOUND(base, dimension)}) {
-        return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension));
+      } else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
+        return ComputeUpperBound(
+            std::move(*lb), GetExtent(base, dimension, invariantOnly));
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
     if (assoc->rank()) { // SELECT RANK case
       const Symbol &resolved{ResolveAssociations(symbol)};
       if (IsDescriptor(resolved) && dimension < *assoc->rank()) {
         ExtentExpr lb{DescriptorInquiry{NamedEntity{base},
             DescriptorInquiry::Field::LowerBound, dimension}};
         ExtentExpr extent{DescriptorInquiry{
             std::move(base), DescriptorInquiry::Field::Extent, dimension}};
         return ComputeUpperBound(std::move(lb), std::move(extent));
       }
     } else if (assoc->expr()) {
       if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
-        if (auto lb{GetLBOUND(base, dimension)}) {
+        if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
           return ComputeUpperBound(std::move(*lb), std::move(extent));
         }
       }
     }
   }
   return std::nullopt;
 }
 
-MaybeExtentExpr GetUBOUND(const NamedEntity &base, int dimension) {
-  return GetUBOUND(nullptr, base, dimension);
+MaybeExtentExpr GetUBOUND(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return GetUBOUND(nullptr, base, dimension, invariantOnly);
 }
 
-MaybeExtentExpr GetUBOUND(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
-  return Fold(context, GetUBOUND(&context, base, dimension));
+MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
+  return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly));
 }
 
-static Shape GetUBOUNDs(FoldingContext *context, const NamedEntity &base) {
+static Shape GetUBOUNDs(
+    FoldingContext *context, const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetUBOUND(context, base, dim));
+    result.emplace_back(GetUBOUND(context, base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetUBOUNDs(FoldingContext &context, const NamedEntity &base) {
-  return Fold(context, GetUBOUNDs(&context, base));
+Shape GetUBOUNDs(
+    FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
+  return Fold(context, GetUBOUNDs(&context, base, invariantOnly));
 }
 
-Shape GetUBOUNDs(const NamedEntity &base) { return GetUBOUNDs(nullptr, base); }
+Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) {
+  return GetUBOUNDs(nullptr, base, invariantOnly);
+}
 
 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
   return common::visit(
       common::visitors{
           [&](const semantics::ObjectEntityDetails &object) {
             if (IsImpliedShape(symbol) && object.init()) {
               return (*this)(object.init());
             } else if (IsAssumedRank(symbol)) {

flang/lib/Evaluate/tools.cpp

bool IsPureProcedure(const Symbol &original) {
   return IsPureProcedureImpl(original, set);
 }
 
 bool IsPureProcedure(const Scope &scope) {
   const Symbol *symbol{scope.GetSymbol()};
   return symbol && IsPureProcedure(*symbol);
 }
 
+bool IsExplicitlyImpureProcedure(const Symbol &original) {
+  // An ENTRY is IMPURE if its containing subprogram is so
+  return DEREF(GetMainEntry(&original.GetUltimate()))
+      .attrs()
+      .test(Attr::IMPURE);
+}
+
 bool IsElementalProcedure(const Symbol &original) {
   // An ENTRY is elemental if its containing subprogram is
   const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
-  if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
-    if (const Symbol * procInterface{procDetails->procInterface()}) {
-      // procedure with an elemental interface, ignoring the elemental
-      // aspect of intrinsic functions
-      return !procInterface->attrs().test(Attr::INTRINSIC) &&
-          IsElementalProcedure(*procInterface);
-    }
-  } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
-    return !details->symbol().attrs().test(Attr::INTRINSIC) &&
-        IsElementalProcedure(details->symbol());
-  } else if (!IsProcedure(symbol)) {
+  if (IsProcedure(symbol)) {
+    auto &foldingContext{symbol.owner().context().foldingContext()};
+    auto restorer{foldingContext.messages().DiscardMessages()};
+    auto proc{evaluate::characteristics::Procedure::Characterize(
+        symbol, foldingContext)};
+    return proc &&
+        proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental);
+  } else {
     return false;
   }
-  return symbol.attrs().test(Attr::ELEMENTAL);
 }
 
 bool IsFunction(const Symbol &symbol) {
   const Symbol &ultimate{symbol.GetUltimate()};
   return ultimate.test(Symbol::Flag::Function) ||
       (!ultimate.test(Symbol::Flag::Subroutine) &&
           common::visit(
               common::visitors{

flang/lib/Evaluate/variable.cpp

 }
 
 NamedEntity CoarrayRef::GetBase() const { return AsNamedEntity(base_); }
 
 // Equality testing
 
 // For the purposes of comparing type parameter expressions while
 // testing the compatibility of procedure characteristics, two
-// object dummy arguments with the same name are considered equal.
+// dummy arguments with the same position are considered equal.
+static std::optional<int> GetDummyArgPosition(const Symbol &original) {
+  const Symbol &symbol(original.GetUltimate());
+  if (IsDummy(symbol)) {
+    if (const Symbol * proc{symbol.owner().symbol()}) {
+      if (const auto *subp{proc->detailsIf<semantics::SubprogramDetails>()}) {
+        int j{0};
+        for (const Symbol *arg : subp->dummyArgs()) {
+          if (arg == &symbol) {
+            return j;
+          }
+          ++j;
+        }
+      }
+    }
+  }
+  return std::nullopt;
+}
+
 static bool AreSameSymbol(const Symbol &x, const Symbol &y) {
   if (&x == &y) {
     return true;
   }
-  if (x.name() == y.name()) {
-    if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
-      if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
-        return xObject->isDummy() && yObject->isDummy();
-      }
+  if (auto xPos{GetDummyArgPosition(x)}) {
+    if (auto yPos{GetDummyArgPosition(y)}) {
+      return *xPos == *yPos;
     }
   }
   return false;
 }
 
 // Implements operator==() for a union type, using special case handling
 // for Symbol references.
 template <typename A> static bool TestVariableEquality(const A &x, const A &y) {

flang/lib/Lower/ConvertType.cpp

if (const Fortran::semantics::DeclTypeSpec *type = ultimate.GetType()) {
       }
     } else {
       fir::emitFatalError(loc, "symbol must have a type");
     }
     bool isPolymorphic = (Fortran::semantics::IsPolymorphic(symbol) ||
                           Fortran::semantics::IsUnlimitedPolymorphic(symbol)) &&
                          !Fortran::semantics::IsAssumedType(symbol);
     if (ultimate.IsObjectArray()) {
-      auto shapeExpr = Fortran::evaluate::GetShapeHelper{
-          converter.getFoldingContext()}(ultimate);
+      auto shapeExpr =
+          Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
       if (!shapeExpr)
         TODO(loc, "assumed rank symbol type");
       fir::SequenceType::Shape shape;
       translateShape(shape, std::move(*shapeExpr));
       ty = fir::SequenceType::get(shape, ty);
     }
     if (Fortran::semantics::IsPointer(symbol))
       return fir::wrapInClassOrBoxType(fir::PointerType::get(ty),

flang/lib/Semantics/check-declarations.cpp

 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
   if (IsPointer(symbol) && !context_.HasError(symbol) &&
       !scopeIsUninstantiatedPDT_) {
     if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
       if (object->init()) { // C764, C765; C808
         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
           auto restorer{messages_.SetLocation(symbol.name())};
           context_.set_location(symbol.name());
-          CheckInitialTarget(
+          CheckInitialDataPointerTarget(
               context_, *designator, *object->init(), DEREF(scope_));
         }
       }
     } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
       if (proc->init() && *proc->init()) {
         // C1519 - must be nonelemental external or module procedure,
         // or an unrestricted specific intrinsic function.
         const Symbol &ultimate{(*proc->init())->GetUltimate()};
+        bool checkTarget{true};
         if (ultimate.attrs().test(Attr::INTRINSIC)) {
-          if (const auto intrinsic{
-                  context_.intrinsics().IsSpecificIntrinsicFunction(
-                      ultimate.name().ToString())};
+          if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
               !intrinsic || intrinsic->isRestrictedSpecific) { // C1030
             context_.Say(
                 "Intrinsic procedure '%s' is not an unrestricted specific "
                 "intrinsic permitted for use as the initializer for procedure "
                 "pointer '%s'"_err_en_US,
                 ultimate.name(), symbol.name());
+            checkTarget = false;
           }
-        } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
-            ultimate.owner().kind() != Scope::Kind::Module) {
+        } else if ((!ultimate.attrs().test(Attr::EXTERNAL) &&
+                       ultimate.owner().kind() != Scope::Kind::Module) ||
+            IsDummy(ultimate) || IsPointer(ultimate)) {
           context_.Say("Procedure pointer '%s' initializer '%s' is neither "
                        "an external nor a module procedure"_err_en_US,
               symbol.name(), ultimate.name());
+          checkTarget = false;
         } else if (IsElementalProcedure(ultimate)) {
           context_.Say("Procedure pointer '%s' cannot be initialized with the "
-                       "elemental procedure '%s"_err_en_US,
+                       "elemental procedure '%s'"_err_en_US,
               symbol.name(), ultimate.name());
-        } else {
-          // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
+          checkTarget = false;
+        }
+        if (checkTarget) {
+          SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
+          SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
+          CheckPointerAssignment(context_, lhs, rhs,
+              GetProgramUnitOrBlockConstructContaining(symbol));
         }
       }
     }
   }
 }
 
 // The six different kinds of array-specs:
 //   array-spec     -> explicit-shape-list | deferred-shape-list
void CheckHelper::CheckArraySpec(
   if (msg) {
     context_.Say(std::move(*msg), symbol.name());
   }
 }
 
 void CheckHelper::CheckProcEntity(
     const Symbol &symbol, const ProcEntityDetails &details) {
   CheckSymbolType(symbol);
+  const Symbol *interface {
+    details.procInterface() ? &details.procInterface()->GetUltimate() : nullptr
+  };
   if (details.isDummy()) {
     if (!symbol.attrs().test(Attr::POINTER) && // C843
         (symbol.attrs().test(Attr::INTENT_IN) ||
             symbol.attrs().test(Attr::INTENT_OUT) ||
             symbol.attrs().test(Attr::INTENT_INOUT))) {
       messages_.Say("A dummy procedure without the POINTER attribute"
                     " may not have an INTENT attribute"_err_en_US);
     }
     if (InElemental()) { // C15100
       messages_.Say(
           "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
     }
-    const Symbol *interface {
-      details.procInterface()
-    };
-    if (!symbol.attrs().test(Attr::INTRINSIC) &&
-        (IsElementalProcedure(symbol) ||
-            (interface && !interface->attrs().test(Attr::INTRINSIC) &&
-                IsElementalProcedure(*interface)))) {
+    if (interface && IsElementalProcedure(*interface)) {
       // There's no explicit constraint or "shall" that we can find in the
       // standard for this check, but it seems to be implied in multiple
       // sites, and ELEMENTAL non-intrinsic actual arguments *are*
       // explicitly forbidden.  But we allow "PROCEDURE(SIN)::dummy"
       // because it is explicitly legal to *pass* the specific intrinsic
       // function SIN as an actual argument.
+      if (interface->attrs().test(Attr::INTRINSIC)) {
+        messages_.Say(
+            "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
+      } else {
         messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
       }
+    }
   } else if (symbol.attrs().test(Attr::INTENT_IN) ||
       symbol.attrs().test(Attr::INTENT_OUT) ||
       symbol.attrs().test(Attr::INTENT_INOUT)) {
     messages_.Say("INTENT attributes may apply only to a dummy "
                   "argument"_err_en_US); // C843
   } else if (IsOptional(symbol)) {
     messages_.Say("OPTIONAL attribute may apply only to a dummy "
                   "argument"_err_en_US); // C849
-  } else if (symbol.owner().IsDerivedType()) {
-    if (!symbol.attrs().test(Attr::POINTER)) { // C756
-      const auto &name{symbol.name()};
-      messages_.Say(name,
-          "Procedure component '%s' must have POINTER attribute"_err_en_US,
-          name);
-    }
-    CheckPassArg(symbol, details.procInterface(), details);
-  }
-  if (IsPointer(symbol)) {
+  } else if (IsPointer(symbol)) {
     CheckPointerInitialization(symbol);
-    if (const Symbol * interface{details.procInterface()}) {
-      const Symbol &ultimate{interface->GetUltimate()};
-      if (ultimate.attrs().test(Attr::INTRINSIC)) {
-        if (const auto intrinsic{
-                context_.intrinsics().IsSpecificIntrinsicFunction(
-                    ultimate.name().ToString())};
-            !intrinsic || intrinsic->isRestrictedSpecific) { // C1515
+    if (interface) {
+      if (interface->attrs().test(Attr::INTRINSIC)) {
+        auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
+            interface->name().ToString())};
+        if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
           messages_.Say(
               "Intrinsic procedure '%s' is not an unrestricted specific "
               "intrinsic permitted for use as the definition of the interface "
               "to procedure pointer '%s'"_err_en_US,
-              ultimate.name(), symbol.name());
+              interface->name(), symbol.name());
+        } else if (IsElementalProcedure(*interface)) {
+          messages_.Say(
+              "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
+              symbol.name()); // C1517
         }
       } else if (IsElementalProcedure(*interface)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }
     }
+    if (symbol.owner().IsDerivedType()) {
+      CheckPassArg(symbol, interface, details);
+    }
+  } else if (symbol.owner().IsDerivedType()) {
+    const auto &name{symbol.name()};
+    messages_.Say(name,
+        "Procedure component '%s' must have POINTER attribute"_err_en_US, name);
   }
   CheckExternal(symbol);
 }
 
 // When a module subprogram has the MODULE prefix the following must match
 // with the corresponding separate module procedure interface body:
 // - C1549: characteristics and dummy argument names
 // - C1550: binding label

flang/lib/Semantics/data-to-inits.cpp

if (static_cast<std::size_t>(offsetSymbol.offset() + offsetSymbol.size()) >
         exprAnalyzer_.Say(
             "Data object '%s' may not be used to initialize '%s', which is a procedure pointer"_err_en_US,
             expr->AsFortran(), DescribeElement());
       }
     } else if (evaluate::IsProcedure(*expr)) {
       exprAnalyzer_.Say(
           "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US,
           expr->AsFortran(), DescribeElement());
-    } else if (CheckInitialTarget(
+    } else if (CheckInitialDataPointerTarget(
                    exprAnalyzer_.context(), designator, *expr, DEREF(scope_))) {
       GetImage().AddPointer(offsetSymbol.offset(), *expr);
       return true;
     }
   } else if (evaluate::IsNullPointer(*expr)) {
     exprAnalyzer_.Say("Initializer for '%s' must not be a pointer"_err_en_US,
         DescribeElement());
   } else if (evaluate::IsProcedure(*expr)) {

flang/lib/Semantics/pointer-assignment.h

 
 class SemanticsContext;
 class Symbol;
 
 bool CheckPointerAssignment(
     SemanticsContext &, const evaluate::Assignment &, const Scope &);
 bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
     const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false);
-bool CheckStructConstructorPointerComponent(
-    SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
 bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
     const std::string &description,
     const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
     const Scope &);
 
+bool CheckStructConstructorPointerComponent(
+    SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
+
 // Checks whether an expression is a valid static initializer for a
 // particular pointer designator.
-bool CheckInitialTarget(SemanticsContext &, const SomeExpr &pointer,
+bool CheckInitialDataPointerTarget(SemanticsContext &, const SomeExpr &pointer,
     const SomeExpr &init, const Scope &);
 
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_SEMANTICS_POINTER_ASSIGNMENT_H_

flang/lib/Semantics/pointer-assignment.cpp

if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
           isCall, procedure_, rhsProcedure, specific, whyNot)}) {
     Say(std::move(*msg), description_, rhsName, whyNot);
     return false;
   }
   return true;
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
-  if (const Symbol * symbol{d.GetSymbol()}) {
+  const Symbol *symbol{d.GetSymbol()};
+  if (symbol) {
     if (const auto *subp{
             symbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
       if (subp->stmtFunction()) {
         evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol,
             "Statement function '%s' may not be the target of a pointer assignment"_err_en_US,
             symbol->name());
         return false;
       }
     } else if (symbol->has<ProcBindingDetails>() &&
         context_.ShouldWarn(common::UsageWarning::Portability)) {
       evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol,
           "Procedure binding '%s' used as target of a pointer assignment"_port_en_US,
           symbol->name());
     }
   }
   if (auto chars{Procedure::Characterize(d, foldingContext_)}) {
+    // Disregard the elemental attribute of RHS intrinsics.
+    if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) {
+      chars->attrs.reset(Procedure::Attr::Elemental);
+    }
     return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
   } else {
     return Check(d.GetName(), false);
   }
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
   if (auto chars{Procedure::Characterize(ref, foldingContext_)}) {
bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
     const SomeExpr &rhs, const Scope &scope) {
   return PointerAssignmentChecker{context, scope, source, description}
       .set_lhsType(common::Clone(lhs.type))
       .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
       .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
       .Check(rhs);
 }
 
-bool CheckInitialTarget(SemanticsContext &context, const SomeExpr &pointer,
-    const SomeExpr &init, const Scope &scope) {
+bool CheckInitialDataPointerTarget(SemanticsContext &context,
+    const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
   return evaluate::IsInitialDataTarget(
              init, &context.foldingContext().messages()) &&
       CheckPointerAssignment(context, pointer, init, scope);
 }
 
 } // namespace Fortran::semantics

flang/test/Semantics/block-data01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Test BLOCK DATA subprogram (14.3)
 block data foo
   !ERROR: IMPORT is not allowed in a BLOCK DATA subprogram
   import
   real :: pi = asin(-1.0) ! ok
   !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
   integer :: notInCommon = 1
   integer :: uninitialized ! ok
+  !PORTABILITY: Procedure pointer 'q' should not have an ELEMENTAL intrinsic as its interface
   !ERROR: 'q' may not appear in a BLOCK DATA subprogram
   procedure(sin), pointer :: q => cos
   !ERROR: 'p' may not be a procedure as it is in a COMMON block
   procedure(sin), pointer :: p => cos
   common /block/ p, pi
   !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
   integer :: inDataButNotCommon
   data inDataButNotCommon /1/

flang/test/Semantics/c_loc01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 module m
   use iso_c_binding
   type haslen(L)
     integer, len :: L
   end type
  contains
   subroutine test(assumedType, poly, nclen)
     type(*), target :: assumedType
     class(*), target ::  poly
     type(c_ptr) cp
     type(c_funptr) cfp
     real notATarget
+    !PORTABILITY: Procedure pointer 'pptr' should not have an ELEMENTAL intrinsic as its interface
     procedure(sin), pointer :: pptr
     real, target :: arr(3)
     type(hasLen(1)), target :: clen
     type(hasLen(*)), target :: nclen
     character(2), target :: ch
     !ERROR: C_LOC() argument must be a data pointer or target
     cp = c_loc(notATarget)
     !ERROR: C_LOC() argument must be a data pointer or target

flang/test/Semantics/call02.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! 15.5.1 procedure reference constraints and restrictions
 
 subroutine s01(elem, subr)
   interface
     !ERROR: A dummy procedure may not be ELEMENTAL
     elemental real function elem(x)
       real, intent(in), value :: x
     end function
     subroutine subr(dummy)
+      !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
       procedure(sin) :: dummy
     end subroutine
     subroutine badsubr(dummy)
       import :: elem
       !ERROR: A dummy procedure may not be ELEMENTAL
       procedure(elem) :: dummy
     end subroutine
     subroutine optionalsubr(dummy)
+      !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
       procedure(sin), optional :: dummy
     end subroutine
     subroutine ptrsubr(dummy)
+      !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
       procedure(sin), pointer, intent(in) :: dummy
     end subroutine
   end interface
   intrinsic :: cos
   call subr(cos) ! not an error
   !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
   call subr(elem) ! C1533
   !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is a null pointer

flang/test/Semantics/call09.f90

subroutine s04(p)
     !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
     procedure(realfunc), intent(in) :: p
   end subroutine
   subroutine s05(p)
     procedure(realfunc), pointer, intent(in out) :: p
   end subroutine
 
   subroutine selemental1(p)
+    !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
     procedure(cos) :: p ! ok
   end subroutine
 
   real elemental function elemfunc(x)
     real, intent(in) :: x
     elemfunc = x
   end function
   subroutine selemental2(p)

flang/test/Semantics/io11.f90

module m4
   contains
     procedure, pass :: tbp=>formattedReadProc
     generic :: read(formatted) => tbp
   end type
   private
 contains
   !ERROR: Dummy argument 0 of 'formattedreadproc' must be a data object
   !ERROR: Cannot use an alternate return as the passed-object dummy argument
-  subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg) 
+  subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg)
     !ERROR: Dummy argument 'unit' must be a data object
     !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
+    !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
     procedure(sin), intent(in) :: unit
     character(len=*), intent(in) :: iotype
     integer, intent(in) :: vlist(:)
     integer, intent(out) :: iostat
     character(len=*), intent(inout) :: iomsg
 
     iostat = 343
     stop 'fail'

flang/test/Semantics/modfile49.f90

 ! RUN: %python %S/test_modfile.py %s %flang_fc1
 ! Ensure that symbols and types needed to declare procedures and procedure pointers
 ! are properly imported into interfaces.
 module m
   type :: t
   end type
-  procedure(sin) :: ext
+  abstract interface
+    subroutine iface
+    end
+  end interface
+  procedure(iface) :: ext
   interface
     subroutine subr(p1,p2)
       import ext, t
       procedure(ext) :: p1
       procedure(type(t)), pointer :: p2
     end subroutine
     function fun() result(res)
       import subr
       procedure(subr), pointer :: res
     end function
   end interface
 end module
 
 !Expect: m.mod
 !module m
 !type::t
 !end type
-!intrinsic::sin
-!procedure(sin)::ext
+!abstract interface
+!subroutine iface()
+!end
+!end interface
+!procedure(iface)::ext
 !interface
 !subroutine subr(p1,p2)
 !import::ext
 !import::t
 !procedure(ext)::p1
 !procedure(type(t)),pointer::p2
 !end
 !end interface
 !interface
 !function fun() result(res)
 !import::subr
 !procedure(subr),pointer::res
 !end
 !end interface
 !end

flang/test/Semantics/procinterface01.f90

interface
    real, intent(in) :: x
   end function tan
  end interface
 
  !DEF: /module1/derived1 PUBLIC DerivedType
  type :: derived1
   !REF: /module1/abstract1
   !DEF: /module1/derived1/p1 NOPASS, POINTER (Function) ProcEntity REAL(4)
-  !DEF: /module1/nested1 PUBLIC (Function) Subprogram REAL(4)
+  !DEF: /module1/nested1 PUBLIC, PURE (Function) Subprogram REAL(4)
   procedure(abstract1), pointer, nopass :: p1 => nested1
   !REF: /module1/explicit1
   !DEF: /module1/derived1/p2 NOPASS, POINTER (Function) ProcEntity REAL(4)
   !REF: /module1/nested1
   procedure(explicit1), pointer, nopass :: p2 => nested1
   !DEF: /module1/derived1/p3 NOPASS, POINTER (Function) ProcEntity LOGICAL(4)
   !DEF: /module1/nested2 PUBLIC (Function) Subprogram LOGICAL(4)
   procedure(logical), pointer, nopass :: p3 => nested2
type :: derived1
   !DEF: /module1/nested5 PUBLIC (Function) Subprogram CHARACTER(1_8,1)
   procedure(tan), pointer, nopass :: p8 => nested5
  end type derived1
 
 contains
 
  !REF: /module1/nested1
  !DEF: /module1/nested1/x INTENT(IN) ObjectEntity REAL(4)
- real function nested1(x)
+ pure real function nested1(x)
   !REF: /module1/nested1/x
   real, intent(in) :: x
   !DEF: /module1/nested1/nested1 ObjectEntity REAL(4)
   !REF: /module1/nested1/x
   nested1 = x+1.
  end function nested1
 
  !REF: /module1/nested2

flang/test/Semantics/procinterface02.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 subroutine foo(A, B, P)
   interface
     real elemental function foo_elemental(x)
       real, intent(in) :: x
     end function
     pure real function foo_pure(x)
       real, intent(in) :: x
     end function
     real function foo_nonelemental(x)
       real, intent(in) :: x
     end function
   end interface
   real :: A(:), B(:)
+  !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
   procedure(sqrt), pointer :: P
   !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
   A = P(B)
   !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'foo_elemental': incompatible procedure attributes: Elemental
   P => foo_elemental
   P => foo_pure ! ok
   !ERROR: PURE procedure pointer 'p' may not be associated with non-PURE procedure designator 'foo_nonelemental'
   P => foo_nonelemental
 end subroutine

flang/test/Semantics/procinterface04.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+subroutine test(dp1, dp2)
+  intrinsic sin
+  interface
+    elemental real function elemental(x)
+      real, intent(in) :: x
+    end
+    pure real function nonelemental(x)
+      real, intent(in) :: x
+    end
+  end interface
+  !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
+  procedure(sin) :: dp1
+  !ERROR: A dummy procedure may not be ELEMENTAL
+  procedure(elemental) :: dp2
+  !PORTABILITY: Procedure pointer 'pp1' should not have an ELEMENTAL intrinsic as its interface
+  procedure(sin), pointer :: pp1
+  !ERROR: Procedure pointer 'pp2' may not be ELEMENTAL
+  procedure(elemental), pointer :: pp2
+  procedure(elemental) :: pp3 ! ok, external
+  procedure(nonelemental), pointer :: pp4 => sin ! ok, special case
+  !ERROR: Procedure pointer 'pp5' cannot be initialized with the elemental procedure 'elemental'
+  procedure(nonelemental), pointer :: pp5 => elemental
+end

flang/test/Semantics/reduce01.f90

subroutine errors
     !ERROR: OPERATION= argument of REDUCE() must be a scalar function
     b = reduce(a, f2)
     !ERROR: OPERATION= argument of REDUCE() must be a pure function of two data arguments
     b = reduce(a, f3)
     !ERROR: OPERATION= argument of REDUCE() may not have dummy procedure arguments
     b = reduce(a, f4)
     !ERROR: OPERATION= argument of REDUCE() must have the same type as ARRAY=
     b = reduce(a, f5)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f6)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f7)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f8)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f9)
     !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute
     b = reduce(a, f10)
   end subroutine
   subroutine not_errors
     type(pdt(10)) :: a(10), b
     b = reduce(a, f11) ! check no bogus type incompatibility diagnostic
   end subroutine
 end module

flang/test/Semantics/resolve114.f90

subroutine ext2(a, b)
       integer, intent(in) :: b(:)
     end subroutine
   end interface
 end module m2
 
 subroutine s2a
   use m1
   use m2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(sin), pointer :: p1 => sin
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iabs), pointer :: p2 => iabs
   procedure(ext1), pointer :: p3 => ext1
   procedure(ext2), pointer :: p4 => ext2
 end subroutine
 
 subroutine s2b
   use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface1), pointer :: p1 => x1
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface2), pointer :: p2 => x2
   procedure(iface3), pointer :: p3 => x3
   procedure(iface4), pointer :: p4 => x4
 end subroutine
 
 module m3
   use m1
   use m2
 end module
 subroutine s3
   use m3
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(sin), pointer :: p1 => sin
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iabs), pointer :: p2 => iabs
   procedure(ext1), pointer :: p3 => ext1
   procedure(ext2), pointer :: p4 => ext2
 end subroutine
 
 module m4
   use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
 end module
 subroutine s4
   use m4
   use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface1), pointer :: p1 => x1
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface2), pointer :: p2 => x2
   procedure(iface3), pointer :: p3 => x3
   procedure(iface4), pointer :: p4 => x4
 end subroutine
 
 subroutine s5
   use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m2, only: x1 => tan, x2 => idim, x3 => ext2, x4 => ext1
   use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   !ERROR: Reference to 'x1' is ambiguous
   procedure(iface1), pointer :: p1 => x1
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   !ERROR: Reference to 'x2' is ambiguous
   procedure(iface2), pointer :: p2 => x2
   !ERROR: Reference to 'x3' is ambiguous
   procedure(iface3), pointer :: p3 => x3
   !ERROR: Reference to 'x4' is ambiguous
   procedure(iface4), pointer :: p4 => x4
 end subroutine

flang/test/Semantics/resolve46.f90

program main
 
   abstract interface
      logical function chrcmp(a,b)
        character(*), intent(in) :: a
        character(*), intent(in) :: b
      end function chrcmp
   end interface
 
+  !PORTABILITY: Procedure pointer 'p' should not have an ELEMENTAL intrinsic as its interface
   procedure(sin), pointer :: p => cos
   !ERROR: Intrinsic procedure 'amin0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'q'
   procedure(amin0), pointer :: q
   !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'r'
   procedure(bessel_j0), pointer :: r
   !ERROR: Intrinsic procedure 'llt' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 's'
   procedure(chrcmp), pointer :: s => llt
   !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
+  !PORTABILITY: Procedure pointer 't' should not have an ELEMENTAL intrinsic as its interface
   procedure(cos), pointer :: t => bessel_j0
   procedure(chrcmp), pointer :: u
   p => alog ! valid use of an unrestricted specific intrinsic
   p => alog10 ! ditto, but already declared intrinsic
   p => cos ! ditto, but also generic
   p => tan ! a generic & an unrestricted specific, not already declared
   !ERROR: Function pointer 'p' associated with incompatible function designator 'mod': function results have distinct types: REAL(4) vs INTEGER(4)
   p => mod
   !ERROR: Function pointer 'p' associated with incompatible function designator 'index': function results have distinct types: REAL(4) vs INTEGER(4)
   p => index
   !ERROR: 'bessel_j0' is not an unrestricted specific intrinsic procedure
   p => bessel_j0
   !ERROR: 'llt' is not an unrestricted specific intrinsic procedure
   u => llt
 end program main

flang/test/Semantics/resolve59.f90

function f4() result(r)
     !ERROR: Actual argument for 'x=' may not be a procedure
     x = acos(f4()) ! recursive call
     !ERROR: Actual argument for 'x=' may not be a procedure
     x = acos(f4)
     x = acos(r()) ! OK
   end function
   function f5(x) result(r)
     real :: x
+    !PORTABILITY: Procedure pointer 'r' should not have an ELEMENTAL intrinsic as its interface
     procedure(acos), pointer :: r
     r => acos
     !ERROR: Actual argument for 'x=' may not be a procedure
     x = acos(f5(x+1)) ! recursive call
     !ERROR: Actual argument for 'x=' may not be a procedure
     x = acos(f5)
     x = acos(r(x+1)) ! OK
   end function