inline bool IsImpliedDoIndex(const Symbol &symbol) {
return symbol.owner().kind() == Scope::Kind::ImpliedDos;
}
-bool IsFinalizable(const Symbol &);
-bool IsFinalizable(const DerivedTypeSpec &);
+bool IsFinalizable(
+ const Symbol &, std::set<const DerivedTypeSpec *> * = nullptr);
+bool IsFinalizable(
+ const DerivedTypeSpec &, std::set<const DerivedTypeSpec *> * = nullptr);
bool HasImpureFinal(const DerivedTypeSpec &);
bool IsCoarray(const Symbol &);
bool IsInBlankCommon(const Symbol &);
bool IsForwardReferenced() const;
bool HasDefaultInitialization() const;
bool HasDestruction() const;
+ bool HasFinalization() const;
// The "raw" type parameter list is a simple transcription from the
// parameter list in the parse tree, built by calling AddRawParamValue().
#include "flang/Evaluate/type.h"
#include "flang/Semantics/scope.h"
#include "flang/Semantics/tools.h"
+#include <functional>
#include <list>
#include <map>
#include <string>
std::vector<evaluate::StructureConstructor> DescribeBindings(
const Scope &dtScope, Scope &);
void DescribeGeneric(
- const GenericDetails &, std::vector<evaluate::StructureConstructor> &);
- void DescribeSpecialProc(std::vector<evaluate::StructureConstructor> &,
+ const GenericDetails &, std::map<int, evaluate::StructureConstructor> &);
+ void DescribeSpecialProc(std::map<int, evaluate::StructureConstructor> &,
const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
std::optional<GenericKind::DefinedIo>);
void IncorporateDefinedIoGenericInterfaces(
- std::vector<evaluate::StructureConstructor> &, SourceName,
+ std::map<int, evaluate::StructureConstructor> &, SourceName,
GenericKind::DefinedIo, const Scope *);
// Instantiated for ParamValue and Bound
SomeExpr deferredEnum_; // Value::Genre::Deferred
SomeExpr explicitEnum_; // Value::Genre::Explicit
SomeExpr lenParameterEnum_; // Value::Genre::LenParameter
- SomeExpr assignmentEnum_; // SpecialBinding::Which::Assignment
+ SomeExpr scalarAssignmentEnum_; // SpecialBinding::Which::ScalarAssignment
SomeExpr
elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment
- SomeExpr finalEnum_; // SpecialBinding::Which::Final
- SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
- SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted
SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted
SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted
SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted
+ SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
+ SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
+ SomeExpr scalarFinalEnum_; // SpecialBinding::Which::ScalarFinal
parser::CharBlock location_;
std::set<const Scope *> ignoreScopes_;
};
"deferred")},
explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
"lenparameter")},
- assignmentEnum_{GetEnumValue("assignment")},
+ scalarAssignmentEnum_{GetEnumValue("scalarassignment")},
elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
- finalEnum_{GetEnumValue("final")}, elementalFinalEnum_{GetEnumValue(
- "elementalfinal")},
- assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
readFormattedEnum_{GetEnumValue("readformatted")},
readUnformattedEnum_{GetEnumValue("readunformatted")},
writeFormattedEnum_{GetEnumValue("writeformatted")},
- writeUnformattedEnum_{GetEnumValue("writeunformatted")} {
+ writeUnformattedEnum_{GetEnumValue("writeunformatted")},
+ elementalFinalEnum_{GetEnumValue("elementalfinal")},
+ assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
+ scalarFinalEnum_{GetEnumValue("scalarfinal")} {
ignoreScopes_.insert(tables_.schemata);
}
AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
SomeExpr{evaluate::NullPointer{}});
}
-
- // TODO: compute typeHash
-
using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
std::vector<Int8::Scalar> kinds;
if (!isPDTdefinition) {
std::vector<const Symbol *> dataComponentSymbols;
std::vector<evaluate::StructureConstructor> procPtrComponents;
- std::vector<evaluate::StructureConstructor> specials;
+ std::map<int, evaluate::StructureConstructor> specials;
for (const auto &pair : dtScope) {
const Symbol &symbol{*pair.second};
auto locationRestorer{common::ScopedSet(location_, symbol.name())};
static_cast<evaluate::ConstantSubscript>(bindings.size())}));
// Describe "special" bindings to defined assignments, FINAL subroutines,
// and user-defined derived type I/O subroutines.
- if (dtScope.symbol()) {
- for (const auto &pair :
- dtScope.symbol()->get<DerivedTypeDetails>().finals()) {
- DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
- true, std::nullopt);
- }
+ const DerivedTypeDetails &dtDetails{dtSymbol->get<DerivedTypeDetails>()};
+ for (const auto &pair : dtDetails.finals()) {
+ DescribeSpecialProc(
+ specials, *pair.second, false /*!isAssignment*/, true, std::nullopt);
}
IncorporateDefinedIoGenericInterfaces(specials,
SourceName{"read(formatted)", 15},
IncorporateDefinedIoGenericInterfaces(specials,
SourceName{"write(unformatted)", 18},
GenericKind::DefinedIo::WriteUnformatted, &scope);
+ // Pack the special procedure bindings in ascending order of their "which"
+ // code values, and compile a little-endian bit-set of those codes for
+ // use in O(1) look-up at run time.
+ std::vector<evaluate::StructureConstructor> sortedSpecials;
+ std::uint32_t specialBitSet{0};
+ for (auto &pair : specials) {
+ auto bit{std::uint32_t{1} << pair.first};
+ CHECK(!(specialBitSet & bit));
+ specialBitSet |= bit;
+ sortedSpecials.emplace_back(std::move(pair.second));
+ }
AddValue(dtValues, derivedTypeSchema_, "special"s,
SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName),
- std::move(specials),
+ std::move(sortedSpecials),
evaluate::ConstantSubscripts{
static_cast<evaluate::ConstantSubscript>(specials.size())}));
+ AddValue(dtValues, derivedTypeSchema_, "specialbitset"s,
+ IntExpr<4>(specialBitSet));
// Note the presence/absence of a parent component
AddValue(dtValues, derivedTypeSchema_, "hasparent"s,
IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));
// Similarly, a flag to short-circuit destruction when not needed.
AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s,
IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction()));
+ // Similarly, a flag to short-circuit finalization when not needed.
+ AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s,
+ IntExpr<1>(derivedTypeSpec && !IsFinalizable(*derivedTypeSpec)));
}
dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
}
void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
- std::vector<evaluate::StructureConstructor> &specials) {
+ std::map<int, evaluate::StructureConstructor> &specials) {
std::visit(common::visitors{
[&](const GenericKind::OtherKind &k) {
if (k == GenericKind::OtherKind::Assignment) {
}
void RuntimeTableBuilder::DescribeSpecialProc(
- std::vector<evaluate::StructureConstructor> &specials,
+ std::map<int, evaluate::StructureConstructor> &specials,
const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
std::optional<GenericKind::DefinedIo> io) {
const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
if (auto proc{evaluate::characteristics::Procedure::Characterize(
specific, context_.foldingContext())}) {
- std::uint8_t rank{0};
std::uint8_t isArgDescriptorSet{0};
int argThatMightBeDescriptor{0};
MaybeExpr which;
if (isAssignment) { // only type-bound asst's are germane to runtime
CHECK(binding != nullptr);
CHECK(proc->dummyArguments.size() == 2);
- which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_;
+ which = proc->IsElemental() ? elementalAssignmentEnum_
+ : scalarAssignmentEnum_;
if (binding && binding->passName() &&
*binding->passName() == proc->dummyArguments[1].name) {
argThatMightBeDescriptor = 1;
which = assumedRankFinalEnum_;
isArgDescriptorSet |= 1;
} else {
- which = finalEnum_;
- rank = evaluate::GetRank(typeAndShape.shape());
- if (rank > 0) {
+ which = scalarFinalEnum_;
+ if (int rank{evaluate::GetRank(typeAndShape.shape())}; rank > 0) {
argThatMightBeDescriptor = 1;
+ which = IntExpr<1>(ToInt64(which).value() + rank);
}
}
}
isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
}
evaluate::StructureConstructorValues values;
+ auto index{evaluate::ToInt64(which)};
+ CHECK(index.has_value());
AddValue(
values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
- AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank));
AddValue(values, specialSchema_, "isargdescriptorset"s,
IntExpr<1>(isArgDescriptorSet));
AddValue(values, specialSchema_, "proc"s,
SomeExpr{evaluate::ProcedureDesignator{specific}});
- specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values));
+ auto pair{specials.try_emplace(
+ *index, DEREF(specialSchema_.AsDerived()), std::move(values))};
+ CHECK(pair.second); // ensure not already present
}
}
void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
- std::vector<evaluate::StructureConstructor> &specials, SourceName name,
+ std::map<int, evaluate::StructureConstructor> &specials, SourceName name,
GenericKind::DefinedIo definedIo, const Scope *scope) {
for (; !scope->IsGlobal(); scope = &scope->parent()) {
if (auto asst{scope->find(name)}; asst != scope->end()) {
return false;
}
-bool IsFinalizable(const Symbol &symbol) {
+bool IsFinalizable(
+ const Symbol &symbol, std::set<const DerivedTypeSpec *> *inProgress) {
if (IsPointer(symbol)) {
return false;
}
return false;
}
const DeclTypeSpec *type{object->type()};
- const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
- return derived && IsFinalizable(*derived);
+ const DerivedTypeSpec *typeSpec{type ? type->AsDerived() : nullptr};
+ return typeSpec && IsFinalizable(*typeSpec, inProgress);
}
return false;
}
-bool IsFinalizable(const DerivedTypeSpec &derived) {
+bool IsFinalizable(const DerivedTypeSpec &derived,
+ std::set<const DerivedTypeSpec *> *inProgress) {
if (!derived.typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
return true;
}
- DirectComponentIterator components{derived};
- return bool{std::find_if(components.begin(), components.end(),
- [](const Symbol &component) { return IsFinalizable(component); })};
+ std::set<const DerivedTypeSpec *> basis;
+ if (inProgress) {
+ if (inProgress->find(&derived) != inProgress->end()) {
+ return false; // don't loop on recursive type
+ }
+ } else {
+ inProgress = &basis;
+ }
+ auto iterator{inProgress->insert(&derived).first};
+ PotentialComponentIterator components{derived};
+ bool result{bool{std::find_if(
+ components.begin(), components.end(), [=](const Symbol &component) {
+ return IsFinalizable(component, inProgress);
+ })}};
+ inProgress->erase(iterator);
+ return result;
}
bool HasImpureFinal(const DerivedTypeSpec &derived) {
! Instances of parameterized derived types use the "uninstantiated"
! component to point to the pristine original definition.
type(DerivedType), pointer :: uninstantiated
- integer(kind=int64) :: typeHash
integer(kind=int64), pointer, contiguous :: kindParameter(:) ! values of instance
integer(1), pointer, contiguous :: lenParameterKind(:) ! INTEGER kinds of LEN types
! Data components appear in component order.
type(Component), pointer, contiguous :: component(:) ! data components
type(ProcPtrComponent), pointer, contiguous :: procptr(:) ! procedure pointers
! Special bindings of the ancestral types are not duplicated here.
+ ! Bindings are in ascending order of their "which" code values.
type(SpecialBinding), pointer, contiguous :: special(:)
+ ! A little-endian bit set of SpecialBinding::Which codes present in "special"
+ integer(4) :: specialBitSet
integer(1) :: hasParent
integer(1) :: noInitializationNeeded ! 1 if no component w/ init
integer(1) :: noDestructionNeeded ! 1 if no component w/ dealloc/final
- integer(1) :: __padding0(5)
+ integer(1) :: noFinalizationNeeded ! 1 if nothing finalizaable
+ integer(1) :: __padding0(4)
end type
type :: Binding
end type
enum, bind(c) ! SpecialBinding::Which
- enumerator :: Assignment = 4, ElementalAssignment = 5
- enumerator :: Final = 8, ElementalFinal = 9, AssumedRankFinal = 10
- enumerator :: ReadFormatted = 16, ReadUnformatted = 17
- enumerator :: WriteFormatted = 18, WriteUnformatted = 19
+ enumerator :: ScalarAssignment = 1, ElementalAssignment = 2
+ enumerator :: ReadFormatted = 3, ReadUnformatted = 4
+ enumerator :: WriteFormatted = 5, WriteUnformatted = 6
+ enumerator :: ElementalFinal = 7, AssumedRankFinal = 8
+ enumerator :: ScalarFinal = 9 ! higher-rank final procedures follow
end enum
type, bind(c) :: SpecialBinding
integer(1) :: which ! SpecialBinding::Which
- integer(1) :: rank ! for which == SpecialBinding::Which::Final only
integer(1) :: isArgDescriptorSet
- integer(1) :: __padding0(5)
+ integer(1) :: __padding0(6)
type(__builtin_c_funptr) :: proc
end type
add_flang_library(FortranRuntime
ISO_Fortran_binding.cpp
allocatable.cpp
+ assign.cpp
buffer.cpp
complex-reduction.c
copy.cpp
//===----------------------------------------------------------------------===//
#include "allocatable.h"
+#include "assign.h"
#include "derived.h"
#include "stat.h"
#include "terminator.h"
derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
}
-void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {
- INTERNAL_CHECK(false); // TODO: AllocatableAssign is not yet implemented
-}
-
int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
bool /*hasStat*/, const Descriptor * /*errMsg*/,
const char * /*sourceFile*/, int /*sourceLine*/) {
bool hasStat = false, const Descriptor *errMsg = nullptr,
const char *sourceFile = nullptr, int sourceLine = 0);
-// Assigns to a whole allocatable, with automatic (re)allocation when the
-// destination is unallocated or nonconforming (Fortran 2003 semantics).
-// The descriptor must be initialized.
-// Recursively assigns components with (re)allocation as necessary.
-// TODO: Consider renaming to a more general name that will work for
-// assignments to pointers, dummy arguments, and anything else with a
-// descriptor.
-void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor &from);
-
// Implements the intrinsic subroutine MOVE_ALLOC (16.9.137 in F'2018,
// but note the order of first two arguments is reversed for consistency
// with the other APIs for allocatables.) The destination descriptor
--- /dev/null
+//===-- runtime/assign.cpp ------------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "assign.h"
+#include "derived.h"
+#include "descriptor.h"
+#include "stat.h"
+#include "terminator.h"
+#include "type-info.h"
+
+namespace Fortran::runtime {
+
+static void DoScalarDefinedAssignment(const Descriptor &to,
+ const Descriptor &from, const typeInfo::SpecialBinding &special) {
+ bool toIsDesc{special.IsArgDescriptor(0)};
+ bool fromIsDesc{special.IsArgDescriptor(1)};
+ if (toIsDesc) {
+ if (fromIsDesc) {
+ auto *p{
+ special.GetProc<void (*)(const Descriptor &, const Descriptor &)>()};
+ p(to, from);
+ } else {
+ auto *p{special.GetProc<void (*)(const Descriptor &, void *)>()};
+ p(to, from.raw().base_addr);
+ }
+ } else {
+ if (fromIsDesc) {
+ auto *p{special.GetProc<void (*)(void *, const Descriptor &)>()};
+ p(to.raw().base_addr, from);
+ } else {
+ auto *p{special.GetProc<void (*)(void *, void *)>()};
+ p(to.raw().base_addr, from.raw().base_addr);
+ }
+ }
+}
+
+static void DoElementalDefinedAssignment(const Descriptor &to,
+ const Descriptor &from, const typeInfo::SpecialBinding &special,
+ std::size_t toElements, SubscriptValue toAt[], SubscriptValue fromAt[]) {
+ StaticDescriptor<maxRank, true, 8 /*?*/> statDesc[2];
+ Descriptor &toElementDesc{statDesc[0].descriptor()};
+ Descriptor &fromElementDesc{statDesc[1].descriptor()};
+ toElementDesc = to;
+ toElementDesc.raw().attribute = CFI_attribute_pointer;
+ toElementDesc.raw().rank = 0;
+ fromElementDesc = from;
+ fromElementDesc.raw().attribute = CFI_attribute_pointer;
+ fromElementDesc.raw().rank = 0;
+ for (std::size_t j{0}; j < toElements;
+ ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ toElementDesc.set_base_addr(to.Element<char>(toAt));
+ fromElementDesc.set_base_addr(from.Element<char>(fromAt));
+ DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special);
+ }
+}
+
+void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) {
+ 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};
+ bool wasJustAllocated{false};
+ if (to.IsAllocatable()) {
+ std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0};
+ if (to.IsAllocated()) {
+ // 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).
+ bool deallocate{false};
+ if (to.type() != from.type()) {
+ deallocate = true;
+ } else if (toDerived != fromDerived) {
+ deallocate = true;
+ } else {
+ if (toAddendum) {
+ // Distinct LEN parameters? Deallocate
+ for (std::size_t j{0}; j < lenParms; ++j) {
+ if (toAddendum->LenParameterValue(j) !=
+ fromAddendum->LenParameterValue(j)) {
+ deallocate = true;
+ break;
+ }
+ }
+ }
+ if (from.rank() > 0) {
+ // Distinct shape? Deallocate
+ int rank{to.rank()};
+ for (int j{0}; j < rank; ++j) {
+ if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) {
+ deallocate = true;
+ break;
+ }
+ }
+ }
+ }
+ if (deallocate) {
+ to.Destroy(true /*finalize*/);
+ }
+ } else if (to.rank() != from.rank()) {
+ terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
+ "unallocated allocatable",
+ to.rank(), from.rank());
+ }
+ if (!to.IsAllocated()) {
+ to.raw().type = from.raw().type;
+ to.raw().elem_len = from.ElementBytes();
+ if (toAddendum) {
+ toDerived = fromDerived;
+ toAddendum->set_derivedType(toDerived);
+ for (std::size_t j{0}; j < lenParms; ++j) {
+ toAddendum->SetLenParameterValue(
+ j, fromAddendum->LenParameterValue(j));
+ }
+ }
+ // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3))
+ int rank{from.rank()};
+ auto stride{static_cast<SubscriptValue>(to.ElementBytes())};
+ for (int j{0}; j < rank; ++j) {
+ auto &toDim{to.GetDimension(j)};
+ const auto &fromDim{from.GetDimension(j)};
+ toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound());
+ toDim.SetByteStride(stride);
+ stride *= toDim.Extent();
+ }
+ ReturnError(terminator, to.Allocate());
+ if (fromDerived && !fromDerived->noInitializationNeeded()) {
+ ReturnError(terminator, Initialize(to, *toDerived, terminator));
+ }
+ wasJustAllocated = true;
+ }
+ }
+ SubscriptValue toAt[maxRank];
+ to.GetLowerBounds(toAt);
+ // Scalar expansion of the RHS is implied by using the same empty
+ // subscript values on each (seemingly) elemental reference into
+ // "from".
+ SubscriptValue fromAt[maxRank];
+ from.GetLowerBounds(fromAt);
+ std::size_t toElements{to.Elements()};
+ if (from.rank() > 0 && toElements != from.Elements()) {
+ terminator.Crash("Assign: mismatching element counts in array assignment "
+ "(to %zd, from %zd)",
+ toElements, from.Elements());
+ }
+ if (to.type() != from.type()) {
+ 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 (toDerived) { // Derived type assignment
+ // Check for defined assignment type-bound procedures (10.2.1.4-5)
+ 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::ElementalAssignment)}) {
+ return DoElementalDefinedAssignment(
+ to, from, *special, toElements, toAt, fromAt);
+ }
+ // 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 (!wasJustAllocated && !toDerived->noFinalizationNeeded()) {
+ Finalize(to, *toDerived);
+ }
+ // Copy the data components (incl. the parent) first.
+ const Descriptor &componentDesc{toDerived->component()};
+ std::size_t numComponents{componentDesc.Elements()};
+ for (std::size_t k{0}; k < numComponents; ++k) {
+ const auto &comp{
+ *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
+ k)}; // TODO: exploit contiguity here
+ switch (comp.genre()) {
+ case typeInfo::Component::Genre::Data:
+ if (comp.category() == TypeCategory::Derived) {
+ StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
+ Descriptor &toCompDesc{statDesc[0].descriptor()};
+ Descriptor &fromCompDesc{statDesc[1].descriptor()};
+ for (std::size_t j{0}; j < toElements; ++j,
+ to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ comp.CreatePointerDescriptor(toCompDesc, to, toAt, terminator);
+ comp.CreatePointerDescriptor(
+ fromCompDesc, from, fromAt, terminator);
+ Assign(toCompDesc, fromCompDesc, terminator);
+ }
+ } else { // Component has intrinsic type; simply copy raw bytes
+ std::size_t componentByteSize{comp.SizeInBytes(to)};
+ for (std::size_t j{0}; j < toElements; ++j,
+ to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ std::memmove(to.Element<char>(toAt) + comp.offset(),
+ from.Element<const char>(fromAt) + comp.offset(),
+ componentByteSize);
+ }
+ }
+ break;
+ case typeInfo::Component::Genre::Pointer: {
+ std::size_t componentByteSize{comp.SizeInBytes(to)};
+ for (std::size_t j{0}; j < toElements; ++j,
+ to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ std::memmove(to.Element<char>(toAt) + comp.offset(),
+ from.Element<const char>(fromAt) + comp.offset(),
+ componentByteSize);
+ }
+ } break;
+ case typeInfo::Component::Genre::Allocatable:
+ case typeInfo::Component::Genre::Automatic:
+ for (std::size_t j{0}; j < toElements; ++j,
+ to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ auto *toDesc{reinterpret_cast<Descriptor *>(
+ to.Element<char>(toAt) + comp.offset())};
+ const auto *fromDesc{reinterpret_cast<const Descriptor *>(
+ from.Element<char>(fromAt) + comp.offset())};
+ if (toDesc->IsAllocatable()) {
+ if (toDesc->IsAllocated()) {
+ // Allocatable components of the LHS are unconditionally
+ // deallocated before assignment (F'2018 10.2.1.3(13)(1)),
+ // unlike a "top-level" assignment to a variable, where
+ // deallocation is optional.
+ // TODO: Consider skipping this step and deferring the
+ // deallocation to the recursive activation of Assign(),
+ // which might be able to avoid deallocation/reallocation
+ // when the existing allocation can be reoccupied.
+ toDesc->Destroy(false /*already finalized*/);
+ }
+ if (!fromDesc->IsAllocated()) {
+ continue; // F'2018 10.2.1.3(13)(2)
+ }
+ }
+ Assign(*toDesc, *fromDesc, terminator);
+ }
+ break;
+ }
+ }
+ // Copy procedure pointer components
+ const Descriptor &procPtrDesc{toDerived->procPtr()};
+ std::size_t numProcPtrs{procPtrDesc.Elements()};
+ for (std::size_t k{0}; k < numProcPtrs; ++k) {
+ const auto &procPtr{
+ *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
+ for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt),
+ from.IncrementSubscripts(fromAt)) {
+ std::memmove(to.Element<char>(toAt) + procPtr.offset,
+ from.Element<const char>(fromAt) + procPtr.offset,
+ sizeof(typeInfo::ProcedurePointer));
+ }
+ }
+ } else { // intrinsic type, intrinsic assignment
+ if (to.rank() == from.rank() && to.IsContiguous() && from.IsContiguous()) {
+ // Everything is contiguous; do a single big copy
+ std::memmove(
+ to.raw().base_addr, from.raw().base_addr, toElements * elementBytes);
+ } else { // elemental copies
+ for (std::size_t n{toElements}; n-- > 0;
+ to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ std::memmove(to.Element<char>(toAt), from.Element<const char>(fromAt),
+ elementBytes);
+ }
+ }
+ }
+}
+
+extern "C" {
+void RTNAME(Assign)(Descriptor &to, const Descriptor &from,
+ const char *sourceFile, int sourceLine) {
+ Terminator terminator{sourceFile, sourceLine};
+ Assign(to, from, terminator);
+}
+
+} // extern "C"
+} // namespace Fortran::runtime
--- /dev/null
+//===-- runtime/assign.h --------------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+// External and internal APIs for data assignment (both intrinsic assignment
+// and TBP defined generic ASSIGNMENT(=)). Should be called by lowering
+// for any assignments possibly needing special handling. Intrinsic assignment
+// to non-allocatable variables whose types are intrinsic need not come through
+// here (though they may do so). Assignments to allocatables, and assignments
+// whose types may be polymorphic or are monomorphic and of derived types with
+// finalization, allocatable components, or components with type-bound defined
+// assignments, in the original type or the types of its non-pointer components
+// (recursively) must arrive here.
+//
+// Non-type-bound generic INTERFACE ASSIGNMENT(=) is resolved in semantics and
+// need not be handled here in the runtime; ditto for type conversions on
+// intrinsic assignments.
+
+#ifndef FLANG_RUNTIME_ASSIGN_H_
+#define FLANG_RUNTIME_ASSIGN_H_
+
+#include "entry-names.h"
+
+namespace Fortran::runtime {
+class Descriptor;
+class Terminator;
+
+// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or
+// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs
+// finalization, scalar expansion, & allocatable (re)allocation as needed.
+// Does not perform intrinsic assignment implicit type conversion. Both
+// descriptors must be initialized. Recurses as needed to handle components.
+void Assign(Descriptor &, const Descriptor &, Terminator &);
+
+extern "C" {
+// API for lowering assignment
+void RTNAME(Assign)(Descriptor &to, const Descriptor &from,
+ const char *sourceFile = nullptr, int sourceLine = 0);
+} // extern "C"
+} // namespace Fortran::runtime
+#endif // FLANG_RUNTIME_ASSIGN_H_
static const typeInfo::SpecialBinding *FindFinal(
const typeInfo::DerivedType &derived, int rank) {
- const typeInfo::SpecialBinding *elemental{nullptr};
- const Descriptor &specialDesc{derived.special()};
- std::size_t totalSpecialBindings{specialDesc.Elements()};
- for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
- const auto &special{
- *specialDesc.ZeroBasedIndexedElement<typeInfo::SpecialBinding>(j)};
- switch (special.which()) {
- case typeInfo::SpecialBinding::Which::Final:
- if (special.rank() == rank) {
- return &special;
- }
- break;
- case typeInfo::SpecialBinding::Which::ElementalFinal:
- elemental = &special;
- break;
- case typeInfo::SpecialBinding::Which::AssumedRankFinal:
- return &special;
- default:;
- }
+ if (const auto *ranked{derived.FindSpecialBinding(
+ typeInfo::SpecialBinding::RankFinal(rank))}) {
+ return ranked;
+ } else if (const auto *assumed{derived.FindSpecialBinding(
+ typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
+ return assumed;
+ } else {
+ return derived.FindSpecialBinding(
+ typeInfo::SpecialBinding::Which::ElementalFinal);
}
- return elemental;
}
static void CallFinalSubroutine(
}
}
-// The order of finalization follows Fortran 2018 7.5.6.2, with
-// deallocation of non-parent components (and their consequent finalization)
-// taking place before parent component finalization.
-void Destroy(const Descriptor &descriptor, bool finalize,
- const typeInfo::DerivedType &derived) {
- if (finalize) {
- CallFinalSubroutine(descriptor, derived);
+// Fortran 2018 subclause 7.5.6.2
+void Finalize(
+ const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+ if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
+ return;
}
+ CallFinalSubroutine(descriptor, derived);
+ const auto *parentType{derived.GetParentType()};
+ bool recurse{parentType && !parentType->noFinalizationNeeded()};
+ // If there's a finalizable parent component, handle it last, as required
+ // by the Fortran standard (7.5.6.2), and do so recursively with the same
+ // descriptor so that the rank is preserved.
const Descriptor &componentDesc{derived.component()};
std::size_t myComponents{componentDesc.Elements()};
std::size_t elements{descriptor.Elements()};
std::size_t byteStride{descriptor.ElementBytes()};
- // If there's a finalizable parent component, handle it last, as required
- // by the Fortran standard (7.5.6.2), and do so recursively with the same
- // descriptor so that the rank is preserved. Otherwise, destroy the parent
- // component like any other.
- const auto *parentType{derived.GetParentType()};
- bool recurse{finalize && parentType && !parentType->noDestructionNeeded()};
for (auto k{recurse
? std::size_t{1} /* skip first component, it's the parent */
: 0};
if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
comp.genre() == typeInfo::Component::Genre::Automatic) {
if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
- if (!compType->noDestructionNeeded()) {
+ if (!compType->noFinalizationNeeded()) {
for (std::size_t j{0}; j < elements; ++j) {
- Destroy(*descriptor.OffsetElement<Descriptor>(
- j * byteStride + comp.offset()),
- finalize, *compType);
+ const Descriptor &compDesc{*descriptor.OffsetElement<Descriptor>(
+ j * byteStride + comp.offset())};
+ if (compDesc.IsAllocated()) {
+ Finalize(compDesc, *compType);
+ }
}
}
}
- for (std::size_t j{0}; j < elements; ++j) {
- descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
- ->Deallocate();
- }
} else if (comp.genre() == typeInfo::Component::Genre::Data &&
- comp.derivedType() && !comp.derivedType()->noDestructionNeeded()) {
+ comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
SubscriptValue extent[maxRank];
const typeInfo::Value *bounds{comp.bounds()};
for (int dim{0}; dim < comp.rank(); ++dim) {
compDesc.Establish(compType,
descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
comp.rank(), extent);
- Destroy(compDesc, finalize, compType);
+ Finalize(compDesc, compType);
}
}
}
if (recurse) {
- Destroy(descriptor, finalize, *parentType);
+ Finalize(descriptor, *parentType);
}
}
-// TODO: Assign()
+// The order of finalization follows Fortran 2018 7.5.6.2, with
+// elementwise deallocation of non-parent components (and their consequent
+// finalizations) taking place before parent component finalization.
+void Destroy(const Descriptor &descriptor, bool finalize,
+ const typeInfo::DerivedType &derived) {
+ if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
+ return;
+ }
+ if (finalize && !derived.noFinalizationNeeded()) {
+ Finalize(descriptor, derived);
+ }
+ const Descriptor &componentDesc{derived.component()};
+ std::size_t myComponents{componentDesc.Elements()};
+ std::size_t elements{descriptor.Elements()};
+ std::size_t byteStride{descriptor.ElementBytes()};
+ for (std::size_t k{0}; k < myComponents; ++k) {
+ const auto &comp{
+ *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
+ if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
+ comp.genre() == typeInfo::Component::Genre::Automatic) {
+ for (std::size_t j{0}; j < elements; ++j) {
+ descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
+ ->Deallocate();
+ }
+ }
+ }
+}
} // namespace Fortran::runtime
int Initialize(const Descriptor &, const typeInfo::DerivedType &, Terminator &,
bool hasStat = false, const Descriptor *errMsg = nullptr);
+// Call FINAL subroutines, if any
+void Finalize(const Descriptor &, const typeInfo::DerivedType &derived);
+
// Call FINAL subroutines, deallocate allocatable & automatic components.
// Does not deallocate the original descriptor.
void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &);
-// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or
-// defined assignment (10.2.1.4), as appropriate. Performs scalar expansion
-// or allocatable reallocation as needed. Does not perform intrinsic
-// assignment implicit type conversion.
-void Assign(Descriptor &, const Descriptor &, const typeInfo::DerivedType &,
- Terminator &);
-
} // namespace Fortran::runtime
#endif // FLANG_RUNTIME_DERIVED_H_
return parent ? parent->FindDataComponent(compName, compNameLen) : nullptr;
}
-const SpecialBinding *DerivedType::FindSpecialBinding(
- SpecialBinding::Which which) const {
- const Descriptor &specialDesc{special()};
- std::size_t n{specialDesc.Elements()};
- SubscriptValue at[maxRank];
- specialDesc.GetLowerBounds(at);
- for (std::size_t j{0}; j < n; ++j, specialDesc.IncrementSubscripts(at)) {
- const SpecialBinding &special{*specialDesc.Element<SpecialBinding>(at)};
- if (special.which() == which) {
- return &special;
- }
- }
- return nullptr;
-}
-
static void DumpScalarCharacter(
FILE *f, const Descriptor &desc, const char *what) {
if (desc.raw().version == CFI_VERSION &&
std::fputs(" <-- sizeInBytes_\n", f);
} else if (offset == offsetof(DerivedType, uninstantiated_)) {
std::fputs(" <-- uninstantiated_\n", f);
- } else if (offset == offsetof(DerivedType, typeHash_)) {
- std::fputs(" <-- typeHash_\n", f);
} else if (offset == offsetof(DerivedType, kindParameter_)) {
std::fputs(" <-- kindParameter_\n", f);
} else if (offset == offsetof(DerivedType, lenParameterKind_)) {
std::fputs(" <-- procPtr_\n", f);
} else if (offset == offsetof(DerivedType, special_)) {
std::fputs(" <-- special_\n", f);
- } else if (offset == offsetof(DerivedType, special_)) {
- std::fputs(" <-- special_\n", f);
+ } else if (offset == offsetof(DerivedType, specialBitSet_)) {
+ std::fputs(" <-- specialBitSet_\n", f);
} else if (offset == offsetof(DerivedType, hasParent_)) {
- std::fputs(
- " <-- hasParent_, noInitializationNeeded_, noDestructionNeeded_\n",
- f);
+ std::fputs(" <-- (flags)\n", f);
} else {
std::fputc('\n', f);
}
std::fprintf(
f, "SpecialBinding @ 0x%p:\n", reinterpret_cast<const void *>(this));
switch (which_) {
- case Which::Assignment:
- std::fputs(" Assignment", f);
+ case Which::ScalarAssignment:
+ std::fputs(" ScalarAssignment", f);
break;
case Which::ElementalAssignment:
std::fputs(" ElementalAssignment", f);
break;
- case Which::Final:
- std::fputs(" Final", f);
- break;
- case Which::ElementalFinal:
- std::fputs(" ElementalFinal", f);
- break;
- case Which::AssumedRankFinal:
- std::fputs(" AssumedRankFinal", f);
- break;
case Which::ReadFormatted:
std::fputs(" ReadFormatted", f);
break;
case Which::WriteUnformatted:
std::fputs(" WriteUnformatted", f);
break;
+ case Which::ElementalFinal:
+ std::fputs(" ElementalFinal", f);
+ break;
+ case Which::AssumedRankFinal:
+ std::fputs(" AssumedRankFinal", f);
+ break;
default:
- std::fprintf(
- f, " Unknown which: 0x%x", static_cast<std::uint8_t>(which_));
+ std::fprintf(f, " rank-%d final:",
+ static_cast<int>(which_) - static_cast<int>(Which::ScalarFinal));
break;
}
- std::fprintf(f, "\n rank: %d\n", rank_);
std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
std::fprintf(f, " proc: 0x%p\n", reinterpret_cast<void *>(proc_));
return f;
// flang/module/__fortran_type_info.f90.
#include "descriptor.h"
+#include "terminator.h"
#include "flang/Common/Fortran.h"
+#include "flang/Common/bit-population-count.h"
#include <cinttypes>
#include <memory>
#include <optional>
public:
enum class Which : std::uint8_t {
None = 0,
- Assignment = 4,
- ElementalAssignment = 5,
- Final = 8,
- ElementalFinal = 9,
- AssumedRankFinal = 10,
- ReadFormatted = 16,
- ReadUnformatted = 17,
- WriteFormatted = 18,
- WriteUnformatted = 19
+ ScalarAssignment = 1,
+ ElementalAssignment = 2,
+ ReadFormatted = 3,
+ ReadUnformatted = 4,
+ WriteFormatted = 5,
+ WriteUnformatted = 6,
+ ElementalFinal = 7,
+ AssumedRankFinal = 8,
+ ScalarFinal = 9,
+ // higher-ranked final procedures follow
};
+ static constexpr Which RankFinal(int rank) {
+ return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
+ }
+
Which which() const { return which_; }
- int rank() const { return rank_; }
bool IsArgDescriptor(int zeroBasedArg) const {
return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
}
private:
Which which_{Which::None};
- // Used for Which::Final only. Which::Assignment always has rank 0, as
- // type-bound defined assignment for rank > 0 must be elemental
- // due to the required passed object dummy argument, which are scalar.
- // User defined derived type I/O is always scalar.
- std::uint8_t rank_{0};
-
// The following little bit-set identifies which dummy arguments are
// passed via descriptors for their derived type arguments.
// Which::Assignment and Which::ElementalAssignment:
// When false, the user derived type I/O subroutine must have been
// called via a generic interface, not a generic TBP.
std::uint8_t isArgDescriptorSet_{0};
+ std::uint8_t __padding0_[6];
ProcedurePointer proc_{nullptr};
};
const Descriptor &binding() const { return binding_.descriptor(); }
const Descriptor &name() const { return name_.descriptor(); }
std::uint64_t sizeInBytes() const { return sizeInBytes_; }
- std::uint64_t typeHash() const { return typeHash_; }
const Descriptor &uninstatiated() const {
return uninstantiated_.descriptor();
}
bool hasParent() const { return hasParent_; }
bool noInitializationNeeded() const { return noInitializationNeeded_; }
bool noDestructionNeeded() const { return noDestructionNeeded_; }
+ bool noFinalizationNeeded() const { return noFinalizationNeeded_; }
std::size_t LenParameters() const { return lenParameterKind().Elements(); }
const Component *FindDataComponent(
const char *name, std::size_t nameLen) const;
- const SpecialBinding *FindSpecialBinding(SpecialBinding::Which) const;
+ // O(1) look-up of special procedure bindings
+ const SpecialBinding *FindSpecialBinding(SpecialBinding::Which which) const {
+ auto bitIndex{static_cast<std::uint32_t>(which)};
+ auto bit{std::uint32_t{1} << bitIndex};
+ if (specialBitSet_ & bit) {
+ // The index of this special procedure in the sorted array is the
+ // number of special bindings that are present with smaller "which"
+ // code values.
+ int offset{common::BitPopulationCount(specialBitSet_ & (bit - 1))};
+ const auto *binding{
+ special_.descriptor().ZeroBasedIndexedElement<SpecialBinding>(
+ offset)};
+ INTERNAL_CHECK(binding && binding->which() == which);
+ return binding;
+ } else {
+ return nullptr;
+ }
+ }
FILE *Dump(FILE * = stdout) const;
// no KIND type parameters will have a null pointer here.
StaticDescriptor<0, true> uninstantiated_; // TYPE(DERIVEDTYPE), POINTER
- // TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2)
- std::uint64_t typeHash_{0};
-
// These pointer targets include all of the items from the parent, if any.
StaticDescriptor<1> kindParameter_; // pointer to rank-1 array of INTEGER(8)
StaticDescriptor<1>
StaticDescriptor<1, true>
procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS
+ // Packed in ascending order of "which" code values.
// Does not include special bindings from ancestral types.
StaticDescriptor<1, true>
special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS
+ // Little-endian bit-set of special procedure binding "which" code values
+ // for O(1) look-up in FindSpecialBinding() above.
+ std::uint32_t specialBitSet_{0};
+
+ // Flags
bool hasParent_{false};
bool noInitializationNeeded_{false};
bool noDestructionNeeded_{false};
+ bool noFinalizationNeeded_{false};
+ bool __padding0_[4];
};
} // namespace Fortran::runtime::typeInfo
end type
!CHECK: Module scope: m01
!CHECK: .c.t1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.n,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
-!CHECK: .dt.t1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
+!CHECK: .dt.t1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
!CHECK: .n.n, SAVE, TARGET: ObjectEntity type: CHARACTER(1_8,1) init:"n"
!CHECK: .n.t1, SAVE, TARGET: ObjectEntity type: CHARACTER(2_8,1) init:"t1"
!CHECK: DerivedType scope: t1
end type
!CHECK: .c.child, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::component(name=.n.parent,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.parent,lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.cn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=4_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
!CHECK: .c.parent, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.pn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
-!CHECK: .dt.child, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL(),hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
-!CHECK: .dt.parent, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
+!CHECK: .dt.child, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
+!CHECK: .dt.parent, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
end module
module m03
type(kpdt(4)) :: x
!CHECK: .c.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.a,genre=1_1,category=1_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
!CHECK: .dt.kpdt, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.kpdt,uninstantiated=NULL(),kindparameter=.kp.kpdt,lenparameterkind=NULL())
-!CHECK: .dt.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.0,lenparameterkind=NULL(),component=.c.kpdt.0,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
+!CHECK: .dt.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.0,lenparameterkind=NULL(),component=.c.kpdt.0,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
!CHECK: .kp.kpdt, SAVE, TARGET: ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::1_8]
!CHECK: .kp.kpdt.0, SAVE, TARGET: ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::4_8]
end module
subroutine s1(x)
class(tbps), intent(in) :: x
end subroutine
-!CHECK: .dt.tbps, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
+!CHECK: .dt.tbps, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
!CHECK: .v.tbps, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=s1,name=.n.b1),binding(proc=s1,name=.n.b2)]
end module
subroutine s1(x)
class(t), intent(in) :: x
end subroutine
-!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=24_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL(),hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1)
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=24_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
!CHECK: .p.t, SAVE, TARGET: ObjectEntity type: TYPE(procptrcomponent) shape: 0_8:0_8 init:[procptrcomponent::procptrcomponent(name=.n.p1,offset=0_8,initialization=s1)]
end module
class(t), intent(in) :: y
end subroutine
!CHECK: .c.t2, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.t,lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
-!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
-!CHECK: .dt.t2, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=4_1,rank=0_1,isargdescriptorset=3_1,proc=s1)]
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
+!CHECK: .dt.t2, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,proc=s1)]
!CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
!CHECK: .v.t2, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s2,name=.n.s1)]
end module
class(t), intent(out) :: x
class(t), intent(in) :: y
end subroutine
-!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,rank=0_1,isargdescriptorset=3_1,proc=s1)]
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,proc=s1)]
!CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
end module
impure elemental subroutine s3(x)
type(t) :: x
end subroutine
-!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1)
-!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=8_1,rank=1_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=8_1,rank=2_1,isargdescriptorset=0_1,proc=s2),specialbinding(which=9_1,rank=0_1,isargdescriptorset=0_1,proc=s3)]
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=3200_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,proc=s2)]
end module
module m09
integer, intent(out) :: iostat
character(len=*), intent(inout) :: iomsg
end subroutine
-!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=16_1,rank=0_1,isargdescriptorset=1_1,proc=rf),specialbinding(which=17_1,rank=0_1,isargdescriptorset=1_1,proc=ru),specialbinding(which=18_1,rank=0_1,isargdescriptorset=1_1,proc=wf),specialbinding(which=19_1,rank=0_1,isargdescriptorset=1_1,proc=wu)]
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,proc=wu)]
!CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:3_8 init:[binding::binding(proc=rf,name=.n.rf),binding(proc=ru,name=.n.ru),binding(proc=wf,name=.n.wf),binding(proc=wu,name=.n.wu)]
end module
integer, intent(out) :: iostat
character(len=*), intent(inout) :: iomsg
end subroutine
-!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=16_1,rank=0_1,isargdescriptorset=0_1,proc=rf),specialbinding(which=17_1,rank=0_1,isargdescriptorset=0_1,proc=ru),specialbinding(which=18_1,rank=0_1,isargdescriptorset=0_1,proc=wf),specialbinding(which=19_1,rank=0_1,isargdescriptorset=0_1,proc=wu)]
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,proc=wu)]
end module
module m11
!CHECK: .c.t.1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=1_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=.di.t.1.pointer),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL())]
!CHECK: .di.t.1.pointer, SAVE, TARGET: ObjectEntity type: TYPE(.dp.t.1.pointer) init:.dp.t.1.pointer(pointer=target)
!CHECK: .dp.t.1.pointer: DerivedType components: pointer
-!CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1)
+!CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1)
!CHECK: .lpk.t.1, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1]
!CHECK: DerivedType scope: .dp.t.1.pointer size=24 alignment=8 instantiation of .dp.t.1.pointer
!CHECK: pointer, POINTER size=24 offset=0: ObjectEntity type: REAL(4)