diff --git a/flang/include/flang/Runtime/assign.h b/flang/include/flang/Runtime/assign.h --- a/flang/include/flang/Runtime/assign.h +++ b/flang/include/flang/Runtime/assign.h @@ -36,6 +36,16 @@ // reallocation. void RTNAME(AssignTemporary)(Descriptor &to, const Descriptor &from, const char *sourceFile = nullptr, int sourceLine = 0); +// This variant is for assignments to explicit-length CHARACTER left-hand +// sides that might need to handle truncation or blank-fill, and +// must maintain the character length even if an allocatable array +// is reallocated. +void RTNAME(AssignExplicitLengthCharacter)(Descriptor &to, + const Descriptor &from, const char *sourceFile = nullptr, + int sourceLine = 0); +// This variant is assignments to whole polymorphic allocatables. +void RTNAME(AssignPolymorphic)(Descriptor &to, const Descriptor &from, + const char *sourceFile = nullptr, int sourceLine = 0); } // extern "C" } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_ASSIGN_H_ diff --git a/flang/runtime/assign.cpp b/flang/runtime/assign.cpp --- a/flang/runtime/assign.cpp +++ b/flang/runtime/assign.cpp @@ -16,35 +16,54 @@ namespace Fortran::runtime { +enum AssignFlags { + NoAssignFlags = 0, + MaybeReallocate = 1 << 0, + NeedFinalization = 1 << 1, + CanBeDefinedAssignment = 1 << 2, + ComponentCanBeDefinedAssignment = 1 << 3, + ExplicitLengthCharacterLHS = 1 << 4, + PolymorphicLHS = 1 << 5 +}; + // Predicate: is the left-hand side of an assignment an allocated allocatable // that must be deallocated? static inline bool MustDeallocateLHS( - Descriptor &to, const Descriptor &from, Terminator &terminator) { + Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { // Top-level assignments to allocatable variables (*not* components) // may first deallocate existing content if there's about to be a // change in type or shape; see F'2018 10.2.1.3(3). + if (!(flags & MaybeReallocate)) { + return false; + } if (!to.IsAllocatable() || !to.IsAllocated()) { return false; } if (to.type() != from.type()) { return true; } - DescriptorAddendum *toAddendum{to.Addendum()}; - const typeInfo::DerivedType *toDerived{ - toAddendum ? toAddendum->derivedType() : nullptr}; - const DescriptorAddendum *fromAddendum{from.Addendum()}; - const typeInfo::DerivedType *fromDerived{ - fromAddendum ? fromAddendum->derivedType() : nullptr}; - if (toDerived != fromDerived) { + if (!(flags & ExplicitLengthCharacterLHS) && to.type().IsCharacter() && + to.ElementBytes() != from.ElementBytes()) { return true; } - if (toAddendum) { - // Distinct LEN parameters? Deallocate - std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0}; - for (std::size_t j{0}; j < lenParms; ++j) { - if (toAddendum->LenParameterValue(j) != - fromAddendum->LenParameterValue(j)) { - return true; + if (flags & PolymorphicLHS) { + DescriptorAddendum *toAddendum{to.Addendum()}; + const typeInfo::DerivedType *toDerived{ + toAddendum ? toAddendum->derivedType() : nullptr}; + const DescriptorAddendum *fromAddendum{from.Addendum()}; + const typeInfo::DerivedType *fromDerived{ + fromAddendum ? fromAddendum->derivedType() : nullptr}; + if (toDerived != fromDerived) { + return true; + } + if (fromDerived) { + // Distinct LEN parameters? Deallocate + std::size_t lenParms{fromDerived->LenParameters()}; + for (std::size_t j{0}; j < lenParms; ++j) { + if (toAddendum->LenParameterValue(j) != + fromAddendum->LenParameterValue(j)) { + return true; + } } } } @@ -63,9 +82,11 @@ // Utility: allocate the allocatable left-hand side, either because it was // originally deallocated or because it required reallocation static int AllocateAssignmentLHS( - Descriptor &to, const Descriptor &from, Terminator &terminator) { + Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { to.raw().type = from.raw().type; - to.raw().elem_len = from.ElementBytes(); + if (!(flags & ExplicitLengthCharacterLHS)) { + to.raw().elem_len = from.ElementBytes(); + } const typeInfo::DerivedType *derived{nullptr}; if (const DescriptorAddendum * fromAddendum{from.Addendum()}) { derived = fromAddendum->derivedType(); @@ -199,6 +220,23 @@ } } +template +static void BlankPadCharacterAssignment(Descriptor &to, const Descriptor &from, + SubscriptValue toAt[], SubscriptValue fromAt[], std::size_t elements, + std::size_t toElementBytes, std::size_t fromElementBytes) { + std::size_t padding{(toElementBytes - fromElementBytes) / sizeof(CHAR)}; + for (; elements-- > 0; + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + CHAR *p{to.Element(toAt)}; + std::memmove( + p, from.Element>(fromAt), fromElementBytes); + p += fromElementBytes; + for (auto n{padding}; n-- > 0;) { + *p++ = CHAR{' '}; + } + } +} + // Common implementation of assignments, both intrinsic assignments and // those cases of polymorphic user-defined ASSIGNMENT(=) TBPs that could not // be resolved in semantics. Most assignment statements do not need any @@ -210,33 +248,39 @@ // of elements, but their shape need not to conform (the assignment is done in // element sequence order). This facilitates some internal usages, like when // dealing with array constructors. -static void Assign(Descriptor &to, const Descriptor &from, - Terminator &terminator, bool maybeReallocate, bool needFinalization, - bool canBeDefinedAssignment, bool componentCanBeDefinedAssignment) { - bool mustDeallocateLHS{ - maybeReallocate && MustDeallocateLHS(to, from, terminator)}; +static void Assign( + Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { + bool mustDeallocateLHS{MustDeallocateLHS(to, from, terminator, flags)}; DescriptorAddendum *toAddendum{to.Addendum()}; const typeInfo::DerivedType *toDerived{ toAddendum ? toAddendum->derivedType() : nullptr}; - if (canBeDefinedAssignment && toDerived) { - needFinalization &= !toDerived->noFinalizationNeeded(); - // Check for a user-defined assignment type-bound procedure; - // see 10.2.1.4-5. A user-defined assignment TBP defines all of - // the semantics, including allocatable (re)allocation and any - // finalization. - if (to.rank() == 0) { + if (toDerived) { + if (flags & CanBeDefinedAssignment) { + // Check for a user-defined assignment type-bound procedure; + // see 10.2.1.4-5. A user-defined assignment TBP defines all of + // the semantics, including allocatable (re)allocation and any + // finalization. + if (to.rank() == 0) { + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ScalarAssignment)}) { + return DoScalarDefinedAssignment(to, from, *special); + } + } if (const auto *special{toDerived->FindSpecialBinding( - typeInfo::SpecialBinding::Which::ScalarAssignment)}) { - return DoScalarDefinedAssignment(to, from, *special); + typeInfo::SpecialBinding::Which::ElementalAssignment)}) { + return DoElementalDefinedAssignment(to, from, *special); } } - if (const auto *special{toDerived->FindSpecialBinding( - typeInfo::SpecialBinding::Which::ElementalAssignment)}) { - return DoElementalDefinedAssignment(to, from, *special); + if ((flags & NeedFinalization) && toDerived->noFinalizationNeeded()) { + flags &= ~NeedFinalization; } } - bool isSimpleMemmove{!toDerived && to.rank() == from.rank() && - to.IsContiguous() && from.IsContiguous()}; + std::size_t toElementBytes{to.ElementBytes()}; + std::size_t fromElementBytes{from.ElementBytes()}; + auto isSimpleMemmove{[&]() { + return !toDerived && to.rank() == from.rank() && to.IsContiguous() && + from.IsContiguous() && toElementBytes == fromElementBytes; + }}; StaticDescriptor deferredDeallocStatDesc; Descriptor *deferDeallocation{nullptr}; if (MayAlias(to, from)) { @@ -244,7 +288,7 @@ deferDeallocation = &deferredDeallocStatDesc.descriptor(); std::memcpy(deferDeallocation, &to, to.SizeInBytes()); to.set_base_addr(nullptr); - } else if (!isSimpleMemmove) { + } else if (!isSimpleMemmove()) { // Handle LHS/RHS aliasing by copying RHS into a temp, then // recursively assigning from that temp. auto descBytes{from.SizeInBytes()}; @@ -255,18 +299,20 @@ if (stat == StatOk) { char *toAt{newFrom.OffsetElement()}; std::size_t fromElements{from.Elements()}; - std::size_t elementBytes{from.ElementBytes()}; if (from.IsContiguous()) { - std::memcpy(toAt, from.OffsetElement(), fromElements * elementBytes); + std::memcpy( + toAt, from.OffsetElement(), fromElements * fromElementBytes); } else { SubscriptValue fromAt[maxRank]; for (from.GetLowerBounds(fromAt); fromElements-- > 0; - toAt += elementBytes, from.IncrementSubscripts(fromAt)) { - std::memcpy(toAt, from.Element(fromAt), elementBytes); + toAt += fromElementBytes, from.IncrementSubscripts(fromAt)) { + std::memcpy(toAt, from.Element(fromAt), fromElementBytes); } } - Assign(to, newFrom, terminator, /*maybeReallocate=*/false, - needFinalization, false, componentCanBeDefinedAssignment); + Assign(to, newFrom, terminator, + flags & + (NeedFinalization | ComponentCanBeDefinedAssignment | + ExplicitLengthCharacterLHS)); newFrom.Deallocate(); } return; @@ -275,24 +321,25 @@ if (to.IsAllocatable()) { if (mustDeallocateLHS) { if (deferDeallocation) { - if (needFinalization && toDerived) { + if ((flags & NeedFinalization) && toDerived) { Finalize(to, *toDerived); - needFinalization = false; + flags &= ~NeedFinalization; } } else { - to.Destroy(/*finalize=*/needFinalization); - needFinalization = false; + to.Destroy((flags & NeedFinalization) != 0); + flags &= ~NeedFinalization; } - } else if (to.rank() != from.rank()) { + } else if (to.rank() != from.rank() && !to.IsAllocated()) { terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to " "unallocated allocatable", to.rank(), from.rank()); } if (!to.IsAllocated()) { - if (AllocateAssignmentLHS(to, from, terminator) != StatOk) { + if (AllocateAssignmentLHS(to, from, terminator, flags) != StatOk) { return; } - needFinalization = false; + flags &= ~NeedFinalization; + toElementBytes = to.ElementBytes(); // may have changed } } SubscriptValue toAt[maxRank]; @@ -312,18 +359,17 @@ terminator.Crash("Assign: mismatching types (to code %d != from code %d)", to.type().raw(), from.type().raw()); } - std::size_t elementBytes{to.ElementBytes()}; - if (elementBytes != from.ElementBytes()) { - terminator.Crash( - "Assign: mismatching element sizes (to %zd bytes != from %zd bytes)", - elementBytes, from.ElementBytes()); + if (toElementBytes > fromElementBytes && !to.type().IsCharacter()) { + terminator.Crash("Assign: mismatching non-character element sizes (to %zd " + "bytes != from %zd bytes)", + toElementBytes, fromElementBytes); } if (const typeInfo::DerivedType * updatedToDerived{toAddendum ? toAddendum->derivedType() : nullptr}) { // Derived type intrinsic assignment, which is componentwise and elementwise // for all components, including parent components (10.2.1.2-3). // The target is first finalized if still necessary (7.5.6.3(1)) - if (needFinalization) { + if (flags & NeedFinalization) { Finalize(to, *updatedToDerived); } // Copy the data components (incl. the parent) first. @@ -333,6 +379,16 @@ const auto &comp{ *componentDesc.ZeroBasedIndexedElement( k)}; // TODO: exploit contiguity here + // Use PolymorphicLHS for components so that the right things happen + // when the components are polymorphic; when they're not, they're both + // not, and their declared types will match. + int nestedFlags{MaybeReallocate | PolymorphicLHS}; + if (comp.genre() != typeInfo::Component::Genre::Allocatable && + (flags & ComponentCanBeDefinedAssignment)) { + // Allocatable components are assigned via intrinsic assignment, + // not defined assignment (see F'2018 10.2.1.3 paragraph 13). + nestedFlags |= CanBeDefinedAssignment | ComponentCanBeDefinedAssignment; + } switch (comp.genre()) { case typeInfo::Component::Genre::Data: if (comp.category() == TypeCategory::Derived) { @@ -344,10 +400,7 @@ comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt); comp.CreatePointerDescriptor( fromCompDesc, from, terminator, fromAt); - Assign(toCompDesc, fromCompDesc, terminator, - /*maybeReallocate=*/true, - /*needFinalization=*/false, componentCanBeDefinedAssignment, - componentCanBeDefinedAssignment); + Assign(toCompDesc, fromCompDesc, terminator, nestedFlags); } } else { // Component has intrinsic type; simply copy raw bytes std::size_t componentByteSize{comp.SizeInBytes(to)}; @@ -392,9 +445,7 @@ continue; // F'2018 10.2.1.3(13)(2) } } - Assign(*toDesc, *fromDesc, terminator, /*maybeReallocate=*/true, - /*needFinalization=*/false, componentCanBeDefinedAssignment, - componentCanBeDefinedAssignment); + Assign(*toDesc, *fromDesc, terminator, nestedFlags); } break; } @@ -413,14 +464,33 @@ } } } else { // intrinsic type, intrinsic assignment - if (isSimpleMemmove) { - std::memmove( - to.raw().base_addr, from.raw().base_addr, toElements * elementBytes); - } else { // elemental copies + if (isSimpleMemmove()) { + std::memmove(to.raw().base_addr, from.raw().base_addr, + toElements * toElementBytes); + } else if (toElementBytes > fromElementBytes) { // blank padding + switch (to.type().raw()) { + case CFI_type_signed_char: + case CFI_type_char: + BlankPadCharacterAssignment(to, from, toAt, fromAt, toElements, + toElementBytes, fromElementBytes); + break; + case CFI_type_char16_t: + BlankPadCharacterAssignment(to, from, toAt, fromAt, + toElements, toElementBytes, fromElementBytes); + break; + case CFI_type_char32_t: + BlankPadCharacterAssignment(to, from, toAt, fromAt, + toElements, toElementBytes, fromElementBytes); + break; + default: + terminator.Crash("unexpected type code %d in blank padded Assign()", + to.type().raw()); + } + } else { // elemental copies, possibly with character truncation for (std::size_t n{toElements}; n-- > 0; to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { std::memmove(to.Element(toAt), from.Element(fromAt), - elementBytes); + toElementBytes); } } } @@ -443,8 +513,7 @@ alloc.IncrementSubscripts(allocAt)) { Descriptor allocElement{*Descriptor::Create(*allocDerived, reinterpret_cast(alloc.Element(allocAt)), 0)}; - Assign(allocElement, source, terminator, /*maybeReallocate=*/false, - /*needFinalization=*/false, false, false); + Assign(allocElement, source, terminator, NoAssignFlags); } } else { // intrinsic type for (std::size_t n{alloc.Elements()}; n-- > 0; @@ -454,8 +523,7 @@ } } } else { - Assign(alloc, source, terminator, /*maybeReallocate=*/false, - /*needFinalization=*/false, false, false); + Assign(alloc, source, terminator, NoAssignFlags); } } @@ -466,20 +534,30 @@ // All top-level defined assignments can be recognized in semantics and // will have been already been converted to calls, so don't check for // defined assignment apart from components. - Assign(to, from, terminator, /*maybeReallocate=*/true, - /*needFinalization=*/true, - /*canBeDefinedAssignment=*/false, - /*componentCanBeDefinedAssignment=*/true); + Assign(to, from, terminator, + MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment); } void RTNAME(AssignTemporary)(Descriptor &to, const Descriptor &from, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; - Assign(to, from, terminator, /*maybeReallocate=*/false, - /*needFinalization=*/false, - /*canBeDefinedAssignment=*/false, - /*componentCanBeDefinedAssignment=*/false); + Assign(to, from, terminator, PolymorphicLHS); +} + +void RTNAME(AssignExplicitLengthCharacter)(Descriptor &to, + const Descriptor &from, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + Assign(to, from, terminator, + MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment | + ExplicitLengthCharacterLHS); } +void RTNAME(AssignPolymorphic)(Descriptor &to, const Descriptor &from, + const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + Assign(to, from, terminator, + MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment | + PolymorphicLHS); +} } // extern "C" } // namespace Fortran::runtime diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h --- a/flang/runtime/type-info.h +++ b/flang/runtime/type-info.h @@ -78,7 +78,7 @@ std::size_t GetElementByteSize(const Descriptor &) const; std::size_t GetElements(const Descriptor &) const; - // For ocmponents that are descriptors, returns size of descriptor; + // For components that are descriptors, returns size of descriptor; // for Genre::Data, returns elemental byte size times element count. std::size_t SizeInBytes(const Descriptor &) const;