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