[flang] Non-type-bound defined IO lowering

[vdonaldson]

Summary

Generate supporting data structures and calls to new runtime IO functions
for defined IO that accesses non-type-bound procedures, such as wft in:

module m1
  type t
    integer n
  end type
  interface write(formatted)
    module procedure wft
  end interface
 contains
  subroutine wft(dtv, unit, iotype, v_list, iostat, iomsg)
    class(t), intent(in) :: dtv
    integer, intent(in) :: unit
    character(*), intent(in) :: iotype
    integer, intent(in) :: v_list(:)
    integer, intent(out) :: iostat
    character(*), intent(inout) :: iomsg
    iostat = 0
    write(unit,*,iostat=iostat,iomsg=iomsg) 'wft was called: ', dtv%n
  end subroutine
end module

module m2
 contains
  subroutine test1
    use m1
    print *, 'test1, should call wft: ', t(1)
  end subroutine
  subroutine test2
    use m1, only: t
    print *, 'test2, should not call wft: ', t(2)
  end subroutine
end module

use m1
use m2
call test1
call test2
print *, 'main, should call wft: ', t(3)
end

[vdonaldson]

https://reviews.llvm.org/D150719

flang/include/flang/Lower/AbstractConverter.h

public:
 
   /// Get the converter's current location
   virtual mlir::Location getCurrentLocation() = 0;
   /// Generate a dummy location
   virtual mlir::Location genUnknownLocation() = 0;
   /// Generate the location as converted from a CharBlock
   virtual mlir::Location genLocation(const Fortran::parser::CharBlock &) = 0;
 
+  /// Get the converter's current scope
+  virtual const Fortran::semantics::Scope &getCurrentScope() = 0;
+
   //===--------------------------------------------------------------------===//
   // FIR/MLIR
   //===--------------------------------------------------------------------===//
 
   /// Get the OpBuilder
   virtual fir::FirOpBuilder &getFirOpBuilder() = 0;
   /// Get the ModuleOp
   virtual mlir::ModuleOp &getModuleOp() = 0;
   /// Get the MLIRContext
   virtual mlir::MLIRContext &getMLIRContext() = 0;
-  /// Unique a symbol
+  /// Unique a symbol (add a containing scope specific prefix)
   virtual std::string mangleName(const Fortran::semantics::Symbol &) = 0;
-  /// Unique a derived type
+  /// Unique a derived type (add a containing scope specific prefix)
   virtual std::string
   mangleName(const Fortran::semantics::DerivedTypeSpec &) = 0;
+  /// Unique a compiler generated name (add a containing scope specific prefix)
+  virtual std::string mangleName(std::string &) = 0;
   /// Get the KindMap.
   virtual const fir::KindMapping &getKindMap() = 0;
 
   virtual Fortran::lower::StatementContext &getFctCtx() = 0;
 
   AbstractConverter(const Fortran::lower::LoweringOptions &loweringOptions)
       : loweringOptions(loweringOptions) {}
   virtual ~AbstractConverter() = default;

flang/include/flang/Lower/Mangler.h

 std::string mangleName(const semantics::Symbol &, ScopeBlockIdMap &,
                        bool keepExternalInScope = false);
 std::string mangleName(const semantics::Symbol &,
                        bool keepExternalInScope = false);
 
 /// Convert a derived type instance to an internal name.
 std::string mangleName(const semantics::DerivedTypeSpec &, ScopeBlockIdMap &);
 
+/// Add a scope specific mangling prefix to a compiler generated name.
+std::string mangleName(std::string &, const Fortran::semantics::Scope &,
+                       ScopeBlockIdMap &);
+
 /// Recover the bare name of the original symbol from an internal name.
 std::string demangleName(llvm::StringRef name);
 
 std::string
 mangleArrayLiteral(size_t size,
                    const Fortran::evaluate::ConstantSubscripts &shape,
                    Fortran::common::TypeCategory cat, int kind = 0,
                    Fortran::common::ConstantSubscript charLen = -1,

flang/include/flang/Optimizer/Support/InternalNames.h

static std::string doConstant(llvm::ArrayRef<llvm::StringRef> modules,
                                 std::int64_t block, llvm::StringRef name);
 
   /// Unique a dispatch table name
   static std::string doDispatchTable(llvm::ArrayRef<llvm::StringRef> modules,
                                      llvm::ArrayRef<llvm::StringRef> procs,
                                      std::int64_t block, llvm::StringRef name,
                                      llvm::ArrayRef<std::int64_t> kinds);
 
-  /// Unique a compiler generated name
+  /// Unique a compiler generated name without scope context.
   static std::string doGenerated(llvm::StringRef name);
+  /// Unique a compiler generated name with scope context.
+  static std::string doGenerated(llvm::ArrayRef<llvm::StringRef> modules,
+                                 llvm::ArrayRef<llvm::StringRef> procs,
+                                 std::int64_t blockId, llvm::StringRef name);
 
   /// Unique an intrinsic type descriptor
   static std::string
   doIntrinsicTypeDescriptor(llvm::ArrayRef<llvm::StringRef> modules,
                             llvm::ArrayRef<llvm::StringRef> procs,
                             std::int64_t block, IntrinsicType type,
                             std::int64_t kind);
 

flang/include/flang/Semantics/runtime-type-info.h

 
 struct NonTbpDefinedIo {
   const Symbol *subroutine;
   common::DefinedIo definedIo;
   bool isDtvArgPolymorphic;
 };
 
 std::multimap<const Symbol *, NonTbpDefinedIo>
-CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope);
+CollectNonTbpDefinedIoGenericInterfaces(
+    const Scope &, bool useRuntimeTypeInfoEntries);
+
+bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+    const Scope &, const DerivedTypeSpec *);
+bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+    const Scope &, const DeclTypeSpec *);
+bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+    const Scope &, const Symbol *);
 
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_

flang/lib/Lower/Bridge.cpp

if (const Fortran::parser::AllCookedSources *cooked =
         llvm::sys::path::remove_dots(filePath);
         return mlir::FileLineColLoc::get(&getMLIRContext(), filePath.str(),
                                          filePos.line, filePos.column);
       }
     }
     return genUnknownLocation();
   }
 
+  const Fortran::semantics::Scope &getCurrentScope() override final {
+    return bridge.getSemanticsContext().FindScope(currentPosition);
+  }
+
   fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; }
 
   mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); }
 
   mlir::MLIRContext &getMLIRContext() override final {
     return bridge.getMLIRContext();
   }
   std::string
   mangleName(const Fortran::semantics::Symbol &symbol) override final {
     return Fortran::lower::mangle::mangleName(symbol, scopeBlockIdMap);
   }
   std::string mangleName(
       const Fortran::semantics::DerivedTypeSpec &derivedType) override final {
     return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap);
   }
-
+  std::string mangleName(std::string &name) override final {
+    return Fortran::lower::mangle::mangleName(name, getCurrentScope(),
+                                              scopeBlockIdMap);
+  }
   const fir::KindMapping &getKindMap() override final {
     return bridge.getKindMap();
   }
 
   /// Return the current function context, which may be a nested BLOCK context
   /// or a full subprogram context.
   Fortran::lower::StatementContext &getFctCtx() override final {
     if (!activeConstructStack.empty() &&

flang/lib/Lower/IO.cpp

 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/IO.h"
 #include "flang/Common/uint128.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Lower/Allocatable.h"
 #include "flang/Lower/Bridge.h"
+#include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Lower/VectorSubscripts.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/Support/FIRContext.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Runtime/io-api.h"
+#include "flang/Semantics/runtime-type-info.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "llvm/Support/Debug.h"
 #include <optional>
 
 #define DEBUG_TYPE "flang-lower-io"
 
 // Define additional runtime type models specific to IO.
 namespace fir::runtime {
 template <>
 constexpr TypeBuilderFunc getModel<Fortran::runtime::io::IoStatementState *>() {
   return getModel<char *>();
 }
 template <>
+constexpr TypeBuilderFunc getModel<Fortran::runtime::io::Iostat>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context,
+                                  8 * sizeof(Fortran::runtime::io::Iostat));
+  };
+}
+template <>
 constexpr TypeBuilderFunc
 getModel<const Fortran::runtime::io::NamelistGroup &>() {
   return [](mlir::MLIRContext *context) -> mlir::Type {
     return fir::ReferenceType::get(mlir::TupleType::get(context));
   };
 }
 template <>
-constexpr TypeBuilderFunc getModel<Fortran::runtime::io::Iostat>() {
+constexpr TypeBuilderFunc
+getModel<const Fortran::runtime::io::NonTbpDefinedIoTable *>() {
   return [](mlir::MLIRContext *context) -> mlir::Type {
-    return mlir::IntegerType::get(context,
-                                  8 * sizeof(Fortran::runtime::io::Iostat));
+    return fir::ReferenceType::get(mlir::TupleType::get(context));
   };
 }
 } // namespace fir::runtime
 
 using namespace Fortran::runtime::io;
 
 #define mkIOKey(X) FirmkKey(IONAME(X))
 
 namespace Fortran::lower {
 /// Static table of IO runtime calls
 ///
 /// This logical map contains the name and type builder function for each IO
 /// runtime function listed in the tuple. This table is fully constructed at
 /// compile-time. Use the `mkIOKey` macro to access the table.
 static constexpr std::tuple<
-    mkIOKey(BeginInternalArrayListOutput), mkIOKey(BeginInternalArrayListInput),
+    mkIOKey(BeginBackspace), mkIOKey(BeginClose), mkIOKey(BeginEndfile),
+    mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginExternalFormattedOutput),
+    mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalListOutput),
+    mkIOKey(BeginFlush), mkIOKey(BeginInquireFile),
+    mkIOKey(BeginInquireIoLength), mkIOKey(BeginInquireUnit),
+    mkIOKey(BeginInternalArrayFormattedInput),
     mkIOKey(BeginInternalArrayFormattedOutput),
-    mkIOKey(BeginInternalArrayFormattedInput), mkIOKey(BeginInternalListOutput),
-    mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalFormattedOutput),
-    mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginExternalListOutput),
-    mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalFormattedOutput),
-    mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginUnformattedOutput),
-    mkIOKey(BeginUnformattedInput), mkIOKey(BeginWait), mkIOKey(BeginWaitAll),
-    mkIOKey(BeginClose), mkIOKey(BeginFlush), mkIOKey(BeginBackspace),
-    mkIOKey(BeginEndfile), mkIOKey(BeginRewind), mkIOKey(BeginOpenUnit),
-    mkIOKey(BeginOpenNewUnit), mkIOKey(BeginInquireUnit),
-    mkIOKey(BeginInquireFile), mkIOKey(BeginInquireIoLength),
+    mkIOKey(BeginInternalArrayListInput), mkIOKey(BeginInternalArrayListOutput),
+    mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginInternalFormattedOutput),
+    mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalListOutput),
+    mkIOKey(BeginOpenNewUnit), mkIOKey(BeginOpenUnit), mkIOKey(BeginRewind),
+    mkIOKey(BeginUnformattedInput), mkIOKey(BeginUnformattedOutput),
+    mkIOKey(BeginWait), mkIOKey(BeginWaitAll),
     mkIOKey(CheckUnitNumberInRange64), mkIOKey(CheckUnitNumberInRange128),
-    mkIOKey(EnableHandlers), mkIOKey(SetAdvance), mkIOKey(SetBlank),
-    mkIOKey(SetDecimal), mkIOKey(SetDelim), mkIOKey(SetPad), mkIOKey(SetPos),
-    mkIOKey(SetRec), mkIOKey(SetRound), mkIOKey(SetSign),
-    mkIOKey(OutputNamelist), mkIOKey(InputNamelist), mkIOKey(OutputDescriptor),
-    mkIOKey(InputDescriptor), mkIOKey(OutputUnformattedBlock),
-    mkIOKey(InputUnformattedBlock), mkIOKey(OutputInteger8),
-    mkIOKey(OutputInteger16), mkIOKey(OutputInteger32),
-    mkIOKey(OutputInteger64), mkIOKey(OutputInteger128), mkIOKey(InputInteger),
-    mkIOKey(OutputReal32), mkIOKey(InputReal32), mkIOKey(OutputReal64),
-    mkIOKey(InputReal64), mkIOKey(OutputComplex32), mkIOKey(InputComplex32),
-    mkIOKey(OutputComplex64), mkIOKey(InputComplex64), mkIOKey(OutputAscii),
-    mkIOKey(InputAscii), mkIOKey(OutputLogical), mkIOKey(InputLogical),
-    mkIOKey(SetAccess), mkIOKey(SetAction), mkIOKey(SetAsynchronous),
-    mkIOKey(SetCarriagecontrol), mkIOKey(SetEncoding), mkIOKey(SetForm),
-    mkIOKey(SetPosition), mkIOKey(SetRecl), mkIOKey(SetStatus),
-    mkIOKey(SetFile), mkIOKey(GetNewUnit), mkIOKey(GetSize),
-    mkIOKey(GetIoLength), mkIOKey(GetIoMsg), mkIOKey(InquireCharacter),
-    mkIOKey(InquireLogical), mkIOKey(InquirePendingId),
-    mkIOKey(InquireInteger64), mkIOKey(EndIoStatement), mkIOKey(SetConvert)>
+    mkIOKey(EnableHandlers), mkIOKey(EndIoStatement), mkIOKey(GetIoLength),
+    mkIOKey(GetIoMsg), mkIOKey(GetNewUnit), mkIOKey(GetSize),
+    mkIOKey(InputAscii), mkIOKey(InputComplex32), mkIOKey(InputComplex64),
+    mkIOKey(InputDerivedType), mkIOKey(InputDescriptor), mkIOKey(InputInteger),
+    mkIOKey(InputLogical), mkIOKey(InputNamelist), mkIOKey(InputReal32),
+    mkIOKey(InputReal64), mkIOKey(InputUnformattedBlock),
+    mkIOKey(InquireCharacter), mkIOKey(InquireInteger64),
+    mkIOKey(InquireLogical), mkIOKey(InquirePendingId), mkIOKey(OutputAscii),
+    mkIOKey(OutputComplex32), mkIOKey(OutputComplex64),
+    mkIOKey(OutputDerivedType), mkIOKey(OutputDescriptor),
+    mkIOKey(OutputInteger8), mkIOKey(OutputInteger16), mkIOKey(OutputInteger32),
+    mkIOKey(OutputInteger64), mkIOKey(OutputInteger128), mkIOKey(OutputLogical),
+    mkIOKey(OutputNamelist), mkIOKey(OutputReal32), mkIOKey(OutputReal64),
+    mkIOKey(OutputUnformattedBlock), mkIOKey(SetAccess), mkIOKey(SetAction),
+    mkIOKey(SetAdvance), mkIOKey(SetAsynchronous), mkIOKey(SetBlank),
+    mkIOKey(SetCarriagecontrol), mkIOKey(SetConvert), mkIOKey(SetDecimal),
+    mkIOKey(SetDelim), mkIOKey(SetEncoding), mkIOKey(SetFile), mkIOKey(SetForm),
+    mkIOKey(SetPad), mkIOKey(SetPos), mkIOKey(SetPosition), mkIOKey(SetRec),
+    mkIOKey(SetRecl), mkIOKey(SetRound), mkIOKey(SetSign), mkIOKey(SetStatus)>
     newIOTable;
 } // namespace Fortran::lower
 
 namespace {
 /// IO statements may require exceptional condition handling. A statement that
 /// encounters an exceptional condition may branch to a label given on an ERR
 /// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT
 /// specifier variable may be set to a value that indicates some condition,
static void makeNextConditionalOn(fir::FirOpBuilder &builder,
   mlir::TypeRange resTy;
   if (inLoop)
     resTy = builder.getI1Type();
   auto ifOp = builder.create<fir::IfOp>(loc, resTy, ok,
                                         /*withElseRegion=*/inLoop);
   builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
 }
 
-/// Retrieve or generate a runtime description of NAMELIST group `symbol`.
+// Derived type symbols may each be mapped to up to 4 defined IO procedures.
+using DefinedIoProcMap = std::multimap<const Fortran::semantics::Symbol *,
+                                       Fortran::semantics::NonTbpDefinedIo>;
+
+/// Get the current scope's non-type-bound defined IO procedures.
+static DefinedIoProcMap
+getDefinedIoProcMap(Fortran::lower::AbstractConverter &converter) {
+  const Fortran::semantics::Scope *scope = &converter.getCurrentScope();
+  for (; !scope->IsGlobal(); scope = &scope->parent())
+    if (scope->kind() == Fortran::semantics::Scope::Kind::MainProgram ||
+        scope->kind() == Fortran::semantics::Scope::Kind::Subprogram ||
+        scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct)
+      break;
+  return Fortran::semantics::CollectNonTbpDefinedIoGenericInterfaces(*scope,
+                                                                     false);
+}
+
+/// Check a set of defined IO procedures for any procedure pointer or dummy
+/// procedures.
+static bool hasLocalDefinedIoProc(DefinedIoProcMap &definedIoProcMap) {
+  for (auto &iface : definedIoProcMap) {
+    const Fortran::semantics::Symbol *procSym = iface.second.subroutine;
+    if (!procSym)
+      continue;
+    procSym = &procSym->GetUltimate();
+    if (Fortran::semantics::IsProcedurePointer(*procSym) ||
+        Fortran::semantics::IsDummy(*procSym))
+      return true;
+  }
+  return false;
+}
+
+/// Retrieve or generate a runtime description of the non-type-bound defined
+/// IO procedures in the current scope. If any procedure is a dummy or a
+/// procedure pointer, the result is local. Otherwise the result is static.
+/// If there are no procedures, return a scope-independent default table with
+/// an empty procedure list, but with the `ignoreNonTbpEntries` flag set. The
+/// form of the description is defined in runtime header file non-tbp-dio.h.
+static mlir::Value
+getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
+                            DefinedIoProcMap &definedIoProcMap) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::MLIRContext *context = builder.getContext();
+  mlir::Location loc = converter.getCurrentLocation();
+  mlir::Type refTy = fir::ReferenceType::get(mlir::NoneType::get(context));
+  std::string suffix = ".nonTbpDefinedIoTable";
+  std::string tableMangleName = definedIoProcMap.empty()
+                                    ? "default" + suffix
+                                    : converter.mangleName(suffix);
+  if (auto table = builder.getNamedGlobal(tableMangleName))
+    return builder.createConvert(
+        loc, refTy,
+        builder.create<fir::AddrOfOp>(loc, table.resultType(),
+                                      table.getSymbol()));
+
+  mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
+  mlir::Type idxTy = builder.getIndexType();
+  mlir::Type sizeTy =
+      fir::runtime::getModel<std::size_t>()(builder.getContext());
+  mlir::Type intTy = fir::runtime::getModel<int>()(builder.getContext());
+  mlir::Type boolTy = fir::runtime::getModel<bool>()(builder.getContext());
+  mlir::Type listTy = fir::SequenceType::get(
+      definedIoProcMap.size(),
+      mlir::TupleType::get(context, {refTy, refTy, intTy, boolTy}));
+  mlir::Type tableTy = mlir::TupleType::get(
+      context, {sizeTy, fir::ReferenceType::get(listTy), boolTy});
+
+  // Define the list of NonTbpDefinedIo procedures.
+  bool tableIsLocal =
+      !definedIoProcMap.empty() && hasLocalDefinedIoProc(definedIoProcMap);
+  mlir::Value listAddr =
+      tableIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
+  std::string listMangleName = tableMangleName + ".list";
+  auto listFunc = [&](fir::FirOpBuilder &builder) {
+    mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
+    mlir::IntegerAttr intAttr[4];
+    for (int i = 0; i < 4; ++i)
+      intAttr[i] = builder.getIntegerAttr(idxTy, i);
+    llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
+                                                 mlir::Attribute{}};
+    int n0 = 0, n1;
+    auto insert = [&](mlir::Value val) {
+      idx[1] = intAttr[n1++];
+      list = builder.create<fir::InsertValueOp>(loc, listTy, list, val,
+                                                builder.getArrayAttr(idx));
+    };
+    for (auto &iface : definedIoProcMap) {
+      idx[0] = builder.getIntegerAttr(idxTy, n0++);
+      n1 = 0;
+      // derived type description [const typeInfo::DerivedType &derivedType]
+      const Fortran::semantics::Symbol &dtSym = iface.first->GetUltimate();
+      std::string dtName = converter.mangleName(dtSym);
+      insert(builder.createConvert(
+          loc, refTy,
+          builder.create<fir::AddrOfOp>(
+              loc, fir::ReferenceType::get(converter.genType(dtSym)),
+              builder.getSymbolRefAttr(dtName))));
+      // defined IO procedure [void (*subroutine)()], may be null
+      const Fortran::semantics::Symbol *procSym = iface.second.subroutine;
+      if (procSym) {
+        procSym = &procSym->GetUltimate();
+        if (Fortran::semantics::IsProcedurePointer(*procSym)) {
+          TODO(loc, "defined IO procedure pointers");
+        } else if (Fortran::semantics::IsDummy(*procSym)) {
+          Fortran::lower::StatementContext stmtCtx;
+          insert(builder.create<fir::BoxAddrOp>(
+              loc, refTy,
+              fir::getBase(converter.genExprAddr(
+                  loc,
+                  Fortran::lower::SomeExpr{
+                      Fortran::evaluate::ProcedureDesignator{*procSym}},
+                  stmtCtx))));
+        } else {
+          std::string procName = converter.mangleName(*procSym);
+          mlir::func::FuncOp procDef = builder.getNamedFunction(procName);
+          if (!procDef)
+            procDef = Fortran::lower::getOrDeclareFunction(
+                procName, Fortran::evaluate::ProcedureDesignator{*procSym},
+                converter);
+          insert(
+              builder.createConvert(loc, refTy,
+                                    builder.create<fir::AddrOfOp>(
+                                        loc, procDef.getFunctionType(),
+                                        builder.getSymbolRefAttr(procName))));
+        }
+      } else {
+        insert(builder.createNullConstant(loc, refTy));
+      }
+      // defined IO variant, one of (read/write, formatted/unformatted)
+      // [common::DefinedIo definedIo]
+      insert(builder.createIntegerConstant(
+          loc, intTy, static_cast<int>(iface.second.definedIo)));
+      // polymorphic flag is set if first defined IO dummy arg is CLASS(T)
+      // [bool isDtvArgPolymorphic]
+      insert(builder.createIntegerConstant(loc, boolTy,
+                                           iface.second.isDtvArgPolymorphic));
+    }
+    if (tableIsLocal)
+      builder.create<fir::StoreOp>(loc, list, listAddr);
+    else
+      builder.create<fir::HasValueOp>(loc, list);
+  };
+  if (!definedIoProcMap.empty()) {
+    if (tableIsLocal)
+      listFunc(builder);
+    else
+      builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
+                                   linkOnce);
+  }
+
+  // Define the NonTbpDefinedIoTable.
+  mlir::Value tableAddr = tableIsLocal
+                              ? builder.create<fir::AllocaOp>(loc, tableTy)
+                              : mlir::Value{};
+  auto tableFunc = [&](fir::FirOpBuilder &builder) {
+    mlir::Value table = builder.create<fir::UndefOp>(loc, tableTy);
+    // list item count [std::size_t items]
+    table = builder.create<fir::InsertValueOp>(
+        loc, tableTy, table,
+        builder.createIntegerConstant(loc, sizeTy, definedIoProcMap.size()),
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0)));
+    // item list [const NonTbpDefinedIo *item]
+    if (definedIoProcMap.empty())
+      listAddr = builder.createNullConstant(loc, builder.getRefType(listTy));
+    else if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
+      listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
+                                               list.getSymbol());
+    assert(listAddr && "missing namelist object list");
+    table = builder.create<fir::InsertValueOp>(
+        loc, tableTy, table, listAddr,
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1)));
+    // [bool ignoreNonTbpEntries] conservatively set to true
+    table = builder.create<fir::InsertValueOp>(
+        loc, tableTy, table, builder.createIntegerConstant(loc, boolTy, true),
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2)));
+    if (tableIsLocal)
+      builder.create<fir::StoreOp>(loc, table, tableAddr);
+    else
+      builder.create<fir::HasValueOp>(loc, table);
+  };
+  if (tableIsLocal) {
+    tableFunc(builder);
+  } else {
+    fir::GlobalOp table = builder.createGlobal(
+        loc, tableTy, tableMangleName,
+        /*isConst=*/true, /*isTarget=*/false, tableFunc, linkOnce);
+    tableAddr = builder.create<fir::AddrOfOp>(
+        loc, fir::ReferenceType::get(tableTy), table.getSymbol());
+  }
+  assert(tableAddr && "missing NonTbpDefinedIo table result");
+  return builder.createConvert(loc, refTy, tableAddr);
+}
+
+static mlir::Value
+getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter) {
+  DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter);
+  return getNonTbpDefinedIoTableAddr(converter, definedIoProcMap);
+}
+
+/// Retrieve or generate a runtime description of NAMELIST group \p symbol.
 /// The form of the description is defined in runtime header file namelist.h.
 /// Static descriptors are generated for global objects; local descriptors for
-/// local objects. If all descriptors are static, the NamelistGroup is static.
+/// local objects. If all descriptors and defined IO procedures are static,
+/// the NamelistGroup is static.
 static mlir::Value
 getNamelistGroup(Fortran::lower::AbstractConverter &converter,
                  const Fortran::semantics::Symbol &symbol,
                  Fortran::lower::StatementContext &stmtCtx) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   mlir::Location loc = converter.getCurrentLocation();
   std::string groupMangleName = converter.mangleName(symbol);
   if (auto group = builder.getNamedGlobal(groupMangleName))
     return builder.create<fir::AddrOfOp>(loc, group.resultType(),
                                          group.getSymbol());
 
   const auto &details =
       symbol.GetUltimate().get<Fortran::semantics::NamelistDetails>();
   mlir::MLIRContext *context = builder.getContext();
   mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
-  mlir::IndexType idxTy = builder.getIndexType();
-  mlir::IntegerType sizeTy = builder.getIntegerType(8 * sizeof(std::size_t));
-  fir::ReferenceType charRefTy =
-      fir::ReferenceType::get(builder.getIntegerType(8));
-  fir::ReferenceType descRefTy =
+  mlir::Type idxTy = builder.getIndexType();
+  mlir::Type sizeTy =
+      fir::runtime::getModel<std::size_t>()(builder.getContext());
+  mlir::Type charRefTy = fir::ReferenceType::get(builder.getIntegerType(8));
+  mlir::Type descRefTy =
       fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context)));
-  fir::SequenceType listTy = fir::SequenceType::get(
+  mlir::Type listTy = fir::SequenceType::get(
       details.objects().size(),
       mlir::TupleType::get(context, {charRefTy, descRefTy}));
-  mlir::TupleType groupTy = mlir::TupleType::get(
-      context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy)});
+  mlir::Type groupTy = mlir::TupleType::get(
+      context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy),
+                fir::ReferenceType::get(mlir::NoneType::get(context))});
   auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) {
     return fir::factory::createStringLiteral(builder, loc,
                                              symbol.name().ToString() + '\0');
   };
 
   // Define variable names, and static descriptors for global variables.
-  bool groupIsLocal = false;
+  DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter);
+  bool groupIsLocal = hasLocalDefinedIoProc(definedIoProcMap);
   stringAddress(symbol);
   for (const Fortran::semantics::Symbol &s : details.objects()) {
     stringAddress(s);
     if (!Fortran::lower::symbolIsGlobal(s)) {
       groupIsLocal = true;
       continue;
     }
     // A global pointer or allocatable variable has a descriptor for typical
mlir::Value listAddr =
       groupIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
   std::string listMangleName = groupMangleName + ".list";
   auto listFunc = [&](fir::FirOpBuilder &builder) {
     mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
     mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0);
     mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1);
     llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
                                                  mlir::Attribute{}};
-    size_t n = 0;
+    int n = 0;
     for (const Fortran::semantics::Symbol &s : details.objects()) {
-      idx[0] = builder.getIntegerAttr(idxTy, n);
+      idx[0] = builder.getIntegerAttr(idxTy, n++);
       idx[1] = zero;
       mlir::Value nameAddr =
           builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s)));
       list = builder.create<fir::InsertValueOp>(loc, listTy, list, nameAddr,
                                                 builder.getArrayAttr(idx));
       idx[1] = one;
       mlir::Value descAddr;
       if (auto desc = builder.getNamedGlobal(
for (const Fortran::semantics::Symbol &s : details.objects()) {
         descAddr = builder.createTemporary(loc, boxType);
         fir::MutableBoxValue box = fir::MutableBoxValue(descAddr, {}, {});
         fir::factory::associateMutableBox(builder, loc, box, exv,
                                           /*lbounds=*/std::nullopt);
       }
       descAddr = builder.createConvert(loc, descRefTy, descAddr);
       list = builder.create<fir::InsertValueOp>(loc, listTy, list, descAddr,
                                                 builder.getArrayAttr(idx));
-      ++n;
     }
     if (groupIsLocal)
       builder.create<fir::StoreOp>(loc, list, listAddr);
     else
       builder.create<fir::HasValueOp>(loc, list);
   };
   if (groupIsLocal)
     listFunc(builder);
   else
     builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
                                  linkOnce);
 
   // Define the group.
   mlir::Value groupAddr = groupIsLocal
                               ? builder.create<fir::AllocaOp>(loc, groupTy)
                               : mlir::Value{};
   auto groupFunc = [&](fir::FirOpBuilder &builder) {
-    mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0);
-    mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1);
-    mlir::IntegerAttr two = builder.getIntegerAttr(idxTy, 2);
     mlir::Value group = builder.create<fir::UndefOp>(loc, groupTy);
-    mlir::Value nameAddr = builder.createConvert(
-        loc, charRefTy, fir::getBase(stringAddress(symbol)));
-    group = builder.create<fir::InsertValueOp>(loc, groupTy, group, nameAddr,
-                                               builder.getArrayAttr(zero));
-    mlir::Value itemCount =
-        builder.createIntegerConstant(loc, sizeTy, details.objects().size());
-    group = builder.create<fir::InsertValueOp>(loc, groupTy, group, itemCount,
-                                               builder.getArrayAttr(one));
+    // group name [const char *groupName]
+    group = builder.create<fir::InsertValueOp>(
+        loc, groupTy, group,
+        builder.createConvert(loc, charRefTy,
+                              fir::getBase(stringAddress(symbol))),
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0)));
+    // list item count [std::size_t items]
+    group = builder.create<fir::InsertValueOp>(
+        loc, groupTy, group,
+        builder.createIntegerConstant(loc, sizeTy, details.objects().size()),
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1)));
+    // item list [const Item *item]
     if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
       listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
                                                list.getSymbol());
     assert(listAddr && "missing namelist object list");
-    group = builder.create<fir::InsertValueOp>(loc, groupTy, group, listAddr,
-                                               builder.getArrayAttr(two));
+    group = builder.create<fir::InsertValueOp>(
+        loc, groupTy, group, listAddr,
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2)));
+    // non-type-bound defined IO procedures
+    // [const NonTbpDefinedIoTable *nonTbpDefinedIo]
+    group = builder.create<fir::InsertValueOp>(
+        loc, groupTy, group,
+        getNonTbpDefinedIoTableAddr(converter, definedIoProcMap),
+        builder.getArrayAttr(builder.getIntegerAttr(idxTy, 3)));
     if (groupIsLocal)
       builder.create<fir::StoreOp>(loc, group, groupAddr);
     else
       builder.create<fir::HasValueOp>(loc, group);
   };
   if (groupIsLocal) {
     groupFunc(builder);
   } else {
static void genNamelistIO(Fortran::lower::AbstractConverter &converter,
   llvm::SmallVector<mlir::Value> args = {cookie, groupAddr};
   ok = builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
 }
 
 /// Get the output function to call for a value of the given type.
 static mlir::func::FuncOp getOutputFunc(mlir::Location loc,
                                         fir::FirOpBuilder &builder,
                                         mlir::Type type, bool isFormatted) {
+  if (type.isa<fir::RecordType>())
+    return getIORuntimeFunc<mkIOKey(OutputDerivedType)>(loc, builder);
   if (!isFormatted)
     return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder);
   if (auto ty = type.dyn_cast<mlir::IntegerType>()) {
     switch (ty.getWidth()) {
     case 1:
       return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder);
     case 8:
       return getIORuntimeFunc<mkIOKey(OutputInteger8)>(loc, builder);
for (const Fortran::parser::OutputItem &item : items) {
     mlir::Type argType = outputFunc.getFunctionType().getInput(1);
     assert((isFormatted || argType.isa<fir::BoxType>()) &&
            "expect descriptor for unformatted IO runtime");
     llvm::SmallVector<mlir::Value> outputFuncArgs = {cookie};
     fir::factory::CharacterExprHelper helper{builder, loc};
     if (argType.isa<fir::BoxType>()) {
       mlir::Value box = fir::getBase(converter.genExprBox(loc, *expr, stmtCtx));
       outputFuncArgs.push_back(builder.createConvert(loc, argType, box));
+      if (itemTy.isa<fir::RecordType>())
+        outputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter));
     } else if (helper.isCharacterScalar(itemTy)) {
       fir::ExtendedValue exv = converter.genExprAddr(loc, expr, stmtCtx);
       // scalar allocatable/pointer may also get here, not clear if
       // genExprAddr will lower them as CharBoxValue or BoxValue.
       if (!exv.getCharBox())
         llvm::report_fatal_error(
             "internal error: scalar character not in CharBox");
       outputFuncArgs.push_back(builder.createConvert(
ok = builder.create<fir::CallOp>(loc, outputFunc, outputFuncArgs)
              .getResult(0);
   }
 }
 
 /// Get the input function to call for a value of the given type.
 static mlir::func::FuncOp getInputFunc(mlir::Location loc,
                                        fir::FirOpBuilder &builder,
                                        mlir::Type type, bool isFormatted) {
+  if (type.isa<fir::RecordType>())
+    return getIORuntimeFunc<mkIOKey(InputDerivedType)>(loc, builder);
   if (!isFormatted)
     return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
   if (auto ty = type.dyn_cast<mlir::IntegerType>())
     return ty.getWidth() == 1
                ? getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder)
                : getIORuntimeFunc<mkIOKey(InputInteger)>(loc, builder);
   if (auto ty = type.dyn_cast<mlir::FloatType>()) {
     if (auto width = ty.getWidth(); width == 32)
static void boolRefToLogical(mlir::Location loc, fir::FirOpBuilder &builder,
   auto boolValue = builder.create<fir::LoadOp>(loc, boolAddr);
   auto logicalType = fir::unwrapPassByRefType(addr.getType());
   // The convert avoid making any assumptions about how LOGICALs are actually
   // represented (it might end-up being either a signed or zero extension).
   auto logicalValue = builder.createConvert(loc, logicalType, boolValue);
   builder.create<fir::StoreOp>(loc, logicalValue, addr);
 }
 
-static mlir::Value createIoRuntimeCallForItem(mlir::Location loc,
-                                              fir::FirOpBuilder &builder,
-                                              mlir::func::FuncOp inputFunc,
-                                              mlir::Value cookie,
-                                              const fir::ExtendedValue &item) {
+static mlir::Value
+createIoRuntimeCallForItem(Fortran::lower::AbstractConverter &converter,
+                           mlir::Location loc, mlir::func::FuncOp inputFunc,
+                           mlir::Value cookie, const fir::ExtendedValue &item) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   mlir::Type argType = inputFunc.getFunctionType().getInput(1);
   llvm::SmallVector<mlir::Value> inputFuncArgs = {cookie};
   if (argType.isa<fir::BaseBoxType>()) {
     mlir::Value box = fir::getBase(item);
-    assert(box.getType().isa<fir::BaseBoxType>() &&
-           "must be previously emboxed");
+    auto boxTy = box.getType().dyn_cast<fir::BaseBoxType>();
+    assert(boxTy && "must be previously emboxed");
     inputFuncArgs.push_back(builder.createConvert(loc, argType, box));
+    if (boxTy.getEleTy().isa<fir::RecordType>())
+      inputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter));
   } else {
     mlir::Value itemAddr = fir::getBase(item);
     mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType());
     inputFuncArgs.push_back(builder.createConvert(loc, argType, itemAddr));
     fir::factory::CharacterExprHelper charHelper{builder, loc};
     if (charHelper.isCharacterScalar(itemTy)) {
       mlir::Value len = fir::getLen(item);
       inputFuncArgs.push_back(builder.createConvert(
if (Fortran::evaluate::HasVectorSubscript(*expr)) {
       auto vectorSubscriptBox =
           Fortran::lower::genVectorSubscriptBox(loc, converter, stmtCtx, *expr);
       mlir::func::FuncOp inputFunc = getInputFunc(
           loc, builder, vectorSubscriptBox.getElementType(), isFormatted);
       const bool mustBox =
           inputFunc.getFunctionType().getInput(1).isa<fir::BoxType>();
       if (!checkResult) {
         auto elementalGenerator = [&](const fir::ExtendedValue &element) {
-          createIoRuntimeCallForItem(loc, builder, inputFunc, cookie,
+          createIoRuntimeCallForItem(converter, loc, inputFunc, cookie,
                                      mustBox ? builder.createBox(loc, element)
                                              : element);
         };
         vectorSubscriptBox.loopOverElements(builder, loc, elementalGenerator);
       } else {
         auto elementalGenerator =
             [&](const fir::ExtendedValue &element) -> mlir::Value {
           return createIoRuntimeCallForItem(
-              loc, builder, inputFunc, cookie,
+              converter, loc, inputFunc, cookie,
               mustBox ? builder.createBox(loc, element) : element);
         };
         if (!ok)
           ok = builder.createBool(loc, true);
         ok = vectorSubscriptBox.loopOverElementsWhile(builder, loc,
                                                       elementalGenerator, ok);
       }
       continue;
     }
     mlir::Type itemTy = converter.genType(*expr);
     mlir::func::FuncOp inputFunc =
         getInputFunc(loc, builder, itemTy, isFormatted);
     auto itemExv = inputFunc.getFunctionType().getInput(1).isa<fir::BoxType>()
                        ? converter.genExprBox(loc, *expr, stmtCtx)
                        : converter.genExprAddr(loc, expr, stmtCtx);
-    ok = createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, itemExv);
+    ok = createIoRuntimeCallForItem(converter, loc, inputFunc, cookie, itemExv);
   }
 }
 
 /// Generate an io-implied-do loop.
 template <typename D>
 static void genIoLoop(Fortran::lower::AbstractConverter &converter,
                       mlir::Value cookie, const D &ioImpliedDo,
                       bool isFormatted, bool checkResult, mlir::Value &ok,

flang/lib/Lower/Mangler.cpp

 #include "flang/Semantics/tools.h"
 #include "llvm/ADT/ArrayRef.h"
 #include "llvm/ADT/SmallVector.h"
 #include "llvm/ADT/StringRef.h"
 #include "llvm/Support/MD5.h"
 
 /// Return all ancestor module and submodule scope names; all host procedure
 /// and statement function scope names; and the innermost blockId containing
-/// \p symbol.
+/// \p scope, including scope itself.
 static std::tuple<llvm::SmallVector<llvm::StringRef>,
                   llvm::SmallVector<llvm::StringRef>, std::int64_t>
-ancestors(const Fortran::semantics::Symbol &symbol,
+ancestors(const Fortran::semantics::Scope &scope,
           Fortran::lower::mangle::ScopeBlockIdMap &scopeBlockIdMap) {
   llvm::SmallVector<const Fortran::semantics::Scope *> scopes;
-  for (auto *scp = &symbol.owner(); !scp->IsGlobal(); scp = &scp->parent())
+  for (auto *scp = &scope; !scp->IsGlobal(); scp = &scp->parent())
     scopes.push_back(scp);
   llvm::SmallVector<llvm::StringRef> modules;
   llvm::SmallVector<llvm::StringRef> procs;
   std::int64_t blockId = 0;
   for (auto iter = scopes.rbegin(), rend = scopes.rend(); iter != rend;
        ++iter) {
     auto *scp = *iter;
     switch (scp->kind()) {
for (auto iter = scopes.rbegin(), rend = scopes.rend(); iter != rend;
     } break;
     default:
       break;
     }
   }
   return {modules, procs, blockId};
 }
 
+/// Return all ancestor module and submodule scope names; all host procedure
+/// and statement function scope names; and the innermost blockId containing
+/// \p symbol.
+static std::tuple<llvm::SmallVector<llvm::StringRef>,
+                  llvm::SmallVector<llvm::StringRef>, std::int64_t>
+ancestors(const Fortran::semantics::Symbol &symbol,
+          Fortran::lower::mangle::ScopeBlockIdMap &scopeBlockIdMap) {
+  return ancestors(symbol.owner(), scopeBlockIdMap);
+}
+
+/// Return a globally unique string for a compiler generated \p name.
+std::string
+Fortran::lower::mangle::mangleName(std::string &name,
+                                   const Fortran::semantics::Scope &scope,
+                                   ScopeBlockIdMap &scopeBlockIdMap) {
+  llvm::SmallVector<llvm::StringRef> modules;
+  llvm::SmallVector<llvm::StringRef> procs;
+  std::int64_t blockId;
+  std::tie(modules, procs, blockId) = ancestors(scope, scopeBlockIdMap);
+  return fir::NameUniquer::doGenerated(modules, procs, blockId, name);
+}
+
 // Mangle the name of \p symbol to make it globally unique.
 std::string
 Fortran::lower::mangle::mangleName(const Fortran::semantics::Symbol &symbol,
                                    ScopeBlockIdMap &scopeBlockIdMap,
                                    bool keepExternalInScope) {
   // Resolve module and host associations before mangling.
   const auto &ultimateSymbol = symbol.GetUltimate();
 

flang/lib/Optimizer/Support/InternalNames.cpp

 std::string fir::NameUniquer::doKinds(llvm::ArrayRef<std::int64_t> kinds) {
   std::string result;
   for (auto i : kinds)
     result.append(doKind(i));
   return result;
 }
 
 std::string fir::NameUniquer::doCommonBlock(llvm::StringRef name) {
-  std::string result = prefix();
-  return result.append("C").append(toLower(name));
+  return prefix().append("C").append(toLower(name));
 }
 
 std::string
 fir::NameUniquer::doConstant(llvm::ArrayRef<llvm::StringRef> modules,
                              llvm::ArrayRef<llvm::StringRef> procs,
                              std::int64_t blockId, llvm::StringRef name) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs, blockId)).append("EC");
-  return result.append(toLower(name));
+  return prefix()
+      .append(doAncestors(modules, procs, blockId))
+      .append("EC")
+      .append(toLower(name));
 }
 
 std::string
 fir::NameUniquer::doDispatchTable(llvm::ArrayRef<llvm::StringRef> modules,
                                   llvm::ArrayRef<llvm::StringRef> procs,
                                   std::int64_t blockId, llvm::StringRef name,
                                   llvm::ArrayRef<std::int64_t> kinds) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs, blockId)).append("DT");
-  return result.append(toLower(name)).append(doKinds(kinds));
+  return prefix()
+      .append(doAncestors(modules, procs, blockId))
+      .append("DT")
+      .append(toLower(name))
+      .append(doKinds(kinds));
 }
 
 std::string fir::NameUniquer::doGenerated(llvm::StringRef name) {
-  std::string result = prefix();
-  return result.append("Q").append(name);
+  return prefix().append("Q").append(name);
+}
+
+std::string
+fir::NameUniquer::doGenerated(llvm::ArrayRef<llvm::StringRef> modules,
+                              llvm::ArrayRef<llvm::StringRef> procs,
+                              std::int64_t blockId, llvm::StringRef name) {
+  return prefix()
+      .append("Q")
+      .append(doAncestors(modules, procs, blockId))
+      .append(name);
 }
 
 std::string fir::NameUniquer::doIntrinsicTypeDescriptor(
     llvm::ArrayRef<llvm::StringRef> modules,
     llvm::ArrayRef<llvm::StringRef> procs, std::int64_t blockId,
     IntrinsicType type, std::int64_t kind) {
   const char *name = nullptr;
   switch (type) {
std::string fir::NameUniquer::doIntrinsicTypeDescriptor(
   case IntrinsicType::LOGICAL:
     name = "logical";
     break;
   case IntrinsicType::REAL:
     name = "real";
     break;
   }
   assert(name && "unknown intrinsic type");
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs, blockId)).append("YI");
-  return result.append(name).append(doKind(kind));
+  return prefix()
+      .append(doAncestors(modules, procs, blockId))
+      .append("YI")
+      .append(name)
+      .append(doKind(kind));
 }
 
 std::string
 fir::NameUniquer::doProcedure(llvm::ArrayRef<llvm::StringRef> modules,
                               llvm::ArrayRef<llvm::StringRef> procs,
                               llvm::StringRef name) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs)).append("P");
-  return result.append(toLower(name));
+  return prefix()
+      .append(doAncestors(modules, procs))
+      .append("P")
+      .append(toLower(name));
 }
 
 std::string fir::NameUniquer::doType(llvm::ArrayRef<llvm::StringRef> modules,
                                      llvm::ArrayRef<llvm::StringRef> procs,
                                      std::int64_t blockId, llvm::StringRef name,
                                      llvm::ArrayRef<std::int64_t> kinds) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs, blockId)).append("T");
-  return result.append(toLower(name)).append(doKinds(kinds));
+  return prefix()
+      .append(doAncestors(modules, procs, blockId))
+      .append("T")
+      .append(toLower(name))
+      .append(doKinds(kinds));
 }
 
 std::string
 fir::NameUniquer::doTypeDescriptor(llvm::ArrayRef<llvm::StringRef> modules,
                                    llvm::ArrayRef<llvm::StringRef> procs,
                                    std::int64_t blockId, llvm::StringRef name,
                                    llvm::ArrayRef<std::int64_t> kinds) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs, blockId)).append("CT");
-  return result.append(toLower(name)).append(doKinds(kinds));
+  return prefix()
+      .append(doAncestors(modules, procs, blockId))
+      .append("CT")
+      .append(toLower(name))
+      .append(doKinds(kinds));
 }
 
 std::string
 fir::NameUniquer::doTypeDescriptor(llvm::ArrayRef<std::string> modules,
                                    llvm::ArrayRef<std::string> procs,
                                    std::int64_t blockId, llvm::StringRef name,
                                    llvm::ArrayRef<std::int64_t> kinds) {
   auto rmodules = convertToStringRef(modules);
   auto rprocs = convertToStringRef(procs);
   return doTypeDescriptor(rmodules, rprocs, blockId, name, kinds);
 }
 
 std::string
 fir::NameUniquer::doVariable(llvm::ArrayRef<llvm::StringRef> modules,
                              llvm::ArrayRef<llvm::StringRef> procs,
                              std::int64_t blockId, llvm::StringRef name) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs, blockId)).append("E");
-  return result.append(toLower(name));
+  return prefix()
+      .append(doAncestors(modules, procs, blockId))
+      .append("E")
+      .append(toLower(name));
 }
 
 std::string
 fir::NameUniquer::doNamelistGroup(llvm::ArrayRef<llvm::StringRef> modules,
                                   llvm::ArrayRef<llvm::StringRef> procs,
                                   llvm::StringRef name) {
-  std::string result = prefix();
-  result.append(doAncestors(modules, procs)).append("N");
-  return result.append(toLower(name));
+  return prefix()
+      .append(doAncestors(modules, procs))
+      .append("N")
+      .append(toLower(name));
 }
 
 llvm::StringRef fir::NameUniquer::doProgramEntry() {
   if (mainEntryName.size())
     return mainEntryName;
   return "_QQmain";
 }
 

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

for (auto pair : dtScope) {
     }
   }
   return 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);
-                        }
-                      }
-                    },
-                    [&](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);
-                        }
-                        break;
-                      }
-                    },
-                    [](const auto &) {},
-                },
+  common::visit(
+      common::visitors{
+                DescribeSpecialProc(specials, *ref, true, false /*!final*/,
+                    std::nullopt, &dtScope, derivedTypeSpec, true);
+                DescribeSpecialProc(specials, *ref, false, false /*!final*/, io,
+                    &dtScope, derivedTypeSpec, true);
       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 {
RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
   result.schemata = context.GetBuiltinModule(typeInfoBuiltinModule);
   if (result.schemata) {
     RuntimeTableBuilder builder{context, result};
     builder.DescribeTypes(context.globalScope(), false);
   }
   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()
+  };
+  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)}) {
+        if (const DeclTypeSpec * declType{dtvArg->GetType()}) {
+          return declType->AsDerived() ? declType : nullptr;
+        }
+      }
+    }
+  }
+  return nullptr;
+}
+
+// Locate a particular scope's generic interface for a specific kind of
+// defined I/O.
+static const Symbol *FindGenericDefinedIo(
+    const Scope &scope, common::DefinedIo which) {
+  if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(which))}) {
+    const Symbol &generic{symbol->GetUltimate()};
+    const auto &genericDetails{generic.get<GenericDetails>()};
+    CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
+    CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == which);
+    return &generic;
+  } else {
+    return nullptr;
+  }
+}
+
 std::multimap<const Symbol *, NonTbpDefinedIo>
-CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope) {
+CollectNonTbpDefinedIoGenericInterfaces(
+    const Scope &scope, bool useRuntimeTypeInfoEntries) {
   std::multimap<const Symbol *, NonTbpDefinedIo> result;
   if (!scope.IsTopLevel() &&
       (scope.GetImportKind() == Scope::ImportKind::All ||
           scope.GetImportKind() == Scope::ImportKind::Default)) {
-    result = CollectNonTbpDefinedIoGenericInterfaces(scope.parent());
+    result = CollectNonTbpDefinedIoGenericInterfaces(
+        scope.parent(), useRuntimeTypeInfoEntries);
   }
   if (scope.kind() != Scope::Kind::DerivedType) {
     for (common::DefinedIo which :
         {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
             common::DefinedIo::WriteFormatted,
             common::DefinedIo::WriteUnformatted}) {
-      if (auto iter{scope.find(GenericKind::AsFortran(which))};
-          iter != scope.end()) {
-        const Symbol &generic{iter->second->GetUltimate()};
-        const auto *genericDetails{generic.detailsIf<GenericDetails>()};
-        CHECK(genericDetails != nullptr);
-        CHECK(std::holds_alternative<common::DefinedIo>(
-            genericDetails->kind().u));
-        CHECK(std::get<common::DefinedIo>(genericDetails->kind().u) == which);
-        for (auto specific : genericDetails->specificProcs()) {
-          const Symbol *interface {
-            &specific->GetUltimate()
-          };
-          if (const auto *procEntity{
-                  specific->detailsIf<ProcEntityDetails>()}) {
-            interface = procEntity->procInterface();
-          }
-          const SubprogramDetails *subprogram{
-              interface ? interface->detailsIf<SubprogramDetails>() : nullptr};
-          const Symbol *dtvArg{subprogram && subprogram->dummyArgs().size() > 0
-                  ? subprogram->dummyArgs().at(0)
-                  : nullptr};
-          const DeclTypeSpec *declType{dtvArg ? dtvArg->GetType() : nullptr};
-          const DerivedTypeSpec *derived{
-              declType ? declType->AsDerived() : nullptr};
+      auto name{GenericKind::AsFortran(which)};
+      if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
+        for (auto specific : generic->get<GenericDetails>().specificProcs()) {
+          if (const DeclTypeSpec *
+              declType{GetDefinedIoSpecificArgType(*specific)}) {
+            const DerivedTypeSpec &derived{DEREF(declType->AsDerived())};
             if (const Symbol *
-              dtDesc{derived && derived->scope()
-                      ? derived->scope()->runtimeDerivedTypeDescription()
+                dtDesc{derived.scope()
+                        ? derived.scope()->runtimeDerivedTypeDescription()
                         : nullptr}) {
-            if (&derived->scope()->parent() == &generic.owner()) {
+              if (useRuntimeTypeInfoEntries &&
+                  &derived.scope()->parent() == &generic->owner()) {
                 // This non-TBP defined I/O generic was defined in the
                 // same scope as the derived type, and it will be
                 // included in the derived type's special bindings
                 // by IncorporateDefinedIoGenericInterfaces().
               } else {
                 // Local scope's specific overrides host's for this type
                 bool updated{false};
                 for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;
                      ++iter) {
                   NonTbpDefinedIo &nonTbp{iter->second};
                   if (nonTbp.definedIo == which) {
                     nonTbp.subroutine = &*specific;
                     nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic();
                     updated = true;
                   }
                 }
                 if (!updated) {
                   result.emplace(dtDesc,
                       NonTbpDefinedIo{
                           &*specific, which, declType->IsPolymorphic()});
                 }
               }
             }
           }
         }
       }
     }
+  }
   return result;
 }
 
+// ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces()
+//
+// Returns a true result when a kind of defined I/O generic procedure
+// has a type (from a symbol or a NAMELIST) such that
+// (1) there is a specific procedure matching that type for a non-type-bound
+//     generic defined in the scope of the type, and
+// (2) that specific procedure is unavailable or overridden in a particular
+//     local scope.
+// Specific procedures of non-type-bound defined I/O generic interfaces
+// declared in the scope of a derived type are identified as special bindings
+// in the derived type's runtime type information, as if they had been
+// type-bound.  This predicate is meant to determine local situations in
+// which those special bindings are not to be used.  Its result is intended
+// to be put into the "ignoreNonTbpEntries" flag of
+// runtime::NonTbpDefinedIoTable and passed (negated) as the
+// "useRuntimeTypeInfoEntries" argument of
+// CollectNonTbpDefinedIoGenericInterfaces() above.
+
+static const Symbol *FindSpecificDefinedIo(const Scope &scope,
+    const evaluate::DynamicType &derived, common::DefinedIo which) {
+  if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
+    for (auto ref : generic->get<GenericDetails>().specificProcs()) {
+      const Symbol &specific{*ref};
+      if (const DeclTypeSpec *
+          thisType{GetDefinedIoSpecificArgType(specific)}) {
+        if (evaluate::DynamicType{DEREF(thisType->AsDerived()), true}
+                .IsTkCompatibleWith(derived)) {
+          return &specific.GetUltimate();
+        }
+      }
+    }
+  }
+  return nullptr;
+}
+
+bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+    const Scope &scope, const DerivedTypeSpec *derived) {
+  if (!derived) {
+    return false;
+  }
+  const Symbol &typeSymbol{derived->typeSymbol()};
+  const Scope &typeScope{typeSymbol.GetUltimate().owner()};
+  evaluate::DynamicType dyType{*derived};
+  for (common::DefinedIo which :
+      {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
+          common::DefinedIo::WriteFormatted,
+          common::DefinedIo::WriteUnformatted}) {
+    if (const Symbol *
+        specific{FindSpecificDefinedIo(typeScope, dyType, which)}) {
+      // There's a non-TBP defined I/O procedure in the scope of the type's
+      // definition that applies to this type.  It will appear in the type's
+      // runtime information.  Determine whether it still applies in the
+      // scope of interest.
+      if (FindSpecificDefinedIo(scope, dyType, which) != specific) {
+        return true;
+      }
+    }
+  }
+  return false;
+}
+
+bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+    const Scope &scope, const DeclTypeSpec *type) {
+  return type &&
+      ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+          scope, type->AsDerived());
+}
+
+bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+    const Scope &scope, const Symbol *symbol) {
+  if (!symbol) {
+    return false;
+  }
+  return common::visit(
+      common::visitors{
+          [&](const NamelistDetails &x) {
+            for (auto ref : x.objects()) {
+              if (ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+                      scope, &*ref)) {
+                return true;
+              }
+            }
+            return false;
+          },
+          [&](const auto &) {
+            return ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
+                scope, symbol->GetType());
+          },
+      },
+      symbol->GetUltimate().details());
+}
+
 } // namespace Fortran::semantics

flang/runtime/namelist.cpp

 //===-- runtime/namelist.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
 //
 //===----------------------------------------------------------------------===//
 
-// TODO: When lowering has been updated to used the new pointer data member in
-// the NamelistGroup structure, delete this definition and the two #ifndef
-// directives below that test it.
-#define DISABLE_NON_TBP_DIO 1
-
 #include "namelist.h"
 #include "descriptor-io.h"
 #include "emit-encoded.h"
 #include "io-stmt.h"
 #include "flang/Runtime/io-api.h"
 #include <algorithm>
 #include <cstring>
 #include <limits>
if (listOutput) {
       listOutput->set_lastWasUndelimitedCharacter(false);
     }
     if (!EmitWithAdvance(j == 0 ? ' ' : comma) || !EmitUpperCase(item.name) ||
         !EmitWithAdvance('=')) {
       return false;
     }
     if (const auto *addendum{item.descriptor.Addendum()};
         addendum && addendum->derivedType()) {
-      NonTbpDefinedIoTable *table{nullptr};
-#ifndef DISABLE_NON_TBP_DIO
-      table = group.nonTbpDefinedIo;
-#endif
+      const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo};
       if (!IONAME(OutputDerivedType)(cookie, item.descriptor, table)) {
         return false;
       }
     } else if (!descr::DescriptorIO<Direction::Output>(io, item.descriptor)) {
       return false;
     }
   }
   // terminal /
if (!next || *next != '=') {
           name, group.groupName);
       return false;
     }
     io.HandleRelativePosition(byteCount);
     // Read the values into the descriptor.  An array can be short.
     listInput->ResetForNextNamelistItem(useDescriptor->rank() > 0);
     if (const auto *addendum{useDescriptor->Addendum()};
         addendum && addendum->derivedType()) {
-      NonTbpDefinedIoTable *table{nullptr};
-#ifndef DISABLE_NON_TBP_DIO
-      table = group.nonTbpDefinedIo;
-#endif
+      const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo};
       if (!IONAME(InputDerivedType)(cookie, *useDescriptor, table)) {
         return false;
       }
     } else if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
       return false;
     }
     next = io.GetNextNonBlank(byteCount);
     if (next && *next == comma) {

flang/runtime/non-tbp-dio.h

 struct NonTbpDefinedIoTable {
   const NonTbpDefinedIo *Find(
       const typeInfo::DerivedType &, common::DefinedIo) const;
   std::size_t items{0};
   const NonTbpDefinedIo *item{nullptr};
   // True when the only procedures to be used are the type-bound special
   // procedures in the type information tables and any non-null procedures
   // in this table.  When false, the entries in this table override whatever
-  // non-type-bound specific procedures might be in the type inforamtion,
+  // non-type-bound specific procedures might be in the type information,
   // but the remaining specifics remain visible.
   bool ignoreNonTbpEntries{false};
 };
 
 } // namespace Fortran::runtime::io
 #endif // FORTRAN_RUNTIME_NON_TBP_DIO_H_

flang/test/Lower/derived-type-finalization.f90

subroutine test_nonpointer_function()
     print*, get_t1(20)
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_nonpointer_function() {
 ! CHECK: %[[TMP:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = ".result"}
 ! CHECK: %{{.*}} = fir.call @_FortranAioBeginExternalListOutput
 ! CHECK: %[[RES:.*]] = fir.call @_QMderived_type_finalizationPget_t1(%{{.*}}) {{.*}} : (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>
 ! CHECK: fir.save_result %[[RES]] to %[[TMP]] : !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>, !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>
-! CHECK: %{{.*}} = fir.call @_FortranAioOutputDescriptor
+! CHECK: %{{.*}} = fir.call @_FortranAioOutputDerivedType
 ! CHECK-NOT: %{{.*}} = fir.call @_FortranADestroy
 ! CHECK: %{{.*}} = fir.call @_FortranAioEndIoStatement
 ! CHECK: return
 
   subroutine test_avoid_double_finalization(a)
     type(t3), intent(inout) :: a
     type(t3)                :: b
     b = a

flang/test/Lower/io-derived-type.f90

+! RUN: bbc -polymorphic-type -emit-fir -o - %s | FileCheck %s
+
+module m
+  type t
+    integer n
+  end type
+  interface write(formatted)
+    module procedure wft
+  end interface
+ contains
+  ! CHECK-LABEL: @_QMmPwft
+  subroutine wft(dtv, unit, iotype, v_list, iostat, iomsg)
+    class(t), intent(in) :: dtv
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+    iostat = 0
+    write(unit,*,iostat=iostat,iomsg=iomsg) 'wft was called: ', dtv%n
+  end subroutine
+
+  ! CHECK-LABEL: @_QMmPwftd
+  subroutine wftd(dtv, unit, iotype, v_list, iostat, iomsg)
+    type(t), intent(in) :: dtv
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+    iostat = 0
+    write(unit,*,iostat=iostat,iomsg=iomsg) 'wftd: ', dtv%n
+  end subroutine
+
+  ! CHECK-LABEL: @_QMmPtest1
+  subroutine test1
+    import, all
+    ! CHECK:   %[[V_14:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}>
+    ! CHECK:   %[[V_15:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_14]] : (!fir.ref<!fir.type<_QMmTt{n:i32}>>, !fir.field) -> !fir.ref<i32>
+    ! CHECK:   fir.store %c1{{.*}} to %[[V_15]] : !fir.ref<i32>
+    ! CHECK:   %[[V_16:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<!fir.type<_QMmTt{n:i32}>>
+    ! CHECK:   %[[V_17:[0-9]+]] = fir.convert %[[V_16]] : (!fir.box<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<none>
+    ! CHECK:   %[[V_18:[0-9]+]] = fir.address_of(@_QQMmFtest1.nonTbpDefinedIoTable) : !fir.ref<tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>
+    ! CHECK:   %[[V_19:[0-9]+]] = fir.convert %[[V_18]] : (!fir.ref<tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>) -> !fir.ref<none>
+    ! CHECK:   %[[V_20:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_17]], %[[V_19]]) fastmath<contract> : (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
+    print *, 'test1 outer, should call wft: ', t(1)
+    block
+      import, only: t
+      ! CHECK:   %[[V_35:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}>
+      ! CHECK:   %[[V_36:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_35]] : (!fir.ref<!fir.type<_QMmTt{n:i32}>>, !fir.field) -> !fir.ref<i32>
+      ! CHECK:   fir.store %c2{{.*}} to %[[V_36]] : !fir.ref<i32>
+      ! CHECK:   %[[V_37:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<!fir.type<_QMmTt{n:i32}>>
+      ! CHECK:   %[[V_38:[0-9]+]] = fir.convert %[[V_37]] : (!fir.box<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<none>
+      ! CHECK:   %[[V_39:[0-9]+]] = fir.address_of(@default.nonTbpDefinedIoTable) : !fir.ref<tuple<i64, !fir.ref<!fir.array<0xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>
+      ! CHECK:   %[[V_40:[0-9]+]] = fir.convert %[[V_39]] : (!fir.ref<tuple<i64, !fir.ref<!fir.array<0xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>) -> !fir.ref<none>
+      ! CHECK:   %[[V_41:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_38]], %[[V_40]]) fastmath<contract> : (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
+      print *, 'test1 block, should not call wft: ', t(2)
+    end block
+  end subroutine
+
+  ! CHECK-LABEL: @_QMmPtest2
+  subroutine test2
+    ! CHECK:   %[[V_13:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}>
+    ! CHECK:   %[[V_14:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_13]] : (!fir.ref<!fir.type<_QMmTt{n:i32}>>, !fir.field) -> !fir.ref<i32>
+    ! CHECK:   fir.store %c3{{.*}} to %[[V_14]] : !fir.ref<i32>
+    ! CHECK:   %[[V_15:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<!fir.type<_QMmTt{n:i32}>>
+    ! CHECK:   %[[V_16:[0-9]+]] = fir.convert %[[V_15]] : (!fir.box<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<none>
+    ! CHECK:   %[[V_17:[0-9]+]] = fir.address_of(@default.nonTbpDefinedIoTable) : !fir.ref<tuple<i64, !fir.ref<!fir.array<0xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>
+    ! CHECK:   %[[V_18:[0-9]+]] = fir.convert %[[V_17]] : (!fir.ref<tuple<i64, !fir.ref<!fir.array<0xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>) -> !fir.ref<none>
+    ! CHECK:   %[[V_19:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_16]], %[[V_18]]) fastmath<contract> : (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
+
+    import, only: t
+    print *, 'test2, should not call wft: ', t(3)
+  end subroutine
+
+  ! CHECK-LABEL: @_QMmPtest3
+  subroutine test3(p, x)
+    procedure(wftd) p
+    type(t), intent(in) :: x
+    interface write(formatted)
+      procedure p
+    end interface
+
+    ! CHECK:     %[[V_3:[0-9]+]] = fir.embox %arg1 : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<!fir.type<_QMmTt{n:i32}>>
+    ! CHECK:     %[[V_4:[0-9]+]] = fir.convert %[[V_3]] : (!fir.box<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<none>
+    ! CHECK:     %[[V_5:[0-9]+]] = fir.alloca !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+    ! CHECK:     %[[V_6:[0-9]+]] = fir.undefined !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+    ! CHECK:     %[[V_7:[0-9]+]] = fir.address_of(@_QMmE.dt.t)
+    ! CHECK:     %[[V_8:[0-9]+]] = fir.convert %[[V_7]] : {{.*}} -> !fir.ref<none>
+    ! CHECK:     %[[V_9:[0-9]+]] = fir.insert_value %[[V_6]], %[[V_8]], [0 : index, 0 : index] : (!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>, !fir.ref<none>) -> !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+    ! CHECK:     %[[V_10:[0-9]+]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> !fir.ref<none>
+    ! CHECK:     %[[V_11:[0-9]+]] = fir.insert_value %[[V_9]], %[[V_10]], [0 : index, 1 : index] : (!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>, !fir.ref<none>) -> !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+    ! CHECK:     %[[V_12:[0-9]+]] = fir.insert_value %[[V_11]], %c2{{.*}}, [0 : index, 2 : index] : (!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>, i32) -> !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+    ! CHECK:     %[[V_13:[0-9]+]] = fir.insert_value %[[V_12]], %false, [0 : index, 3 : index] : (!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>, i1) -> !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+    ! CHECK:     fir.store %[[V_13]] to %[[V_5]] : !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>
+    ! CHECK:     %[[V_14:[0-9]+]] = fir.alloca tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+    ! CHECK:     %[[V_15:[0-9]+]] = fir.undefined tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+    ! CHECK:     %[[V_16:[0-9]+]] = fir.insert_value %[[V_15]], %c1{{.*}}, [0 : index] : (tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>, i64) -> tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+    ! CHECK:     %[[V_17:[0-9]+]] = fir.insert_value %[[V_16]], %[[V_5]], [1 : index] : (tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>) -> tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+    ! CHECK:     %[[V_18:[0-9]+]] = fir.insert_value %[[V_17]], %true, [2 : index] : (tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>, i1) -> tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+    ! CHECK:     fir.store %[[V_18]] to %[[V_14]] : !fir.ref<tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>
+    ! CHECK:     %[[V_19:[0-9]+]] = fir.convert %[[V_14]] : (!fir.ref<tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>) -> !fir.ref<none>
+    ! CHECK:     %[[V_20:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_4]], %[[V_19]]) fastmath<contract> : (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
+    print *, x
+  end subroutine
+end module
+
+! CHECK-LABEL: @_QQmain
+program p
+  use m
+  character*3 ccc(4)
+  namelist /nnn/ jjj, ccc
+
+  ! CHECK:   fir.call @_QMmPtest1
+  call test1
+  ! CHECK:   fir.call @_QMmPtest2
+  call test2
+  ! CHECK:   fir.call @_QMmPtest3
+  call test3(wftd, t(17))
+
+  ! CHECK:   %[[V_95:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}>
+  ! CHECK:   %[[V_96:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_95]] : (!fir.ref<!fir.type<_QMmTt{n:i32}>>, !fir.field) -> !fir.ref<i32>
+  ! CHECK:   fir.store %c4{{.*}} to %[[V_96]] : !fir.ref<i32>
+  ! CHECK:   %[[V_97:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<!fir.type<_QMmTt{n:i32}>>
+  ! CHECK:   %[[V_98:[0-9]+]] = fir.convert %[[V_97]] : (!fir.box<!fir.type<_QMmTt{n:i32}>>) -> !fir.box<none>
+  ! CHECK:   %[[V_99:[0-9]+]] = fir.address_of(@_QQF.nonTbpDefinedIoTable) : !fir.ref<tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>
+  ! CHECK:   %[[V_100:[0-9]+]] = fir.convert %[[V_99]] : (!fir.ref<tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>>) -> !fir.ref<none>
+  ! CHECK:   %[[V_101:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_98]], %[[V_100]]) fastmath<contract> : (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
+  print *, 'main, should call wft: ', t(4)
+end
+
+! CHECK: fir.global linkonce @_QQMmFtest1.nonTbpDefinedIoTable.list constant : !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+! CHECK: fir.global linkonce @_QQMmFtest1.nonTbpDefinedIoTable constant : tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+! CHECK: fir.global linkonce @default.nonTbpDefinedIoTable constant : tuple<i64, !fir.ref<!fir.array<0xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>
+! CHECK: fir.global linkonce @_QQF.nonTbpDefinedIoTable.list constant : !fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>
+! CHECK: fir.global linkonce @_QQF.nonTbpDefinedIoTable constant : tuple<i64, !fir.ref<!fir.array<1xtuple<!fir.ref<none>, !fir.ref<none>, i32, i1>>>, i1>

flang/test/Lower/namelist.f90

program p
   ! CHECK: fir.address_of
   ! CHECK: fir.insert_value
   ! CHECK: fir.embox [[jjj]]
   ! CHECK: fir.insert_value
   ! CHECK: fir.address_of
   ! CHECK: fir.insert_value
   ! CHECK: fir.embox [[ccc]]
   ! CHECK: fir.insert_value
-  ! CHECK: fir.alloca tuple<!fir.ref<i8>, i64, !fir.ref<!fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>>>
+  ! CHECK: fir.alloca tuple<!fir.ref<i8>, i64, !fir.ref<!fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>>, !fir.ref<none>>
   ! CHECK: fir.address_of
-  ! CHECK-COUNT-3: fir.insert_value
+  ! CHECK-COUNT-4: fir.insert_value
   ! CHECK: fir.call @_FortranAioOutputNamelist([[cookie]]
   ! CHECK: fir.call @_FortranAioEndIoStatement([[cookie]]
   write(*, nnn)
   jjj = 27
   ! CHECK: fir.coordinate_of
   ccc(4) = "zz "
   ! CHECK: [[cookie:%[0-9]+]] = fir.call @_FortranAioBeginExternalListOutput
   ! CHECK: fir.alloca !fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>
   ! CHECK: fir.undefined
   ! CHECK: fir.address_of
   ! CHECK: fir.insert_value
   ! CHECK: fir.embox [[jjj]]
   ! CHECK: fir.insert_value
   ! CHECK: fir.address_of
   ! CHECK: fir.insert_value
   ! CHECK: fir.embox [[ccc]]
   ! CHECK: fir.insert_value
-  ! CHECK: fir.alloca tuple<!fir.ref<i8>, i64, !fir.ref<!fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>>>
+  ! CHECK: fir.alloca tuple<!fir.ref<i8>, i64, !fir.ref<!fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>>, !fir.ref<none>>
   ! CHECK: fir.address_of
-  ! CHECK-COUNT-3: fir.insert_value
+  ! CHECK-COUNT-4: fir.insert_value
   ! CHECK: fir.call @_FortranAioOutputNamelist([[cookie]]
   ! CHECK: fir.call @_FortranAioEndIoStatement([[cookie]]
   write(*, nnn)
 end
 
 ! CHECK-LABEL: sss
 subroutine sss
   integer xxx(11:13)

flang/test/Lower/parent-component.f90

contains
 
   ! CHECK-LABEL: func.func @_QFPinit_scalar()
   ! CHECK: %[[S:.*]] = fir.address_of(@_QFFinit_scalarEs) : !fir.ref<!fir.type<_QFTc{a:i32,b:i32}>>
   ! CHECK: %[[CAST:.*]] = fir.convert %[[S]] : (!fir.ref<!fir.type<_QFTc{a:i32,b:i32}>>) -> !fir.ref<!fir.type<_QFTp{a:i32}>>
   ! CHECK: fir.call @_QFPprint_scalar(%[[CAST]]) {{.*}}: (!fir.ref<!fir.type<_QFTp{a:i32}>>) -> ()
 
   ! CHECK: %[[BOX:.*]] = fir.embox %{{.*}} : (!fir.ref<!fir.type<_QFTc{a:i32,b:i32}>>) -> !fir.box<!fir.type<_QFTp{a:i32}>>
   ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOX]] : (!fir.box<!fir.type<_QFTp{a:i32}>>) -> !fir.box<none>
-  ! CHECK: %{{.*}} = fir.call @_FortranAioOutputDescriptor(%{{.*}}, %[[BOX_NONE]]) {{.*}}: (!fir.ref<i8>, !fir.box<none>) -> i1
+  ! CHECK: %{{.*}} = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[BOX_NONE]], %{{.*}}) {{.*}}: (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
 
   subroutine init_assumed(y)
     type(c) :: y(:)
     call print_p(y%p)
     print*,y%p
   end subroutine
 
   ! CHECK-LABEL: func.func @_QFPinit_assumed(

flang/test/Lower/vector-subscript-io.f90

 ! CHECK:   cf.cond_br %[[VAL_281]], ^bb2, ^bb3
 ! CHECK: ^bb2:
 ! CHECK:   %[[VAL_282:.*]] = fir.coordinate_of %[[VAL_283]], %[[VAL_279]] : (!fir.ref<!fir.array<4xi32>>, index) -> !fir.ref<i32>
 ! CHECK:   %[[VAL_284:.*]] = fir.load %[[VAL_282]] : !fir.ref<i32>
 ! CHECK:   %[[VAL_285:.*]] = fir.convert %[[VAL_284]] : (i32) -> index
 ! CHECK:   %[[VAL_286:.*]] = fir.array_coor %[[VAL_287]](%[[VAL_277]]) {{\[}}%[[VAL_278]]] %[[VAL_285]] : (!fir.ref<!fir.array<6x!fir.type<_QMderived_typesTt{i:i32,c:!fir.char<1,2>}>>>, !fir.shapeshift<1>, !fir.slice<1>, index) -> !fir.ref<!fir.type<_QMderived_typesTt{i:i32,c:!fir.char<1,2>}>>
 ! CHECK:   %[[VAL_288:.*]] = fir.embox %[[VAL_286]] : (!fir.ref<!fir.type<_QMderived_typesTt{i:i32,c:!fir.char<1,2>}>>) -> !fir.box<!fir.type<_QMderived_typesTt{i:i32,c:!fir.char<1,2>}>>
 ! CHECK:   %[[VAL_289:.*]] = fir.convert %[[VAL_288]] : (!fir.box<!fir.type<_QMderived_typesTt{i:i32,c:!fir.char<1,2>}>>) -> !fir.box<none>
-! CHECK:   %[[VAL_290:.*]] = fir.call @_FortranAioInputDescriptor(%[[VAL_276]], %[[VAL_289]]) {{.*}}: (!fir.ref<i8>, !fir.box<none>) -> i1
+! CHECK:   %[[VAL_290:.*]] = fir.call @_FortranAioInputDerivedType(%[[VAL_276]], %[[VAL_289]], {{.*}}) {{.*}}: (!fir.ref<i8>, !fir.box<none>, !fir.ref<none>) -> i1
 ! CHECK:   %[[VAL_291:.*]] = arith.addi %[[VAL_279]], %[[VAL_273]] : index
 ! CHECK:   %[[VAL_292:.*]] = arith.subi %[[VAL_280]], %[[VAL_273]] : index
 ! CHECK:   cf.br ^bb1(%[[VAL_291]], %[[VAL_292]] : index, index)
 ! CHECK: ^bb3:
 ! CHECK:   %[[VAL_293:.*]] = fir.call @_FortranAioEndIoStatement(%[[VAL_276]]) {{.*}}: (!fir.ref<i8>) -> i32
 ! CHECK:   return
 end subroutine