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 }
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, derived: *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 j{0}; j < toElements;
397 ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
398 for (std::size_t k{0}; k < numComponents; ++k) {
399 const auto &comp{
400 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
401 k)}; // TODO: exploit contiguity here
402 // Use PolymorphicLHS for components so that the right things happen
403 // when the components are polymorphic; when they're not, they're both
404 // not, and their declared types will match.
405 int nestedFlags{MaybeReallocate | PolymorphicLHS};
406 if (flags & ComponentCanBeDefinedAssignment) {
407 nestedFlags |=
408 CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;
409 }
410 switch (comp.genre()) {
411 case typeInfo::Component::Genre::Data:
412 if (comp.category() == TypeCategory::Derived) {
413 StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
414 Descriptor &toCompDesc{statDesc[0].descriptor()};
415 Descriptor &fromCompDesc{statDesc[1].descriptor()};
416 comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt);
417 comp.CreatePointerDescriptor(
418 fromCompDesc, from, terminator, fromAt);
419 Assign(to&: toCompDesc, from: fromCompDesc, terminator, flags: nestedFlags);
420 } else { // Component has intrinsic type; simply copy raw bytes
421 std::size_t componentByteSize{comp.SizeInBytes(to)};
422 Fortran::runtime::memmove(dest: to.Element<char>(toAt) + comp.offset(),
423 src: from.Element<const char>(fromAt) + comp.offset(),
424 n: componentByteSize);
425 }
426 break;
427 case typeInfo::Component::Genre::Pointer: {
428 std::size_t componentByteSize{comp.SizeInBytes(to)};
429 Fortran::runtime::memmove(dest: to.Element<char>(toAt) + comp.offset(),
430 src: from.Element<const char>(fromAt) + comp.offset(),
431 n: componentByteSize);
432 } break;
433 case typeInfo::Component::Genre::Allocatable:
434 case typeInfo::Component::Genre::Automatic: {
435 auto *toDesc{reinterpret_cast<Descriptor *>(
436 to.Element<char>(toAt) + comp.offset())};
437 const auto *fromDesc{reinterpret_cast<const Descriptor *>(
438 from.Element<char>(fromAt) + comp.offset())};
439 // Allocatable components of the LHS are unconditionally
440 // deallocated before assignment (F'2018 10.2.1.3(13)(1)),
441 // unlike a "top-level" assignment to a variable, where
442 // deallocation is optional.
443 //
444 // Be careful not to destroy/reallocate the LHS, if there is
445 // overlap between LHS and RHS (it seems that partial overlap
446 // is not possible, though).
447 // Invoke Assign() recursively to deal with potential aliasing.
448 if (toDesc->IsAllocatable()) {
449 if (!fromDesc->IsAllocated()) {
450 // No aliasing.
451 //
452 // If to is not allocated, the Destroy() call is a no-op.
453 // This is just a shortcut, because the recursive Assign()
454 // below would initiate the destruction for to.
455 // No finalization is required.
456 toDesc->Destroy(
457 /*finalize=*/false, /*destroyPointers=*/false, &terminator);
458 continue; // F'2018 10.2.1.3(13)(2)
459 }
460 }
461 // Force LHS deallocation with DeallocateLHS flag.
462 // The actual deallocation may be avoided, if the existing
463 // location can be reoccupied.
464 Assign(*toDesc, *fromDesc, terminator, nestedFlags | DeallocateLHS);
465 } break;
466 }
467 }
468 // Copy procedure pointer components
469 const Descriptor &procPtrDesc{updatedToDerived->procPtr()};
470 std::size_t numProcPtrs{procPtrDesc.Elements()};
471 for (std::size_t k{0}; k < numProcPtrs; ++k) {
472 const auto &procPtr{
473 *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(
474 k)};
475 Fortran::runtime::memmove(dest: to.Element<char>(toAt) + procPtr.offset,
476 src: from.Element<const char>(fromAt) + procPtr.offset,
477 n: sizeof(typeInfo::ProcedurePointer));
478 }
479 }
480 } else { // intrinsic type, intrinsic assignment
481 if (isSimpleMemmove()) {
482 Fortran::runtime::memmove(dest: to.raw().base_addr, src: from.raw().base_addr,
483 n: toElements * toElementBytes);
484 } else if (toElementBytes > fromElementBytes) { // blank padding
485 switch (to.type().raw()) {
486 case CFI_type_signed_char:
487 case CFI_type_char:
488 BlankPadCharacterAssignment<char>(to, from, toAt, fromAt, toElements,
489 toElementBytes, fromElementBytes);
490 break;
491 case CFI_type_char16_t:
492 BlankPadCharacterAssignment<char16_t>(to, from, toAt, fromAt,
493 toElements, toElementBytes, fromElementBytes);
494 break;
495 case CFI_type_char32_t:
496 BlankPadCharacterAssignment<char32_t>(to, from, toAt, fromAt,
497 toElements, toElementBytes, fromElementBytes);
498 break;
499 default:
500 terminator.Crash("unexpected type code %d in blank padded Assign()",
501 to.type().raw());
502 }
503 } else { // elemental copies, possibly with character truncation
504 for (std::size_t n{toElements}; n-- > 0;
505 to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
506 Fortran::runtime::memmove(dest: to.Element<char>(toAt),
507 src: from.Element<const char>(fromAt), n: toElementBytes);
508 }
509 }
510 }
511 if (deferDeallocation) {
512 // deferDeallocation is used only when LHS is an allocatable.
513 // The finalization has already been run for it.
514 deferDeallocation->Destroy(
515 /*finalize=*/false, /*destroyPointers=*/false, &terminator);
516 }
517}
518
519RT_OFFLOAD_API_GROUP_BEGIN
520
521RT_API_ATTRS void DoFromSourceAssign(
522 Descriptor &alloc, const Descriptor &source, Terminator &terminator) {
523 if (alloc.rank() > 0 && source.rank() == 0) {
524 // The value of each element of allocate object becomes the value of source.
525 DescriptorAddendum *allocAddendum{alloc.Addendum()};
526 const typeInfo::DerivedType *allocDerived{
527 allocAddendum ? allocAddendum->derivedType() : nullptr};
528 SubscriptValue allocAt[maxRank];
529 alloc.GetLowerBounds(allocAt);
530 if (allocDerived) {
531 for (std::size_t n{alloc.Elements()}; n-- > 0;
532 alloc.IncrementSubscripts(allocAt)) {
533 Descriptor allocElement{*Descriptor::Create(*allocDerived,
534 reinterpret_cast<void *>(alloc.Element<char>(allocAt)), 0)};
535 Assign(allocElement, source, terminator, NoAssignFlags);
536 }
537 } else { // intrinsic type
538 for (std::size_t n{alloc.Elements()}; n-- > 0;
539 alloc.IncrementSubscripts(allocAt)) {
540 Fortran::runtime::memmove(dest: alloc.Element<char>(allocAt),
541 src: source.raw().base_addr, n: alloc.ElementBytes());
542 }
543 }
544 } else {
545 Assign(to&: alloc, from: source, terminator, flags: NoAssignFlags);
546 }
547}
548
549RT_OFFLOAD_API_GROUP_END
550
551extern "C" {
552RT_EXT_API_GROUP_BEGIN
553
554void RTDEF(Assign)(Descriptor &to, const Descriptor &from,
555 const char *sourceFile, int sourceLine) {
556 Terminator terminator{sourceFile, sourceLine};
557 // All top-level defined assignments can be recognized in semantics and
558 // will have been already been converted to calls, so don't check for
559 // defined assignment apart from components.
560 Assign(to, from, terminator,
561 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment);
562}
563
564void RTDEF(AssignTemporary)(Descriptor &to, const Descriptor &from,
565 const char *sourceFile, int sourceLine) {
566 Terminator terminator{sourceFile, sourceLine};
567 // Initialize the "to" if it is of derived type that needs initialization.
568 if (const DescriptorAddendum * addendum{to.Addendum()}) {
569 if (const auto *derived{addendum->derivedType()}) {
570 // Do not invoke the initialization, if the descriptor is unallocated.
571 // AssignTemporary() is used for component-by-component assignments,
572 // for example, for structure constructors. This means that the LHS
573 // may be an allocatable component with unallocated status.
574 // The initialization will just fail in this case. By skipping
575 // the initialization we let Assign() automatically allocate
576 // and initialize the component according to the RHS.
577 // So we only need to initialize the LHS here if it is allocated.
578 // Note that initializing already initialized entity has no visible
579 // effect, though, it is assumed that the compiler does not initialize
580 // the temporary and leaves the initialization to this runtime code.
581 if (!derived->noInitializationNeeded() && to.IsAllocated()) {
582 if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=
583 StatOk) {
584 return;
585 }
586 }
587 }
588 }
589
590 Assign(to, from, terminator, PolymorphicLHS);
591}
592
593void RTDEF(CopyOutAssign)(Descriptor &to, const Descriptor &from,
594 bool skipToInit, const char *sourceFile, int sourceLine) {
595 Terminator terminator{sourceFile, sourceLine};
596 // Initialize the "to" if it is of derived type that needs initialization.
597 if (!skipToInit) {
598 if (const DescriptorAddendum * addendum{to.Addendum()}) {
599 if (const auto *derived{addendum->derivedType()}) {
600 if (!derived->noInitializationNeeded()) {
601 if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=
602 StatOk) {
603 return;
604 }
605 }
606 }
607 }
608 }
609
610 // Copyout from the temporary must not cause any finalizations
611 // for LHS.
612 Assign(to, from, terminator, NoAssignFlags);
613}
614
615void RTDEF(AssignExplicitLengthCharacter)(Descriptor &to,
616 const Descriptor &from, const char *sourceFile, int sourceLine) {
617 Terminator terminator{sourceFile, sourceLine};
618 Assign(to, from, terminator,
619 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
620 ExplicitLengthCharacterLHS);
621}
622
623void RTDEF(AssignPolymorphic)(Descriptor &to, const Descriptor &from,
624 const char *sourceFile, int sourceLine) {
625 Terminator terminator{sourceFile, sourceLine};
626 Assign(to, from, terminator,
627 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |
628 PolymorphicLHS);
629}
630
631RT_EXT_API_GROUP_END
632} // extern "C"
633} // namespace Fortran::runtime
634

source code of flang/runtime/assign.cpp