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

source code of flang-rt/lib/runtime/assign.cpp