[flang] Implement runtime Assign()

[klausler]

Summary

Define an API for, and implement, runtime support for arbitrary
assignment of one descriptor's data to another, with full support for
(re)allocation of allocatables with finalization when necessary,
user-defined derived type assignment TBP calls, and intrinsic (default)
componentwise assignment of derived type instances with allocation of
automatic components. Also clean up API and implementation of
finalization/destruction using knowledge gained while studying
edge cases for assignment in the 2018 standard.

The look-up procedure for special procedure bindings in derived
types has been optimized from O(N) to O(1) since it will probably
matter more. This required some analysis in runtime derived type
description table construction in semantics and some changes to the
table schemata.

Executable Fortran tests have been developed; they'll be added
to the test base once they can be lowered and run by f18.

[jeanPerier]

Looks great, thanks !

flang/include/flang/Semantics/tools.h

inline bool IsIntentOut(const Symbol &symbol) {
   return symbol.attrs().test(Attr::INTENT_OUT);
 }
 inline bool IsProtected(const Symbol &symbol) {
   return symbol.attrs().test(Attr::PROTECTED);
 }
 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 IsAutomaticObject(const Symbol &);
 inline bool IsAssumedSizeArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->IsAssumedSize();
 }

flang/include/flang/Semantics/type.h

public:
   void ReplaceScope(const Scope &);
   RawParameters &rawParameters() { return rawParameters_; }
   const ParameterMapType &parameters() const { return parameters_; }
 
   bool MightBeParameterized() const;
   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().
   // It can be used with forward-referenced derived types.
   void AddRawParamValue(const std::optional<parser::Keyword> &, ParamValue &&);
   // Checks the raw parameter list against the definition of a derived type.
   // Converts the raw parameter list to a map, naming each actual parameter.
   void CookParameters(evaluate::FoldingContext &);

flang/lib/Semantics/runtime-type-info.cpp

 //===-- lib/Semantics/runtime-type-info.cpp ---------------------*- C++ -*-===//
 //
 // 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 "flang/Semantics/runtime-type-info.h"
 #include "mod-file.h"
 #include "flang/Evaluate/fold-designator.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/tools.h"
+#include <functional>
 #include <list>
 #include <map>
 #include <string>
 
 namespace Fortran::semantics {
 
 static int FindLenParameterIndex(
     const SymbolVector &parameters, const Symbol &symbol) {
bool InitializeDataPointer(evaluate::StructureConstructorValues &,
       Scope &dtScope, const std::string &distinctName);
   evaluate::StructureConstructor PackageIntValue(
       const SomeExpr &genre, std::int64_t = 0) const;
   SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;
   std::vector<const Symbol *> CollectBindings(const Scope &dtScope) const;
   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
   template <typename A>
   evaluate::StructureConstructor GetValue(
       const A &x, const SymbolVector *parameters) {
     if (x.isExplicit()) {
       return GetValue(x.GetExplicit(), parameters);
private:
   const DeclTypeSpec &componentSchema_; // TYPE(Component)
   const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent)
   const DeclTypeSpec &valueSchema_; // TYPE(Value)
   const DeclTypeSpec &bindingSchema_; // TYPE(Binding)
   const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding)
   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_;
 };
 
 RuntimeTableBuilder::RuntimeTableBuilder(
     SemanticsContext &c, RuntimeDerivedTypeTables &t)
     : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
       componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema(
                                                     "procptrcomponent")},
       valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema("binding")},
       specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
                                                        "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);
 }
 
 void RuntimeTableBuilder::DescribeTypes(Scope &scope, bool inSchemata) {
   inSchemata |= ignoreScopes_.find(&scope) != ignoreScopes_.end();
   if (scope.IsDerivedType()) {
     if (!inSchemata) { // don't loop trying to describe a schema
       DescribeType(scope);
if (isPDTinstantiation) {
     AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
             evaluate::Designator<evaluate::SomeDerived>{
                 DEREF(uninstDescObject)}}));
   } else {
     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;
   std::vector<Int1::Scalar> lenKinds;
   const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
   if (parameters) {
     // Package the derived type's parameters in declaration order for
     // each category of parameter.  KIND= type parameters are described
AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
           scope, SaveObjectName(".kp."s + distinctName), std::move(kinds)));
   AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
       SaveNumericPointerTarget<Int1>(
           scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
   // Traverse the components of the derived type
   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())};
       std::visit(
           common::visitors{
               [&](const TypeParamDetails &) {
                 // already handled above in declaration order
               },
std::vector<evaluate::StructureConstructor> bindings{
         DescribeBindings(dtScope, scope)};
     AddValue(dtValues, derivedTypeSchema_, "binding"s,
         SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName),
             std::move(bindings),
             evaluate::ConstantSubscripts{
                 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},
         GenericKind::DefinedIo::ReadFormatted, &scope);
     IncorporateDefinedIoGenericInterfaces(specials,
         SourceName{"read(unformatted)", 17},
         GenericKind::DefinedIo::ReadUnformatted, &scope);
     IncorporateDefinedIoGenericInterfaces(specials,
         SourceName{"write(formatted)", 16},
         GenericKind::DefinedIo::WriteFormatted, &scope);
     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));
     // To avoid wasting run time attempting to initialize derived type
     // instances without any initialized components, analyze the type
     // and set a flag if there's nothing to do for it at run time.
     AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s,
         IntExpr<1>(
             derivedTypeSpec && !derivedTypeSpec->HasDefaultInitialization()));
     // 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)))});
   return &dtObject;
 }
 
 static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
   auto iter{schemata.find(name)};
for (const Symbol *symbol : CollectBindings(dtScope)) {
     AddValue(values, bindingSchema_, "name"s,
         SaveNameAsPointerTarget(scope, symbol->name().ToString()));
     result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
   }
   return result;
 }
 
 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) {
                      for (auto ref : generic.specificProcs()) {
                        DescribeSpecialProc(specials, *ref, true,
                            false /*!final*/, std::nullopt);
                      }
                    }
std::visit(common::visitors{
                    }
                  },
                  [](const auto &) {},
              },
       generic.kind().u);
 }
 
 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;
         isArgDescriptorSet |= 2;
       } else {
         argThatMightBeDescriptor = 2; // the non-passed-object argument
         isArgDescriptorSet |= 1;
       }
     } else if (isFinal) {
       CHECK(binding == nullptr); // FINALs are not bindings
       CHECK(proc->dummyArguments.size() == 1);
       if (proc->IsElemental()) {
         which = elementalFinalEnum_;
       } else {
         const auto &typeAndShape{
             std::get<evaluate::characteristics::DummyDataObject>(
                 proc->dummyArguments.at(0).u)
                 .type};
         if (typeAndShape.attrs().test(
                 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
           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);
           }
         }
       }
     } else { // user defined derived type I/O
       CHECK(proc->dummyArguments.size() >= 4);
       if (binding) {
         isArgDescriptorSet |= 1;
       }
if (isAssignment) { // only type-bound asst's are germane to runtime
       }
     }
     if (argThatMightBeDescriptor != 0 &&
         !proc->dummyArguments.at(argThatMightBeDescriptor - 1)
              .CanBePassedViaImplicitInterface()) {
       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()) {
       const Symbol &generic{*asst->second};
       const auto &genericDetails{generic.get<GenericDetails>()};
       CHECK(std::holds_alternative<GenericKind::DefinedIo>(
           genericDetails.kind().u));
       CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==

flang/lib/Semantics/tools.cpp

if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
           }
         }
       }
     }
   }
   return false;
 }
 
-bool IsFinalizable(const Symbol &symbol) {
+bool IsFinalizable(
+    const Symbol &symbol, std::set<const DerivedTypeSpec *> *inProgress) {
   if (IsPointer(symbol)) {
     return false;
   }
   if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
     if (object->isDummy() && !IsIntentOut(symbol)) {
       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) {
   if (const auto *details{
           derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
     const auto &finals{details->finals()};
     return std::any_of(finals.begin(), finals.end(),
         [](const auto &x) { return !x.second->attrs().test(Attr::PURE); });

flang/module/__fortran_type_info.f90

type :: DerivedType
     ! appear in the parent type's bindings, if any.  They are followed
     ! by new local bindings in alphabetic order of theing binding names.
     type(Binding), pointer, contiguous :: binding(:)
     character(len=:), pointer :: name
     integer(kind=int64) :: sizeInBytes
     ! 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.
     ! The parent component, if any, appears explicitly and first.
     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
     type(__builtin_c_funptr) :: proc
     character(len=:), pointer :: name
   end type
 
   ! Array bounds and type parameters of components are deferred
module __Fortran_type_info
 
   type :: ProcPtrComponent ! procedure pointer components
     character(len=:), pointer :: name
     integer(kind=int64) :: offset
     type(__builtin_c_funptr) :: initialization
   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
 
 end module

flang/runtime/CMakeLists.txt

 # include_directories is used here instead of target_include_directories
 # because add_flang_library creates multiple objects (STATIC/SHARED, OBJECT)
 # with different names
 include_directories(AFTER ${CMAKE_CURRENT_BINARY_DIR})
 
 add_flang_library(FortranRuntime
   ISO_Fortran_binding.cpp
   allocatable.cpp
+  assign.cpp
   buffer.cpp
   complex-reduction.c
   copy.cpp
   character.cpp
   connection.cpp
   derived.cpp
   derived-api.cpp
   descriptor.cpp

flang/runtime/allocatable.h

 // Performs all necessary coarray synchronization and validation actions.
 int RTNAME(AllocatableAllocate)(Descriptor &, bool hasStat = false,
     const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
     int sourceLine = 0);
 int RTNAME(AllocatableAllocateSource)(Descriptor &, const Descriptor &source,
     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
 // must be initialized.
 int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor &from,
     bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 

flang/runtime/allocatable.cpp

 //===-- runtime/allocatable.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 "allocatable.h"
+#include "assign.h"
 #include "derived.h"
 #include "stat.h"
 #include "terminator.h"
 #include "type-info.h"
 
 namespace Fortran::runtime {
 extern "C" {
 

 
 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
     const typeInfo::DerivedType &derivedType, int rank, int corank) {
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(
       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*/) {
   INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented
   return StatOk;
 }
 
 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,

flang/runtime/assign.h

+//===-- 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_

flang/runtime/assign.cpp

+//===-- 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

flang/runtime/derived.h

 class Descriptor;
 class Terminator;
 
 // Perform default component initialization, allocate automatic components.
 // Returns a STAT= code (0 when all's well).
 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_

flang/runtime/derived.cpp

for (std::size_t j{0}; j < elements; ++j) {
       pptr = comp.procInitialization;
     }
   }
   return stat;
 }
 
 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(
     const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
   if (const auto *special{FindFinal(derived, descriptor.rank())}) {
     // The following code relies on the fact that finalizable objects
     // must be contiguous.
     if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
       p(tmpDesc);
     } else {
       auto *p{special->GetProc<void (*)(char *)>()};
       p(descriptor.OffsetElement<char>());
     }
   }
 }
 
-// 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};
        k < myComponents; ++k) {
     const auto &comp{
         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
     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) {
         extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) -
             bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1;
       }
       StaticDescriptor<maxRank, true, 0> staticDescriptor;
       Descriptor &compDesc{staticDescriptor.descriptor()};
       const typeInfo::DerivedType &compType{*comp.derivedType()};
       for (std::size_t j{0}; j < elements; ++j) {
         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

flang/runtime/type-info.h

 //===-- runtime/type-info.h -------------------------------------*- C++ -*-===//
 //
 // 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
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_RUNTIME_TYPE_INFO_H_
 #define FORTRAN_RUNTIME_TYPE_INFO_H_
 
 // A C++ perspective of the derived type description schemata in
 // 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>
 
 namespace Fortran::runtime::typeInfo {
 
 class DerivedType;
 
struct ProcPtrComponent {
   std::uint64_t offset{0};
   ProcedurePointer procInitialization;
 };
 
 class SpecialBinding {
 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;
   }
   template <typename PROC> PROC GetProc() const {
     return reinterpret_cast<PROC>(proc_);
   }
 
   FILE *Dump(FILE *) const;
 
 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:
   //     Set to 1, 2, or (usually 3).
   //     The passed-object argument (usually the "to") is always passed via a
   //     a descriptor in the cases where the runtime will call a defined
   //     assignment because these calls are to type-bound generics,
   //     not generic interfaces, and type-bound generic defined assigment
private:
   //     use a descriptors when the type has LEN parameters.)
   //   Which::AssumedRankFinal: flag must necessarily be set
   //   User derived type I/O:
   //     Set to 1 when "dtv" initial dummy argument is polymorphic, which is
   //     the case when and only when the derived type is extensible.
   //     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};
 };
 
 class DerivedType {
 public:
   ~DerivedType(); // never defined
 
   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();
   }
   const Descriptor &kindParameter() const {
     return kindParameter_.descriptor();
   }
   const Descriptor &lenParameterKind() const {
     return lenParameterKind_.descriptor();
   }
   const Descriptor &component() const { return component_.descriptor(); }
   const Descriptor &procPtr() const { return procPtr_.descriptor(); }
   const Descriptor &special() const { return special_.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 DerivedType *GetParentType() const;
 
   // Finds a data component by name in this derived type or tis ancestors.
   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;
 
 private:
   // This member comes first because it's used like a vtable by generated code.
   // It includes all of the ancestor types' bindings, if any, first,
   // with any overrides from descendants already applied to them.  Local
   // bindings then follow in alphabetic order of binding name.
   StaticDescriptor<1, true>
       binding_; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS
 
   StaticDescriptor<0> name_; // CHARACTER(:), POINTER
 
   std::uint64_t sizeInBytes_{0};
 
   // Instantiations of a parameterized derived type with KIND type
   // parameters will point this data member to the description of
   // the original uninstantiated type, which may be shared from a
   // module via use association.  The original uninstantiated derived
   // type description will point to itself.  Derived types that have
   // 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>
       lenParameterKind_; // pointer to rank-1 array of INTEGER(1)
 
   // This array of local data components includes the parent component.
   // Components are in component order, not collation order of their names.
   // It does not include procedure pointer components.
   StaticDescriptor<1, true>
       component_; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
 
   // Procedure pointer components
   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
 #endif // FORTRAN_RUNTIME_TYPE_INFO_H_

flang/runtime/type-info.cpp

if (nameDesc.ElementBytes() == compNameLen &&
         std::memcmp(compName, nameDesc.OffsetElement(), compNameLen) == 0) {
       return component;
     }
   }
   const DerivedType *parent{GetParentType()};
   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 &&
       desc.type() == TypeCode{TypeCategory::Character, 1} &&
       desc.ElementBytes() > 0 && desc.rank() == 0 &&
       desc.OffsetElement() != nullptr) {
     std::fwrite(desc.OffsetElement(), desc.ElementBytes(), 1, f);
   } else {
for (int j{0}; j < 64; ++j) {
     if (offset == offsetof(DerivedType, binding_)) {
       std::fputs(" <-- binding_\n", f);
     } else if (offset == offsetof(DerivedType, name_)) {
       std::fputs(" <-- name_\n", f);
     } else if (offset == offsetof(DerivedType, sizeInBytes_)) {
       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(" <-- lenParameterKind_\n", f);
     } else if (offset == offsetof(DerivedType, component_)) {
       std::fputs(" <-- component_\n", f);
     } else if (offset == offsetof(DerivedType, procPtr_)) {
       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::fputs("  name: ", f);
   DumpScalarCharacter(f, name(), "DerivedType::name");
   const Descriptor &bindingDesc{binding()};
   std::fprintf(
FILE *Component::Dump(FILE *f) const {
   }
   return f;
 }
 
 FILE *SpecialBinding::Dump(FILE *f) const {
   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::ReadUnformatted:
     std::fputs("    ReadUnformatted", f);
     break;
   case Which::WriteFormatted:
     std::fputs("    WriteFormatted", 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;
 }
 
 } // namespace Fortran::runtime::typeInfo

flang/test/Semantics/typeinfo01.f90

 !RUN: %flang_fc1 -fdebug-dump-symbols %s | FileCheck %s
 ! Tests for derived type runtime descriptions
 
 module m01
   type :: t1
     integer :: n
   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 module
 
 module m02
   type :: parent
     integer :: pn
   end type
   type, extends(parent) :: child
     integer :: cn
   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(k)
     integer(kind=1), kind :: k = 1
     real(kind=k) :: a
   end type
   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
 
 module m04
   type :: tbps
    contains
     procedure :: b2 => s1
     procedure :: b1 => s1
   end type
  contains
   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
 
 module m05
   type :: t
     procedure(s1), pointer :: p1 => s1
   end type
  contains
   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
 
 module m06
   type :: t
    contains
     procedure :: s1
     generic :: assignment(=) => s1
   end type
   type, extends(t) :: t2
    contains
     procedure :: s1 => s2 ! override
   end type
  contains
   subroutine s1(x, y)
     class(t), intent(out) :: x
     class(t), intent(in) :: y
   end subroutine
   subroutine s2(x, y)
     class(t2), intent(out) :: x
     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
 
 module m07
   type :: t
    contains
     procedure :: s1
     generic :: assignment(=) => s1
   end type
  contains
   impure elemental subroutine s1(x, y)
     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
 
 module m08
   type :: t
    contains
     final :: s1, s2, s3
   end type
  contains
   subroutine s1(x)
     type(t) :: x(:)
   end subroutine
   subroutine s2(x)
     type(t) :: x(3,3)
   end subroutine
   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
   type :: t
    contains
     procedure :: rf, ru, wf, wu
     generic :: read(formatted) => rf
     generic :: read(unformatted) => ru
subroutine wf(x,u,iot,v,iostat,iomsg)
     character(len=*), intent(inout) :: iomsg
   end subroutine
   subroutine wu(x,u,iostat,iomsg)
     class(t), intent(in) :: x
     integer, intent(in) :: u
     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
 
 module m10
   type, bind(c) :: t ! non-extensible
   end type
   interface read(formatted)
     procedure :: rf
subroutine wf(x,u,iot,v,iostat,iomsg)
     character(len=*), intent(inout) :: iomsg
   end subroutine
   subroutine wu(x,u,iostat,iomsg)
     type(t), intent(in) :: x
     integer, intent(in) :: u
     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
   real, target :: target
   type :: t(len)
     integer(kind=8), len :: len
     real, allocatable :: allocatable(:)
     real, pointer :: pointer => target
     character(len=len) :: chauto
     real :: automatic(len)
   end type
 !CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t)
 !CHECK: .lpk.t, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1]
  contains
   subroutine s1(x)
 !CHECK: .b.t.1.automatic, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=2_1,value=1_8),value(genre=3_1,value=0_8)],shape=[2,1])
 !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)
     type(t(*)), intent(in) :: x
   end subroutine
 end module
 
 module m12