[flang-commits] [flang] 6f7a3b0 - [flang] Non-type-bound defined IO lowering
V Donaldson via flang-commits
flang-commits at lists.llvm.org
Wed May 17 09:22:32 PDT 2023
Author: V Donaldson
Date: 2023-05-17T09:22:13-07:00
New Revision: 6f7a3b078191a925546ea3fead2e9cf0efdd9257
URL: https://github.com/llvm/llvm-project/commit/6f7a3b078191a925546ea3fead2e9cf0efdd9257
DIFF: https://github.com/llvm/llvm-project/commit/6f7a3b078191a925546ea3fead2e9cf0efdd9257.diff
LOG: [flang] Non-type-bound defined IO lowering
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
Added:
flang/test/Lower/io-derived-type.f90
Modified:
flang/include/flang/Lower/AbstractConverter.h
flang/include/flang/Lower/Mangler.h
flang/include/flang/Optimizer/Support/InternalNames.h
flang/include/flang/Semantics/runtime-type-info.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/IO.cpp
flang/lib/Lower/Mangler.cpp
flang/lib/Optimizer/Support/InternalNames.cpp
flang/lib/Semantics/runtime-type-info.cpp
flang/runtime/namelist.cpp
flang/runtime/non-tbp-dio.h
flang/test/Lower/derived-type-finalization.f90
flang/test/Lower/namelist.f90
flang/test/Lower/parent-component.f90
flang/test/Lower/vector-subscript-io.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h
index 7452f71d8083b..2c19eb10612af 100644
--- a/flang/include/flang/Lower/AbstractConverter.h
+++ b/flang/include/flang/Lower/AbstractConverter.h
@@ -227,6 +227,9 @@ class AbstractConverter {
/// 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
//===--------------------------------------------------------------------===//
@@ -237,11 +240,13 @@ class AbstractConverter {
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;
diff --git a/flang/include/flang/Lower/Mangler.h b/flang/include/flang/Lower/Mangler.h
index e32132a6692a7..1f3109b354191 100644
--- a/flang/include/flang/Lower/Mangler.h
+++ b/flang/include/flang/Lower/Mangler.h
@@ -50,6 +50,10 @@ std::string mangleName(const semantics::Symbol &,
/// 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);
diff --git a/flang/include/flang/Optimizer/Support/InternalNames.h b/flang/include/flang/Optimizer/Support/InternalNames.h
index d6e28f4d360f7..f3f9fe7051893 100644
--- a/flang/include/flang/Optimizer/Support/InternalNames.h
+++ b/flang/include/flang/Optimizer/Support/InternalNames.h
@@ -80,8 +80,12 @@ struct NameUniquer {
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
diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h
index 86c37d43bc16e..e90d3ae8baf1e 100644
--- a/flang/include/flang/Semantics/runtime-type-info.h
+++ b/flang/include/flang/Semantics/runtime-type-info.h
@@ -55,7 +55,15 @@ struct NonTbpDefinedIo {
};
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_
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 19ae9576dfac2..ea34da28d0bac 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -743,6 +743,10 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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(); }
@@ -758,7 +762,10 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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();
}
diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp
index e5a84b43264f7..505744adaa63f 100644
--- a/flang/lib/Lower/IO.cpp
+++ b/flang/lib/Lower/IO.cpp
@@ -15,6 +15,7 @@
#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"
@@ -32,6 +33,7 @@
#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"
@@ -46,6 +48,13 @@ 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 {
@@ -53,10 +62,10 @@ getModel<const Fortran::runtime::io::NamelistGroup &>() {
};
}
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
@@ -72,38 +81,39 @@ namespace Fortran::lower {
/// 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
@@ -238,10 +248,210 @@ static void makeNextConditionalOn(fir::FirOpBuilder &builder,
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,
@@ -257,24 +467,26 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
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);
@@ -312,9 +524,9 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
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)));
@@ -361,7 +573,6 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
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);
@@ -379,24 +590,32 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
? 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
@@ -435,6 +654,8 @@ static void genNamelistIO(Fortran::lower::AbstractConverter &converter,
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>()) {
@@ -515,6 +736,8 @@ static void genOutputItemList(
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
@@ -548,6 +771,8 @@ static void genOutputItemList(
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>())
@@ -596,18 +821,20 @@ static void boolRefToLogical(mlir::Location loc, fir::FirOpBuilder &builder,
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());
@@ -660,7 +887,7 @@ static void genInputItemList(Fortran::lower::AbstractConverter &converter,
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);
};
@@ -669,7 +896,7 @@ static void genInputItemList(Fortran::lower::AbstractConverter &converter,
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)
@@ -685,7 +912,7 @@ static void genInputItemList(Fortran::lower::AbstractConverter &converter,
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);
}
}
diff --git a/flang/lib/Lower/Mangler.cpp b/flang/lib/Lower/Mangler.cpp
index 0f46458b7266e..ff1631c6929ab 100644
--- a/flang/lib/Lower/Mangler.cpp
+++ b/flang/lib/Lower/Mangler.cpp
@@ -20,13 +20,13 @@
/// 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;
@@ -60,6 +60,28 @@ ancestors(const Fortran::semantics::Symbol &symbol,
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,
diff --git a/flang/lib/Optimizer/Support/InternalNames.cpp b/flang/lib/Optimizer/Support/InternalNames.cpp
index df99cc7243f00..6138c1f425d62 100644
--- a/flang/lib/Optimizer/Support/InternalNames.cpp
+++ b/flang/lib/Optimizer/Support/InternalNames.cpp
@@ -100,17 +100,17 @@ std::string fir::NameUniquer::doKinds(llvm::ArrayRef<std::int64_t> kinds) {
}
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
@@ -118,14 +118,25 @@ 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(
@@ -151,27 +162,32 @@ std::string fir::NameUniquer::doIntrinsicTypeDescriptor(
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
@@ -179,9 +195,11 @@ 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
@@ -198,18 +216,20 @@ 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() {
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index 5f62a0870745c..827bb8e9fbf71 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -1037,32 +1037,31 @@ RuntimeTableBuilder::DescribeSpecialGenerics(const Scope &dtScope,
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{
+ [&](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 &) {},
+ },
generic.kind().u);
}
@@ -1219,68 +1218,93 @@ 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()
+ };
+ 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};
- if (const Symbol *
- dtDesc{derived && derived->scope()
- ? derived->scope()->runtimeDerivedTypeDescription()
- : nullptr}) {
- if (&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;
+ 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.scope()
+ ? derived.scope()->runtimeDerivedTypeDescription()
+ : nullptr}) {
+ 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()});
}
- }
- if (!updated) {
- result.emplace(dtDesc,
- NonTbpDefinedIo{
- &*specific, which, declType->IsPolymorphic()});
}
}
}
@@ -1291,4 +1315,96 @@ CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope) {
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
diff --git a/flang/runtime/namelist.cpp b/flang/runtime/namelist.cpp
index 71d6388a7f893..1b3207ef2f932 100644
--- a/flang/runtime/namelist.cpp
+++ b/flang/runtime/namelist.cpp
@@ -6,11 +6,6 @@
//
//===----------------------------------------------------------------------===//
-// 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"
@@ -73,10 +68,7 @@ bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
}
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;
}
@@ -533,10 +525,7 @@ bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
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;
}
diff --git a/flang/runtime/non-tbp-dio.h b/flang/runtime/non-tbp-dio.h
index 49b23cea1954c..a2030dbfdfe8d 100644
--- a/flang/runtime/non-tbp-dio.h
+++ b/flang/runtime/non-tbp-dio.h
@@ -46,7 +46,7 @@ struct NonTbpDefinedIoTable {
// 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};
};
diff --git a/flang/test/Lower/derived-type-finalization.f90 b/flang/test/Lower/derived-type-finalization.f90
index b73c0c66a7654..4f223ab7511d1 100644
--- a/flang/test/Lower/derived-type-finalization.f90
+++ b/flang/test/Lower/derived-type-finalization.f90
@@ -182,7 +182,7 @@ subroutine test_nonpointer_function()
! 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
diff --git a/flang/test/Lower/io-derived-type.f90 b/flang/test/Lower/io-derived-type.f90
new file mode 100644
index 0000000000000..0bc41564715df
--- /dev/null
+++ b/flang/test/Lower/io-derived-type.f90
@@ -0,0 +1,136 @@
+! 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>
diff --git a/flang/test/Lower/namelist.f90 b/flang/test/Lower/namelist.f90
index 7789effc0d313..6637283b61381 100644
--- a/flang/test/Lower/namelist.f90
+++ b/flang/test/Lower/namelist.f90
@@ -19,9 +19,9 @@ program p
! 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)
@@ -39,9 +39,9 @@ program p
! 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)
diff --git a/flang/test/Lower/parent-component.f90 b/flang/test/Lower/parent-component.f90
index 377d7d70a9819..e7582c5b3a939 100644
--- a/flang/test/Lower/parent-component.f90
+++ b/flang/test/Lower/parent-component.f90
@@ -146,7 +146,7 @@ subroutine init_scalar()
! 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(:)
diff --git a/flang/test/Lower/vector-subscript-io.f90 b/flang/test/Lower/vector-subscript-io.f90
index 27eea1efe1bec..38733cfc6cda2 100644
--- a/flang/test/Lower/vector-subscript-io.f90
+++ b/flang/test/Lower/vector-subscript-io.f90
@@ -413,7 +413,7 @@ subroutine simple_derived(x, y)
! 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)
More information about the flang-commits
mailing list