[flang-commits] [flang] 7cf1608 - [flang] Rework handling of non-type-bound user-defined I/O
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Apr 13 15:35:36 PDT 2023
Author: Peter Klausler
Date: 2023-04-13T15:35:01-07:00
New Revision: 7cf1608b4d8f7f4d20c994dd13451efb7c9560b5
URL: https://github.com/llvm/llvm-project/commit/7cf1608b4d8f7f4d20c994dd13451efb7c9560b5
DIFF: https://github.com/llvm/llvm-project/commit/7cf1608b4d8f7f4d20c994dd13451efb7c9560b5.diff
LOG: [flang] Rework handling of non-type-bound user-defined I/O
A fairly recent introduction of runtime I/O APIs called OutputDerivedType()
and InputDerivedType() didn't cover NAMELIST I/O's need to access
non-type-bound generic interfaces for user-defined derived type I/O
when those generic interfaces are defined in some scope other than the
one that defines the derived type.
The patch adds a new data structure shared between lowering
and the runtime that can represent all of the cases that can
arise with non-type-bound defined I/O. It can represent
scopes in which non-type-bound defined I/O generic interfaces
are inaccessible, too, due to IMPORT statements.
The data structure is now an operand to OutputDerivedType() and
InputDerivedType() as well as a data member in the NamelistGroup
structure.
Differential Revision: https://reviews.llvm.org/D148257
Added:
flang/runtime/non-tbp-dio.cpp
flang/runtime/non-tbp-dio.h
Modified:
flang/include/flang/Common/Fortran.h
flang/include/flang/Runtime/io-api.h
flang/include/flang/Semantics/runtime-type-info.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Common/Fortran.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/check-io.cpp
flang/lib/Semantics/check-io.h
flang/lib/Semantics/resolve-names-utils.cpp
flang/lib/Semantics/runtime-type-info.cpp
flang/lib/Semantics/symbol.cpp
flang/lib/Semantics/tools.cpp
flang/module/__fortran_type_info.f90
flang/runtime/CMakeLists.txt
flang/runtime/descriptor-io.cpp
flang/runtime/descriptor-io.h
flang/runtime/format-implementation.h
flang/runtime/format.h
flang/runtime/io-api.cpp
flang/runtime/namelist.cpp
flang/runtime/namelist.h
flang/runtime/type-info.h
flang/runtime/unit.h
flang/test/Semantics/typeinfo01.f90
flang/test/Semantics/typeinfo02.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h
index dc9bd8bae04dc..92d2b48f71242 100644
--- a/flang/include/flang/Common/Fortran.h
+++ b/flang/include/flang/Common/Fortran.h
@@ -57,6 +57,11 @@ ENUM_CLASS(IoSpecKind, Access, Action, Advance, Asynchronous, Blank, Decimal,
Dispose, // nonstandard
)
+// Defined I/O variants
+ENUM_CLASS(
+ DefinedIo, ReadFormatted, ReadUnformatted, WriteFormatted, WriteUnformatted)
+const char *AsFortran(DefinedIo);
+
// Floating-point rounding modes; these are packed into a byte to save
// room in the runtime's format processing context structure.
enum class RoundingMode : std::uint8_t {
@@ -75,5 +80,6 @@ static constexpr int maxRank{15};
// Fortran names may have up to 63 characters (See Fortran 2018 C601).
static constexpr int maxNameLen{63};
+
} // namespace Fortran::common
#endif // FORTRAN_COMMON_FORTRAN_H_
diff --git a/flang/include/flang/Runtime/io-api.h b/flang/include/flang/Runtime/io-api.h
index 6aabb01354f5b..ae4b85136a191 100644
--- a/flang/include/flang/Runtime/io-api.h
+++ b/flang/include/flang/Runtime/io-api.h
@@ -23,6 +23,7 @@ class Descriptor;
namespace Fortran::runtime::io {
+class NonTbpDefinedIoTable;
class NamelistGroup;
class IoStatementState;
using Cookie = IoStatementState *;
@@ -275,21 +276,19 @@ bool IONAME(InputLogical)(Cookie, bool &);
bool IONAME(OutputNamelist)(Cookie, const NamelistGroup &);
bool IONAME(InputNamelist)(Cookie, const NamelistGroup &);
-// When an I/O list item has a derived type with a specific user-defined
+// When an I/O list item has a derived type with a specific defined
// I/O subroutine of the appropriate generic kind for the active
// I/O data transfer statement (read/write, formatted/unformatted)
-// and that I/O subroutine is a specific procedure for an explicit
-// generic INTERFACE or GENERIC statement that is *not* type-bound,
-// this data item transfer API enables the use of that procedure
-// for the item. Pass 'true' for 'isPolymorphic' when the first ("dtv")
-// dummy argument of the specific procedure is CLASS(t), not TYPE(t).
-// If the procedure pointer is null, or when the next edit descriptor for
-// formatted I/O is not DT, the procedure will not be called and the
-// behavior will be as if (Output/Input)Descriptor had been called.
+// that pertains to the type or its components, and those subroutines
+// are dynamic or neither type-bound nor defined with interfaces
+// in the same scope as the derived type (or an IMPORT statement has
+// made such a generic interface inaccessible), these data item transfer
+// APIs enable the I/O runtime to make the right calls to defined I/O
+// subroutines.
bool IONAME(OutputDerivedType)(
- Cookie, const Descriptor &, void (*)(), bool isPolymorphic);
+ Cookie, const Descriptor &, const NonTbpDefinedIoTable *);
bool IONAME(InputDerivedType)(
- Cookie, const Descriptor &, void (*)(), bool isPolymorphic);
+ Cookie, const Descriptor &, const NonTbpDefinedIoTable *);
// Additional specifier interfaces for the connection-list of
// on OPEN statement (only). SetBlank(), SetDecimal(),
diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h
index e27091cf32de0..86c37d43bc16e 100644
--- a/flang/include/flang/Semantics/runtime-type-info.h
+++ b/flang/include/flang/Semantics/runtime-type-info.h
@@ -15,6 +15,8 @@
#define FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_
#include "flang/Common/reference.h"
+#include "flang/Semantics/symbol.h"
+#include <map>
#include <set>
#include <string>
#include <vector>
@@ -24,12 +26,6 @@ class raw_ostream;
}
namespace Fortran::semantics {
-class Scope;
-class SemanticsContext;
-class Symbol;
-
-using SymbolRef = common::Reference<const Symbol>;
-using SymbolVector = std::vector<SymbolRef>;
struct RuntimeDerivedTypeTables {
Scope *schemata{nullptr};
@@ -52,5 +48,14 @@ constexpr char procCompName[]{"proc"};
SymbolVector CollectBindings(const Scope &dtScope);
+struct NonTbpDefinedIo {
+ const Symbol *subroutine;
+ common::DefinedIo definedIo;
+ bool isDtvArgPolymorphic;
+};
+
+std::multimap<const Symbol *, NonTbpDefinedIo>
+CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope);
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index e2a771251e6b5..281c1903ad397 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -445,8 +445,6 @@ class HostAssocDetails {
// defined assignment, intrinsic operator, or defined I/O.
struct GenericKind {
ENUM_CLASS(OtherKind, Name, DefinedOp, Assignment, Concat)
- ENUM_CLASS(DefinedIo, // defined io
- ReadFormatted, ReadUnformatted, WriteFormatted, WriteUnformatted)
GenericKind() : u{OtherKind::Name} {}
template <typename T> GenericKind(const T &x) { u = x; }
bool IsName() const { return Is(OtherKind::Name); }
@@ -455,9 +453,9 @@ struct GenericKind {
bool IsIntrinsicOperator() const;
bool IsOperator() const;
std::string ToString() const;
- static SourceName AsFortran(DefinedIo);
+ static SourceName AsFortran(common::DefinedIo);
std::variant<OtherKind, common::NumericOperator, common::LogicalOperator,
- common::RelationalOperator, DefinedIo>
+ common::RelationalOperator, common::DefinedIo>
u;
private:
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index a7a01a0dd7e30..4a78b31c5a792 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -620,10 +620,9 @@ std::optional<ArraySpec> ToArraySpec(
std::optional<ArraySpec> ToArraySpec(
evaluate::FoldingContext &, const std::optional<evaluate::Shape> &);
-// Searches a derived type and a scope for a particular user defined I/O
-// procedure.
+// Searches a derived type and a scope for a particular defined I/O procedure.
bool HasDefinedIo(
- GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr);
+ common::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr);
// Some intrinsic operators have more than one name (e.g. `operator(.eq.)` and
// `operator(==)`). GetAllNames() returns them all, including symbolName.
@@ -631,19 +630,9 @@ std::forward_list<std::string> GetAllNames(
const SemanticsContext &, const SourceName &);
// Determines the derived type of a procedure's initial "dtv" dummy argument,
-// assuming that the procedure is a specific procedure of a user-defined
-// derived type I/O generic interface,
+// assuming that the procedure is a specific procedure of a defined I/O
+// generic interface,
const DerivedTypeSpec *GetDtvArgDerivedType(const Symbol &);
-// Locates a non-type-bound generic interface in the enclosing scopes for a
-// given user-defined derived type I/O operation, given a specific derived type
-// spec. Intended for use when lowering I/O data list items to identify a remote
-// or dynamic non-type-bound UDDTIO subroutine so that it can be passed to the
-// I/O runtime's NonTypeBoundDefinedIo() API.
-std::pair<const Symbol *, bool /*isPolymorphic*/> FindNonTypeBoundDefinedIo(
- const SemanticsContext, const parser::OutputItem &, bool isFormatted);
-std::pair<const Symbol *, bool /*isPolymorphic*/> FindNonTypeBoundDefinedIo(
- const SemanticsContext, const parser::InputItem &, bool isFormatted);
-
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_TOOLS_H_
diff --git a/flang/lib/Common/Fortran.cpp b/flang/lib/Common/Fortran.cpp
index 45a0614511684..42c27c9eb53f2 100644
--- a/flang/lib/Common/Fortran.cpp
+++ b/flang/lib/Common/Fortran.cpp
@@ -60,4 +60,18 @@ const char *AsFortran(RelationalOperator opr) {
}
}
+const char *AsFortran(DefinedIo x) {
+ switch (x) {
+ SWITCH_COVERS_ALL_CASES
+ case DefinedIo::ReadFormatted:
+ return "read(formatted)";
+ case DefinedIo::ReadUnformatted:
+ return "read(unformatted)";
+ case DefinedIo::WriteFormatted:
+ return "write(formatted)";
+ case DefinedIo::WriteUnformatted:
+ return "write(unformatted)";
+ }
+}
+
} // namespace Fortran::common
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index c8c899b670a2c..da7d9c99ff863 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -121,30 +121,29 @@ class CheckHelper {
void CheckBindCFunctionResult(const Symbol &);
// Check functions for defined I/O procedures
void CheckDefinedIoProc(
- const Symbol &, const GenericDetails &, GenericKind::DefinedIo);
+ const Symbol &, const GenericDetails &, common::DefinedIo);
bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
- void CheckDioDummyIsDerived(const Symbol &, const Symbol &,
- GenericKind::DefinedIo ioKind, const Symbol &);
+ void CheckDioDummyIsDerived(
+ const Symbol &, const Symbol &, common::DefinedIo ioKind, const Symbol &);
void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
void CheckDioDtvArg(
- const Symbol &, const Symbol *, GenericKind::DefinedIo, const Symbol &);
+ const Symbol &, const Symbol *, common::DefinedIo, const Symbol &);
void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);
void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
void CheckDioAssumedLenCharacterArg(
const Symbol &, const Symbol *, std::size_t, Attr);
void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
- void CheckDioArgCount(
- const Symbol &, GenericKind::DefinedIo ioKind, std::size_t);
+ void CheckDioArgCount(const Symbol &, common::DefinedIo ioKind, std::size_t);
struct TypeWithDefinedIo {
const DerivedTypeSpec &type;
- GenericKind::DefinedIo ioKind;
+ common::DefinedIo ioKind;
const Symbol &proc;
const Symbol &generic;
};
- void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &,
- GenericKind::DefinedIo, const Symbol &, const Symbol &generic);
+ void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &, common::DefinedIo,
+ const Symbol &, const Symbol &generic);
void CheckModuleProcedureDef(const Symbol &);
SemanticsContext &context_;
@@ -1426,7 +1425,7 @@ void CheckHelper::CheckGeneric(
const Symbol &symbol, const GenericDetails &details) {
CheckSpecifics(symbol, details);
common::visit(common::visitors{
- [&](const GenericKind::DefinedIo &io) {
+ [&](const common::DefinedIo &io) {
CheckDefinedIoProc(symbol, details, io);
},
[&](const GenericKind::OtherKind &other) {
@@ -2498,13 +2497,13 @@ bool CheckHelper::CheckDioDummyIsData(
}
void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
- GenericKind::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
- // Check for conflict between non-type-bound UDDTIO and type-bound generics.
- // It's okay to have two or more distinct derived type I/O procedures
- // for the same type if they're coming from distinct non-type-bound
- // interfaces. (The non-type-bound interfaces would have been merged into
- // a single generic -- with errors where indistinguishable -- if both were
- // visible in the same scope.)
+ common::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
+ // Check for conflict between non-type-bound defined I/O and type-bound
+ // generics. It's okay to have two or more distinct defined I/O procedures for
+ // the same type if they're coming from distinct non-type-bound interfaces.
+ // (The non-type-bound interfaces would have been merged into a single generic
+ // -- with errors where indistinguishable -- when both were visible from the
+ // same scope.)
if (generic.owner().IsDerivedType()) {
return;
}
@@ -2528,7 +2527,7 @@ void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
}
void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,
- GenericKind::DefinedIo ioKind, const Symbol &generic) {
+ common::DefinedIo ioKind, const Symbol &generic) {
if (const DeclTypeSpec *type{arg.GetType()}) {
if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {
CheckAlreadySeenDefinedIo(*derivedType, ioKind, subp, generic);
@@ -2573,13 +2572,13 @@ void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {
}
void CheckHelper::CheckDioDtvArg(const Symbol &subp, const Symbol *arg,
- GenericKind::DefinedIo ioKind, const Symbol &generic) {
+ common::DefinedIo ioKind, const Symbol &generic) {
// Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv
if (CheckDioDummyIsData(subp, arg, 0)) {
CheckDioDummyIsDerived(subp, *arg, ioKind, generic);
CheckDioDummyAttrs(subp, *arg,
- ioKind == GenericKind::DefinedIo::ReadFormatted ||
- ioKind == GenericKind::DefinedIo::ReadUnformatted
+ ioKind == common::DefinedIo::ReadFormatted ||
+ ioKind == common::DefinedIo::ReadUnformatted
? Attr::INTENT_INOUT
: Attr::INTENT_IN);
}
@@ -2668,10 +2667,10 @@ void CheckHelper::CheckDioVlistArg(
}
void CheckHelper::CheckDioArgCount(
- const Symbol &subp, GenericKind::DefinedIo ioKind, std::size_t argCount) {
+ const Symbol &subp, common::DefinedIo ioKind, std::size_t argCount) {
const std::size_t requiredArgCount{
- (std::size_t)(ioKind == GenericKind::DefinedIo::ReadFormatted ||
- ioKind == GenericKind::DefinedIo::WriteFormatted
+ (std::size_t)(ioKind == common::DefinedIo::ReadFormatted ||
+ ioKind == common::DefinedIo::WriteFormatted
? 6
: 4)};
if (argCount != requiredArgCount) {
@@ -2704,7 +2703,7 @@ void CheckHelper::CheckDioDummyAttrs(
// Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777
void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
- const GenericDetails &details, GenericKind::DefinedIo ioKind) {
+ const GenericDetails &details, common::DefinedIo ioKind) {
for (auto ref : details.specificProcs()) {
const Symbol &ultimate{ref->GetUltimate()};
const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};
@@ -2730,8 +2729,8 @@ void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
CheckDefaultIntegerArg(specific, arg, Attr::INTENT_IN);
break;
case 2:
- if (ioKind == GenericKind::DefinedIo::ReadFormatted ||
- ioKind == GenericKind::DefinedIo::WriteFormatted) {
+ if (ioKind == common::DefinedIo::ReadFormatted ||
+ ioKind == common::DefinedIo::WriteFormatted) {
// CHARACTER (LEN=*), INTENT(IN) :: iotype
CheckDioAssumedLenCharacterArg(
specific, arg, argCount, Attr::INTENT_IN);
@@ -2741,8 +2740,8 @@ void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
}
break;
case 3:
- if (ioKind == GenericKind::DefinedIo::ReadFormatted ||
- ioKind == GenericKind::DefinedIo::WriteFormatted) {
+ if (ioKind == common::DefinedIo::ReadFormatted ||
+ ioKind == common::DefinedIo::WriteFormatted) {
// INTEGER, INTENT(IN) :: v_list(:)
CheckDioVlistArg(specific, arg, argCount);
} else {
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index bbe76c4cc93a7..6df5eadc8ae62 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -327,8 +327,8 @@ void IoChecker::Enter(const parser::InputItem &spec) {
CheckForDefinableVariable(*var, "Input");
if (auto expr{AnalyzeExpr(context_, *var)}) {
CheckForBadIoType(*expr,
- flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted
- : GenericKind::DefinedIo::ReadUnformatted,
+ flags_.test(Flag::FmtOrNml) ? common::DefinedIo::ReadFormatted
+ : common::DefinedIo::ReadUnformatted,
var->GetSource());
}
}
@@ -618,9 +618,8 @@ void IoChecker::Enter(const parser::OutputItem &item) {
"Output item must not be a procedure"_err_en_US); // C1233
}
CheckForBadIoType(*expr,
- flags_.test(Flag::FmtOrNml)
- ? GenericKind::DefinedIo::WriteFormatted
- : GenericKind::DefinedIo::WriteUnformatted,
+ flags_.test(Flag::FmtOrNml) ? common::DefinedIo::WriteFormatted
+ : common::DefinedIo::WriteUnformatted,
parser::FindSourceLocation(item));
}
}
@@ -769,7 +768,7 @@ void IoChecker::Leave(const parser::ReadStmt &readStmt) {
}
if (const parser::Name * namelist{FindNamelist(readStmt.controls)}) {
if (namelist->symbol) {
- CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::ReadFormatted,
+ CheckNamelist(*namelist->symbol, common::DefinedIo::ReadFormatted,
namelist->source);
}
}
@@ -812,7 +811,7 @@ void IoChecker::Leave(const parser::WriteStmt &writeStmt) {
}
if (const parser::Name * namelist{FindNamelist(writeStmt.controls)}) {
if (namelist->symbol) {
- CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::WriteFormatted,
+ CheckNamelist(*namelist->symbol, common::DefinedIo::WriteFormatted,
namelist->source);
}
}
@@ -1038,7 +1037,7 @@ void IoChecker::CheckForPureSubprogram() const { // C1597
// Seeks out an allocatable or pointer ultimate component that is not
// nested in a nonallocatable/nonpointer component with a specific
// defined I/O procedure.
-static const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which,
+static const Symbol *FindUnsafeIoDirectComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope) {
if (HasDefinedIo(which, derived, &scope)) {
return nullptr;
@@ -1069,7 +1068,7 @@ static const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which,
// For a type that does not have a defined I/O subroutine, finds a direct
// component that is a witness to an accessibility violation outside the module
// in which the type was defined.
-static const Symbol *FindInaccessibleComponent(GenericKind::DefinedIo which,
+static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
const DerivedTypeSpec &derived, const Scope &scope) {
if (const Scope * dtScope{derived.scope()}) {
if (const Scope * module{FindModuleContaining(*dtScope)}) {
@@ -1111,7 +1110,7 @@ static const Symbol *FindInaccessibleComponent(GenericKind::DefinedIo which,
// Fortran 2018, 12.6.3 paragraphs 5 & 7
parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
- GenericKind::DefinedIo which, parser::CharBlock where) const {
+ common::DefinedIo which, parser::CharBlock where) const {
if (type.IsUnlimitedPolymorphic()) {
return &context_.Say(
where, "I/O list item may not be unlimited polymorphic"_err_en_US);
@@ -1141,15 +1140,15 @@ parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
return nullptr;
}
-void IoChecker::CheckForBadIoType(const SomeExpr &expr,
- GenericKind::DefinedIo which, parser::CharBlock where) const {
+void IoChecker::CheckForBadIoType(const SomeExpr &expr, common::DefinedIo which,
+ parser::CharBlock where) const {
if (auto type{expr.GetType()}) {
CheckForBadIoType(*type, which, where);
}
}
parser::Message *IoChecker::CheckForBadIoType(const Symbol &symbol,
- GenericKind::DefinedIo which, parser::CharBlock where) const {
+ common::DefinedIo which, parser::CharBlock where) const {
if (auto type{evaluate::DynamicType::From(symbol)}) {
if (auto *msg{CheckForBadIoType(*type, which, where)}) {
evaluate::AttachDeclaration(*msg, symbol);
@@ -1159,8 +1158,8 @@ parser::Message *IoChecker::CheckForBadIoType(const Symbol &symbol,
return nullptr;
}
-void IoChecker::CheckNamelist(const Symbol &namelist,
- GenericKind::DefinedIo which, parser::CharBlock namelistLocation) const {
+void IoChecker::CheckNamelist(const Symbol &namelist, common::DefinedIo which,
+ parser::CharBlock namelistLocation) const {
const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
for (const Symbol &object : details.objects()) {
context_.CheckIndexVarRedefine(namelistLocation, object);
diff --git a/flang/lib/Semantics/check-io.h b/flang/lib/Semantics/check-io.h
index 03738e883cc54..0ef166f7f100e 100644
--- a/flang/lib/Semantics/check-io.h
+++ b/flang/lib/Semantics/check-io.h
@@ -127,14 +127,14 @@ class IoChecker : public virtual BaseChecker {
void CheckForPureSubprogram() const;
parser::Message *CheckForBadIoType(const evaluate::DynamicType &,
- GenericKind::DefinedIo, parser::CharBlock) const;
+ common::DefinedIo, parser::CharBlock) const;
void CheckForBadIoType(
- const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const;
+ const SomeExpr &, common::DefinedIo, parser::CharBlock) const;
parser::Message *CheckForBadIoType(
- const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const;
+ const Symbol &, common::DefinedIo, parser::CharBlock) const;
void CheckNamelist(
- const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const;
+ const Symbol &, common::DefinedIo, parser::CharBlock) const;
void Init(IoStmtKind s) {
stmt_ = s;
diff --git a/flang/lib/Semantics/resolve-names-utils.cpp b/flang/lib/Semantics/resolve-names-utils.cpp
index a5b50a81f08f9..507f88a633afe 100644
--- a/flang/lib/Semantics/resolve-names-utils.cpp
+++ b/flang/lib/Semantics/resolve-names-utils.cpp
@@ -151,16 +151,16 @@ void GenericSpecInfo::Analyze(const parser::GenericSpec &x) {
return GenericKind::OtherKind::Assignment;
},
[&](const parser::GenericSpec::ReadFormatted &) -> GenericKind {
- return GenericKind::DefinedIo::ReadFormatted;
+ return common::DefinedIo::ReadFormatted;
},
[&](const parser::GenericSpec::ReadUnformatted &) -> GenericKind {
- return GenericKind::DefinedIo::ReadUnformatted;
+ return common::DefinedIo::ReadUnformatted;
},
[&](const parser::GenericSpec::WriteFormatted &) -> GenericKind {
- return GenericKind::DefinedIo::WriteFormatted;
+ return common::DefinedIo::WriteFormatted;
},
[&](const parser::GenericSpec::WriteUnformatted &) -> GenericKind {
- return GenericKind::DefinedIo::WriteUnformatted;
+ return common::DefinedIo::WriteUnformatted;
},
},
x.u);
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index 5e57c70c42fbb..15a2a67103236 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -19,6 +19,20 @@
#include <map>
#include <string>
+// The symbols added by this code to various scopes in the program include:
+// .b.TYPE.NAME - Bounds values for an array component
+// .c.TYPE - TYPE(Component) descriptions for TYPE
+// .di.TYPE.NAME - Data initialization for a component
+// .dp.TYPE.NAME - Data pointer initialization for a component
+// .dt.TYPE - TYPE(DerivedType) description for TYPE
+// .kp.TYPE - KIND type parameter values for TYPE
+// .lpk.TYPE - Integer kinds of LEN type parameter values
+// .lv.TYPE.NAME - LEN type parameter values for a component's type
+// .n.NAME - Character representation of a name
+// .p.TYPE - TYPE(ProcPtrComponent) descriptions for TYPE
+// .s.TYPE - TYPE(SpecialBinding) bindings for TYPE
+// .v.TYPE - TYPE(Binding) bindings for TYPE
+
namespace Fortran::semantics {
static int FindLenParameterIndex(
@@ -75,10 +89,10 @@ class RuntimeTableBuilder {
const DerivedTypeSpec *) const;
void DescribeSpecialProc(std::map<int, evaluate::StructureConstructor> &,
const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
- std::optional<GenericKind::DefinedIo>, const Scope *,
- const DerivedTypeSpec *) const;
+ std::optional<common::DefinedIo>, const Scope *, const DerivedTypeSpec *,
+ bool isTypeBound) const;
void IncorporateDefinedIoGenericInterfaces(
- std::map<int, evaluate::StructureConstructor> &, GenericKind::DefinedIo,
+ std::map<int, evaluate::StructureConstructor> &, common::DefinedIo,
const Scope *, const DerivedTypeSpec *);
// Instantiated for ParamValue and Bound
@@ -169,6 +183,54 @@ RuntimeTableBuilder::RuntimeTableBuilder(
ignoreScopes_.insert(tables_.schemata);
}
+static void SetReadOnlyCompilerCreatedFlags(Symbol &symbol) {
+ symbol.set(Symbol::Flag::CompilerCreated);
+ // Runtime type info symbols may have types that are incompatible with the
+ // PARAMETER attribute (the main issue is that they may be TARGET, and normal
+ // Fortran parameters cannot be TARGETs).
+ if (symbol.has<semantics::ObjectEntityDetails>() ||
+ symbol.has<semantics::ProcEntityDetails>()) {
+ symbol.set(Symbol::Flag::ReadOnly);
+ }
+}
+
+// Save an arbitrarily shaped array constant of some derived type
+// as an initialized data object in a scope.
+static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name,
+ std::vector<evaluate::StructureConstructor> &&x,
+ evaluate::ConstantSubscripts &&shape) {
+ if (x.empty()) {
+ return SomeExpr{evaluate::NullPointer{}};
+ } else {
+ const auto &derivedType{x.front().GetType().GetDerivedTypeSpec()};
+ ObjectEntityDetails object;
+ DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType};
+ if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) {
+ object.set_type(*spec);
+ } else {
+ object.set_type(scope.MakeDerivedType(
+ DeclTypeSpec::TypeDerived, common::Clone(derivedType)));
+ }
+ if (!shape.empty()) {
+ ArraySpec arraySpec;
+ for (auto n : shape) {
+ arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1}));
+ }
+ object.set_shape(arraySpec);
+ }
+ object.set_init(
+ evaluate::AsGenericExpr(evaluate::Constant<evaluate::SomeDerived>{
+ derivedType, std::move(x), std::move(shape)}));
+ Symbol &symbol{*scope
+ .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
+ std::move(object))
+ .first->second};
+ SetReadOnlyCompilerCreatedFlags(symbol);
+ return evaluate::AsGenericExpr(
+ evaluate::Designator<evaluate::SomeDerived>{symbol});
+ }
+}
+
void RuntimeTableBuilder::DescribeTypes(Scope &scope, bool inSchemata) {
inSchemata |= ignoreScopes_.find(&scope) != ignoreScopes_.end();
if (scope.IsDerivedType()) {
@@ -251,17 +313,6 @@ static int GetIntegerKind(const Symbol &symbol) {
return dyType->kind();
}
-static void SetReadOnlyCompilerCreatedFlags(Symbol &symbol) {
- symbol.set(Symbol::Flag::CompilerCreated);
- // Runtime type info symbols may have types that are incompatible with the
- // PARAMETER attribute (the main issue is that they may be TARGET, and normal
- // Fortran parameters cannot be TARGETs).
- if (symbol.has<semantics::ObjectEntityDetails>() ||
- symbol.has<semantics::ProcEntityDetails>()) {
- symbol.set(Symbol::Flag::ReadOnly);
- }
-}
-
// Save a rank-1 array constant of some numeric type as an
// initialized data object in a scope.
template <typename T>
@@ -293,43 +344,6 @@ static SomeExpr SaveNumericPointerTarget(
}
}
-// Save an arbitrarily shaped array constant of some derived type
-// as an initialized data object in a scope.
-static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name,
- std::vector<evaluate::StructureConstructor> &&x,
- evaluate::ConstantSubscripts &&shape) {
- if (x.empty()) {
- return SomeExpr{evaluate::NullPointer{}};
- } else {
- const auto &derivedType{x.front().GetType().GetDerivedTypeSpec()};
- ObjectEntityDetails object;
- DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType};
- if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) {
- object.set_type(*spec);
- } else {
- object.set_type(scope.MakeDerivedType(
- DeclTypeSpec::TypeDerived, common::Clone(derivedType)));
- }
- if (!shape.empty()) {
- ArraySpec arraySpec;
- for (auto n : shape) {
- arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1}));
- }
- object.set_shape(arraySpec);
- }
- object.set_init(
- evaluate::AsGenericExpr(evaluate::Constant<evaluate::SomeDerived>{
- derivedType, std::move(x), std::move(shape)}));
- Symbol &symbol{*scope
- .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
- std::move(object))
- .first->second};
- SetReadOnlyCompilerCreatedFlags(symbol);
- return evaluate::AsGenericExpr(
- evaluate::Designator<evaluate::SomeDerived>{symbol});
- }
-}
-
static SomeExpr SaveObjectInit(
Scope &scope, SourceName name, const ObjectEntityDetails &object) {
Symbol &symbol{*scope
@@ -454,7 +468,6 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
}
bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
if (isPDTinstantiation) {
- // is PDT instantiation
const Symbol *uninstDescObject{
DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))};
AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
@@ -569,24 +582,24 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
evaluate::ConstantSubscripts{
static_cast<evaluate::ConstantSubscript>(bindings.size())}));
// Describe "special" bindings to defined assignments, FINAL subroutines,
- // and user-defined derived type I/O subroutines. Defined assignments
- // and I/O subroutines override any parent bindings; FINAL subroutines
- // do not (the runtime will call all of them).
+ // and defined derived type I/O subroutines. Defined assignments and I/O
+ // subroutines override any parent bindings, but FINAL subroutines do not
+ // (the runtime will call all of them).
std::map<int, evaluate::StructureConstructor> specials{
DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
if (derivedTypeSpec) {
for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
DescribeSpecialProc(specials, *ref, false /*!isAssignment*/, true,
- std::nullopt, nullptr, derivedTypeSpec);
+ std::nullopt, nullptr, derivedTypeSpec, true);
}
IncorporateDefinedIoGenericInterfaces(specials,
- GenericKind::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
+ common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
IncorporateDefinedIoGenericInterfaces(specials,
- GenericKind::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
+ common::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
IncorporateDefinedIoGenericInterfaces(specials,
- GenericKind::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
+ common::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
IncorporateDefinedIoGenericInterfaces(specials,
- GenericKind::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);
+ common::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);
}
// Pack the special procedure bindings in ascending order of their "which"
// code values, and compile a little-endian bit-set of those codes for
@@ -1019,19 +1032,20 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
for (auto ref : generic.specificProcs()) {
DescribeSpecialProc(specials, *ref, true,
false /*!final*/, std::nullopt, &dtScope,
- derivedTypeSpec);
+ derivedTypeSpec, true);
}
}
},
- [&](const GenericKind::DefinedIo &io) {
+ [&](const common::DefinedIo &io) {
switch (io) {
- case GenericKind::DefinedIo::ReadFormatted:
- case GenericKind::DefinedIo::ReadUnformatted:
- case GenericKind::DefinedIo::WriteFormatted:
- case GenericKind::DefinedIo::WriteUnformatted:
+ 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);
+ false /*!final*/, io, &dtScope, derivedTypeSpec,
+ true);
}
break;
}
@@ -1044,8 +1058,8 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
void RuntimeTableBuilder::DescribeSpecialProc(
std::map<int, evaluate::StructureConstructor> &specials,
const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
- std::optional<GenericKind::DefinedIo> io, const Scope *dtScope,
- const DerivedTypeSpec *derivedTypeSpec) const {
+ std::optional<common::DefinedIo> io, const Scope *dtScope,
+ const DerivedTypeSpec *derivedTypeSpec, bool isTypeBound) const {
const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
if (binding && dtScope) { // use most recent override
binding = &DEREF(dtScope->FindComponent(specificOrBinding.name()))
@@ -1110,7 +1124,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
}
}
}
- } else { // user defined derived type I/O
+ } else { // defined derived type I/O
CHECK(proc->dummyArguments.size() >= 4);
const auto *ddo{std::get_if<evaluate::characteristics::DummyDataObject>(
&proc->dummyArguments[0].u)};
@@ -1127,16 +1141,16 @@ void RuntimeTableBuilder::DescribeSpecialProc(
isArgDescriptorSet |= 1;
}
switch (io.value()) {
- case GenericKind::DefinedIo::ReadFormatted:
+ case common::DefinedIo::ReadFormatted:
which = readFormattedEnum_;
break;
- case GenericKind::DefinedIo::ReadUnformatted:
+ case common::DefinedIo::ReadUnformatted:
which = readUnformattedEnum_;
break;
- case GenericKind::DefinedIo::WriteFormatted:
+ case common::DefinedIo::WriteFormatted:
which = writeFormattedEnum_;
break;
- case GenericKind::DefinedIo::WriteUnformatted:
+ case common::DefinedIo::WriteUnformatted:
which = writeUnformattedEnum_;
break;
}
@@ -1153,6 +1167,8 @@ void RuntimeTableBuilder::DescribeSpecialProc(
values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
AddValue(values, specialSchema_, "isargdescriptorset"s,
IntExpr<1>(isArgDescriptorSet));
+ AddValue(values, specialSchema_, "istypebound"s,
+ IntExpr<1>(isTypeBound ? 1 : 0));
AddValue(values, specialSchema_, procCompName,
SomeExpr{evaluate::ProcedureDesignator{specific}});
// index might already be present in the case of an override
@@ -1164,20 +1180,18 @@ void RuntimeTableBuilder::DescribeSpecialProc(
void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
std::map<int, evaluate::StructureConstructor> &specials,
- GenericKind::DefinedIo definedIo, const Scope *scope,
+ common::DefinedIo definedIo, const Scope *scope,
const DerivedTypeSpec *derivedTypeSpec) {
SourceName name{GenericKind::AsFortran(definedIo)};
for (; !scope->IsGlobal(); scope = &scope->parent()) {
if (auto asst{scope->find(name)}; asst != scope->end()) {
const Symbol &generic{asst->second->GetUltimate()};
const auto &genericDetails{generic.get<GenericDetails>()};
- CHECK(std::holds_alternative<GenericKind::DefinedIo>(
- genericDetails.kind().u));
- CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
- definedIo);
+ CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
+ CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == definedIo);
for (auto ref : genericDetails.specificProcs()) {
- DescribeSpecialProc(
- specials, *ref, false, false, definedIo, nullptr, derivedTypeSpec);
+ DescribeSpecialProc(specials, *ref, false, false, definedIo, nullptr,
+ derivedTypeSpec, false);
}
}
}
@@ -1194,4 +1208,76 @@ RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
return result;
}
+std::multimap<const Symbol *, NonTbpDefinedIo>
+CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope) {
+ std::multimap<const Symbol *, NonTbpDefinedIo> result;
+ if (!scope.IsTopLevel() &&
+ (scope.GetImportKind() == Scope::ImportKind::All ||
+ scope.GetImportKind() == Scope::ImportKind::Default)) {
+ result = CollectNonTbpDefinedIoGenericInterfaces(scope.parent());
+ }
+ 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;
+ }
+ }
+ if (!updated) {
+ result.emplace(dtDesc,
+ NonTbpDefinedIo{
+ &*specific, which, declType->IsPolymorphic()});
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return result;
+}
+
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 348ca338fa58c..6822cba0c090b 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -694,7 +694,7 @@ std::string GenericKind::ToString() const {
return common::visit(
common::visitors {
[](const OtherKind &x) { return std::string{EnumToString(x)}; },
- [](const DefinedIo &x) { return AsFortran(x).ToString(); },
+ [](const common::DefinedIo &x) { return AsFortran(x).ToString(); },
#if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2
[](const common::NumericOperator &x) {
return std::string{common::EnumToString(x)};
@@ -712,23 +712,8 @@ std::string GenericKind::ToString() const {
u);
}
-SourceName GenericKind::AsFortran(DefinedIo x) {
- const char *name{nullptr};
- switch (x) {
- SWITCH_COVERS_ALL_CASES
- case DefinedIo::ReadFormatted:
- name = "read(formatted)";
- break;
- case DefinedIo::ReadUnformatted:
- name = "read(unformatted)";
- break;
- case DefinedIo::WriteFormatted:
- name = "write(formatted)";
- break;
- case DefinedIo::WriteUnformatted:
- name = "write(unformatted)";
- break;
- }
+SourceName GenericKind::AsFortran(common::DefinedIo x) {
+ const char *name{common::AsFortran(x)};
return {name, std::strlen(name)};
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 8c9ad672831fb..fb2710b54284c 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1549,14 +1549,14 @@ const DerivedTypeSpec *GetDtvArgDerivedType(const Symbol &proc) {
}
}
-bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived,
+bool HasDefinedIo(common::DefinedIo which, const DerivedTypeSpec &derived,
const Scope *scope) {
if (const Scope * dtScope{derived.scope()}) {
for (const auto &pair : *dtScope) {
const Symbol &symbol{*pair.second};
if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
GenericKind kind{generic->kind()};
- if (const auto *io{std::get_if<GenericKind::DefinedIo>(&kind.u)}) {
+ if (const auto *io{std::get_if<common::DefinedIo>(&kind.u)}) {
if (*io == which) {
return true; // type-bound GENERIC exists
}
@@ -1587,55 +1587,4 @@ bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived,
return false;
}
-static std::pair<const Symbol *, bool /*isPolymorphic*/>
-FindNonTypeBoundDefinedIo(const Scope &scope, const evaluate::DynamicType &type,
- GenericKind::DefinedIo io) {
- if (const DerivedTypeSpec * derived{evaluate::GetDerivedTypeSpec(type)}) {
- if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(io))}) {
- if (const auto *generic{symbol->detailsIf<GenericDetails>()}) {
- for (const auto &ref : generic->specificProcs()) {
- const Symbol &specific{ref->GetUltimate()};
- if (const DeclTypeSpec * dtvTypeSpec{GetDtvArgTypeSpec(specific)}) {
- if (const DerivedTypeSpec * dtvDerived{dtvTypeSpec->AsDerived()}) {
- if (evaluate::AreSameDerivedType(*derived, *dtvDerived)) {
- return {&specific, dtvTypeSpec->IsPolymorphic()};
- }
- }
- }
- }
- }
- }
- }
- return {nullptr, false};
-}
-
-std::pair<const Symbol *, bool /*isPolymorphic*/> FindNonTypeBoundDefinedIo(
- const SemanticsContext &context, const parser::OutputItem &item,
- bool isFormatted) {
- if (const auto *expr{std::get_if<parser::Expr>(&item.u)};
- expr && expr->typedExpr && expr->typedExpr->v) {
- if (auto type{expr->typedExpr->v->GetType()}) {
- return FindNonTypeBoundDefinedIo(context.FindScope(expr->source), *type,
- isFormatted ? GenericKind::DefinedIo::WriteFormatted
- : GenericKind::DefinedIo::WriteUnformatted);
- }
- }
- return {nullptr, false};
-}
-
-std::pair<const Symbol *, bool /*isPolymorphic*/> FindNonTypeBoundDefinedIo(
- const SemanticsContext &context, const parser::InputItem &item,
- bool isFormatted) {
- if (const auto *var{std::get_if<parser::Variable>(&item.u)};
- var && var->typedExpr && var->typedExpr->v) {
- if (auto type{var->typedExpr->v->GetType()}) {
- return FindNonTypeBoundDefinedIo(context.FindScope(var->GetSource()),
- *type,
- isFormatted ? GenericKind::DefinedIo::ReadFormatted
- : GenericKind::DefinedIo::ReadUnformatted);
- }
- }
- return {nullptr, false};
-}
-
} // namespace Fortran::semantics
diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90
index 7371cee465843..5a92ff2999959 100644
--- a/flang/module/__fortran_type_info.f90
+++ b/flang/module/__fortran_type_info.f90
@@ -108,7 +108,8 @@
type, bind(c) :: SpecialBinding
integer(1) :: which ! SpecialBinding::Which
integer(1) :: isArgDescriptorSet
- integer(1) :: __padding0(6)
+ integer(1) :: isTypeBound
+ integer(1) :: __padding0(5)
type(__builtin_c_funptr) :: proc
end type
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index 15da5a20aaec8..20e78ff6654af 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -130,6 +130,7 @@ add_flang_library(FortranRuntime
memory.cpp
misc-intrinsic.cpp
namelist.cpp
+ non-tbp-dio.cpp
numeric.cpp
ragged.cpp
random.cpp
diff --git a/flang/runtime/descriptor-io.cpp b/flang/runtime/descriptor-io.cpp
index c51a36b1a7bd1..563a69e999d5f 100644
--- a/flang/runtime/descriptor-io.cpp
+++ b/flang/runtime/descriptor-io.cpp
@@ -11,7 +11,7 @@
namespace Fortran::runtime::io::descr {
-// User-defined derived type formatted I/O (maybe)
+// Defined formatted I/O (maybe)
std::optional<bool> DefinedFormattedIo(IoStatementState &io,
const Descriptor &descriptor, const typeInfo::DerivedType &derived,
const typeInfo::SpecialBinding &special) {
@@ -19,7 +19,7 @@ std::optional<bool> DefinedFormattedIo(IoStatementState &io,
if (peek &&
(peek->descriptor == DataEdit::DefinedDerivedType ||
peek->descriptor == DataEdit::ListDirected)) {
- // User-defined derived type formatting
+ // Defined formatting
IoErrorHandler &handler{io.GetIoErrorHandler()};
DataEdit edit{*io.GetNextDataEdit(1)}; // now consume it; no repeats
RUNTIME_CHECK(handler, edit.descriptor == peek->descriptor);
@@ -105,14 +105,14 @@ std::optional<bool> DefinedFormattedIo(IoStatementState &io,
}
return handler.GetIoStat() == IostatOk;
} else {
- // There's a user-defined I/O subroutine, but there's a FORMAT present and
+ // There's a defined I/O subroutine, but there's a FORMAT present and
// it does not have a DT data edit descriptor, so apply default formatting
// to the components of the derived type as usual.
return std::nullopt;
}
}
-// User-defined derived type unformatted I/O
+// Defined unformatted I/O
bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor,
const typeInfo::DerivedType &derived,
const typeInfo::SpecialBinding &special) {
diff --git a/flang/runtime/descriptor-io.h b/flang/runtime/descriptor-io.h
index 7bf55ded31d39..80b5d87a6efb8 100644
--- a/flang/runtime/descriptor-io.h
+++ b/flang/runtime/descriptor-io.h
@@ -17,6 +17,7 @@
#include "edit-input.h"
#include "edit-output.h"
#include "io-stmt.h"
+#include "namelist.h"
#include "terminator.h"
#include "type-info.h"
#include "unit.h"
@@ -239,20 +240,22 @@ inline bool FormattedLogicalIO(
}
template <Direction DIR>
-static bool DescriptorIO(IoStatementState &, const Descriptor &);
+static bool DescriptorIO(IoStatementState &, const Descriptor &,
+ const NonTbpDefinedIoTable * = nullptr);
-// For default (not user-defined) derived type I/O, formatted & unformatted
+// For intrinsic (not defined) derived type I/O, formatted & unformatted
template <Direction DIR>
static bool DefaultComponentIO(IoStatementState &io,
const typeInfo::Component &component, const Descriptor &origDescriptor,
- const SubscriptValue origSubscripts[], Terminator &terminator) {
+ const SubscriptValue origSubscripts[], Terminator &terminator,
+ const NonTbpDefinedIoTable *table) {
if (component.genre() == typeInfo::Component::Genre::Data) {
// Create a descriptor for the component
StaticDescriptor<maxRank, true, 16 /*?*/> statDesc;
Descriptor &desc{statDesc.descriptor()};
component.CreatePointerDescriptor(
desc, origDescriptor, terminator, origSubscripts);
- return DescriptorIO<DIR>(io, desc);
+ return DescriptorIO<DIR>(io, desc, table);
} else {
// Component is itself a descriptor
char *pointer{
@@ -260,13 +263,14 @@ static bool DefaultComponentIO(IoStatementState &io,
RUNTIME_CHECK(
terminator, component.genre() == typeInfo::Component::Genre::Automatic);
const Descriptor &compDesc{*reinterpret_cast<const Descriptor *>(pointer)};
- return DescriptorIO<DIR>(io, compDesc);
+ return DescriptorIO<DIR>(io, compDesc, table);
}
}
template <Direction DIR>
static bool DefaultComponentwiseIO(IoStatementState &io,
- const Descriptor &descriptor, const typeInfo::DerivedType &type) {
+ const Descriptor &descriptor, const typeInfo::DerivedType &type,
+ const NonTbpDefinedIoTable *table) {
IoErrorHandler &handler{io.GetIoErrorHandler()};
const Descriptor &compArray{type.component()};
RUNTIME_CHECK(handler, compArray.rank() == 1);
@@ -283,7 +287,7 @@ static bool DefaultComponentwiseIO(IoStatementState &io,
const typeInfo::Component &component{
*compArray.Element<typeInfo::Component>(at)};
if (!DefaultComponentIO<DIR>(
- io, component, descriptor, subscripts, handler)) {
+ io, component, descriptor, subscripts, handler, table)) {
return false;
}
}
@@ -295,24 +299,44 @@ std::optional<bool> DefinedFormattedIo(IoStatementState &, const Descriptor &,
const typeInfo::DerivedType &, const typeInfo::SpecialBinding &);
template <Direction DIR>
-static bool FormattedDerivedTypeIO(
- IoStatementState &io, const Descriptor &descriptor) {
+static bool FormattedDerivedTypeIO(IoStatementState &io,
+ const Descriptor &descriptor, const NonTbpDefinedIoTable *table) {
IoErrorHandler &handler{io.GetIoErrorHandler()};
// Derived type information must be present for formatted I/O.
const DescriptorAddendum *addendum{descriptor.Addendum()};
RUNTIME_CHECK(handler, addendum != nullptr);
const typeInfo::DerivedType *type{addendum->derivedType()};
RUNTIME_CHECK(handler, type != nullptr);
+ if (table) {
+ if (const auto *definedIo{table->Find(*type,
+ DIR == Direction::Input ? common::DefinedIo::ReadFormatted
+ : common::DefinedIo::WriteFormatted)}) {
+ if (definedIo->subroutine) {
+ typeInfo::SpecialBinding special{DIR == Direction::Input
+ ? typeInfo::SpecialBinding::Which::ReadFormatted
+ : typeInfo::SpecialBinding::Which::WriteFormatted,
+ definedIo->subroutine, definedIo->isDtvArgPolymorphic, false};
+ if (std::optional<bool> wasDefined{
+ DefinedFormattedIo(io, descriptor, *type, special)}) {
+ return *wasDefined;
+ }
+ } else {
+ return DefaultComponentwiseIO<DIR>(io, descriptor, *type, table);
+ }
+ }
+ }
if (const typeInfo::SpecialBinding *
special{type->FindSpecialBinding(DIR == Direction::Input
? typeInfo::SpecialBinding::Which::ReadFormatted
: typeInfo::SpecialBinding::Which::WriteFormatted)}) {
- if (std::optional<bool> wasDefined{
- DefinedFormattedIo(io, descriptor, *type, *special)}) {
- return *wasDefined; // user-defined I/O was applied
+ if (!table || !table->ignoreNonTbpEntries || special->isTypeBound()) {
+ if (std::optional<bool> wasDefined{
+ DefinedFormattedIo(io, descriptor, *type, *special)}) {
+ return *wasDefined; // defined I/O was applied
+ }
}
}
- return DefaultComponentwiseIO<DIR>(io, descriptor, *type);
+ return DefaultComponentwiseIO<DIR>(io, descriptor, *type, table);
}
bool DefinedUnformattedIo(IoStatementState &, const Descriptor &,
@@ -320,26 +344,45 @@ bool DefinedUnformattedIo(IoStatementState &, const Descriptor &,
// Unformatted I/O
template <Direction DIR>
-static bool UnformattedDescriptorIO(
- IoStatementState &io, const Descriptor &descriptor) {
+static bool UnformattedDescriptorIO(IoStatementState &io,
+ const Descriptor &descriptor, const NonTbpDefinedIoTable *table = nullptr) {
IoErrorHandler &handler{io.GetIoErrorHandler()};
const DescriptorAddendum *addendum{descriptor.Addendum()};
if (const typeInfo::DerivedType *
type{addendum ? addendum->derivedType() : nullptr}) {
// derived type unformatted I/O
+ if (table) {
+ if (const auto *definedIo{table->Find(*type,
+ DIR == Direction::Input ? common::DefinedIo::ReadUnformatted
+ : common::DefinedIo::WriteUnformatted)}) {
+ if (definedIo->subroutine) {
+ typeInfo::SpecialBinding special{DIR == Direction::Input
+ ? typeInfo::SpecialBinding::Which::ReadUnformatted
+ : typeInfo::SpecialBinding::Which::WriteUnformatted,
+ definedIo->subroutine, definedIo->isDtvArgPolymorphic, false};
+ if (std::optional<bool> wasDefined{
+ DefinedUnformattedIo(io, descriptor, *type, special)}) {
+ return *wasDefined;
+ }
+ } else {
+ return DefaultComponentwiseIO<DIR>(io, descriptor, *type, table);
+ }
+ }
+ }
if (const typeInfo::SpecialBinding *
special{type->FindSpecialBinding(DIR == Direction::Input
? typeInfo::SpecialBinding::Which::ReadUnformatted
: typeInfo::SpecialBinding::Which::WriteUnformatted)}) {
- // User-defined derived type unformatted I/O
- return DefinedUnformattedIo(io, descriptor, *type, *special);
- } else {
- // Default derived type unformatted I/O
- // TODO: If no component at any level has user defined READ or WRITE
- // (as appropriate), the elements are contiguous, and no byte swapping
- // is active, do a block transfer via the code below.
- return DefaultComponentwiseIO<DIR>(io, descriptor, *type);
+ if (!table || !table->ignoreNonTbpEntries || special->isTypeBound()) {
+ // defined derived type unformatted I/O
+ return DefinedUnformattedIo(io, descriptor, *type, *special);
+ }
}
+ // Default derived type unformatted I/O
+ // TODO: If no component at any level has defined READ or WRITE
+ // (as appropriate), the elements are contiguous, and no byte swapping
+ // is active, do a block transfer via the code below.
+ return DefaultComponentwiseIO<DIR>(io, descriptor, *type, table);
} else {
// intrinsic type unformatted I/O
auto *externalUnf{io.get_if<ExternalUnformattedIoStatementState<DIR>>()};
@@ -397,7 +440,8 @@ static bool UnformattedDescriptorIO(
}
template <Direction DIR>
-static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
+static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor,
+ const NonTbpDefinedIoTable *table) {
IoErrorHandler &handler{io.GetIoErrorHandler()};
if (handler.InError()) {
return false;
@@ -413,7 +457,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
}
}
if (!io.get_if<FormattedIoStatementState<DIR>>()) {
- return UnformattedDescriptorIO<DIR>(io, descriptor);
+ return UnformattedDescriptorIO<DIR>(io, descriptor, table);
}
if (auto catAndKind{descriptor.type().GetCategoryAndKind()}) {
TypeCategory cat{catAndKind->first};
@@ -509,7 +553,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
return false;
}
case TypeCategory::Derived:
- return FormattedDerivedTypeIO<DIR>(io, descriptor);
+ return FormattedDerivedTypeIO<DIR>(io, descriptor, table);
}
}
handler.Crash("DescriptorIO: bad type code (%d) in descriptor",
diff --git a/flang/runtime/format-implementation.h b/flang/runtime/format-implementation.h
index 79063e2f9ebac..0daacc6bcccbb 100644
--- a/flang/runtime/format-implementation.h
+++ b/flang/runtime/format-implementation.h
@@ -423,7 +423,7 @@ std::optional<DataEdit> FormatControl<CONTEXT>::GetNextDataEdit(
++offset_;
}
} else if (edit.descriptor == 'D' && Capitalize(PeekNext()) == 'T') {
- // DT['iotype'][(v_list)] user-defined derived type I/O
+ // DT['iotype'][(v_list)] defined I/O
edit.descriptor = DataEdit::DefinedDerivedType;
++offset_;
if (auto quote{static_cast<char>(PeekNext())};
diff --git a/flang/runtime/format.h b/flang/runtime/format.h
index 9077a849eaec6..b9f8f73a48dec 100644
--- a/flang/runtime/format.h
+++ b/flang/runtime/format.h
@@ -61,7 +61,7 @@ struct DataEdit {
return IsListDirected() && modes.inNamelist;
}
- static constexpr char DefinedDerivedType{'d'}; // DT user-defined derived type
+ static constexpr char DefinedDerivedType{'d'}; // DT defined I/O
char variation{'\0'}; // N, S, or X for EN, ES, EX
std::optional<int> width; // the 'w' field; optional for A
@@ -71,7 +71,7 @@ struct DataEdit {
int repeat{1};
// "iotype" &/or "v_list" values for a DT'iotype'(v_list)
- // user-defined derived type data edit descriptor
+ // defined I/O data edit descriptor
static constexpr std::size_t maxIoTypeChars{32};
static constexpr std::size_t maxVListEntries{4};
std::uint8_t ioTypeChars{0};
diff --git a/flang/runtime/io-api.cpp b/flang/runtime/io-api.cpp
index dd27c6c54dd64..09639c136c2af 100644
--- a/flang/runtime/io-api.cpp
+++ b/flang/runtime/io-api.cpp
@@ -1379,59 +1379,14 @@ bool IONAME(InputLogical)(Cookie cookie, bool &truth) {
return descr::DescriptorIO<Direction::Input>(*cookie, descriptor);
}
-template <Direction DIR>
-static bool DoDerivedTypeIo(Cookie cookie, const Descriptor &descriptor,
- void (*procedure)(), bool isPolymorphic, const char *which) {
- IoStatementState &io{*cookie};
- IoErrorHandler &handler{io.GetIoErrorHandler()};
- if (handler.InError()) {
- return false;
- }
- const DescriptorAddendum *addendum{descriptor.Addendum()};
- const typeInfo::DerivedType *type{
- addendum ? addendum->derivedType() : nullptr};
- RUNTIME_CHECK(handler, type != nullptr);
- if (!procedure) {
- if constexpr (DIR == Direction::Output) {
- return IONAME(OutputDescriptor)(cookie, descriptor);
- } else {
- return IONAME(InputDescriptor)(cookie, descriptor);
- }
- }
- if (!io.get_if<IoDirectionState<DIR>>()) {
- handler.Crash("%s called for I/O statement that is not %s", which,
- DIR == Direction::Output ? "output" : "input");
- }
- std::uint8_t isArgDesc{isPolymorphic};
- if (io.get_if<FormattedIoStatementState<DIR>>()) {
- if (std::optional<bool> wasDefined{
- descr::DefinedFormattedIo(io, descriptor, *type,
- typeInfo::SpecialBinding{DIR == Direction::Output
- ? typeInfo::SpecialBinding::Which::WriteFormatted
- : typeInfo::SpecialBinding::Which::ReadFormatted,
- procedure, isArgDesc})}) {
- return *wasDefined;
- }
- return descr::DefaultComponentwiseIO<DIR>(io, descriptor, *type);
- } else { // unformatted
- return descr::DefinedUnformattedIo(io, descriptor, *type,
- typeInfo::SpecialBinding{DIR == Direction::Output
- ? typeInfo::SpecialBinding::Which::WriteUnformatted
- : typeInfo::SpecialBinding::Which::ReadUnformatted,
- procedure, isArgDesc});
- }
-}
-
bool IONAME(OutputDerivedType)(Cookie cookie, const Descriptor &descriptor,
- void (*procedure)(), bool isPolymorphic) {
- return DoDerivedTypeIo<Direction::Output>(
- cookie, descriptor, procedure, isPolymorphic, "OutputDerivedType");
+ const NonTbpDefinedIoTable *table) {
+ return descr::DescriptorIO<Direction::Output>(*cookie, descriptor, table);
}
bool IONAME(InputDerivedType)(Cookie cookie, const Descriptor &descriptor,
- void (*procedure)(), bool isPolymorphic) {
- return DoDerivedTypeIo<Direction::Output>(
- cookie, descriptor, procedure, isPolymorphic, "InputDerivedType");
+ const NonTbpDefinedIoTable *table) {
+ return descr::DescriptorIO<Direction::Input>(*cookie, descriptor, table);
}
std::size_t IONAME(GetSize)(Cookie cookie) {
diff --git a/flang/runtime/namelist.cpp b/flang/runtime/namelist.cpp
index 48761a90e4dc4..71d6388a7f893 100644
--- a/flang/runtime/namelist.cpp
+++ b/flang/runtime/namelist.cpp
@@ -6,6 +6,11 @@
//
//===----------------------------------------------------------------------===//
+// 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"
@@ -62,9 +67,20 @@ bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
if (listOutput) {
listOutput->set_lastWasUndelimitedCharacter(false);
}
- if (!(EmitWithAdvance(j == 0 ? ' ' : comma) && EmitUpperCase(item.name) &&
- EmitWithAdvance('=') &&
- descr::DescriptorIO<Direction::Output>(io, item.descriptor))) {
+ 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
+ if (!IONAME(OutputDerivedType)(cookie, item.descriptor, table)) {
+ return false;
+ }
+ } else if (!descr::DescriptorIO<Direction::Output>(io, item.descriptor)) {
return false;
}
}
@@ -515,7 +531,16 @@ bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
io.HandleRelativePosition(byteCount);
// Read the values into the descriptor. An array can be short.
listInput->ResetForNextNamelistItem(useDescriptor->rank() > 0);
- if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
+ if (const auto *addendum{useDescriptor->Addendum()};
+ addendum && addendum->derivedType()) {
+ NonTbpDefinedIoTable *table{nullptr};
+#ifndef DISABLE_NON_TBP_DIO
+ table = group.nonTbpDefinedIo;
+#endif
+ if (!IONAME(InputDerivedType)(cookie, *useDescriptor, table)) {
+ return false;
+ }
+ } else if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
return false;
}
next = io.GetNextNonBlank(byteCount);
diff --git a/flang/runtime/namelist.h b/flang/runtime/namelist.h
index be40310cb0e00..9a5da33a907e4 100644
--- a/flang/runtime/namelist.h
+++ b/flang/runtime/namelist.h
@@ -11,6 +11,8 @@
#ifndef FORTRAN_RUNTIME_NAMELIST_H_
#define FORTRAN_RUNTIME_NAMELIST_H_
+#include "non-tbp-dio.h"
+
#include <cstddef>
namespace Fortran::runtime {
@@ -30,9 +32,15 @@ class NamelistGroup {
const char *name; // NUL-terminated lower-case
const Descriptor &descriptor;
};
- const char *groupName; // NUL-terminated lower-case
- std::size_t items;
- const Item *item; // in original declaration order
+ const char *groupName{nullptr}; // NUL-terminated lower-case
+ std::size_t items{0};
+ const Item *item{nullptr}; // in original declaration order
+
+ // When the uses of a namelist group appear in scopes with distinct sets
+ // of non-type-bound defined formatted I/O interfaces, they require the
+ // use of distinct NamelistGroups pointing to distinct NonTbpDefinedIoTables.
+ // Multiple NamelistGroup instances may share a NonTbpDefinedIoTable..
+ const NonTbpDefinedIoTable *nonTbpDefinedIo{nullptr};
};
// Look ahead on input for a '/' or an identifier followed by a '=', '(', or '%'
diff --git a/flang/runtime/non-tbp-dio.cpp b/flang/runtime/non-tbp-dio.cpp
new file mode 100644
index 0000000000000..9419adb7631cc
--- /dev/null
+++ b/flang/runtime/non-tbp-dio.cpp
@@ -0,0 +1,32 @@
+//===-- flang/runtime/non-tbp-dio.cpp ---------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "non-tbp-dio.h"
+#include "type-info.h"
+
+namespace Fortran::runtime::io {
+
+const NonTbpDefinedIo *NonTbpDefinedIoTable::Find(
+ const typeInfo::DerivedType &type, common::DefinedIo definedIo) const {
+ std::size_t j{items};
+ for (const auto *p{item}; j-- > 0; ++p) {
+ if (&p->derivedType == &type && p->definedIo == definedIo) {
+ return p;
+ } else if (p->isDtvArgPolymorphic) {
+ for (const typeInfo::DerivedType *t{type.GetParentType()}; t;
+ t = t->GetParentType()) {
+ if (&p->derivedType == t && p->definedIo == definedIo) {
+ return p;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
+} // namespace Fortran::runtime::io
diff --git a/flang/runtime/non-tbp-dio.h b/flang/runtime/non-tbp-dio.h
new file mode 100644
index 0000000000000..49b23cea1954c
--- /dev/null
+++ b/flang/runtime/non-tbp-dio.h
@@ -0,0 +1,55 @@
+//===-- flang/runtime/non-tbp-dio.h -----------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+// Defines a structure used to identify the non-type-bound defined I/O
+// generic interfaces that are accessible in a particular scope. This
+// table is used by some I/O APIs and is also part of the NAMELIST
+// group table.
+//
+// A specific procedure for a particular derived type must appear in
+// this table if it (a) is a dummy procedure or procedure pointer,
+// (b) is part of the defined I/O generic definition in a scope other
+// than the one that contains the derived type definition, or (c)
+// is a null pointer signifying that some specific procedure from
+// a containing scope has become inaccessible in a nested scope due
+// to the use of "IMPORT, NONE" or "IMPORT, ONLY:".
+
+#ifndef FORTRAN_RUNTIME_NON_TBP_DIO_H_
+#define FORTRAN_RUNTIME_NON_TBP_DIO_H_
+
+#include "flang/Common/Fortran.h"
+#include <cstddef>
+
+namespace Fortran::runtime::typeInfo {
+class DerivedType;
+} // namespace Fortran::runtime::typeInfo
+
+namespace Fortran::runtime::io {
+
+struct NonTbpDefinedIo {
+ const typeInfo::DerivedType &derivedType;
+ void (*subroutine)(); // null means no non-TBP defined I/O here
+ common::DefinedIo definedIo;
+ bool isDtvArgPolymorphic; // first dummy arg is CLASS(T)
+};
+
+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,
+ // but the remaining specifics remain visible.
+ bool ignoreNonTbpEntries{false};
+};
+
+} // namespace Fortran::runtime::io
+#endif // FORTRAN_RUNTIME_NON_TBP_DIO_H_
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
index 63939d7fd9bc4..3e6a51c57a3ea 100644
--- a/flang/runtime/type-info.h
+++ b/flang/runtime/type-info.h
@@ -133,10 +133,12 @@ class SpecialBinding {
// higher-ranked final procedures follow
};
- // Special bindings can be created during execution to handle user-defined
- // derived type I/O procedures that are not type-bound.
- SpecialBinding(Which which, ProcedurePointer proc, std::uint8_t isArgDescSet)
- : which_{which}, isArgDescriptorSet_{isArgDescSet}, proc_{proc} {}
+ // Special bindings can be created during execution to handle defined
+ // I/O procedures that are not type-bound.
+ SpecialBinding(Which which, ProcedurePointer proc, std::uint8_t isArgDescSet,
+ std::uint8_t isTypeBound)
+ : which_{which}, isArgDescriptorSet_{isArgDescSet},
+ isTypeBound_{isTypeBound}, proc_{proc} {}
static constexpr Which RankFinal(int rank) {
return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
@@ -146,6 +148,7 @@ class SpecialBinding {
bool IsArgDescriptor(int zeroBasedArg) const {
return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
}
+ bool isTypeBound() const { return isTypeBound_; }
template <typename PROC> PROC GetProc() const {
return reinterpret_cast<PROC>(proc_);
}
@@ -175,12 +178,13 @@ class SpecialBinding {
// elemental final subroutine must be scalar and monomorphic, but
// use a descriptors when the type has LEN parameters.)
// Which::AssumedRankFinal: flag must necessarily be set
- // User derived type I/O:
+ // Defined I/O:
// Set to 1 when "dtv" initial dummy argument is polymorphic, which is
// the case when and only when the derived type is extensible.
- // When false, the user derived type I/O subroutine must have been
+ // When false, the defined I/O subroutine must have been
// called via a generic interface, not a generic TBP.
std::uint8_t isArgDescriptorSet_{0};
+ std::uint8_t isTypeBound_{0};
ProcedurePointer proc_{nullptr};
};
diff --git a/flang/runtime/unit.h b/flang/runtime/unit.h
index aad896afce513..b6007a9b15385 100644
--- a/flang/runtime/unit.h
+++ b/flang/runtime/unit.h
@@ -165,14 +165,14 @@ class ExternalFileUnit : public ConnectionState,
// Points to the active alternative (if any) in u_ for use as a Cookie
std::optional<IoStatementState> io_;
- // A stack of child I/O pseudo-units for user-defined derived type
- // I/O that have this unit number.
+ // A stack of child I/O pseudo-units for defined I/O that have this
+ // unit number.
OwningPtr<ChildIo> child_;
};
-// A pseudo-unit for child I/O statements in user-defined derived type
-// I/O subroutines; it forwards operations to the parent I/O statement,
-// which can also be a child I/O statement.
+// A pseudo-unit for child I/O statements in defined I/O subroutines;
+// it forwards operations to the parent I/O statement, which might also
+// be a child I/O statement.
class ChildIo {
public:
ChildIo(IoStatementState &parent, OwningPtr<ChildIo> &&previous)
diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90
index 323fb27399258..e0e742148cb97 100644
--- a/flang/test/Semantics/typeinfo01.f90
+++ b/flang/test/Semantics/typeinfo01.f90
@@ -88,7 +88,7 @@ subroutine s2(x, y)
!CHECK: .c.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.t,lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,proc=s1)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,proc=s1)]
!CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
!CHECK: .v.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s2,name=.n.s1)]
end module
@@ -105,7 +105,7 @@ impure elemental subroutine s1(x, y)
class(t), intent(in) :: y
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,proc=s1)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,proc=s1)]
!CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
end module
@@ -125,7 +125,7 @@ impure elemental subroutine s3(x)
type(t), intent(in) :: x
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=3200_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,proc=s2)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,istypebound=1_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,istypebound=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,istypebound=1_1,proc=s2)]
end module
module m09
@@ -167,7 +167,7 @@ subroutine wu(x,u,iostat,iomsg)
character(len=*), intent(inout) :: iomsg
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,proc=wu)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,istypebound=1_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,istypebound=1_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,istypebound=1_1,proc=wu)]
!CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:3_8 init:[binding::binding(proc=rf,name=.n.rf),binding(proc=ru,name=.n.ru),binding(proc=wf,name=.n.wf),binding(proc=wu,name=.n.wu)]
end module
@@ -216,7 +216,7 @@ subroutine wu(x,u,iostat,iomsg)
character(len=*), intent(inout) :: iomsg
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,proc=wu)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,istypebound=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,istypebound=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,istypebound=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,istypebound=0_1,proc=wu)]
end module
module m11
@@ -259,7 +259,7 @@ module m13
contains
procedure :: assign1, assign2
generic :: assignment(=) => assign1, assign2
- ! CHECK: .s.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,proc=assign1)]
+ ! CHECK: .s.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,proc=assign1)]
end type
contains
impure elemental subroutine assign1(to, from)
diff --git a/flang/test/Semantics/typeinfo02.f90 b/flang/test/Semantics/typeinfo02.f90
index 076f1b3499b62..35b6bd67462f3 100644
--- a/flang/test/Semantics/typeinfo02.f90
+++ b/flang/test/Semantics/typeinfo02.f90
@@ -29,5 +29,5 @@ subroutine wf2(x,u,iot,v,iostat,iomsg)
character(len=*), intent(inout) :: iomsg
end subroutine
end module
-!CHECK: .s.base, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,proc=wf1)]
-!CHECK: .s.extended, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,proc=wf2)]
+!CHECK: .s.base, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf1)]
+!CHECK: .s.extended, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf2)]
More information about the flang-commits
mailing list