1 | //===-- runtime/assign.cpp ------------------------------------------------===// |
2 | // |
3 | // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
4 | // See https://llvm.org/LICENSE.txt for license information. |
5 | // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
6 | // |
7 | //===----------------------------------------------------------------------===// |
8 | |
9 | #include "flang/Runtime/assign.h" |
10 | #include "assign-impl.h" |
11 | #include "derived.h" |
12 | #include "stat.h" |
13 | #include "terminator.h" |
14 | #include "tools.h" |
15 | #include "type-info.h" |
16 | #include "flang/Runtime/descriptor.h" |
17 | |
18 | namespace Fortran::runtime { |
19 | |
20 | enum AssignFlags { |
21 | NoAssignFlags = 0, |
22 | MaybeReallocate = 1 << 0, |
23 | NeedFinalization = 1 << 1, |
24 | CanBeDefinedAssignment = 1 << 2, |
25 | ComponentCanBeDefinedAssignment = 1 << 3, |
26 | ExplicitLengthCharacterLHS = 1 << 4, |
27 | PolymorphicLHS = 1 << 5, |
28 | DeallocateLHS = 1 << 6 |
29 | }; |
30 | |
31 | // Predicate: is the left-hand side of an assignment an allocated allocatable |
32 | // that must be deallocated? |
33 | static inline RT_API_ATTRS bool MustDeallocateLHS( |
34 | Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { |
35 | // Top-level assignments to allocatable variables (*not* components) |
36 | // may first deallocate existing content if there's about to be a |
37 | // change in type or shape; see F'2018 10.2.1.3(3). |
38 | if (!(flags & MaybeReallocate)) { |
39 | return false; |
40 | } |
41 | if (!to.IsAllocatable() || !to.IsAllocated()) { |
42 | return false; |
43 | } |
44 | if (to.type() != from.type()) { |
45 | return true; |
46 | } |
47 | if (!(flags & ExplicitLengthCharacterLHS) && to.type().IsCharacter() && |
48 | to.ElementBytes() != from.ElementBytes()) { |
49 | return true; |
50 | } |
51 | if (flags & PolymorphicLHS) { |
52 | DescriptorAddendum *toAddendum{to.Addendum()}; |
53 | const typeInfo::DerivedType *toDerived{ |
54 | toAddendum ? toAddendum->derivedType() : nullptr}; |
55 | const DescriptorAddendum *fromAddendum{from.Addendum()}; |
56 | const typeInfo::DerivedType *fromDerived{ |
57 | fromAddendum ? fromAddendum->derivedType() : nullptr}; |
58 | if (toDerived != fromDerived) { |
59 | return true; |
60 | } |
61 | if (fromDerived) { |
62 | // Distinct LEN parameters? Deallocate |
63 | std::size_t lenParms{fromDerived->LenParameters()}; |
64 | for (std::size_t j{0}; j < lenParms; ++j) { |
65 | if (toAddendum->LenParameterValue(j) != |
66 | fromAddendum->LenParameterValue(j)) { |
67 | return true; |
68 | } |
69 | } |
70 | } |
71 | } |
72 | if (from.rank() > 0) { |
73 | // Distinct shape? Deallocate |
74 | int rank{to.rank()}; |
75 | for (int j{0}; j < rank; ++j) { |
76 | if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) { |
77 | return true; |
78 | } |
79 | } |
80 | } |
81 | return false; |
82 | } |
83 | |
84 | // Utility: allocate the allocatable left-hand side, either because it was |
85 | // originally deallocated or because it required reallocation |
86 | static RT_API_ATTRS int AllocateAssignmentLHS( |
87 | Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { |
88 | to.raw().type = from.raw().type; |
89 | if (!(flags & ExplicitLengthCharacterLHS)) { |
90 | to.raw().elem_len = from.ElementBytes(); |
91 | } |
92 | const typeInfo::DerivedType *derived{nullptr}; |
93 | if (const DescriptorAddendum * fromAddendum{from.Addendum()}) { |
94 | derived = fromAddendum->derivedType(); |
95 | if (DescriptorAddendum * toAddendum{to.Addendum()}) { |
96 | toAddendum->set_derivedType(derived); |
97 | std::size_t lenParms{derived ? derived->LenParameters() : 0}; |
98 | for (std::size_t j{0}; j < lenParms; ++j) { |
99 | toAddendum->SetLenParameterValue(j, fromAddendum->LenParameterValue(j)); |
100 | } |
101 | } |
102 | } |
103 | // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3)) |
104 | int rank{from.rank()}; |
105 | auto stride{static_cast<SubscriptValue>(to.ElementBytes())}; |
106 | for (int j{0}; j < rank; ++j) { |
107 | auto &toDim{to.GetDimension(j)}; |
108 | const auto &fromDim{from.GetDimension(j)}; |
109 | toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound()); |
110 | toDim.SetByteStride(stride); |
111 | stride *= toDim.Extent(); |
112 | } |
113 | int result{ReturnError(terminator, to.Allocate())}; |
114 | if (result == StatOk && derived && !derived->noInitializationNeeded()) { |
115 | result = ReturnError(terminator, Initialize(to, *derived, terminator)); |
116 | } |
117 | return result; |
118 | } |
119 | |
120 | // least <= 0, most >= 0 |
121 | static RT_API_ATTRS void MaximalByteOffsetRange( |
122 | const Descriptor &desc, std::int64_t &least, std::int64_t &most) { |
123 | least = most = 0; |
124 | if (desc.ElementBytes() == 0) { |
125 | return; |
126 | } |
127 | int n{desc.raw().rank}; |
128 | for (int j{0}; j < n; ++j) { |
129 | const auto &dim{desc.GetDimension(j)}; |
130 | auto extent{dim.Extent()}; |
131 | if (extent > 0) { |
132 | auto sm{dim.ByteStride()}; |
133 | if (sm < 0) { |
134 | least += (extent - 1) * sm; |
135 | } else { |
136 | most += (extent - 1) * sm; |
137 | } |
138 | } |
139 | } |
140 | most += desc.ElementBytes() - 1; |
141 | } |
142 | |
143 | static inline RT_API_ATTRS bool RangesOverlap(const char *aStart, |
144 | const char *aEnd, const char *bStart, const char *bEnd) { |
145 | return aEnd >= bStart && bEnd >= aStart; |
146 | } |
147 | |
148 | // Predicate: could the left-hand and right-hand sides of the assignment |
149 | // possibly overlap in memory? Note that the descriptors themeselves |
150 | // are included in the test. |
151 | static RT_API_ATTRS bool MayAlias(const Descriptor &x, const Descriptor &y) { |
152 | const char *xBase{x.OffsetElement()}; |
153 | const char *yBase{y.OffsetElement()}; |
154 | if (!xBase || !yBase) { |
155 | return false; // not both allocated |
156 | } |
157 | const char *xDesc{reinterpret_cast<const char *>(&x)}; |
158 | const char *xDescLast{xDesc + x.SizeInBytes()}; |
159 | const char *yDesc{reinterpret_cast<const char *>(&y)}; |
160 | const char *yDescLast{yDesc + y.SizeInBytes()}; |
161 | std::int64_t xLeast, xMost, yLeast, yMost; |
162 | MaximalByteOffsetRange(x, xLeast, xMost); |
163 | MaximalByteOffsetRange(y, yLeast, yMost); |
164 | if (RangesOverlap(xDesc, xDescLast, yBase + yLeast, yBase + yMost) || |
165 | RangesOverlap(yDesc, yDescLast, xBase + xLeast, xBase + xMost)) { |
166 | // A descriptor overlaps with the storage described by the other; |
167 | // this can arise when an allocatable or pointer component is |
168 | // being assigned to/from. |
169 | return true; |
170 | } |
171 | if (!RangesOverlap( |
172 | xBase + xLeast, xBase + xMost, yBase + yLeast, yBase + yMost)) { |
173 | return false; // no storage overlap |
174 | } |
175 | // TODO: check dimensions: if any is independent, return false |
176 | return true; |
177 | } |
178 | |
179 | static RT_API_ATTRS void DoScalarDefinedAssignment(const Descriptor &to, |
180 | const Descriptor &from, const typeInfo::SpecialBinding &special) { |
181 | bool toIsDesc{special.IsArgDescriptor(0)}; |
182 | bool fromIsDesc{special.IsArgDescriptor(1)}; |
183 | if (toIsDesc) { |
184 | if (fromIsDesc) { |
185 | auto *p{ |
186 | special.GetProc<void (*)(const Descriptor &, const Descriptor &)>()}; |
187 | p(to, from); |
188 | } else { |
189 | auto *p{special.GetProc<void (*)(const Descriptor &, void *)>()}; |
190 | p(to, from.raw().base_addr); |
191 | } |
192 | } else { |
193 | if (fromIsDesc) { |
194 | auto *p{special.GetProc<void (*)(void *, const Descriptor &)>()}; |
195 | p(to.raw().base_addr, from); |
196 | } else { |
197 | auto *p{special.GetProc<void (*)(void *, void *)>()}; |
198 | p(to.raw().base_addr, from.raw().base_addr); |
199 | } |
200 | } |
201 | } |
202 | |
203 | static RT_API_ATTRS void DoElementalDefinedAssignment(const Descriptor &to, |
204 | const Descriptor &from, const typeInfo::DerivedType &derived, |
205 | const typeInfo::SpecialBinding &special) { |
206 | SubscriptValue toAt[maxRank], fromAt[maxRank]; |
207 | to.GetLowerBounds(toAt); |
208 | from.GetLowerBounds(fromAt); |
209 | StaticDescriptor<maxRank, true, 8 /*?*/> statDesc[2]; |
210 | Descriptor &toElementDesc{statDesc[0].descriptor()}; |
211 | Descriptor &fromElementDesc{statDesc[1].descriptor()}; |
212 | toElementDesc.Establish(derived, nullptr, 0, nullptr, CFI_attribute_pointer); |
213 | fromElementDesc.Establish( |
214 | derived, nullptr, 0, nullptr, CFI_attribute_pointer); |
215 | for (std::size_t toElements{to.Elements()}; toElements-- > 0; |
216 | to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { |
217 | toElementDesc.set_base_addr(to.Element<char>(toAt)); |
218 | fromElementDesc.set_base_addr(from.Element<char>(fromAt)); |
219 | DoScalarDefinedAssignment(to: toElementDesc, from: fromElementDesc, special); |
220 | } |
221 | } |
222 | |
223 | template <typename CHAR> |
224 | static RT_API_ATTRS void BlankPadCharacterAssignment(Descriptor &to, |
225 | const Descriptor &from, SubscriptValue toAt[], SubscriptValue fromAt[], |
226 | std::size_t elements, std::size_t toElementBytes, |
227 | std::size_t fromElementBytes) { |
228 | std::size_t padding{(toElementBytes - fromElementBytes) / sizeof(CHAR)}; |
229 | std::size_t copiedCharacters{fromElementBytes / sizeof(CHAR)}; |
230 | for (; elements-- > 0; |
231 | to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { |
232 | CHAR *p{to.Element<CHAR>(toAt)}; |
233 | Fortran::runtime::memmove( |
234 | p, from.Element<std::add_const_t<CHAR>>(fromAt), fromElementBytes); |
235 | p += copiedCharacters; |
236 | for (auto n{padding}; n-- > 0;) { |
237 | *p++ = CHAR{' '}; |
238 | } |
239 | } |
240 | } |
241 | |
242 | // Common implementation of assignments, both intrinsic assignments and |
243 | // those cases of polymorphic user-defined ASSIGNMENT(=) TBPs that could not |
244 | // be resolved in semantics. Most assignment statements do not need any |
245 | // of the capabilities of this function -- but when the LHS is allocatable, |
246 | // the type might have a user-defined ASSIGNMENT(=), or the type might be |
247 | // finalizable, this function should be used. |
248 | // When "to" is not a whole allocatable, "from" is an array, and defined |
249 | // assignments are not used, "to" and "from" only need to have the same number |
250 | // of elements, but their shape need not to conform (the assignment is done in |
251 | // element sequence order). This facilitates some internal usages, like when |
252 | // dealing with array constructors. |
253 | RT_API_ATTRS static void Assign( |
254 | Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { |
255 | bool mustDeallocateLHS{(flags & DeallocateLHS) || |
256 | MustDeallocateLHS(to, from, terminator, flags)}; |
257 | DescriptorAddendum *toAddendum{to.Addendum()}; |
258 | const typeInfo::DerivedType *toDerived{ |
259 | toAddendum ? toAddendum->derivedType() : nullptr}; |
260 | if (toDerived && (flags & NeedFinalization) && |
261 | toDerived->noFinalizationNeeded()) { |
262 | flags &= ~NeedFinalization; |
263 | } |
264 | std::size_t toElementBytes{to.ElementBytes()}; |
265 | std::size_t fromElementBytes{from.ElementBytes()}; |
266 | // The following lambda definition violates the conding style, |
267 | // but cuda-11.8 nvcc hits an internal error with the brace initialization. |
268 | auto isSimpleMemmove = [&]() { |
269 | return !toDerived && to.rank() == from.rank() && to.IsContiguous() && |
270 | from.IsContiguous() && toElementBytes == fromElementBytes; |
271 | }; |
272 | StaticDescriptor<maxRank, true, 10 /*?*/> deferredDeallocStatDesc; |
273 | Descriptor *deferDeallocation{nullptr}; |
274 | if (MayAlias(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 | |
519 | RT_OFFLOAD_API_GROUP_BEGIN |
520 | |
521 | RT_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 | |
549 | RT_OFFLOAD_API_GROUP_END |
550 | |
551 | extern "C" { |
552 | RT_EXT_API_GROUP_BEGIN |
553 | |
554 | void 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 | |
564 | void 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 | |
593 | void 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 | |
615 | void 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 | |
623 | void 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 | |
631 | RT_EXT_API_GROUP_END |
632 | } // extern "C" |
633 | } // namespace Fortran::runtime |
634 | |