flang/runtime/assign.cpp

   1 //===-- runtime/assign.cpp ------------------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "flang/Runtime/assign.h"
  10 #include "assign-impl.h"
  11 #include "derived.h"
  12 #include "stat.h"
  13 #include "terminator.h"
  14 #include "tools.h"
  15 #include "type-info.h"
  16 #include "flang/Runtime/descriptor.h"
  17
  18 namespace Fortran::runtime {
  19
  20 enum AssignFlags {
  21   NoAssignFlags = 0,
  22   MaybeReallocate = 1 << 0,
  23   NeedFinalization = 1 << 1,
  24   CanBeDefinedAssignment = 1 << 2,
  25   ComponentCanBeDefinedAssignment = 1 << 3,
  26   ExplicitLengthCharacterLHS = 1 << 4,
  27   PolymorphicLHS = 1 << 5,
  28   DeallocateLHS = 1 << 6
  29 };
  30
  31 // Predicate: is the left-hand side of an assignment an allocated allocatable
  32 // that must be deallocated?
  33 static inline RT_API_ATTRS bool MustDeallocateLHS(
  34     Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
  35   // Top-level assignments to allocatable variables (*not* components)
  36   // may first deallocate existing content if there's about to be a
  37   // change in type or shape; see F'2018 10.2.1.3(3).
  38   if (!(flags & MaybeReallocate)) {
  39     return false;
  40   }
  41   if (!to.IsAllocatable() || !to.IsAllocated()) {
  42     return false;
  43   }
  44   if (to.type() != from.type()) {
  45     return true;
  46   }
  47   if (!(flags & ExplicitLengthCharacterLHS) && to.type().IsCharacter() &&
  48       to.ElementBytes() != from.ElementBytes()) {
  49     return true;
  50   }
  51   if (flags & PolymorphicLHS) {
  52     DescriptorAddendum *toAddendum{to.Addendum()};
  53     const typeInfo::DerivedType *toDerived{
  54         toAddendum ? toAddendum->derivedType() : nullptr};
  55     const DescriptorAddendum *fromAddendum{from.Addendum()};
  56     const typeInfo::DerivedType *fromDerived{
  57         fromAddendum ? fromAddendum->derivedType() : nullptr};
  58     if (toDerived != fromDerived) {
  59       return true;
  60     }
  61     if (fromDerived) {
  62       // Distinct LEN parameters? Deallocate
  63       std::size_t lenParms{fromDerived->LenParameters()};
  64       for (std::size_t j{0}; j < lenParms; ++j) {
  65         if (toAddendum->LenParameterValue(j) !=
  66             fromAddendum->LenParameterValue(j)) {
  67           return true;
  68         }
  69       }
  70     }
  71   }
  72   if (from.rank() > 0) {
  73     // Distinct shape? Deallocate
  74     int rank{to.rank()};
  75     for (int j{0}; j < rank; ++j) {
  76       if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) {
  77         return true;
  78       }
  79     }
  80   }
  81   return false;
  82 }
  83
  84 // Utility: allocate the allocatable left-hand side, either because it was
  85 // originally deallocated or because it required reallocation
  86 static RT_API_ATTRS int AllocateAssignmentLHS(
  87     Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
  88   to.raw().type = from.raw().type;
  89   if (!(flags & ExplicitLengthCharacterLHS)) {
  90     to.raw().elem_len = from.ElementBytes();
  91   }
  92   const typeInfo::DerivedType *derived{nullptr};
  93   if (const DescriptorAddendum * fromAddendum{from.Addendum()}) {
  94     derived = fromAddendum->derivedType();
  95     if (DescriptorAddendum * toAddendum{to.Addendum()}) {
  96       toAddendum->set_derivedType(derived);
  97       std::size_t lenParms{derived ? derived->LenParameters() : 0};
  98       for (std::size_t j{0}; j < lenParms; ++j) {
  99         toAddendum->SetLenParameterValue(j, fromAddendum->LenParameterValue(j));
 100       }
 101     }
 102   }
 103   // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3))
 104   int rank{from.rank()};
 105   auto stride{static_cast<SubscriptValue>(to.ElementBytes())};
 106   for (int j{0}; j < rank; ++j) {
 107     auto &toDim{to.GetDimension(j)};
 108     const auto &fromDim{from.GetDimension(j)};
 109     toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound());
 110     toDim.SetByteStride(stride);
 111     stride *= toDim.Extent();
 112   }
 113   int result{ReturnError(terminator, to.Allocate())};
 114   if (result == StatOk && derived && !derived->noInitializationNeeded()) {
 115     result = ReturnError(terminator, Initialize(to, *derived, terminator));
 116   }
 117   return result;
 118 }
 119
 120 // least <= 0, most >= 0
 121 static RT_API_ATTRS void MaximalByteOffsetRange(
 122     const Descriptor &desc, std::int64_t &least, std::int64_t &most) {
 123   least = most = 0;
 124   if (desc.ElementBytes() == 0) {
 125     return;
 126   }
 127   int n{desc.raw().rank};
 128   for (int j{0}; j < n; ++j) {
 129     const auto &dim{desc.GetDimension(j)};
 130     auto extent{dim.Extent()};
 131     if (extent > 0) {
 132       auto sm{dim.ByteStride()};
 133       if (sm < 0) {
 134         least += (extent - 1) * sm;
 135       } else {
 136         most += (extent - 1) * sm;
 137       }
 138     }
 139   }
 140   most += desc.ElementBytes() - 1;
 141 }
 142
 143 static inline RT_API_ATTRS bool RangesOverlap(const char *aStart,
 144     const char *aEnd, const char *bStart, const char *bEnd) {
 145   return aEnd >= bStart && bEnd >= aStart;
 146 }
 147
 148 // Predicate: could the left-hand and right-hand sides of the assignment
 149 // possibly overlap in memory?  Note that the descriptors themeselves
 150 // are included in the test.
 151 static RT_API_ATTRS bool MayAlias(const Descriptor &x, const Descriptor &y) {
 152   const char *xBase{x.OffsetElement()};
 153   const char *yBase{y.OffsetElement()};
 154   if (!xBase || !yBase) {
 155     return false; // not both allocated
 156   }
 157   const char *xDesc{reinterpret_cast<const char *>(&x)};
 158   const char *xDescLast{xDesc + x.SizeInBytes()};
 159   const char *yDesc{reinterpret_cast<const char *>(&y)};
 160   const char *yDescLast{yDesc + y.SizeInBytes()};
 161   std::int64_t xLeast, xMost, yLeast, yMost;
 162   MaximalByteOffsetRange(x, xLeast, xMost);
 163   MaximalByteOffsetRange(y, yLeast, yMost);
 164   if (RangesOverlap(xDesc, xDescLast, yBase + yLeast, yBase + yMost) ||
 165       RangesOverlap(yDesc, yDescLast, xBase + xLeast, xBase + xMost)) {
 166     // A descriptor overlaps with the storage described by the other;
 167     // this can arise when an allocatable or pointer component is
 168     // being assigned to/from.
 169     return true;
 170   }
 171   if (!RangesOverlap(
 172           xBase + xLeast, xBase + xMost, yBase + yLeast, yBase + yMost)) {
 173     return false; // no storage overlap
 174   }
 175   // TODO: check dimensions: if any is independent, return false
 176   return true;
 177 }
 178
 179 static RT_API_ATTRS void DoScalarDefinedAssignment(const Descriptor &to,
 180     const Descriptor &from, const typeInfo::SpecialBinding &special) {
 181   bool toIsDesc{special.IsArgDescriptor(0)};
 182   bool fromIsDesc{special.IsArgDescriptor(1)};
 183   if (toIsDesc) {
 184     if (fromIsDesc) {
 185       auto *p{
 186           special.GetProc<void (*)(const Descriptor &, const Descriptor &)>()};
 187       p(to, from);
 188     } else {
 189       auto *p{special.GetProc<void (*)(const Descriptor &, void *)>()};
 190       p(to, from.raw().base_addr);
 191     }
 192   } else {
 193     if (fromIsDesc) {
 194       auto *p{special.GetProc<void (*)(void *, const Descriptor &)>()};
 195       p(to.raw().base_addr, from);
 196     } else {
 197       auto *p{special.GetProc<void (*)(void *, void *)>()};
 198       p(to.raw().base_addr, from.raw().base_addr);
 199     }
 200   }
 201 }
 202
 203 static RT_API_ATTRS void DoElementalDefinedAssignment(const Descriptor &to,
 204     const Descriptor &from, const typeInfo::DerivedType &derived,
 205     const typeInfo::SpecialBinding &special) {
 206   SubscriptValue toAt[maxRank], fromAt[maxRank];
 207   to.GetLowerBounds(toAt);
 208   from.GetLowerBounds(fromAt);
 209   StaticDescriptor<maxRank, true, 8 /*?*/> statDesc[2];
 210   Descriptor &toElementDesc{statDesc[0].descriptor()};
 211   Descriptor &fromElementDesc{statDesc[1].descriptor()};
 212   toElementDesc.Establish(derived, nullptr, 0, nullptr, CFI_attribute_pointer);
 213   fromElementDesc.Establish(
 214       derived, nullptr, 0, nullptr, CFI_attribute_pointer);
 215   for (std::size_t toElements{to.Elements()}; toElements-- > 0;
 216        to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 217     toElementDesc.set_base_addr(to.Element<char>(toAt));
 218     fromElementDesc.set_base_addr(from.Element<char>(fromAt));
 219     DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special);
 220   }
 221 }
 222
 223 template <typename CHAR>
 224 static RT_API_ATTRS void BlankPadCharacterAssignment(Descriptor &to,
 225     const Descriptor &from, SubscriptValue toAt[], SubscriptValue fromAt[],
 226     std::size_t elements, std::size_t toElementBytes,
 227     std::size_t fromElementBytes) {
 228   std::size_t padding{(toElementBytes - fromElementBytes) / sizeof(CHAR)};
 229   std::size_t copiedCharacters{fromElementBytes / sizeof(CHAR)};
 230   for (; elements-- > 0;
 231        to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 232     CHAR *p{to.Element<CHAR>(toAt)};
 233     Fortran::runtime::memmove(
 234         p, from.Element<std::add_const_t<CHAR>>(fromAt), fromElementBytes);
 235     p += copiedCharacters;
 236     for (auto n{padding}; n-- > 0;) {
 237       *p++ = CHAR{' '};
 238     }
 239   }
 240 }
 241
 242 // Common implementation of assignments, both intrinsic assignments and
 243 // those cases of polymorphic user-defined ASSIGNMENT(=) TBPs that could not
 244 // be resolved in semantics.  Most assignment statements do not need any
 245 // of the capabilities of this function -- but when the LHS is allocatable,
 246 // the type might have a user-defined ASSIGNMENT(=), or the type might be
 247 // finalizable, this function should be used.
 248 // When "to" is not a whole allocatable, "from" is an array, and defined
 249 // assignments are not used, "to" and "from" only need to have the same number
 250 // of elements, but their shape need not to conform (the assignment is done in
 251 // element sequence order). This facilitates some internal usages, like when
 252 // dealing with array constructors.
 253 RT_API_ATTRS static void Assign(
 254     Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
 255   bool mustDeallocateLHS{(flags & DeallocateLHS) ||
 256       MustDeallocateLHS(to, from, terminator, flags)};
 257   DescriptorAddendum *toAddendum{to.Addendum()};
 258   const typeInfo::DerivedType *toDerived{
 259       toAddendum ? toAddendum->derivedType() : nullptr};
 260   if (toDerived && (flags & NeedFinalization) &&
 261       toDerived->noFinalizationNeeded()) {
 262     flags &= ~NeedFinalization;
 263   }
 264   std::size_t toElementBytes{to.ElementBytes()};
 265   std::size_t fromElementBytes{from.ElementBytes()};
 266   // The following lambda definition violates the conding style,
 267   // but cuda-11.8 nvcc hits an internal error with the brace initialization.
 268   auto isSimpleMemmove = [&]() {
 269     return !toDerived && to.rank() == from.rank() && to.IsContiguous() &&
 270         from.IsContiguous() && toElementBytes == fromElementBytes;
 271   };
 272   StaticDescriptor<maxRank, true, 10 /*?*/> deferredDeallocStatDesc;
 273   Descriptor *deferDeallocation{nullptr};
 274   if (MayAlias(to, from)) {
 275     if (mustDeallocateLHS) {
 276       deferDeallocation = &deferredDeallocStatDesc.descriptor();
 277       std::memcpy(deferDeallocation, &to, to.SizeInBytes());
 278       to.set_base_addr(nullptr);
 279     } else if (!isSimpleMemmove()) {
 280       // Handle LHS/RHS aliasing by copying RHS into a temp, then
 281       // recursively assigning from that temp.
 282       auto descBytes{from.SizeInBytes()};
 283       StaticDescriptor<maxRank, true, 16> staticDesc;
 284       Descriptor &newFrom{staticDesc.descriptor()};
 285       std::memcpy(&newFrom, &from, descBytes);
 286       // Pretend the temporary descriptor is for an ALLOCATABLE
 287       // entity, otherwise, the Deallocate() below will not
 288       // free the descriptor memory.
 289       newFrom.raw().attribute = CFI_attribute_allocatable;
 290       auto stat{ReturnError(terminator, newFrom.Allocate())};
 291       if (stat == StatOk) {
 292         if (HasDynamicComponent(from)) {
 293           // If 'from' has allocatable/automatic component, we cannot
 294           // just make a shallow copy of the descriptor member.
 295           // This will still leave data overlap in 'to' and 'newFrom'.
 296           // For example:
 297           //   type t
 298           //     character, allocatable :: c(:)
 299           //   end type t
 300           //   type(t) :: x(3)
 301           //   x(2:3) = x(1:2)
 302           // We have to make a deep copy into 'newFrom' in this case.
 303           RTNAME(AssignTemporary)
 304           (newFrom, from, terminator.sourceFileName(), terminator.sourceLine());
 305         } else {
 306           ShallowCopy(newFrom, from, true, from.IsContiguous());
 307         }
 308         Assign(to, newFrom, terminator,
 309             flags &
 310                 (NeedFinalization | ComponentCanBeDefinedAssignment |
 311                     ExplicitLengthCharacterLHS | CanBeDefinedAssignment));
 312         newFrom.Deallocate();
 313       }
 314       return;
 315     }
 316   }
 317   if (to.IsAllocatable()) {
 318     if (mustDeallocateLHS) {
 319       if (deferDeallocation) {
 320         if ((flags & NeedFinalization) && toDerived) {
 321           Finalize(to, *toDerived, &terminator);
 322           flags &= ~NeedFinalization;
 323         }
 324       } else {
 325         to.Destroy((flags & NeedFinalization) != 0, /*destroyPointers=*/false,
 326             &terminator);
 327         flags &= ~NeedFinalization;
 328       }
 329     } else if (to.rank() != from.rank() && !to.IsAllocated()) {
 330       terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
 331                        "unallocated allocatable",
 332           to.rank(), from.rank());
 333     }
 334     if (!to.IsAllocated()) {
 335       if (AllocateAssignmentLHS(to, from, terminator, flags) != StatOk) {
 336         return;
 337       }
 338       flags &= ~NeedFinalization;
 339       toElementBytes = to.ElementBytes(); // may have changed
 340     }
 341   }
 342   if (toDerived && (flags & CanBeDefinedAssignment)) {
 343     // Check for a user-defined assignment type-bound procedure;
 344     // see 10.2.1.4-5.  A user-defined assignment TBP defines all of
 345     // the semantics, including allocatable (re)allocation and any
 346     // finalization.
 347     //
 348     // Note that the aliasing and LHS (re)allocation handling above
 349     // needs to run even with CanBeDefinedAssignment flag, when
 350     // the Assign() is invoked recursively for component-per-component
 351     // assignments.
 352     if (to.rank() == 0) {
 353       if (const auto *special{toDerived->FindSpecialBinding(
 354               typeInfo::SpecialBinding::Which::ScalarAssignment)}) {
 355         return DoScalarDefinedAssignment(to, from, *special);
 356       }
 357     }
 358     if (const auto *special{toDerived->FindSpecialBinding(
 359             typeInfo::SpecialBinding::Which::ElementalAssignment)}) {
 360       return DoElementalDefinedAssignment(to, from, *toDerived, *special);
 361     }
 362   }
 363   SubscriptValue toAt[maxRank];
 364   to.GetLowerBounds(toAt);
 365   // Scalar expansion of the RHS is implied by using the same empty
 366   // subscript values on each (seemingly) elemental reference into
 367   // "from".
 368   SubscriptValue fromAt[maxRank];
 369   from.GetLowerBounds(fromAt);
 370   std::size_t toElements{to.Elements()};
 371   if (from.rank() > 0 && toElements != from.Elements()) {
 372     terminator.Crash("Assign: mismatching element counts in array assignment "
 373                      "(to %zd, from %zd)",
 374         toElements, from.Elements());
 375   }
 376   if (to.type() != from.type()) {
 377     terminator.Crash("Assign: mismatching types (to code %d != from code %d)",
 378         to.type().raw(), from.type().raw());
 379   }
 380   if (toElementBytes > fromElementBytes && !to.type().IsCharacter()) {
 381     terminator.Crash("Assign: mismatching non-character element sizes (to %zd "
 382                      "bytes != from %zd bytes)",
 383         toElementBytes, fromElementBytes);
 384   }
 385   if (const typeInfo::DerivedType *
 386       updatedToDerived{toAddendum ? toAddendum->derivedType() : nullptr}) {
 387     // Derived type intrinsic assignment, which is componentwise and elementwise
 388     // for all components, including parent components (10.2.1.2-3).
 389     // The target is first finalized if still necessary (7.5.6.3(1))
 390     if (flags & NeedFinalization) {
 391       Finalize(to, *updatedToDerived, &terminator);
 392     }
 393     // Copy the data components (incl. the parent) first.
 394     const Descriptor &componentDesc{updatedToDerived->component()};
 395     std::size_t numComponents{componentDesc.Elements()};
 396     for (std::size_t k{0}; k < numComponents; ++k) {
 397       const auto &comp{
 398           *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
 399               k)}; // TODO: exploit contiguity here
 400       // Use PolymorphicLHS for components so that the right things happen
 401       // when the components are polymorphic; when they're not, they're both
 402       // not, and their declared types will match.
 403       int nestedFlags{MaybeReallocate | PolymorphicLHS};
 404       if (flags & ComponentCanBeDefinedAssignment) {
 405         nestedFlags |= CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;
 406       }
 407       switch (comp.genre()) {
 408       case typeInfo::Component::Genre::Data:
 409         if (comp.category() == TypeCategory::Derived) {
 410           StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
 411           Descriptor &toCompDesc{statDesc[0].descriptor()};
 412           Descriptor &fromCompDesc{statDesc[1].descriptor()};
 413           for (std::size_t j{0}; j < toElements; ++j,
 414                to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 415             comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt);
 416             comp.CreatePointerDescriptor(
 417                 fromCompDesc, from, terminator, fromAt);
 418             Assign(toCompDesc, fromCompDesc, terminator, nestedFlags);
 419           }
 420         } else { // Component has intrinsic type; simply copy raw bytes
 421           std::size_t componentByteSize{comp.SizeInBytes(to)};
 422           for (std::size_t j{0}; j < toElements; ++j,
 423                to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 424             Fortran::runtime::memmove(to.Element<char>(toAt) + comp.offset(),
 425                 from.Element<const char>(fromAt) + comp.offset(),
 426                 componentByteSize);
 427           }
 428         }
 429         break;
 430       case typeInfo::Component::Genre::Pointer: {
 431         std::size_t componentByteSize{comp.SizeInBytes(to)};
 432         for (std::size_t j{0}; j < toElements; ++j,
 433              to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 434           Fortran::runtime::memmove(to.Element<char>(toAt) + comp.offset(),
 435               from.Element<const char>(fromAt) + comp.offset(),
 436               componentByteSize);
 437         }
 438       } break;
 439       case typeInfo::Component::Genre::Allocatable:
 440       case typeInfo::Component::Genre::Automatic:
 441         for (std::size_t j{0}; j < toElements; ++j,
 442              to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 443           auto *toDesc{reinterpret_cast<Descriptor *>(
 444               to.Element<char>(toAt) + comp.offset())};
 445           const auto *fromDesc{reinterpret_cast<const Descriptor *>(
 446               from.Element<char>(fromAt) + comp.offset())};
 447           // Allocatable components of the LHS are unconditionally
 448           // deallocated before assignment (F'2018 10.2.1.3(13)(1)),
 449           // unlike a "top-level" assignment to a variable, where
 450           // deallocation is optional.
 451           //
 452           // Be careful not to destroy/reallocate the LHS, if there is
 453           // overlap between LHS and RHS (it seems that partial overlap
 454           // is not possible, though).
 455           // Invoke Assign() recursively to deal with potential aliasing.
 456           if (toDesc->IsAllocatable()) {
 457             if (!fromDesc->IsAllocated()) {
 458               // No aliasing.
 459               //
 460               // If to is not allocated, the Destroy() call is a no-op.
 461               // This is just a shortcut, because the recursive Assign()
 462               // below would initiate the destruction for to.
 463               // No finalization is required.
 464               toDesc->Destroy(
 465                   /*finalize=*/false, /*destroyPointers=*/false, &terminator);
 466               continue; // F'2018 10.2.1.3(13)(2)
 467             }
 468           }
 469           // Force LHS deallocation with DeallocateLHS flag.
 470           // The actual deallocation may be avoided, if the existing
 471           // location can be reoccupied.
 472           Assign(*toDesc, *fromDesc, terminator, nestedFlags | DeallocateLHS);
 473         }
 474         break;
 475       }
 476     }
 477     // Copy procedure pointer components
 478     const Descriptor &procPtrDesc{updatedToDerived->procPtr()};
 479     std::size_t numProcPtrs{procPtrDesc.Elements()};
 480     for (std::size_t k{0}; k < numProcPtrs; ++k) {
 481       const auto &procPtr{
 482           *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
 483       for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt),
 484            from.IncrementSubscripts(fromAt)) {
 485         Fortran::runtime::memmove(to.Element<char>(toAt) + procPtr.offset,
 486             from.Element<const char>(fromAt) + procPtr.offset,
 487             sizeof(typeInfo::ProcedurePointer));
 488       }
 489     }
 490   } else { // intrinsic type, intrinsic assignment
 491     if (isSimpleMemmove()) {
 492       Fortran::runtime::memmove(to.raw().base_addr, from.raw().base_addr,
 493           toElements * toElementBytes);
 494     } else if (toElementBytes > fromElementBytes) { // blank padding
 495       switch (to.type().raw()) {
 496       case CFI_type_signed_char:
 497       case CFI_type_char:
 498         BlankPadCharacterAssignment<char>(to, from, toAt, fromAt, toElements,
 499             toElementBytes, fromElementBytes);
 500         break;
 501       case CFI_type_char16_t:
 502         BlankPadCharacterAssignment<char16_t>(to, from, toAt, fromAt,
 503             toElements, toElementBytes, fromElementBytes);
 504         break;
 505       case CFI_type_char32_t:
 506         BlankPadCharacterAssignment<char32_t>(to, from, toAt, fromAt,
 507             toElements, toElementBytes, fromElementBytes);
 508         break;
 509       default:
 510         terminator.Crash("unexpected type code %d in blank padded Assign()",
 511             to.type().raw());
 512       }
 513     } else { // elemental copies, possibly with character truncation
 514       for (std::size_t n{toElements}; n-- > 0;
 515            to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 516         Fortran::runtime::memmove(to.Element<char>(toAt),
 517             from.Element<const char>(fromAt), toElementBytes);
 518       }
 519     }
 520   }
 521   if (deferDeallocation) {
 522     // deferDeallocation is used only when LHS is an allocatable.
 523     // The finalization has already been run for it.
 524     deferDeallocation->Destroy(
 525         /*finalize=*/false, /*destroyPointers=*/false, &terminator);
 526   }
 527 }
 528
 529 RT_OFFLOAD_API_GROUP_BEGIN
 530
 531 RT_API_ATTRS void DoFromSourceAssign(
 532     Descriptor &alloc, const Descriptor &source, Terminator &terminator) {
 533   if (alloc.rank() > 0 && source.rank() == 0) {
 534     // The value of each element of allocate object becomes the value of source.
 535     DescriptorAddendum *allocAddendum{alloc.Addendum()};
 536     const typeInfo::DerivedType *allocDerived{
 537         allocAddendum ? allocAddendum->derivedType() : nullptr};
 538     SubscriptValue allocAt[maxRank];
 539     alloc.GetLowerBounds(allocAt);
 540     if (allocDerived) {
 541       for (std::size_t n{alloc.Elements()}; n-- > 0;
 542            alloc.IncrementSubscripts(allocAt)) {
 543         Descriptor allocElement{*Descriptor::Create(*allocDerived,
 544             reinterpret_cast<void *>(alloc.Element<char>(allocAt)), 0)};
 545         Assign(allocElement, source, terminator, NoAssignFlags);
 546       }
 547     } else { // intrinsic type
 548       for (std::size_t n{alloc.Elements()}; n-- > 0;
 549            alloc.IncrementSubscripts(allocAt)) {
 550         Fortran::runtime::memmove(alloc.Element<char>(allocAt),
 551             source.raw().base_addr, alloc.ElementBytes());
 552       }
 553     }
 554   } else {
 555     Assign(alloc, source, terminator, NoAssignFlags);
 556   }
 557 }
 558
 559 RT_OFFLOAD_API_GROUP_END
 560
 561 extern "C" {
 562 RT_EXT_API_GROUP_BEGIN
 563
 564 void RTDEF(Assign)(Descriptor &to, const Descriptor &from,
 565     const char *sourceFile, int sourceLine) {
 566   Terminator terminator{sourceFile, sourceLine};
 567   // All top-level defined assignments can be recognized in semantics and
 568   // will have been already been converted to calls, so don't check for
 569   // defined assignment apart from components.
 570   Assign(to, from, terminator,
 571       MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment);
 572 }
 573
 574 void RTDEF(AssignTemporary)(Descriptor &to, const Descriptor &from,
 575     const char *sourceFile, int sourceLine) {
 576   Terminator terminator{sourceFile, sourceLine};
 577   // Initialize the "to" if it is of derived type that needs initialization.
 578   if (const DescriptorAddendum * addendum{to.Addendum()}) {
 579     if (const auto *derived{addendum->derivedType()}) {
 580       // Do not invoke the initialization, if the descriptor is unallocated.
 581       // AssignTemporary() is used for component-by-component assignments,
 582       // for example, for structure constructors. This means that the LHS
 583       // may be an allocatable component with unallocated status.
 584       // The initialization will just fail in this case. By skipping
 585       // the initialization we let Assign() automatically allocate
 586       // and initialize the component according to the RHS.
 587       // So we only need to initialize the LHS here if it is allocated.
 588       // Note that initializing already initialized entity has no visible
 589       // effect, though, it is assumed that the compiler does not initialize
 590       // the temporary and leaves the initialization to this runtime code.
 591       if (!derived->noInitializationNeeded() && to.IsAllocated()) {
 592         if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=
 593             StatOk) {
 594           return;
 595         }
 596       }
 597     }
 598   }
 599
 600   Assign(to, from, terminator, PolymorphicLHS);
 601 }
 602
 603 void RTDEF(CopyOutAssign)(Descriptor &to, const Descriptor &from,
 604     bool skipToInit, const char *sourceFile, int sourceLine) {
 605   Terminator terminator{sourceFile, sourceLine};
 606   // Initialize the "to" if it is of derived type that needs initialization.
 607   if (!skipToInit) {
 608     if (const DescriptorAddendum * addendum{to.Addendum()}) {
 609       if (const auto *derived{addendum->derivedType()}) {
 610         if (!derived->noInitializationNeeded()) {
 611           if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=
 612               StatOk) {
 613             return;
 614           }
 615         }
 616       }
 617     }
 618   }
 619
 620   // Copyout from the temporary must not cause any finalizations
 621   // for LHS.
 622   Assign(to, from, terminator, NoAssignFlags);
 623 }
 624
 625 void RTDEF(AssignExplicitLengthCharacter)(Descriptor &to,
 626     const Descriptor &from, const char *sourceFile, int sourceLine) {
 627   Terminator terminator{sourceFile, sourceLine};
 628   Assign(to, from, terminator,
 629       MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
 630           ExplicitLengthCharacterLHS);
 631 }
 632
 633 void RTDEF(AssignPolymorphic)(Descriptor &to, const Descriptor &from,
 634     const char *sourceFile, int sourceLine) {
 635   Terminator terminator{sourceFile, sourceLine};
 636   Assign(to, from, terminator,
 637       MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
 638           PolymorphicLHS);
 639 }
 640
 641 RT_EXT_API_GROUP_END
 642 } // extern "C"
 643 } // namespace Fortran::runtime