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
18namespace Fortran::runtime {
19
20enum 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?
33static 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
86static 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
121static 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
143static 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.
151static 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
179static 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
203static 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(to: toElementDesc, from: fromElementDesc, special);
220 }
221}
222
223template <typename CHAR>
224static 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.
253RT_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(x: to, y: from)) {
275 if (mustDeallocateLHS) {
276 deferDeallocation = &deferredDeallocStatDesc.descriptor();
277 std::memcpy(dest: deferDeallocation, src: &to, n: 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(dest: &newFrom, src: &from, n: 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, from: newFrom, terminator,
309 flags: 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, derived: *toDerived, &terminator);
322 flags &= ~NeedFinalization;
323 } else if (toDerived && !toDerived->noDestructionNeeded()) {
324 Destroy(to, /*finalize=*/false, *toDerived, &terminator);
325 }
326 } else {
327 to.Destroy((flags & NeedFinalization) != 0, /*destroyPointers=*/false,
328 &terminator);
329 flags &= ~NeedFinalization;
330 }
331 } else if (to.rank() != from.rank() && !to.IsAllocated()) {
332 terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
333 "unallocated allocatable",
334 to.rank(), from.rank());
335 }
336 if (!to.IsAllocated()) {
337 if (AllocateAssignmentLHS(to, from, terminator, flags) != StatOk) {
338 return;
339 }
340 flags &= ~NeedFinalization;
341 toElementBytes = to.ElementBytes(); // may have changed
342 }
343 }
344 if (toDerived && (flags & CanBeDefinedAssignment)) {
345 // Check for a user-defined assignment type-bound procedure;
346 // see 10.2.1.4-5. A user-defined assignment TBP defines all of
347 // the semantics, including allocatable (re)allocation and any
348 // finalization.
349 //
350 // Note that the aliasing and LHS (re)allocation handling above
351 // needs to run even with CanBeDefinedAssignment flag, when
352 // the Assign() is invoked recursively for component-per-component
353 // assignments.
354 if (to.rank() == 0) {
355 if (const auto *special{toDerived->FindSpecialBinding(
356 typeInfo::SpecialBinding::Which::ScalarAssignment)}) {
357 return DoScalarDefinedAssignment(to, from, *special);
358 }
359 }
360 if (const auto *special{toDerived->FindSpecialBinding(
361 typeInfo::SpecialBinding::Which::ElementalAssignment)}) {
362 return DoElementalDefinedAssignment(to, from, *toDerived, *special);
363 }
364 }
365 SubscriptValue toAt[maxRank];
366 to.GetLowerBounds(toAt);
367 // Scalar expansion of the RHS is implied by using the same empty
368 // subscript values on each (seemingly) elemental reference into
369 // "from".
370 SubscriptValue fromAt[maxRank];
371 from.GetLowerBounds(fromAt);
372 std::size_t toElements{to.Elements()};
373 if (from.rank() > 0 && toElements != from.Elements()) {
374 terminator.Crash("Assign: mismatching element counts in array assignment "
375 "(to %zd, from %zd)",
376 toElements, from.Elements());
377 }
378 if (to.type() != from.type()) {
379 terminator.Crash("Assign: mismatching types (to code %d != from code %d)",
380 to.type().raw(), from.type().raw());
381 }
382 if (toElementBytes > fromElementBytes && !to.type().IsCharacter()) {
383 terminator.Crash("Assign: mismatching non-character element sizes (to %zd "
384 "bytes != from %zd bytes)",
385 toElementBytes, fromElementBytes);
386 }
387 if (const typeInfo::DerivedType *
388 updatedToDerived{toAddendum ? toAddendum->derivedType() : nullptr}) {
389 // Derived type intrinsic assignment, which is componentwise and elementwise
390 // for all components, including parent components (10.2.1.2-3).
391 // The target is first finalized if still necessary (7.5.6.3(1))
392 if (flags & NeedFinalization) {
393 Finalize(to, derived: *updatedToDerived, &terminator);
394 } else if (updatedToDerived && !updatedToDerived->noDestructionNeeded()) {
395 Destroy(to, /*finalize=*/false, *updatedToDerived, &terminator);
396 }
397 // Copy the data components (incl. the parent) first.
398 const Descriptor &componentDesc{updatedToDerived->component()};
399 std::size_t numComponents{componentDesc.Elements()};
400 for (std::size_t j{0}; j < toElements;
401 ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
402 for (std::size_t k{0}; k < numComponents; ++k) {
403 const auto &comp{
404 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
405 k)}; // TODO: exploit contiguity here
406 // Use PolymorphicLHS for components so that the right things happen
407 // when the components are polymorphic; when they're not, they're both
408 // not, and their declared types will match.
409 int nestedFlags{MaybeReallocate | PolymorphicLHS};
410 if (flags & ComponentCanBeDefinedAssignment) {
411 nestedFlags |=
412 CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;
413 }
414 switch (comp.genre()) {
415 case typeInfo::Component::Genre::Data:
416 if (comp.category() == TypeCategory::Derived) {
417 StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
418 Descriptor &toCompDesc{statDesc[0].descriptor()};
419 Descriptor &fromCompDesc{statDesc[1].descriptor()};
420 comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt);
421 comp.CreatePointerDescriptor(
422 fromCompDesc, from, terminator, fromAt);
423 Assign(to&: toCompDesc, from: fromCompDesc, terminator, flags: nestedFlags);
424 } else { // Component has intrinsic type; simply copy raw bytes
425 std::size_t componentByteSize{comp.SizeInBytes(to)};
426 Fortran::runtime::memmove(to.Element<char>(toAt) + comp.offset(),
427 from.Element<const char>(fromAt) + comp.offset(),
428 componentByteSize);
429 }
430 break;
431 case typeInfo::Component::Genre::Pointer: {
432 std::size_t componentByteSize{comp.SizeInBytes(to)};
433 Fortran::runtime::memmove(to.Element<char>(toAt) + comp.offset(),
434 from.Element<const char>(fromAt) + comp.offset(),
435 componentByteSize);
436 } break;
437 case typeInfo::Component::Genre::Allocatable:
438 case typeInfo::Component::Genre::Automatic: {
439 auto *toDesc{reinterpret_cast<Descriptor *>(
440 to.Element<char>(toAt) + comp.offset())};
441 const auto *fromDesc{reinterpret_cast<const Descriptor *>(
442 from.Element<char>(fromAt) + comp.offset())};
443 // Allocatable components of the LHS are unconditionally
444 // deallocated before assignment (F'2018 10.2.1.3(13)(1)),
445 // unlike a "top-level" assignment to a variable, where
446 // deallocation is optional.
447 //
448 // Be careful not to destroy/reallocate the LHS, if there is
449 // overlap between LHS and RHS (it seems that partial overlap
450 // is not possible, though).
451 // Invoke Assign() recursively to deal with potential aliasing.
452 if (toDesc->IsAllocatable()) {
453 if (!fromDesc->IsAllocated()) {
454 // No aliasing.
455 //
456 // If to is not allocated, the Destroy() call is a no-op.
457 // This is just a shortcut, because the recursive Assign()
458 // below would initiate the destruction for to.
459 // No finalization is required.
460 toDesc->Destroy(
461 /*finalize=*/false, /*destroyPointers=*/false, &terminator);
462 continue; // F'2018 10.2.1.3(13)(2)
463 }
464 }
465 // Force LHS deallocation with DeallocateLHS flag.
466 // The actual deallocation may be avoided, if the existing
467 // location can be reoccupied.
468 Assign(*toDesc, *fromDesc, terminator, nestedFlags | DeallocateLHS);
469 } break;
470 }
471 }
472 // Copy procedure pointer components
473 const Descriptor &procPtrDesc{updatedToDerived->procPtr()};
474 std::size_t numProcPtrs{procPtrDesc.Elements()};
475 for (std::size_t k{0}; k < numProcPtrs; ++k) {
476 const auto &procPtr{
477 *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(
478 k)};
479 Fortran::runtime::memmove(to.Element<char>(toAt) + procPtr.offset,
480 from.Element<const char>(fromAt) + procPtr.offset,
481 sizeof(typeInfo::ProcedurePointer));
482 }
483 }
484 } else { // intrinsic type, intrinsic assignment
485 if (isSimpleMemmove()) {
486 Fortran::runtime::memmove(to.raw().base_addr, from.raw().base_addr,
487 toElements * toElementBytes);
488 } else if (toElementBytes > fromElementBytes) { // blank padding
489 switch (to.type().raw()) {
490 case CFI_type_signed_char:
491 case CFI_type_char:
492 BlankPadCharacterAssignment<char>(to, from, toAt, fromAt, toElements,
493 toElementBytes, fromElementBytes);
494 break;
495 case CFI_type_char16_t:
496 BlankPadCharacterAssignment<char16_t>(to, from, toAt, fromAt,
497 toElements, toElementBytes, fromElementBytes);
498 break;
499 case CFI_type_char32_t:
500 BlankPadCharacterAssignment<char32_t>(to, from, toAt, fromAt,
501 toElements, toElementBytes, fromElementBytes);
502 break;
503 default:
504 terminator.Crash("unexpected type code %d in blank padded Assign()",
505 to.type().raw());
506 }
507 } else { // elemental copies, possibly with character truncation
508 for (std::size_t n{toElements}; n-- > 0;
509 to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
510 Fortran::runtime::memmove(to.Element<char>(toAt),
511 from.Element<const char>(fromAt), toElementBytes);
512 }
513 }
514 }
515 if (deferDeallocation) {
516 // deferDeallocation is used only when LHS is an allocatable.
517 // The finalization has already been run for it.
518 deferDeallocation->Destroy(
519 /*finalize=*/false, /*destroyPointers=*/false, &terminator);
520 }
521}
522
523RT_OFFLOAD_API_GROUP_BEGIN
524
525RT_API_ATTRS void DoFromSourceAssign(
526 Descriptor &alloc, const Descriptor &source, Terminator &terminator) {
527 if (alloc.rank() > 0 && source.rank() == 0) {
528 // The value of each element of allocate object becomes the value of source.
529 DescriptorAddendum *allocAddendum{alloc.Addendum()};
530 const typeInfo::DerivedType *allocDerived{
531 allocAddendum ? allocAddendum->derivedType() : nullptr};
532 SubscriptValue allocAt[maxRank];
533 alloc.GetLowerBounds(allocAt);
534 if (allocDerived) {
535 for (std::size_t n{alloc.Elements()}; n-- > 0;
536 alloc.IncrementSubscripts(allocAt)) {
537 Descriptor allocElement{*Descriptor::Create(*allocDerived,
538 reinterpret_cast<void *>(alloc.Element<char>(allocAt)), 0)};
539 Assign(allocElement, source, terminator, NoAssignFlags);
540 }
541 } else { // intrinsic type
542 for (std::size_t n{alloc.Elements()}; n-- > 0;
543 alloc.IncrementSubscripts(allocAt)) {
544 Fortran::runtime::memmove(alloc.Element<char>(allocAt),
545 source.raw().base_addr, alloc.ElementBytes());
546 }
547 }
548 } else {
549 Assign(to&: alloc, from: source, terminator, flags: NoAssignFlags);
550 }
551}
552
553RT_OFFLOAD_API_GROUP_END
554
555extern "C" {
556RT_EXT_API_GROUP_BEGIN
557
558void RTDEF(Assign)(Descriptor &to, const Descriptor &from,
559 const char *sourceFile, int sourceLine) {
560 Terminator terminator{sourceFile, sourceLine};
561 // All top-level defined assignments can be recognized in semantics and
562 // will have been already been converted to calls, so don't check for
563 // defined assignment apart from components.
564 Assign(to, from, terminator,
565 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment);
566}
567
568void RTDEF(AssignTemporary)(Descriptor &to, const Descriptor &from,
569 const char *sourceFile, int sourceLine) {
570 Terminator terminator{sourceFile, sourceLine};
571 // Initialize the "to" if it is of derived type that needs initialization.
572 if (const DescriptorAddendum * addendum{to.Addendum()}) {
573 if (const auto *derived{addendum->derivedType()}) {
574 // Do not invoke the initialization, if the descriptor is unallocated.
575 // AssignTemporary() is used for component-by-component assignments,
576 // for example, for structure constructors. This means that the LHS
577 // may be an allocatable component with unallocated status.
578 // The initialization will just fail in this case. By skipping
579 // the initialization we let Assign() automatically allocate
580 // and initialize the component according to the RHS.
581 // So we only need to initialize the LHS here if it is allocated.
582 // Note that initializing already initialized entity has no visible
583 // effect, though, it is assumed that the compiler does not initialize
584 // the temporary and leaves the initialization to this runtime code.
585 if (!derived->noInitializationNeeded() && to.IsAllocated()) {
586 if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=
587 StatOk) {
588 return;
589 }
590 }
591 }
592 }
593
594 Assign(to, from, terminator, PolymorphicLHS);
595}
596
597void RTDEF(CopyOutAssign)(Descriptor &to, const Descriptor &from,
598 bool skipToInit, const char *sourceFile, int sourceLine) {
599 Terminator terminator{sourceFile, sourceLine};
600 // Initialize the "to" if it is of derived type that needs initialization.
601 if (!skipToInit) {
602 if (const DescriptorAddendum * addendum{to.Addendum()}) {
603 if (const auto *derived{addendum->derivedType()}) {
604 if (!derived->noInitializationNeeded()) {
605 if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=
606 StatOk) {
607 return;
608 }
609 }
610 }
611 }
612 }
613
614 // Copyout from the temporary must not cause any finalizations
615 // for LHS.
616 Assign(to, from, terminator, NoAssignFlags);
617}
618
619void RTDEF(AssignExplicitLengthCharacter)(Descriptor &to,
620 const Descriptor &from, const char *sourceFile, int sourceLine) {
621 Terminator terminator{sourceFile, sourceLine};
622 Assign(to, from, terminator,
623 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
624 ExplicitLengthCharacterLHS);
625}
626
627void RTDEF(AssignPolymorphic)(Descriptor &to, const Descriptor &from,
628 const char *sourceFile, int sourceLine) {
629 Terminator terminator{sourceFile, sourceLine};
630 Assign(to, from, terminator,
631 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
632 PolymorphicLHS);
633}
634
635RT_EXT_API_GROUP_END
636} // extern "C"
637} // namespace Fortran::runtime
638

source code of flang/runtime/assign.cpp