[flang][runtime] Recognize and handle FINAL subroutines with contiguous dummy arrays when data are not so

[klausler]

Summary

When a FINAL subroutine is being invoked for a discontiguous array, which can
happen for INTENT(OUT) dummy arguments and for some left-hand side variables
in intrinsic assignment statements, it may be the case that the subroutine
being called was defined with a dummy argument that requires contiguous data.

Extend the derived type descriptions used by the runtime to signify when
a special procedure binding requires contiguity; set the flags accordingly;
check them in the runtime support library, and, when necessary, use a
temporary shallow copy of the finalized array data in the call to the
final subroutine.

[vzakhari]

Thank you!

[klausler]

clang-format

[klausler]

Try reformatting with the latest clang-format, maybe that's what the CI check is using. Grr.

flang/include/flang/Runtime/descriptor.h

 namespace Fortran::runtime::typeInfo {
 using TypeParameterValue = std::int64_t;
 class DerivedType;
 } // namespace Fortran::runtime::typeInfo
 
 namespace Fortran::runtime {
 
 using SubscriptValue = ISO::CFI_index_t;
+class Terminator;
 
 RT_VAR_GROUP_BEGIN
 static constexpr RT_CONST_VAR_ATTRS int maxRank{CFI_MAX_RANK};
 RT_VAR_GROUP_END
 
 // A C++ view of the sole interoperable standard descriptor (ISO::CFI_cdesc_t)
 // and its type and per-dimension information.
 
public:
   RT_API_ATTRS int Allocate();
 
   // Deallocates storage; does not call FINAL subroutines or
   // deallocate allocatable/automatic components.
   RT_API_ATTRS int Deallocate();
 
   // Deallocates storage, including allocatable and automatic
   // components.  Optionally invokes FINAL subroutines.
-  RT_API_ATTRS int Destroy(bool finalize = false, bool destroyPointers = false);
+  RT_API_ATTRS int Destroy(bool finalize = false, bool destroyPointers = false,
+      Terminator * = nullptr);
 
   RT_API_ATTRS bool IsContiguous(int leadingDimensions = maxRank) const {
     auto bytes{static_cast<SubscriptValue>(ElementBytes())};
     if (leadingDimensions > raw_.rank) {
       leadingDimensions = raw_.rank;
     }
     for (int j{0}; j < leadingDimensions; ++j) {
       const Dimension &dim{GetDimension(j)};

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

private:
   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(
-                                            bindingDescCompName)},
-      specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
-                                                       "deferred")},
-      explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
-                                                   "lenparameter")},
+      componentSchema_{GetSchema("component")},
+      procPtrSchema_{GetSchema("procptrcomponent")},
+      valueSchema_{GetSchema("value")},
+      bindingSchema_{GetSchema(bindingDescCompName)},
+      specialSchema_{GetSchema("specialbinding")},
+      deferredEnum_{GetEnumValue("deferred")},
+      explicitEnum_{GetEnumValue("explicit")},
+      lenParameterEnum_{GetEnumValue("lenparameter")},
       scalarAssignmentEnum_{GetEnumValue("scalarassignment")},
       elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
       readFormattedEnum_{GetEnumValue("readformatted")},
       readUnformattedEnum_{GetEnumValue("readunformatted")},
       writeFormattedEnum_{GetEnumValue("writeformatted")},
       writeUnformattedEnum_{GetEnumValue("writeunformatted")},
       elementalFinalEnum_{GetEnumValue("elementalfinal")},
       assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
if (!dtSymbol->attrs().test(Attr::ABSTRACT)) {
       // Describe "special" bindings to defined assignments, FINAL subroutines,
       // and defined derived type I/O subroutines.  Defined assignments and I/O
       // subroutines override any parent bindings, but FINAL subroutines do not
       // (the runtime will call all of them).
       std::map<int, evaluate::StructureConstructor> specials{
           DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
       if (derivedTypeSpec) {
         for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
-          DescribeSpecialProc(specials, *ref, false /*!isAssignment*/, true,
-              std::nullopt, nullptr, derivedTypeSpec, true);
+          DescribeSpecialProc(specials, *ref, /*isAssignment-*/ false,
+              /*isFinal=*/true, std::nullopt, nullptr, derivedTypeSpec,
+              /*isTypeBound=*/true);
         }
         IncorporateDefinedIoGenericInterfaces(specials,
             common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
         IncorporateDefinedIoGenericInterfaces(specials,
             common::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
         IncorporateDefinedIoGenericInterfaces(specials,
             common::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
         IncorporateDefinedIoGenericInterfaces(specials,

 void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
     std::map<int, evaluate::StructureConstructor> &specials,
     const Scope &dtScope, const DerivedTypeSpec *derivedTypeSpec) const {
   common::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, &dtScope, derivedTypeSpec, true);
+                DescribeSpecialProc(specials, *ref, /*isAssignment=*/true,
+                    /*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,
+                    /*isTypeBound=*/true);
               }
             }
           },
           [&](const common::DefinedIo &io) {
             switch (io) {
             case common::DefinedIo::ReadFormatted:
             case common::DefinedIo::ReadUnformatted:
             case common::DefinedIo::WriteFormatted:
             case common::DefinedIo::WriteUnformatted:
               for (auto ref : generic.specificProcs()) {
-                DescribeSpecialProc(specials, *ref, false, false /*!final*/, io,
-                    &dtScope, derivedTypeSpec, true);
+                DescribeSpecialProc(specials, *ref, /*isAssignment=*/false,
+                    /*isFinal=*/false, io, &dtScope, derivedTypeSpec,
+                    /*isTypeBound=*/true);
               }
               break;
             }
           },
           [](const auto &) {},
       },
       generic.kind().u);
 }
 
 void RuntimeTableBuilder::DescribeSpecialProc(
     std::map<int, evaluate::StructureConstructor> &specials,
     const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
     std::optional<common::DefinedIo> io, const Scope *dtScope,
     const DerivedTypeSpec *derivedTypeSpec, bool isTypeBound) const {
   const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
   if (binding && dtScope) { // use most recent override
     binding = &DEREF(dtScope->FindComponent(specificOrBinding.name()))
                    .get<ProcBindingDetails>();
   }
   const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
   if (auto proc{evaluate::characteristics::Procedure::Characterize(
           specific, context_.foldingContext())}) {
     std::uint8_t isArgDescriptorSet{0};
+    std::uint8_t isArgContiguousSet{0};
     int argThatMightBeDescriptor{0};
     MaybeExpr which;
     if (isAssignment) {
       // Only type-bound asst's with the same type on both dummy arguments
       // are germane to the runtime, which needs only these to implement
       // component assignment as part of intrinsic assignment.
       // Non-type-bound generic INTERFACEs and assignments from distinct
       // types must not be used for component intrinsic assignment.
if (isAssignment) {
         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{
+        const auto &dummyData{
             std::get<evaluate::characteristics::DummyDataObject>(
-                proc->dummyArguments.at(0).u)
-                .type};
+                proc->dummyArguments.at(0).u)};
+        const auto &typeAndShape{dummyData.type};
         if (typeAndShape.attrs().test(
                 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
           which = assumedRankFinalEnum_;
           isArgDescriptorSet |= 1;
         } else {
           which = scalarFinalEnum_;
           if (int rank{evaluate::GetRank(typeAndShape.shape())}; rank > 0) {
-            argThatMightBeDescriptor = 1;
             which = IntExpr<1>(ToInt64(which).value() + rank);
+            if (!proc->dummyArguments[0].CanBePassedViaImplicitInterface()) {
+              argThatMightBeDescriptor = 1;
+            }
+            if (!typeAndShape.attrs().test(evaluate::characteristics::
+                        TypeAndShape::Attr::AssumedShape) ||
+                dummyData.attrs.test(evaluate::characteristics::
+                        DummyDataObject::Attr::Contiguous)) {
+              isArgContiguousSet |= 1;
+            }
           }
         }
       }
     } else { // defined derived type I/O
       CHECK(proc->dummyArguments.size() >= 4);
       const auto *ddo{std::get_if<evaluate::characteristics::DummyDataObject>(
           &proc->dummyArguments[0].u)};
       if (!ddo) {
if (auto proc{evaluate::characteristics::Procedure::Characterize(
     auto index{evaluate::ToInt64(which)};
     CHECK(index.has_value());
     AddValue(
         values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
     AddValue(values, specialSchema_, "isargdescriptorset"s,
         IntExpr<1>(isArgDescriptorSet));
     AddValue(values, specialSchema_, "istypebound"s,
         IntExpr<1>(isTypeBound ? 1 : 0));
+    AddValue(values, specialSchema_, "isargcontiguousset"s,
+        IntExpr<1>(isArgContiguousSet));
     AddValue(values, specialSchema_, procCompName,
         SomeExpr{evaluate::ProcedureDesignator{specific}});
     // index might already be present in the case of an override
     specials.emplace(*index,
         evaluate::StructureConstructor{
             DEREF(specialSchema_.AsDerived()), std::move(values)});
   }
 }
RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
   }
   return result;
 }
 
 // Find the type of a defined I/O procedure's interface's initial "dtv"
 // dummy argument.  Returns a non-null DeclTypeSpec pointer only if that
 // dtv argument exists and is a derived type.
 static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {
-  const Symbol *interface {
-    &specific.GetUltimate()
-  };
+  const Symbol *interface{&specific.GetUltimate()};
   if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {
     interface = procEntity->procInterface();
   }
   if (interface) {
     if (const SubprogramDetails *
             subprogram{interface->detailsIf<SubprogramDetails>()};
         subprogram && !subprogram->dummyArgs().empty()) {
       if (const Symbol * dtvArg{subprogram->dummyArgs().at(0)}) {

flang/module/__fortran_type_info.f90

enum, bind(c) ! SpecialBinding::Which
     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) :: isArgDescriptorSet
     integer(1) :: isTypeBound
-    integer(1) :: __padding0(5)
+    integer(1) :: isArgContiguousSet
+    integer(1) :: __padding0(4)
     type(__builtin_c_funptr) :: proc
   end type
 
 end module

flang/runtime/allocatable.cpp

std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
   // If to and from are the same allocatable they must not be allocated
   // and nothing should be done.
   if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {
     return ReturnError(
         terminator, StatMoveAllocSameAllocatable, errMsg, hasStat);
   }
 
   if (to.IsAllocated()) {
-    int stat{to.Destroy(/*finalize=*/true)};
+    int stat{
+        to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)};
     if (stat != StatOk) {
       return ReturnError(terminator, stat, errMsg, hasStat);
     }
   }
 
   // If from isn't allocated, the standard defines that nothing should be done.
   if (from.IsAllocated()) {
     to = from;
int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   if (!descriptor.IsAllocatable()) {
     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
   }
   if (!descriptor.IsAllocated()) {
     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
   }
-  return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat);
+  return ReturnError(terminator,
+      descriptor.Destroy(
+          /*finalize=*/true, /*destroyPointers=*/false, &terminator),
+      errMsg, hasStat);
 }
 
 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
     const typeInfo::DerivedType *derivedType, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   int stat{RTNAME(AllocatableDeallocate)(
       descriptor, hasStat, errMsg, sourceFile, sourceLine)};
   if (stat == StatOk) {

 void RTNAME(AllocatableDeallocateNoFinal)(
     Descriptor &descriptor, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   if (!descriptor.IsAllocatable()) {
     ReturnError(terminator, StatInvalidDescriptor);
   } else if (!descriptor.IsAllocated()) {
     ReturnError(terminator, StatBaseNull);
   } else {
-    ReturnError(terminator, descriptor.Destroy(false));
+    ReturnError(terminator,
+        descriptor.Destroy(
+            /*finalize=*/false, /*destroyPointers=*/false, &terminator));
   }
 }
 
 // TODO: AllocatableCheckLengthParameter
 }
 } // namespace Fortran::runtime

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 "flang/Runtime/assign.h"
 #include "assign-impl.h"
 #include "derived.h"
 #include "stat.h"
 #include "terminator.h"
+#include "tools.h"
 #include "type-info.h"
 #include "flang/Runtime/descriptor.h"
 
 namespace Fortran::runtime {
 
 enum AssignFlags {
   NoAssignFlags = 0,
   MaybeReallocate = 1 << 0,
if (mustDeallocateLHS) {
           //     character, allocatable :: c(:)
           //   end type t
           //   type(t) :: x(3)
           //   x(2:3) = x(1:2)
           // We have to make a deep copy into 'newFrom' in this case.
           RTNAME(AssignTemporary)
           (newFrom, from, terminator.sourceFileName(), terminator.sourceLine());
         } else {
-          char *toAt{newFrom.OffsetElement()};
-          std::size_t fromElements{from.Elements()};
-          if (from.IsContiguous()) {
-            std::memcpy(
-                toAt, from.OffsetElement(), fromElements * fromElementBytes);
-          } else {
-            SubscriptValue fromAt[maxRank];
-            for (from.GetLowerBounds(fromAt); fromElements-- > 0;
-                 toAt += fromElementBytes, from.IncrementSubscripts(fromAt)) {
-              std::memcpy(toAt, from.Element<char>(fromAt), fromElementBytes);
-            }
-          }
+          ShallowCopy(newFrom, from, true, from.IsContiguous());
         }
         Assign(to, newFrom, terminator,
             flags &
                 (NeedFinalization | ComponentCanBeDefinedAssignment |
                     ExplicitLengthCharacterLHS | CanBeDefinedAssignment));
         newFrom.Deallocate();
       }
       return;
     }
   }
   if (to.IsAllocatable()) {
     if (mustDeallocateLHS) {
       if (deferDeallocation) {
         if ((flags & NeedFinalization) && toDerived) {
-          Finalize(to, *toDerived);
+          Finalize(to, *toDerived, &terminator);
           flags &= ~NeedFinalization;
         }
       } else {
-        to.Destroy((flags & NeedFinalization) != 0);
+        to.Destroy((flags & NeedFinalization) != 0, /*destroyPointers=*/false,
+            &terminator);
         flags &= ~NeedFinalization;
       }
     } else if (to.rank() != from.rank() && !to.IsAllocated()) {
       terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
                        "unallocated allocatable",
           to.rank(), from.rank());
     }
     if (!to.IsAllocated()) {
terminator.Crash("Assign: mismatching non-character element sizes (to %zd "
         toElementBytes, fromElementBytes);
   }
   if (const typeInfo::DerivedType *
       updatedToDerived{toAddendum ? toAddendum->derivedType() : nullptr}) {
     // Derived type intrinsic assignment, which is componentwise and elementwise
     // for all components, including parent components (10.2.1.2-3).
     // The target is first finalized if still necessary (7.5.6.3(1))
     if (flags & NeedFinalization) {
-      Finalize(to, *updatedToDerived);
+      Finalize(to, *updatedToDerived, &terminator);
     }
     // Copy the data components (incl. the parent) first.
     const Descriptor &componentDesc{updatedToDerived->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
for (std::size_t k{0}; k < numComponents; ++k) {
           if (toDesc->IsAllocatable()) {
             if (!fromDesc->IsAllocated()) {
               // No aliasing.
               //
               // If to is not allocated, the Destroy() call is a no-op.
               // This is just a shortcut, because the recursive Assign()
               // below would initiate the destruction for to.
               // No finalization is required.
-              toDesc->Destroy();
+              toDesc->Destroy(
+                  /*finalize=*/false, /*destroyPointers=*/false, &terminator);
               continue; // F'2018 10.2.1.3(13)(2)
             }
           }
           // Force LHS deallocation with DeallocateLHS flag.
           // The actual deallocation may be avoided, if the existing
           // location can be reoccupied.
           Assign(*toDesc, *fromDesc, terminator, nestedFlags | DeallocateLHS);
         }
if (isSimpleMemmove()) {
         std::memmove(to.Element<char>(toAt), from.Element<const char>(fromAt),
             toElementBytes);
       }
     }
   }
   if (deferDeallocation) {
     // deferDeallocation is used only when LHS is an allocatable.
     // The finalization has already been run for it.
-    deferDeallocation->Destroy();
+    deferDeallocation->Destroy(
+        /*finalize=*/false, /*destroyPointers=*/false, &terminator);
   }
 }
 
 void DoFromSourceAssign(
     Descriptor &alloc, const Descriptor &source, Terminator &terminator) {
   if (alloc.rank() > 0 && source.rank() == 0) {
     // The value of each element of allocate object becomes the value of source.
     DescriptorAddendum *allocAddendum{alloc.Addendum()};

flang/runtime/derived-api.cpp

if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
     }
   }
 }
 
 void RTNAME(Destroy)(const Descriptor &descriptor) {
   if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
     if (const auto *derived{addendum->derivedType()}) {
       if (!derived->noDestructionNeeded()) {
-        Destroy(descriptor, true, *derived);
+        // TODO: Pass source file & line information to the API
+        // so that a good Terminator can be passed
+        Destroy(descriptor, true, *derived, nullptr);
       }
     }
   }
 }
 
 bool RTNAME(ClassIs)(
     const Descriptor &descriptor, const typeInfo::DerivedType &derivedType) {
   if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
   }
   return false;
 }
 
 void RTNAME(DestroyWithoutFinalization)(const Descriptor &descriptor) {
   if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
     if (const auto *derived{addendum->derivedType()}) {
       if (!derived->noDestructionNeeded()) {
-        Destroy(descriptor, /*finalize=*/false, *derived);
+        Destroy(descriptor, /*finalize=*/false, *derived, nullptr);
       }
     }
   }
 }
 
 } // extern "C"
 } // namespace Fortran::runtime

flang/runtime/derived.h

 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);
+void Finalize(
+    const Descriptor &, const typeInfo::DerivedType &derived, Terminator *);
 
 // Call FINAL subroutines, deallocate allocatable & automatic components.
 // Does not deallocate the original descriptor.
-void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &);
+void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &,
+    Terminator *);
 
 // Return true if the passed descriptor is for a derived type
 // entity that has a dynamic (allocatable, automatic) component.
 bool HasDynamicComponent(const Descriptor &);
 
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_DERIVED_H_

flang/runtime/derived.cpp

 //===-- runtime/derived.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 "derived.h"
 #include "stat.h"
 #include "terminator.h"
+#include "tools.h"
 #include "type-info.h"
 #include "flang/Runtime/descriptor.h"
 
 namespace Fortran::runtime {
 
 int Initialize(const Descriptor &instance, const typeInfo::DerivedType &derived,
     Terminator &terminator, bool hasStat, const Descriptor *errMsg) {
   const Descriptor &componentDesc{derived.component()};
return ranked;
                  typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
     return assumed;
   } else {
     return derived.FindSpecialBinding(
         typeInfo::SpecialBinding::Which::ElementalFinal);
   }
 }
 
-static void CallFinalSubroutine(
-    const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+static void CallFinalSubroutine(const Descriptor &descriptor,
+    const typeInfo::DerivedType &derived, Terminator *terminator) {
   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) {
       std::size_t byteStride{descriptor.ElementBytes()};
       std::size_t elements{descriptor.Elements()};
       if (special->IsArgDescriptor(0)) {
         StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
         Descriptor &elemDesc{statDesc.descriptor()};
         elemDesc = descriptor;
         elemDesc.raw().attribute = CFI_attribute_pointer;
         elemDesc.raw().rank = 0;
         auto *p{special->GetProc<void (*)(const Descriptor &)>()};
         for (std::size_t j{0}; j < elements; ++j) {
           elemDesc.set_base_addr(
               descriptor.OffsetElement<char>(j * byteStride));
           p(elemDesc);
         }
       } else {
         auto *p{special->GetProc<void (*)(char *)>()};
         for (std::size_t j{0}; j < elements; ++j) {
           p(descriptor.OffsetElement<char>(j * byteStride));
         }
       }
-    } else if (special->IsArgDescriptor(0)) {
+    } else {
+      StaticDescriptor<maxRank, true, 10> statDesc;
+      Descriptor &copy{statDesc.descriptor()};
+      const Descriptor *argDescriptor{&descriptor};
+      if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
+          !descriptor.IsContiguous()) {
+        // The FINAL subroutine demands a contiguous array argument, but
+        // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.
+        // Finalize a shallow copy of the data.
+        copy = descriptor;
+        copy.set_base_addr(nullptr);
+        copy.raw().attribute = CFI_attribute_allocatable;
+        Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0};
+        RUNTIME_CHECK(terminator ? *terminator : stubTerminator,
+            copy.Allocate() == CFI_SUCCESS);
+        ShallowCopyDiscontiguousToContiguous(copy, descriptor);
+        argDescriptor = &copy;
+      }
+      if (special->IsArgDescriptor(0)) {
         StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
         Descriptor &tmpDesc{statDesc.descriptor()};
-      tmpDesc = descriptor;
+        tmpDesc = *argDescriptor;
         tmpDesc.raw().attribute = CFI_attribute_pointer;
         tmpDesc.Addendum()->set_derivedType(&derived);
         auto *p{special->GetProc<void (*)(const Descriptor &)>()};
         p(tmpDesc);
       } else {
         auto *p{special->GetProc<void (*)(char *)>()};
-      p(descriptor.OffsetElement<char>());
+        p(argDescriptor->OffsetElement<char>());
+      }
+      if (argDescriptor == &copy) {
+        ShallowCopyContiguousToDiscontiguous(descriptor, copy);
+        copy.Deallocate();
+      }
     }
   }
 }
 
 // Fortran 2018 subclause 7.5.6.2
-void Finalize(
-    const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+void Finalize(const Descriptor &descriptor,
+    const typeInfo::DerivedType &derived, Terminator *terminator) {
   if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
     return;
   }
-  CallFinalSubroutine(descriptor, derived);
+  CallFinalSubroutine(descriptor, derived, terminator);
   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()};
-  for (auto k{recurse
-               ? std::size_t{1} /* skip first component, it's the parent */
+  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->noFinalizationNeeded()) {
           for (std::size_t j{0}; j < elements; ++j) {
             const Descriptor &compDesc{*descriptor.OffsetElement<Descriptor>(
                 j * byteStride + comp.offset())};
             if (compDesc.IsAllocated()) {
-              Finalize(compDesc, *compType);
+              Finalize(compDesc, *compType, terminator);
             }
           }
         }
       }
     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
         comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
       SubscriptValue extent[maxRank];
       const typeInfo::Value *bounds{comp.bounds()};
       for (int dim{0}; dim < comp.rank(); ++dim) {
         SubscriptValue lb{bounds[2 * dim].GetValue(&descriptor).value_or(0)};
         SubscriptValue ub{
             bounds[2 * dim + 1].GetValue(&descriptor).value_or(0)};
         extent[dim] = ub >= lb ? ub - lb + 1 : 0;
       }
       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);
-        Finalize(compDesc, compType);
+        Finalize(compDesc, compType, terminator);
       }
     }
   }
   if (recurse) {
-    Finalize(descriptor, *parentType);
+    Finalize(descriptor, *parentType, terminator);
   }
 }
 
 // The order of finalization follows Fortran 2018 7.5.6.2, with
 // elementwise finalization of non-parent components taking place
 // before parent component finalization, and with all finalization
 // preceding any deallocation.
 void Destroy(const Descriptor &descriptor, bool finalize,
-    const typeInfo::DerivedType &derived) {
+    const typeInfo::DerivedType &derived, Terminator *terminator) {
   if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
     return;
   }
   if (finalize && !derived.noFinalizationNeeded()) {
-    Finalize(descriptor, derived);
+    Finalize(descriptor, derived, terminator);
   }
   const Descriptor &componentDesc{derived.component()};
   std::size_t myComponents{componentDesc.Elements()};
   std::size_t elements{descriptor.Elements()};
   SubscriptValue at[maxRank];
   descriptor.GetLowerBounds(at);
   for (std::size_t k{0}; k < myComponents; ++k) {
     const auto &comp{

flang/runtime/descriptor-io.h

static bool FormattedDerivedTypeIO(IoStatementState &io,
   if (table) {
     if (const auto *definedIo{table->Find(*type,
             DIR == Direction::Input ? common::DefinedIo::ReadFormatted
                                     : common::DefinedIo::WriteFormatted)}) {
       if (definedIo->subroutine) {
         typeInfo::SpecialBinding special{DIR == Direction::Input
                 ? typeInfo::SpecialBinding::Which::ReadFormatted
                 : typeInfo::SpecialBinding::Which::WriteFormatted,
-            definedIo->subroutine, definedIo->isDtvArgPolymorphic, false};
+            definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
+            false};
         if (std::optional<bool> wasDefined{
                 DefinedFormattedIo(io, descriptor, *type, special)}) {
           return *wasDefined;
         }
       } else {
         return DefaultComponentwiseIO<DIR>(io, descriptor, *type, table);
       }
     }
if (const typeInfo::DerivedType *
     if (table) {
       if (const auto *definedIo{table->Find(*type,
               DIR == Direction::Input ? common::DefinedIo::ReadUnformatted
                                       : common::DefinedIo::WriteUnformatted)}) {
         if (definedIo->subroutine) {
           typeInfo::SpecialBinding special{DIR == Direction::Input
                   ? typeInfo::SpecialBinding::Which::ReadUnformatted
                   : typeInfo::SpecialBinding::Which::WriteUnformatted,
-              definedIo->subroutine, definedIo->isDtvArgPolymorphic, false};
+              definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
+              false};
           if (std::optional<bool> wasDefined{
                   DefinedUnformattedIo(io, descriptor, *type, special)}) {
             return *wasDefined;
           }
         } else {
           return DefaultComponentwiseIO<DIR>(io, descriptor, *type, table);
         }
       }

flang/runtime/descriptor.cpp

for (int j{0}; j < dims; ++j) {
       auto &dimension{GetDimension(j)};
       dimension.SetByteStride(stride);
       stride *= dimension.Extent();
     }
   }
   return 0;
 }
 
-int Descriptor::Destroy(bool finalize, bool destroyPointers) {
+int Descriptor::Destroy(
+    bool finalize, bool destroyPointers, Terminator *terminator) {
   if (!destroyPointers && raw_.attribute == CFI_attribute_pointer) {
     return StatOk;
   } else {
     if (auto *addendum{Addendum()}) {
       if (const auto *derived{addendum->derivedType()}) {
         if (!derived->noDestructionNeeded()) {
-          runtime::Destroy(*this, finalize, *derived);
+          runtime::Destroy(*this, finalize, *derived, terminator);
         }
       }
     }
     return Deallocate();
   }
 }
 
 int Descriptor::Deallocate() { return ISO::CFI_deallocate(&raw_); }

flang/runtime/pointer.cpp

int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   if (!pointer.IsPointer()) {
     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
   }
   if (!pointer.IsAllocated()) {
     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
   }
-  return ReturnError(terminator, pointer.Destroy(true, true), errMsg, hasStat);
+  return ReturnError(terminator,
+      pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),
+      errMsg, hasStat);
 }
 
 int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer,
     const typeInfo::DerivedType *derivedType, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   int stat{RTNAME(PointerDeallocate)(
       pointer, hasStat, errMsg, sourceFile, sourceLine)};
   if (stat == StatOk) {

flang/runtime/tools.h

 }
 
 template <>
 inline const char *FindCharacter(const char *data, char ch, std::size_t chars) {
   return reinterpret_cast<const char *>(
       std::memchr(data, static_cast<int>(ch), chars));
 }
 
+// Copy payload data from one allocated descriptor to another.
+// Assumes element counts and element sizes match, and that both
+// descriptors are allocated.
+void ShallowCopyDiscontiguousToDiscontiguous(
+    const Descriptor &to, const Descriptor &from);
+void ShallowCopyDiscontiguousToContiguous(
+    const Descriptor &to, const Descriptor &from);
+void ShallowCopyContiguousToDiscontiguous(
+    const Descriptor &to, const Descriptor &from);
+void ShallowCopy(const Descriptor &to, const Descriptor &from,
+    bool toIsContiguous, bool fromIsContiguous);
+void ShallowCopy(const Descriptor &to, const Descriptor &from);
+
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_TOOLS_H_

flang/runtime/tools.cpp

 }
 
 void CheckIntegerKind(Terminator &terminator, int kind, const char *intrinsic) {
   if (kind < 1 || kind > 16 || (kind & (kind - 1)) != 0) {
     terminator.Crash(
         "not yet implemented: %s: KIND=%d argument", intrinsic, kind);
   }
 }
+
+void ShallowCopyDiscontiguousToDiscontiguous(
+    const Descriptor &to, const Descriptor &from) {
+  SubscriptValue toAt[maxRank], fromAt[maxRank];
+  to.GetLowerBounds(toAt);
+  from.GetLowerBounds(fromAt);
+  std::size_t elementBytes{to.ElementBytes()};
+  for (std::size_t n{to.Elements()}; n-- > 0;
+       to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+    std::memcpy(
+        to.Element<char>(toAt), from.Element<char>(fromAt), elementBytes);
+  }
+}
+
+void ShallowCopyDiscontiguousToContiguous(
+    const Descriptor &to, const Descriptor &from) {
+  char *toAt{to.OffsetElement()};
+  SubscriptValue fromAt[maxRank];
+  from.GetLowerBounds(fromAt);
+  std::size_t elementBytes{to.ElementBytes()};
+  for (std::size_t n{to.Elements()}; n-- > 0;
+       toAt += elementBytes, from.IncrementSubscripts(fromAt)) {
+    std::memcpy(toAt, from.Element<char>(fromAt), elementBytes);
+  }
+}
+
+void ShallowCopyContiguousToDiscontiguous(
+    const Descriptor &to, const Descriptor &from) {
+  SubscriptValue toAt[maxRank];
+  to.GetLowerBounds(toAt);
+  char *fromAt{from.OffsetElement()};
+  std::size_t elementBytes{to.ElementBytes()};
+  for (std::size_t n{to.Elements()}; n-- > 0;
+       to.IncrementSubscripts(toAt), fromAt += elementBytes) {
+    std::memcpy(to.Element<char>(toAt), fromAt, elementBytes);
+  }
+}
+
+void ShallowCopy(const Descriptor &to, const Descriptor &from,
+    bool toIsContiguous, bool fromIsContiguous) {
+  if (toIsContiguous) {
+    if (fromIsContiguous) {
+      std::memcpy(to.OffsetElement(), from.OffsetElement(),
+          to.Elements() * to.ElementBytes());
+    } else {
+      ShallowCopyDiscontiguousToContiguous(to, from);
+    }
+  } else {
+    if (fromIsContiguous) {
+      ShallowCopyContiguousToDiscontiguous(to, from);
+    } else {
+      ShallowCopyDiscontiguousToDiscontiguous(to, from);
+    }
+  }
+}
+
+void ShallowCopy(const Descriptor &to, const Descriptor &from) {
+  ShallowCopy(to, from, to.IsContiguous(), from.IsContiguous());
+}
 } // namespace Fortran::runtime

flang/runtime/type-info.h

enum class Which : std::uint8_t {
     AssumedRankFinal = 8,
     ScalarFinal = 9,
     // higher-ranked final procedures follow
   };
 
   // Special bindings can be created during execution to handle defined
   // I/O procedures that are not type-bound.
   SpecialBinding(Which which, ProcedurePointer proc, std::uint8_t isArgDescSet,
-      std::uint8_t isTypeBound)
+      std::uint8_t isTypeBound, std::uint8_t isArgContiguousSet)
       : which_{which}, isArgDescriptorSet_{isArgDescSet},
-        isTypeBound_{isTypeBound}, proc_{proc} {}
+        isTypeBound_{isTypeBound}, isArgContiguousSet_{isArgContiguousSet},
+        proc_{proc} {}
 
   static constexpr Which RankFinal(int rank) {
     return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
   }
 
   Which which() const { return which_; }
   bool IsArgDescriptor(int zeroBasedArg) const {
     return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
   }
   bool isTypeBound() const { return isTypeBound_; }
+  bool IsArgContiguous(int zeroBasedArg) const {
+    return (isArgContiguousSet_ >> zeroBasedArg) & 1;
+  }
   template <typename PROC> PROC GetProc() const {
     return reinterpret_cast<PROC>(proc_);
   }
 
   FILE *Dump(FILE *) const;
 
 private:
   Which which_{Which::None};
private:
   //   Which::AssumedRankFinal: flag must necessarily be set
   //   Defined 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 defined I/O subroutine must have been
   //     called via a generic interface, not a generic TBP.
   std::uint8_t isArgDescriptorSet_{0};
   std::uint8_t isTypeBound_{0};
+  // True when a FINAL subroutine has a dummy argument that is an array that
+  // is CONTIGUOUS or neither assumed-rank nor assumed-shape.
+  std::uint8_t isArgContiguousSet_{0};
 
   ProcedurePointer proc_{nullptr};
 };
 
 class DerivedType {
 public:
   ~DerivedType(); // never defined
 

flang/runtime/type-info.cpp

case Which::AssumedRankFinal:
     std::fputs("    AssumedRankFinal", f);
     break;
   default:
     std::fprintf(f, "    rank-%d final:",
         static_cast<int>(which_) - static_cast<int>(Which::ScalarFinal));
     break;
   }
   std::fprintf(f, "    isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
+  std::fprintf(f, "    isTypeBound: 0x%x\n", isTypeBound_);
+  std::fprintf(f, "    isArgContiguousSet: 0x%x\n", isArgContiguousSet_);
   std::fprintf(f, "    proc: %p\n", reinterpret_cast<void *>(proc_));
   return f;
 }
 
 } // namespace Fortran::runtime::typeInfo

flang/test/Semantics/typeinfo01.f90

contains
   end subroutine
   subroutine s2(x, y)
     class(t2), intent(out) :: x
     class(t), intent(in) :: y
   end subroutine
 !CHECK: .c.t2, SAVE, TARGET (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,proc=s1)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)]
 !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
 !CHECK: .v.t2, SAVE, TARGET (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,proc=s1)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)]
 !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): 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
+    final :: s1, s2, s3, s4
   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), intent(in) :: x
   end subroutine
-!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,istypebound=1_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,istypebound=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,istypebound=1_1,proc=s2)]
+  subroutine s4(x)
+    type(t), contiguous :: x(:,:,:)
+  end subroutine
+!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): 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=7296_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1)
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,istypebound=1_1,isargcontiguousset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,istypebound=1_1,isargcontiguousset=1_1,proc=s2),specialbinding(which=12_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=1_1,proc=s4)]
 end module
 
 module m09
   type :: t
    contains
     procedure :: rf, ru, wf, wu
     generic :: read(formatted) => rf
     generic :: read(unformatted) => ru
contains
   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 (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,istypebound=1_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,istypebound=1_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,istypebound=1_1,proc=wu)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wu)]
 !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): 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
contains
   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 (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,istypebound=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,istypebound=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,istypebound=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,istypebound=0_1,proc=wu)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=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

 end module
 
 module m13
   type :: t1
     integer :: n
    contains
     procedure :: assign1, assign2
     generic :: assignment(=) => assign1, assign2
-    ! CHECK: .s.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,proc=assign1)]
+    ! CHECK: .s.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=assign1)]
   end type
  contains
   impure elemental subroutine assign1(to, from)
     class(t1), intent(out) :: to
     class(t1), intent(in) :: from
   end subroutine
   impure elemental subroutine assign2(to, from)
     class(t1), intent(out) :: to
     integer, intent(in) :: from
   end subroutine
 end module

flang/test/Semantics/typeinfo02.f90

subroutine wf2(x,u,iot,v,iostat,iomsg)
     class(extended), intent(in) :: x
     integer, intent(in) :: u
     character(len=*), intent(in) :: iot
     integer, intent(in) :: v(:)
     integer, intent(out) :: iostat
     character(len=*), intent(inout) :: iomsg
   end subroutine
 end module
-!CHECK: .s.base, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf1)]
-!CHECK: .s.extended, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf2)]
+!CHECK: .s.base, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf1)]
+!CHECK: .s.extended, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf2)]