[flang] Fix crash in folding TRANSFER() with MOLD=substring

[klausler]

Summary

When a substring appears as the MOLD= argument to TRANSFER(),
it's possible for the compiler to assert if it can't figure
out a constant length for the substring. Fix.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Evaluate/initial-image.h

public:
 
   void AddPointer(ConstantSubscript, const Expr<SomeType> &);
 
   void Incorporate(ConstantSubscript toOffset, const InitialImage &from,
       ConstantSubscript fromOffset, ConstantSubscript bytes);
 
   // Conversions to constant initializers
   std::optional<Expr<SomeType>> AsConstant(FoldingContext &,
-      const DynamicType &, const ConstantSubscripts &, bool padWithZero = false,
+      const DynamicType &, std::optional<std::int64_t> charLength,
+      const ConstantSubscripts &, bool padWithZero = false,
       ConstantSubscript offset = 0) const;
   std::optional<Expr<SomeType>> AsConstantPointer(
       ConstantSubscript offset = 0) const;
 
   friend class AsConstantHelper;
 
 private:
   std::vector<char> data_;
   std::map<ConstantSubscript, Expr<SomeType>> pointers_;
 };
 
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_INITIAL_IMAGE_H_

flang/include/flang/Evaluate/type.h

if (knownLength_ < 0) {
       return std::nullopt;
     }
 #endif
     return knownLength_;
   }
   std::optional<Expr<SubscriptInteger>> GetCharLength() const;
 
   std::size_t GetAlignment(const TargetCharacteristics &) const;
-  std::optional<Expr<SubscriptInteger>> MeasureSizeInBytes(
-      FoldingContext &, bool aligned) const;
+  std::optional<Expr<SubscriptInteger>> MeasureSizeInBytes(FoldingContext &,
+      bool aligned,
+      std::optional<std::int64_t> charLength = std::nullopt) const;
 
   std::string AsFortran() const;
   std::string AsFortran(std::string &&charLenExpr) const;
   DynamicType ResultTypeForMultiply(const DynamicType &) const;
 
   bool IsAssumedLengthCharacter() const;
   bool IsNonConstantLengthCharacter() const;
   bool IsTypelessIntrinsicArgument() const;

flang/lib/Evaluate/fold.cpp

if (auto sourceTypeAndShape{
             characteristics::TypeAndShape::Characterize(*source, context)}) {
       if (auto sourceBytesExpr{
               sourceTypeAndShape->MeasureSizeInBytes(context)}) {
         sourceBytes = ToInt64(*sourceBytesExpr);
       }
     }
   }
   std::optional<DynamicType> moldType;
-  if (arguments[1]) {
+  std::optional<std::int64_t> moldLength;
+  if (arguments[1]) { // MOLD=
     moldType = arguments[1]->GetType();
+    if (moldType && moldType->category() == TypeCategory::Character) {
+      if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(arguments[1])}) {
+        moldLength = ToInt64(Fold(context, chExpr->LEN()));
+      }
+    }
   }
   std::optional<ConstantSubscripts> extents;
   if (arguments.size() == 2) { // no SIZE=
     if (moldType && sourceBytes) {
       if (arguments[1]->Rank() == 0) { // scalar MOLD=
         extents = ConstantSubscripts{}; // empty extents (scalar result)
       } else if (auto moldBytesExpr{
                      moldType->MeasureSizeInBytes(context, true)}) {
         if (auto moldBytes{ToInt64(Fold(context, std::move(*moldBytesExpr)))};
             *moldBytes > 0) {
           extents = ConstantSubscripts{
               static_cast<ConstantSubscript>((*sourceBytes) + *moldBytes - 1) /
               *moldBytes};
         }
       }
     }
   } else if (arguments[2]) { // SIZE= is present
     if (const auto *sizeExpr{arguments[2]->UnwrapExpr()}) {
       if (auto sizeValue{ToInt64(*sizeExpr)}) {
         extents = ConstantSubscripts{*sizeValue};
       }
     }
   }
-  if (sourceBytes && IsActuallyConstant(*source) && moldType && extents) {
+  if (sourceBytes && IsActuallyConstant(*source) && moldType && extents &&
+      (moldLength || moldType->category() != TypeCategory::Character)) {
     std::size_t elements{
         extents->empty() ? 1 : static_cast<std::size_t>((*extents)[0])};
     std::size_t totalBytes{*sourceBytes * elements};
     // Don't fold intentional overflow cases from sneaky tests
     if (totalBytes < std::size_t{1000000} &&
         (elements == 0 || totalBytes / elements == *sourceBytes)) {
       InitialImage image{*sourceBytes};
       InitialImage::Result imageResult{
           image.Add(0, *sourceBytes, *source, context)};
       CHECK(imageResult == InitialImage::Ok);
       return image.AsConstant(
-          context, *moldType, *extents, true /*pad with 0*/);
+          context, *moldType, moldLength, *extents, true /*pad with 0*/);
     }
   }
   return std::nullopt;
 }
 
 template class ExpressionBase<SomeDerived>;
 template class ExpressionBase<SomeType>;
 
 } // namespace Fortran::evaluate

flang/lib/Evaluate/initial-image.cpp

 // Classes used with common::SearchTypes() to (re)construct Constant<> values
 // of the right type to initialize each symbol from the values that have
 // been placed into its initialization image by DATA statements.
 class AsConstantHelper {
 public:
   using Result = std::optional<Expr<SomeType>>;
   using Types = AllTypes;
   AsConstantHelper(FoldingContext &context, const DynamicType &type,
-      const ConstantSubscripts &extents, const InitialImage &image,
-      bool padWithZero = false, ConstantSubscript offset = 0)
-      : context_{context}, type_{type}, image_{image}, extents_{extents},
-        padWithZero_{padWithZero}, offset_{offset} {
+      std::optional<std::int64_t> charLength, const ConstantSubscripts &extents,
+      const InitialImage &image, bool padWithZero = false,
+      ConstantSubscript offset = 0)
+      : context_{context}, type_{type}, charLength_{charLength}, image_{image},
+        extents_{extents}, padWithZero_{padWithZero}, offset_{offset} {
     CHECK(!type.IsPolymorphic());
   }
   template <typename T> Result Test() {
     if (T::category != type_.category()) {
       return std::nullopt;
     }
     if constexpr (T::category != TypeCategory::Derived) {
       if (T::kind != type_.kind()) {
         return std::nullopt;
       }
     }
     using Const = Constant<T>;
     using Scalar = typename Const::Element;
     std::size_t elements{TotalElementCount(extents_)};
     std::vector<Scalar> typedValue(elements);
-    auto elemBytes{
-        ToInt64(type_.MeasureSizeInBytes(context_, GetRank(extents_) > 0))};
+    auto elemBytes{ToInt64(type_.MeasureSizeInBytes(
+        context_, GetRank(extents_) > 0, charLength_))};
     CHECK(elemBytes && *elemBytes >= 0);
     std::size_t stride{static_cast<std::size_t>(*elemBytes)};
     CHECK(offset_ + elements * stride <= image_.data_.size() || padWithZero_);
     if constexpr (T::category == TypeCategory::Derived) {
       const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()};
       for (auto iter : DEREF(derived.scope())) {
         const Symbol &component{*iter.second};
         bool isProcPtr{IsProcedurePointer(component)};
if constexpr (T::category == TypeCategory::Derived) {
             }
           } else if (!IsAllocatable(component)) {
             auto componentType{DynamicType::From(component)};
             CHECK(componentType.has_value());
             auto componentExtents{GetConstantExtents(context_, component)};
             CHECK(componentExtents.has_value());
             for (std::size_t j{0}; j < elements; ++j, at += stride) {
               if (Result value{image_.AsConstant(context_, *componentType,
-                      *componentExtents, padWithZero_, at)}) {
+                      std::nullopt, *componentExtents, padWithZero_, at)}) {
                 typedValue[j].emplace(component, std::move(*value));
               }
             }
           }
         }
       }
       return AsGenericExpr(
           Const{derived, std::move(typedValue), std::move(extents_)});
if constexpr (T::category == TypeCategory::Derived) {
       }
       return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)});
     }
   }
 
 private:
   FoldingContext &context_;
   const DynamicType &type_;
+  std::optional<std::int64_t> charLength_;
   const InitialImage &image_;
   ConstantSubscripts extents_; // a copy
   bool padWithZero_;
   ConstantSubscript offset_;
 };
 
 std::optional<Expr<SomeType>> InitialImage::AsConstant(FoldingContext &context,
-    const DynamicType &type, const ConstantSubscripts &extents,
-    bool padWithZero, ConstantSubscript offset) const {
-  return common::SearchTypes(
-      AsConstantHelper{context, type, extents, *this, padWithZero, offset});
+    const DynamicType &type, std::optional<std::int64_t> charLength,
+    const ConstantSubscripts &extents, bool padWithZero,
+    ConstantSubscript offset) const {
+  return common::SearchTypes(AsConstantHelper{
+      context, type, charLength, extents, *this, padWithZero, offset});
 }
 
 std::optional<Expr<SomeType>> InitialImage::AsConstantPointer(
     ConstantSubscript offset) const {
   auto iter{pointers_.find(offset)};
   return iter == pointers_.end() ? std::optional<Expr<SomeType>>{}
                                  : iter->second;
 }
 
 } // namespace Fortran::evaluate

flang/lib/Evaluate/type.cpp

if (category_ == TypeCategory::Derived) {
     }
   } else {
     return targetCharacteristics.GetAlignment(category_, kind_);
   }
   return 1; // needs to be after switch to dodge a bogus gcc warning
 }
 
 std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
-    FoldingContext &context, bool aligned) const {
+    FoldingContext &context, bool aligned,
+    std::optional<std::int64_t> charLength) const {
   switch (category_) {
   case TypeCategory::Integer:
   case TypeCategory::Real:
   case TypeCategory::Complex:
   case TypeCategory::Logical:
     return Expr<SubscriptInteger>{
         context.targetCharacteristics().GetByteSize(category_, kind_)};
   case TypeCategory::Character:
-    if (auto len{GetCharLength()}) {
+    if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+                                  *charLength}}
+                            : GetCharLength()}) {
       return Fold(context,
           Expr<SubscriptInteger>{
               context.targetCharacteristics().GetByteSize(category_, kind_)} *
               std::move(*len));
     }
     break;
   case TypeCategory::Derived:
     if (!IsPolymorphic() && derived_ && derived_->scope()) {

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

if (const auto *object{component.detailsIf<ObjectEntityDetails>()}) {
             if (initialized) {
               init.image.AddPointer(componentOffset, *object->init());
             }
           } else { // data, not pointer
             if (auto dyType{evaluate::DynamicType::From(component)}) {
               if (auto extents{evaluate::GetConstantExtents(
                       foldingContext, component)}) {
                 if (auto extant{init.image.AsConstant(foldingContext, *dyType,
-                        *extents, false /*don't pad*/, componentOffset)}) {
+                        std::nullopt, *extents, false /*don't pad*/,
+                        componentOffset)}) {
                   initialized = !(*extant == *object->init());
                 }
               }
             }
             if (initialized) {
               init.image.Add(componentOffset, component.size(), *object->init(),
                   foldingContext);
             }
if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     if (IsPointer(symbol)) {
       if (auto ptr{initialization.image.AsConstantPointer()}) {
         mutableObject.set_init(*ptr);
       } else {
         mutableObject.set_init(SomeExpr{evaluate::NullPointer{}});
       }
     } else if (auto symbolType{evaluate::DynamicType::From(symbol)}) {
       if (auto extents{evaluate::GetConstantExtents(context, symbol)}) {
-        mutableObject.set_init(
-            initialization.image.AsConstant(context, *symbolType, *extents));
+        mutableObject.set_init(initialization.image.AsConstant(
+            context, *symbolType, std::nullopt, *extents));
       } else {
         exprAnalyzer.Say(symbol.name(),
             "internal: unknown shape for '%s' while constructing initializer from DATA"_err_en_US,
             symbol.name());
         return;
       }
     } else {
       exprAnalyzer.Say(symbol.name(),

flang/test/Evaluate/fold-transfer.f90

module m
   logical, parameter :: test_c2i_v_2 = all(jc3 == [int(z'61626364'), int(z'65666768')]) .or. all(jc3 == [int(z'64636261'), int(z'68676665')])
   integer, parameter :: jc4(*) = transfer(["abcd", "efgh"], 0, 1)
   logical, parameter :: test_c2i_vs_1 = all(jc4 == [int(z'61626364')]) .or. all(jc4 == [int(z'64636261')])
 
   integer, parameter :: le1 = int(z'64636261', 4), be1 = int(z'65666768', 4)
   character*5, parameter :: le1c(*) = transfer(le1, [character(5)::])
   character*5, parameter :: be1c(*) = transfer(be1, [character(5)::])
   logical, parameter :: test_i2c_s = all(le1c == ["abcd"//char(0)]) .or. all(be1c == ["efgh"//char(0)])
+
+  character*4, parameter :: i2ss1 = transfer(int(z'61626364', 4), "12345678"(2:5))
+  logical, parameter :: test_i2ss1 = any(i2ss1 == ["abcd", "dcba"])
 end module