[flang][runtime] Handle explicit-length character padding & truncation in Assign()

[klausler]

Summary

When the left-hand side of an allocatable assignment has an explicit character length,
rather than a deferred length that might imply reallocation, handle any discrepancy
in lengths via truncation or blank padding.

[clementval]

LGTM

flang/include/flang/Runtime/assign.h

 extern "C" {
 // API for lowering assignment
 void RTNAME(Assign)(Descriptor &to, const Descriptor &from,
     const char *sourceFile = nullptr, int sourceLine = 0);
 // This variant has no finalization, defined assignment, or allocatable
 // reallocation.
 void RTNAME(AssignTemporary)(Descriptor &to, const Descriptor &from,
     const char *sourceFile = nullptr, int sourceLine = 0);
+// This variant is for assignments to explicit-length CHARACTER left-hand
+// sides that might need to handle truncation or blank-fill, and
+// must maintain the character length even if an allocatable array
+// is reallocated.
+void RTNAME(AssignExplicitLengthCharacter)(Descriptor &to,
+    const Descriptor &from, const char *sourceFile = nullptr,
+    int sourceLine = 0);
+// This variant is assignments to whole polymorphic allocatables.
+void RTNAME(AssignPolymorphic)(Descriptor &to, const Descriptor &from,
+    const char *sourceFile = nullptr, int sourceLine = 0);
 } // extern "C"
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_ASSIGN_H_

flang/runtime/assign.cpp

 #include "derived.h"
 #include "stat.h"
 #include "terminator.h"
 #include "type-info.h"
 #include "flang/Runtime/descriptor.h"
 
 namespace Fortran::runtime {
 
+enum AssignFlags {
+  NoAssignFlags = 0,
+  MaybeReallocate = 1 << 0,
+  NeedFinalization = 1 << 1,
+  CanBeDefinedAssignment = 1 << 2,
+  ComponentCanBeDefinedAssignment = 1 << 3,
+  ExplicitLengthCharacterLHS = 1 << 4,
+  PolymorphicLHS = 1 << 5
+};
+
 // Predicate: is the left-hand side of an assignment an allocated allocatable
 // that must be deallocated?
 static inline bool MustDeallocateLHS(
-    Descriptor &to, const Descriptor &from, Terminator &terminator) {
+    Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
   // Top-level assignments to allocatable variables (*not* components)
   // may first deallocate existing content if there's about to be a
   // change in type or shape; see F'2018 10.2.1.3(3).
+  if (!(flags & MaybeReallocate)) {
+    return false;
+  }
   if (!to.IsAllocatable() || !to.IsAllocated()) {
     return false;
   }
   if (to.type() != from.type()) {
     return true;
   }
+  if (!(flags & ExplicitLengthCharacterLHS) && to.type().IsCharacter() &&
+      to.ElementBytes() != from.ElementBytes()) {
+    return true;
+  }
+  if (flags & PolymorphicLHS) {
     DescriptorAddendum *toAddendum{to.Addendum()};
     const typeInfo::DerivedType *toDerived{
         toAddendum ? toAddendum->derivedType() : nullptr};
     const DescriptorAddendum *fromAddendum{from.Addendum()};
     const typeInfo::DerivedType *fromDerived{
         fromAddendum ? fromAddendum->derivedType() : nullptr};
     if (toDerived != fromDerived) {
       return true;
     }
-  if (toAddendum) {
+    if (fromDerived) {
       // Distinct LEN parameters? Deallocate
-    std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0};
+      std::size_t lenParms{fromDerived->LenParameters()};
       for (std::size_t j{0}; j < lenParms; ++j) {
         if (toAddendum->LenParameterValue(j) !=
             fromAddendum->LenParameterValue(j)) {
           return true;
         }
       }
     }
+  }
   if (from.rank() > 0) {
     // Distinct shape? Deallocate
     int rank{to.rank()};
     for (int j{0}; j < rank; ++j) {
       if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) {
         return true;
       }
     }
   }
   return false;
 }
 
 // Utility: allocate the allocatable left-hand side, either because it was
 // originally deallocated or because it required reallocation
 static int AllocateAssignmentLHS(
-    Descriptor &to, const Descriptor &from, Terminator &terminator) {
+    Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
   to.raw().type = from.raw().type;
+  if (!(flags & ExplicitLengthCharacterLHS)) {
     to.raw().elem_len = from.ElementBytes();
+  }
   const typeInfo::DerivedType *derived{nullptr};
   if (const DescriptorAddendum * fromAddendum{from.Addendum()}) {
     derived = fromAddendum->derivedType();
     if (DescriptorAddendum * toAddendum{to.Addendum()}) {
       toAddendum->set_derivedType(derived);
       std::size_t lenParms{derived ? derived->LenParameters() : 0};
       for (std::size_t j{0}; j < lenParms; ++j) {
         toAddendum->SetLenParameterValue(j, fromAddendum->LenParameterValue(j));
static void DoElementalDefinedAssignment(const Descriptor &to,
   for (std::size_t toElements{to.Elements()}; toElements-- > 0;
        to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
     toElementDesc.set_base_addr(to.Element<char>(toAt));
     fromElementDesc.set_base_addr(from.Element<char>(fromAt));
     DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special);
   }
 }
 
+template <typename CHAR>
+static void BlankPadCharacterAssignment(Descriptor &to, const Descriptor &from,
+    SubscriptValue toAt[], SubscriptValue fromAt[], std::size_t elements,
+    std::size_t toElementBytes, std::size_t fromElementBytes) {
+  std::size_t padding{(toElementBytes - fromElementBytes) / sizeof(CHAR)};
+  for (; elements-- > 0;
+       to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+    CHAR *p{to.Element<CHAR>(toAt)};
+    std::memmove(
+        p, from.Element<std::add_const_t<CHAR>>(fromAt), fromElementBytes);
+    p += fromElementBytes;
+    for (auto n{padding}; n-- > 0;) {
+      *p++ = CHAR{' '};
+    }
+  }
+}
+
 // Common implementation of assignments, both intrinsic assignments and
 // those cases of polymorphic user-defined ASSIGNMENT(=) TBPs that could not
 // be resolved in semantics.  Most assignment statements do not need any
 // of the capabilities of this function -- but when the LHS is allocatable,
 // the type might have a user-defined ASSIGNMENT(=), or the type might be
 // finalizable, this function should be used.
 // When "to" is not a whole allocatable, "from" is an array, and defined
 // assignments are not used, "to" and "from" only need to have the same number
 // of elements, but their shape need not to conform (the assignment is done in
 // element sequence order). This facilitates some internal usages, like when
 // dealing with array constructors.
-static void Assign(Descriptor &to, const Descriptor &from,
-    Terminator &terminator, bool maybeReallocate, bool needFinalization,
-    bool canBeDefinedAssignment, bool componentCanBeDefinedAssignment) {
-  bool mustDeallocateLHS{
-      maybeReallocate && MustDeallocateLHS(to, from, terminator)};
+static void Assign(
+    Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
+  bool mustDeallocateLHS{MustDeallocateLHS(to, from, terminator, flags)};
   DescriptorAddendum *toAddendum{to.Addendum()};
   const typeInfo::DerivedType *toDerived{
       toAddendum ? toAddendum->derivedType() : nullptr};
-  if (canBeDefinedAssignment && toDerived) {
-    needFinalization &= !toDerived->noFinalizationNeeded();
+  if (toDerived) {
+    if (flags & CanBeDefinedAssignment) {
       // Check for a user-defined assignment type-bound procedure;
       // see 10.2.1.4-5.  A user-defined assignment TBP defines all of
       // the semantics, including allocatable (re)allocation and any
       // finalization.
       if (to.rank() == 0) {
         if (const auto *special{toDerived->FindSpecialBinding(
                 typeInfo::SpecialBinding::Which::ScalarAssignment)}) {
           return DoScalarDefinedAssignment(to, from, *special);
         }
       }
       if (const auto *special{toDerived->FindSpecialBinding(
               typeInfo::SpecialBinding::Which::ElementalAssignment)}) {
         return DoElementalDefinedAssignment(to, from, *special);
       }
     }
-  bool isSimpleMemmove{!toDerived && to.rank() == from.rank() &&
-      to.IsContiguous() && from.IsContiguous()};
+    if ((flags & NeedFinalization) && toDerived->noFinalizationNeeded()) {
+      flags &= ~NeedFinalization;
+    }
+  }
+  std::size_t toElementBytes{to.ElementBytes()};
+  std::size_t fromElementBytes{from.ElementBytes()};
+  auto isSimpleMemmove{[&]() {
+    return !toDerived && to.rank() == from.rank() && to.IsContiguous() &&
+        from.IsContiguous() && toElementBytes == fromElementBytes;
+  }};
   StaticDescriptor<maxRank, true, 10 /*?*/> deferredDeallocStatDesc;
   Descriptor *deferDeallocation{nullptr};
   if (MayAlias(to, from)) {
     if (mustDeallocateLHS) {
       deferDeallocation = &deferredDeallocStatDesc.descriptor();
       std::memcpy(deferDeallocation, &to, to.SizeInBytes());
       to.set_base_addr(nullptr);
-    } else if (!isSimpleMemmove) {
+    } else if (!isSimpleMemmove()) {
       // Handle LHS/RHS aliasing by copying RHS into a temp, then
       // recursively assigning from that temp.
       auto descBytes{from.SizeInBytes()};
       StaticDescriptor<maxRank, true, 16> staticDesc;
       Descriptor &newFrom{staticDesc.descriptor()};
       std::memcpy(&newFrom, &from, descBytes);
       auto stat{ReturnError(terminator, newFrom.Allocate())};
       if (stat == StatOk) {
         char *toAt{newFrom.OffsetElement()};
         std::size_t fromElements{from.Elements()};
-        std::size_t elementBytes{from.ElementBytes()};
         if (from.IsContiguous()) {
-          std::memcpy(toAt, from.OffsetElement(), fromElements * elementBytes);
+          std::memcpy(
+              toAt, from.OffsetElement(), fromElements * fromElementBytes);
         } else {
           SubscriptValue fromAt[maxRank];
           for (from.GetLowerBounds(fromAt); fromElements-- > 0;
-               toAt += elementBytes, from.IncrementSubscripts(fromAt)) {
-            std::memcpy(toAt, from.Element<char>(fromAt), elementBytes);
+               toAt += fromElementBytes, from.IncrementSubscripts(fromAt)) {
+            std::memcpy(toAt, from.Element<char>(fromAt), fromElementBytes);
           }
         }
-        Assign(to, newFrom, terminator, /*maybeReallocate=*/false,
-            needFinalization, false, componentCanBeDefinedAssignment);
+        Assign(to, newFrom, terminator,
+            flags &
+                (NeedFinalization | ComponentCanBeDefinedAssignment |
+                    ExplicitLengthCharacterLHS));
         newFrom.Deallocate();
       }
       return;
     }
   }
   if (to.IsAllocatable()) {
     if (mustDeallocateLHS) {
       if (deferDeallocation) {
-        if (needFinalization && toDerived) {
+        if ((flags & NeedFinalization) && toDerived) {
           Finalize(to, *toDerived);
-          needFinalization = false;
+          flags &= ~NeedFinalization;
         }
       } else {
-        to.Destroy(/*finalize=*/needFinalization);
-        needFinalization = false;
+        to.Destroy((flags & NeedFinalization) != 0);
+        flags &= ~NeedFinalization;
       }
-    } else if (to.rank() != from.rank()) {
+    } else if (to.rank() != from.rank() && !to.IsAllocated()) {
       terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
                        "unallocated allocatable",
           to.rank(), from.rank());
     }
     if (!to.IsAllocated()) {
-      if (AllocateAssignmentLHS(to, from, terminator) != StatOk) {
+      if (AllocateAssignmentLHS(to, from, terminator, flags) != StatOk) {
         return;
       }
-      needFinalization = false;
+      flags &= ~NeedFinalization;
+      toElementBytes = to.ElementBytes(); // may have changed
     }
   }
   SubscriptValue toAt[maxRank];
   to.GetLowerBounds(toAt);
   // Scalar expansion of the RHS is implied by using the same empty
   // subscript values on each (seemingly) elemental reference into
   // "from".
   SubscriptValue fromAt[maxRank];
   from.GetLowerBounds(fromAt);
   std::size_t toElements{to.Elements()};
   if (from.rank() > 0 && toElements != from.Elements()) {
     terminator.Crash("Assign: mismatching element counts in array assignment "
                      "(to %zd, from %zd)",
         toElements, from.Elements());
   }
   if (to.type() != from.type()) {
     terminator.Crash("Assign: mismatching types (to code %d != from code %d)",
         to.type().raw(), from.type().raw());
   }
-  std::size_t elementBytes{to.ElementBytes()};
-  if (elementBytes != from.ElementBytes()) {
-    terminator.Crash(
-        "Assign: mismatching element sizes (to %zd bytes != from %zd bytes)",
-        elementBytes, from.ElementBytes());
+  if (toElementBytes > fromElementBytes && !to.type().IsCharacter()) {
+    terminator.Crash("Assign: mismatching non-character element sizes (to %zd "
+                     "bytes != from %zd bytes)",
+        toElementBytes, fromElementBytes);
   }
   if (const typeInfo::DerivedType *
       updatedToDerived{toAddendum ? toAddendum->derivedType() : nullptr}) {
     // Derived type intrinsic assignment, which is componentwise and elementwise
     // for all components, including parent components (10.2.1.2-3).
     // The target is first finalized if still necessary (7.5.6.3(1))
-    if (needFinalization) {
+    if (flags & NeedFinalization) {
       Finalize(to, *updatedToDerived);
     }
     // Copy the data components (incl. the parent) first.
     const Descriptor &componentDesc{updatedToDerived->component()};
     std::size_t numComponents{componentDesc.Elements()};
     for (std::size_t k{0}; k < numComponents; ++k) {
       const auto &comp{
           *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
               k)}; // TODO: exploit contiguity here
+      // Use PolymorphicLHS for components so that the right things happen
+      // when the components are polymorphic; when they're not, they're both
+      // not, and their declared types will match.
+      int nestedFlags{MaybeReallocate | PolymorphicLHS};
+      if (comp.genre() != typeInfo::Component::Genre::Allocatable &&
+          (flags & ComponentCanBeDefinedAssignment)) {
+        // Allocatable components are assigned via intrinsic assignment,
+        // not defined assignment (see F'2018 10.2.1.3 paragraph 13).
+        nestedFlags |= CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;
+      }
       switch (comp.genre()) {
       case typeInfo::Component::Genre::Data:
         if (comp.category() == TypeCategory::Derived) {
           StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
           Descriptor &toCompDesc{statDesc[0].descriptor()};
           Descriptor &fromCompDesc{statDesc[1].descriptor()};
           for (std::size_t j{0}; j < toElements; ++j,
                to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
             comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt);
             comp.CreatePointerDescriptor(
                 fromCompDesc, from, terminator, fromAt);
-            Assign(toCompDesc, fromCompDesc, terminator,
-                /*maybeReallocate=*/true,
-                /*needFinalization=*/false, componentCanBeDefinedAssignment,
-                componentCanBeDefinedAssignment);
+            Assign(toCompDesc, fromCompDesc, terminator, nestedFlags);
           }
         } else { // Component has intrinsic type; simply copy raw bytes
           std::size_t componentByteSize{comp.SizeInBytes(to)};
           for (std::size_t j{0}; j < toElements; ++j,
                to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
             std::memmove(to.Element<char>(toAt) + comp.offset(),
                 from.Element<const char>(fromAt) + comp.offset(),
                 componentByteSize);
for (std::size_t k{0}; k < numComponents; ++k) {
               // which might be able to avoid deallocation/reallocation
               // when the existing allocation can be reoccupied.
               toDesc->Destroy(false /*already finalized*/);
             }
             if (!fromDesc->IsAllocated()) {
               continue; // F'2018 10.2.1.3(13)(2)
             }
           }
-          Assign(*toDesc, *fromDesc, terminator, /*maybeReallocate=*/true,
-              /*needFinalization=*/false, componentCanBeDefinedAssignment,
-              componentCanBeDefinedAssignment);
+          Assign(*toDesc, *fromDesc, terminator, nestedFlags);
         }
         break;
       }
     }
     // Copy procedure pointer components
     const Descriptor &procPtrDesc{updatedToDerived->procPtr()};
     std::size_t numProcPtrs{procPtrDesc.Elements()};
     for (std::size_t k{0}; k < numProcPtrs; ++k) {
       const auto &procPtr{
           *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
       for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt),
            from.IncrementSubscripts(fromAt)) {
         std::memmove(to.Element<char>(toAt) + procPtr.offset,
             from.Element<const char>(fromAt) + procPtr.offset,
             sizeof(typeInfo::ProcedurePointer));
       }
     }
   } else { // intrinsic type, intrinsic assignment
-    if (isSimpleMemmove) {
-      std::memmove(
-          to.raw().base_addr, from.raw().base_addr, toElements * elementBytes);
-    } else { // elemental copies
+    if (isSimpleMemmove()) {
+      std::memmove(to.raw().base_addr, from.raw().base_addr,
+          toElements * toElementBytes);
+    } else if (toElementBytes > fromElementBytes) { // blank padding
+      switch (to.type().raw()) {
+      case CFI_type_signed_char:
+      case CFI_type_char:
+        BlankPadCharacterAssignment<char>(to, from, toAt, fromAt, toElements,
+            toElementBytes, fromElementBytes);
+        break;
+      case CFI_type_char16_t:
+        BlankPadCharacterAssignment<char16_t>(to, from, toAt, fromAt,
+            toElements, toElementBytes, fromElementBytes);
+        break;
+      case CFI_type_char32_t:
+        BlankPadCharacterAssignment<char32_t>(to, from, toAt, fromAt,
+            toElements, toElementBytes, fromElementBytes);
+        break;
+      default:
+        terminator.Crash("unexpected type code %d in blank padded Assign()",
+            to.type().raw());
+      }
+    } else { // elemental copies, possibly with character truncation
       for (std::size_t n{toElements}; n-- > 0;
            to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
         std::memmove(to.Element<char>(toAt), from.Element<const char>(fromAt),
-            elementBytes);
+            toElementBytes);
       }
     }
   }
   if (deferDeallocation) {
     deferDeallocation->Destroy();
   }
 }
 
 void DoFromSourceAssign(
     Descriptor &alloc, const Descriptor &source, Terminator &terminator) {
   if (alloc.rank() > 0 && source.rank() == 0) {
     // The value of each element of allocate object becomes the value of source.
     DescriptorAddendum *allocAddendum{alloc.Addendum()};
     const typeInfo::DerivedType *allocDerived{
         allocAddendum ? allocAddendum->derivedType() : nullptr};
     SubscriptValue allocAt[maxRank];
     alloc.GetLowerBounds(allocAt);
     if (allocDerived) {
       for (std::size_t n{alloc.Elements()}; n-- > 0;
            alloc.IncrementSubscripts(allocAt)) {
         Descriptor allocElement{*Descriptor::Create(*allocDerived,
             reinterpret_cast<void *>(alloc.Element<char>(allocAt)), 0)};
-        Assign(allocElement, source, terminator, /*maybeReallocate=*/false,
-            /*needFinalization=*/false, false, false);
+        Assign(allocElement, source, terminator, NoAssignFlags);
       }
     } else { // intrinsic type
       for (std::size_t n{alloc.Elements()}; n-- > 0;
            alloc.IncrementSubscripts(allocAt)) {
         std::memmove(alloc.Element<char>(allocAt), source.raw().base_addr,
             alloc.ElementBytes());
       }
     }
   } else {
-    Assign(alloc, source, terminator, /*maybeReallocate=*/false,
-        /*needFinalization=*/false, false, false);
+    Assign(alloc, source, terminator, NoAssignFlags);
   }
 }
 
 extern "C" {
 void RTNAME(Assign)(Descriptor &to, const Descriptor &from,
     const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   // All top-level defined assignments can be recognized in semantics and
   // will have been already been converted to calls, so don't check for
   // defined assignment apart from components.
-  Assign(to, from, terminator, /*maybeReallocate=*/true,
-      /*needFinalization=*/true,
-      /*canBeDefinedAssignment=*/false,
-      /*componentCanBeDefinedAssignment=*/true);
+  Assign(to, from, terminator,
+      MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment);
 }
 
 void RTNAME(AssignTemporary)(Descriptor &to, const Descriptor &from,
     const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
-  Assign(to, from, terminator, /*maybeReallocate=*/false,
-      /*needFinalization=*/false,
-      /*canBeDefinedAssignment=*/false,
-      /*componentCanBeDefinedAssignment=*/false);
+  Assign(to, from, terminator, PolymorphicLHS);
 }
 
+void RTNAME(AssignExplicitLengthCharacter)(Descriptor &to,
+    const Descriptor &from, const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  Assign(to, from, terminator,
+      MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
+          ExplicitLengthCharacterLHS);
+}
+
+void RTNAME(AssignPolymorphic)(Descriptor &to, const Descriptor &from,
+    const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  Assign(to, from, terminator,
+      MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
+          PolymorphicLHS);
+}
 } // extern "C"
 } // namespace Fortran::runtime

flang/runtime/type-info.h

public:
   const Value *bounds() const {
     return bounds_.descriptor().OffsetElement<const Value>();
   }
   const char *initialization() const { return initialization_; }
 
   std::size_t GetElementByteSize(const Descriptor &) const;
   std::size_t GetElements(const Descriptor &) const;
 
-  // For ocmponents that are descriptors, returns size of descriptor;
+  // For components that are descriptors, returns size of descriptor;
   // for Genre::Data, returns elemental byte size times element count.
   std::size_t SizeInBytes(const Descriptor &) const;
 
   // Establishes a descriptor from this component description.
   void EstablishDescriptor(
       Descriptor &, const Descriptor &container, Terminator &) const;
 
   // Creates a pointer descriptor from this component description, possibly