[flang] Improve shape & length characterization

[klausler]

Summary

Analyze the shape of the result of TRANSFER(ptr,array) correctly
when "ptr" is an array of deferred shape. Fixing this bug led to
some refactoring and concentration of common code in TypeAndShape
member functions with code in general shape and character length
analysis, and this led to some regression test failures that have
all been cleaned up.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/include/flang/Evaluate/tools.h

336

I think that this might win the prize for the longest name in the compiler!

flang/include/flang/Evaluate/characteristics.h

public:
   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 &);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::ObjectEntityDetails &, FoldingContext &);
-  static std::optional<TypeAndShape> Characterize(
       const semantics::ProcInterface &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::DeclTypeSpec &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const ActualArgument &, FoldingContext &);
 
+  // Handle Expr<T> & Designator<T>
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
       const A &x, FoldingContext &context) {
-    if (const auto *symbol{UnwrapWholeSymbolDataRef(x)}) {
+    if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
       if (auto result{Characterize(*symbol, context)}) {
         return result;
       }
     }
     if (auto type{x.GetType()}) {
-      if (auto shape{GetShape(context, x)}) {
-        TypeAndShape result{*type, std::move(*shape)};
-        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));
-      }
-    }
+      TypeAndShape result{*type, GetShape(context, x)};
     return std::nullopt;
   }
 
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
       const std::optional<A> &x, FoldingContext &context) {
     if (x) {
       return Characterize(*x, context);
public:
 
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   static std::optional<TypeAndShape> Characterize(
       const semantics::AssocEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcEntityDetails &, FoldingContext &);
-  void AcquireShape(const semantics::ObjectEntityDetails &);
+  void AcquireAttrs(const semantics::Symbol &);
   void AcquireLEN();
+  void AcquireLEN(const semantics::Symbol &);
 
 protected:
   DynamicType type_;
   std::optional<Expr<SubscriptInteger>> LEN_;
   Shape shape_;
   Attrs attrs_;
   int corank_{0};
 };

flang/include/flang/Evaluate/tools.h

template <typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
   if (auto dataRef{ExtractDataRef(x)}) {
     if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
       return &p->get();
     }
   }
   return nullptr;
 }
 
+// If an expression is a whole symbol or a whole component desginator,
+// extract and return that symbol, else null.
+template <typename A>
+const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) {
+  if (auto dataRef{ExtractDataRef(x)}) {
+    if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
+      return &p->get();
+    } else if (const Component * c{std::get_if<Component>(&dataRef->u)}) {
+      if (c->base().Rank() == 0) {
+        return &c->GetLastSymbol();
+      }
+    }
+  }
+  return nullptr;
+}
+
 // GetFirstSymbol(A%B%C[I]%D) -> A
 template <typename A> const Symbol *GetFirstSymbol(const A &x) {
   if (auto dataRef{ExtractDataRef(x, true)}) {
     return &dataRef->GetFirstSymbol();
   } else {
     return nullptr;
   }
 }

flang/lib/Evaluate/characteristics.cpp

 TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) {
   LEN_ = Fold(context, std::move(LEN_));
   shape_ = Fold(context, std::move(shape_));
   return *this;
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::Symbol &symbol, FoldingContext &context) {
+  const auto &ultimate{symbol.GetUltimate()};
   return std::visit(
       common::visitors{
-          [&](const semantics::ObjectEntityDetails &object) {
-            auto result{Characterize(object, context)};
-            if (result &&
-                result->type().category() == TypeCategory::Character) {
-              if (auto len{DataRef{symbol}.LEN()}) {
-                result->set_LEN(Fold(context, std::move(*len)));
-              }
+          [&](const semantics::ObjectEntityDetails &object)
+              -> std::optional<TypeAndShape> {
+            if (auto type{DynamicType::From(object.type())}) {
+              TypeAndShape result{
+                  std::move(*type), GetShape(context, ultimate)};
+              result.AcquireAttrs(ultimate);
+              result.AcquireLEN(ultimate);
+              return std::move(result.Rewrite(context));
+            } else {
+              return std::nullopt;
             }
-            return result;
           },
           [&](const semantics::ProcEntityDetails &proc) {
             const semantics::ProcInterface &interface{proc.interface()};
             if (interface.type()) {
               return Characterize(*interface.type(), context);
             } else if (interface.symbol()) {
               return Characterize(*interface.symbol(), context);
             } else {
return std::visit(
           [&](const semantics::ProcBindingDetails &binding) {
             return Characterize(binding.symbol(), context);
           },
           [](const auto &) { return std::optional<TypeAndShape>{}; },
       },
       // GetUltimate() used here, not ResolveAssociations(), because
       // we need the type/rank of an associate entity from TYPE IS,
       // CLASS IS, or RANK statement.
-      symbol.GetUltimate().details());
-}
-
-std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::ObjectEntityDetails &object, FoldingContext &context) {
-  if (auto type{DynamicType::From(object.type())}) {
-    TypeAndShape result{std::move(*type)};
-    result.AcquireShape(object);
-    return Fold(context, std::move(result));
-  } else {
-    return std::nullopt;
-  }
+      ultimate.details());
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
   std::optional<TypeAndShape> result;
   if (auto type{DynamicType::From(assoc.type())}) {
     if (auto rank{assoc.rank()}) {
       if (*rank >= 0 && *rank <= common::maxRank) {
if (auto elementBytes{
             type_.MeasureSizeInBytes(foldingContext, GetRank(shape_) > 0)}) {
       return Fold(
           foldingContext, std::move(*elements) * std::move(*elementBytes));
     }
   }
   return std::nullopt;
 }
 
-void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
-  CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
-  corank_ = object.coshape().Rank();
-  if (object.IsAssumedRank()) {
+void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) {
+  if (const auto *object{
+          symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
+    corank_ = object->coshape().Rank();
+    if (object->IsAssumedRank()) {
       attrs_.set(Attr::AssumedRank);
-    return;
     }
-  if (object.IsAssumedShape()) {
+    if (object->IsAssumedShape()) {
       attrs_.set(Attr::AssumedShape);
     }
-  if (object.IsAssumedSize()) {
+    if (object->IsAssumedSize()) {
       attrs_.set(Attr::AssumedSize);
     }
-  if (object.IsDeferredShape()) {
+    if (object->IsDeferredShape()) {
       attrs_.set(Attr::DeferredShape);
     }
-  if (object.IsCoarray()) {
+    if (object->IsCoarray()) {
       attrs_.set(Attr::Coarray);
     }
-  for (const semantics::ShapeSpec &dim : object.shape()) {
-    if (dim.ubound().GetExplicit()) {
-      Expr<SubscriptInteger> extent{*dim.ubound().GetExplicit()};
-      if (auto lbound{dim.lbound().GetExplicit()}) {
-        extent =
-            std::move(extent) + Expr<SubscriptInteger>{1} - std::move(*lbound);
-      }
-      shape_.emplace_back(std::move(extent));
-    } else {
-      shape_.push_back(std::nullopt);
-    }
   }
 }
 
 void TypeAndShape::AcquireLEN() {
   if (type_.category() == TypeCategory::Character) {
     if (const auto *param{type_.charLength()}) {
       if (const auto &intExpr{param->GetExplicit()}) {
         LEN_ = ConvertToType<SubscriptInteger>(common::Clone(*intExpr));
       }
     }
   }
 }
 
+void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) {
+  if (type_.category() == TypeCategory::Character) {
+    if (auto len{DataRef{symbol}.LEN()}) {
+      LEN_ = std::move(*len);
+    }
+  }
+}
+
 llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
   o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
   attrs_.Dump(o, EnumToString);
   if (!shape_.empty()) {
     o << " dimension";
     char sep{'('};
     for (const auto &expr : shape_) {
       o << sep;
if (attrs.test(semantics::Attr::INTENT_IN)) {
     return common::Intent::InOut;
   } else {
     return common::Intent::Default;
   }
 }
 
 std::optional<DummyDataObject> DummyDataObject::Characterize(
     const semantics::Symbol &symbol, FoldingContext &context) {
-  if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (auto type{TypeAndShape::Characterize(*obj, context)}) {
+  if (symbol.has<semantics::ObjectEntityDetails>()) {
+    if (auto type{TypeAndShape::Characterize(symbol, context)}) {
       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},

 FunctionResult::~FunctionResult() {}
 
 bool FunctionResult::operator==(const FunctionResult &that) const {
   return attrs == that.attrs && u == that.u;
 }
 
 std::optional<FunctionResult> FunctionResult::Characterize(
     const Symbol &symbol, FoldingContext &context) {
-  if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (auto type{TypeAndShape::Characterize(*object, context)}) {
+  if (symbol.has<semantics::ObjectEntityDetails>()) {
+    if (auto type{TypeAndShape::Characterize(symbol, context)}) {
       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},
           });
       return result;

flang/lib/Evaluate/shape.cpp

Shape GetLowerBounds(FoldingContext &context, const NamedEntity &base) {
   }
   return result;
 }
 
 MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
   CHECK(dimension >= 0);
   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (IsImpliedShape(symbol)) {
-      Shape shape{GetShape(symbol).value()};
-      return std::move(shape.at(dimension));
+    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 (shapeSpec.ubound().isExplicit()) {
             if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
               if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
                 return common::Clone(ubound.value()) -
                     common::Clone(lbound.value()) + ExtentExpr{1};
               } else {
                 return ubound.value();
               }
             }
           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
             return std::nullopt;
           } else if (semantics::IsDescriptor(symbol)) {
-          return ExtentExpr{DescriptorInquiry{
-              NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
+            return ExtentExpr{DescriptorInquiry{NamedEntity{base},
+                DescriptorInquiry::Field::Extent, dimension}};
+          }
         }
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
     if (auto shape{GetShape(assoc->expr())}) {
       if (dimension < static_cast<int>(shape->size())) {
         return std::move(shape->at(dimension));

 Shape GetUpperBounds(FoldingContext &context, const NamedEntity &base) {
   return Fold(context, GetUpperBounds(base));
 }
 
 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
   return std::visit(
       common::visitors{
           [&](const semantics::ObjectEntityDetails &object) {
-            if (IsImpliedShape(symbol)) {
+            if (IsImpliedShape(symbol) && object.init()) {
               return (*this)(object.init());
             } else {
               int n{object.shape().Rank()};
               NamedEntity base{symbol};
               return Result{CreateShape(n, base)};
             }
           },
           [](const semantics::EntityDetails &) {

flang/lib/Evaluate/variable.cpp

 //===-- lib/Evaluate/variable.cpp -----------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/variable.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Parser/char-block.h"
 #include "flang/Parser/characters.h"
 #include "flang/Parser/message.h"
+#include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include <type_traits>
 
 using namespace Fortran::parser::literals;
 
 namespace Fortran::evaluate {
 
 // Constructors, accessors, mutators
DescriptorInquiry::DescriptorInquiry(NamedEntity &&base, Field field, int dim)
     : base_{std::move(base)}, field_{field}, dimension_{dim} {
   const Symbol &last{base_.GetLastSymbol()};
   CHECK(IsDescriptor(last));
   CHECK((field == Field::Len && dim == 0) ||
       (field != Field::Len && dim >= 0 && dim < last.Rank()));
 }
 
 // LEN()
-static std::optional<Expr<SubscriptInteger>> SymbolLEN(const Symbol &sym) {
-  if (auto dyType{DynamicType::From(sym)}) {
+static std::optional<Expr<SubscriptInteger>> SymbolLEN(const Symbol &symbol) {
+  const Symbol &ultimate{symbol.GetUltimate()};
+  if (const auto *assoc{ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
+    if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc->expr())}) {
+      return chExpr->LEN();
+    }
+  } else if (auto dyType{DynamicType::From(ultimate)}) {
     if (const semantics::ParamValue * len{dyType->charLength()}) {
       if (len->isExplicit()) {
         if (auto intExpr{len->GetExplicit()}) {
           if (IsConstantExpr(*intExpr)) {
             return ConvertToType<SubscriptInteger>(*std::move(intExpr));
           }
         }
       }
-      return Expr<SubscriptInteger>{
-          DescriptorInquiry{NamedEntity{sym}, DescriptorInquiry::Field::Len}};
+      if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) {
+        return Expr<SubscriptInteger>{DescriptorInquiry{
+            NamedEntity{ultimate}, DescriptorInquiry::Field::Len}};
+      }
     }
   }
   return std::nullopt;
 }
 
 std::optional<Expr<SubscriptInteger>> BaseObject::LEN() const {
   return std::visit(
       common::visitors{

flang/lib/Semantics/check-call.cpp

static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   if (actualLastSymbol) {
     actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
   }
   const ObjectEntityDetails *actualLastObject{actualLastSymbol
           ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
           : nullptr};
   int actualRank{evaluate::GetRank(actualType.shape())};
   bool actualIsPointer{evaluate::IsObjectPointer(actual, context)};
+  bool dummyIsAssumedRank{dummy.type.attrs().test(
+      characteristics::TypeAndShape::Attr::AssumedRank)};
   if (dummy.type.attrs().test(
           characteristics::TypeAndShape::Attr::AssumedShape)) {
     // 15.5.2.4(16)
     if (actualRank == 0) {
       messages.Say(
           "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,
           dummyName);
     }
     if (actualIsAssumedSize && actualLastSymbol) {
       evaluate::SayWithDeclaration(messages, *actualLastSymbol,
           "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
           dummyName);
     }
   } else if (actualRank == 0 && dummy.type.Rank() > 0) {
     // Actual is scalar, dummy is an array.  15.5.2.4(14), 15.5.2.11
     if (actualIsCoindexed) {
       messages.Say(
           "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
           dummyName);
     }
     if (!IsArrayElement(actual) &&
         !(actualType.type().category() == TypeCategory::Character &&
             actualType.type().kind() == 1) &&
-        !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize)) {
+        !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
+        !dummyIsAssumedRank) {
       messages.Say(
           "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
           dummyName);
     }
     if (actualIsPolymorphic) {
       messages.Say(
           "Polymorphic scalar may not be associated with a %s array"_err_en_US,
           dummyName);
static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   }
 
   // Cases when temporaries might be needed but must not be permitted.
   bool dummyIsPointer{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
   bool dummyIsContiguous{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
   bool actualIsContiguous{IsSimplyContiguous(actual, context)};
-  bool dummyIsAssumedRank{dummy.type.attrs().test(
-      characteristics::TypeAndShape::Attr::AssumedRank)};
   bool dummyIsAssumedShape{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedShape)};
   if ((actualIsAsynchronous || actualIsVolatile) &&
       (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
     if (actualIsCoindexed) { // C1538
       messages.Say(
           "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
           dummyName);

flang/lib/Semantics/expression.cpp

 }
 
 // Can actual be argument associated with dummy?
 static bool CheckCompatibleArgument(bool isElemental,
     const ActualArgument &actual, const characteristics::DummyArgument &dummy) {
   return std::visit(
       common::visitors{
           [&](const characteristics::DummyDataObject &x) {
-            characteristics::TypeAndShape dummyTypeAndShape{x.type};
-            if (!isElemental && actual.Rank() != dummyTypeAndShape.Rank()) {
+            if (!isElemental && actual.Rank() != x.type.Rank() &&
+                !x.type.attrs().test(
+                    characteristics::TypeAndShape::Attr::AssumedRank)) {
               return false;
             } else if (auto actualType{actual.GetType()}) {
-              return dummyTypeAndShape.type().IsTkCompatibleWith(*actualType);
+              return x.type.type().IsTkCompatibleWith(*actualType);
             } else {
               return false;
             }
           },
           [&](const characteristics::DummyProcedure &) {
             const auto *expr{actual.UnwrapExpr()};
             return expr && IsProcedurePointer(*expr);
           },

flang/lib/Semantics/runtime-type-info.cpp

return evaluate::AsGenericExpr(
       AsciiExpr{evaluate::Designator<Ascii>{symbol}});
 }
 
 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
     const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
     const std::string &distinctName, const SymbolVector *parameters) {
   evaluate::StructureConstructorValues values;
   auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
-      object, context_.foldingContext())};
+      symbol, context_.foldingContext())};
   CHECK(typeAndShape.has_value());
   auto dyType{typeAndShape->type()};
   const auto &shape{typeAndShape->shape()};
   AddValue(values, componentSchema_, "name"s,
       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
   AddValue(values, componentSchema_, "category"s,
       IntExpr<1>(static_cast<int>(dyType.category())));
   if (dyType.IsUnlimitedPolymorphic() ||