[flang-commits] [flang] 09b00ab - [flang] Handle dynamic and remotely scoped non-type-bound UDDTIO subroutines
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Mar 27 14:56:45 PDT 2023
Author: Peter Klausler
Date: 2023-03-27T14:56:25-07:00
New Revision: 09b00ab4898449aa70c1bc5eb891cfa2addb85fc
URL: https://github.com/llvm/llvm-project/commit/09b00ab4898449aa70c1bc5eb891cfa2addb85fc
DIFF: https://github.com/llvm/llvm-project/commit/09b00ab4898449aa70c1bc5eb891cfa2addb85fc.diff
LOG: [flang] Handle dynamic and remotely scoped non-type-bound UDDTIO subroutines
The present I/O infrastructure for user-defined derived type I/O
subroutines works fine for type-bound I/O generic bindings. It also works
for explicit INTERFACE blocks and GENERIC statements that define
UDDIO subroutines in the same scope as the definition of the derived type,
so long as the specific procedures in those bindings are module procedures
or external procedures.
For non-type-bound UDDTIO specific procedures that are dummy procedures,
thunks of inner procedures, or procedure pointers, or that are defined with
interfaces or GENERIC outside the scope of the definition of the derived
type, a new runtime I/O API is needed so that lowering can generate
a call that supplies the appropriate procedure as well as the defined
type instance.
This patch specifies and implements this new runtime API and provides
utility routines for lowering to use to determine whether it should be
called for any particular OutputItem or InputItem in the parse tree.
Differential Revision: https://reviews.llvm.org/D146571
Added:
Modified:
flang/include/flang/Runtime/io-api.h
flang/include/flang/Semantics/tools.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/tools.cpp
flang/runtime/io-api.cpp
flang/runtime/type-info.h
flang/test/Semantics/generic05.F90
flang/test/Semantics/io11.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Runtime/io-api.h b/flang/include/flang/Runtime/io-api.h
index 20ff9fc2ce42b..6aabb01354f5b 100644
--- a/flang/include/flang/Runtime/io-api.h
+++ b/flang/include/flang/Runtime/io-api.h
@@ -275,6 +275,22 @@ 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
+// 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.
+bool IONAME(OutputDerivedType)(
+ Cookie, const Descriptor &, void (*)(), bool isPolymorphic);
+bool IONAME(InputDerivedType)(
+ Cookie, const Descriptor &, void (*)(), bool isPolymorphic);
+
// Additional specifier interfaces for the connection-list of
// on OPEN statement (only). SetBlank(), SetDecimal(),
// SetDelim(), GetIoMsg(), SetPad(), SetRound(), SetSign(),
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 2de6e1f8c9ddd..443c9455ee4a4 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -631,5 +631,20 @@ bool HasDefinedIo(
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,
+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/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index b7c82a4942636..d8d6bdc196ac1 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -161,8 +161,6 @@ class CheckHelper {
std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
// Collection of symbols with global names, BIND(C) or otherwise
std::map<std::string, SymbolRef> globalNames_;
- // Derived types that have defined input/output procedures
- std::vector<TypeWithDefinedIo> seenDefinedIoTypes_;
};
class DistinguishabilityHelper {
@@ -2428,24 +2426,32 @@ bool CheckHelper::CheckDioDummyIsData(
void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
GenericKind::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
- for (TypeWithDefinedIo definedIoType : seenDefinedIoTypes_) {
- // 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 if both were visible in the same scope.)
- if (derivedType == definedIoType.type && ioKind == definedIoType.ioKind &&
- proc != definedIoType.proc &&
- (generic.owner().IsDerivedType() ||
- definedIoType.generic.owner().IsDerivedType())) {
- SayWithDeclaration(proc, definedIoType.proc.name(),
- "Derived type '%s' already has defined input/output procedure"
- " '%s'"_err_en_US,
- derivedType.name(), GenericKind::AsFortran(ioKind));
- return;
+ // 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.)
+ if (generic.owner().IsDerivedType()) {
+ return;
+ }
+ if (const Scope * dtScope{derivedType.scope()}) {
+ if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end()) {
+ for (auto specRef : iter->second->get<GenericDetails>().specificProcs()) {
+ const Symbol &specific{specRef->get<ProcBindingDetails>().symbol()};
+ if (specific == proc) { // unambiguous, accept
+ continue;
+ }
+ if (const auto *specDT{GetDtvArgDerivedType(specific)};
+ specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) {
+ SayWithDeclaration(*specRef, proc.name(),
+ "Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US,
+ derivedType.name(), GenericKind::AsFortran(ioKind));
+ return;
+ }
+ }
}
}
- seenDefinedIoTypes_.emplace_back(
- TypeWithDefinedIo{derivedType, ioKind, proc, generic});
}
void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index b4178975f567b..25a5c0e991317 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1475,6 +1475,24 @@ std::optional<ArraySpec> ToArraySpec(evaluate::FoldingContext &context,
return shape ? ToArraySpec(context, *shape) : std::nullopt;
}
+static const DeclTypeSpec *GetDtvArgTypeSpec(const Symbol &proc) {
+ if (const auto *subp{proc.detailsIf<SubprogramDetails>()};
+ subp && !subp->dummyArgs().empty()) {
+ if (const auto *arg{subp->dummyArgs()[0]}) {
+ return arg->GetType();
+ }
+ }
+ return nullptr;
+}
+
+const DerivedTypeSpec *GetDtvArgDerivedType(const Symbol &proc) {
+ if (const auto *type{GetDtvArgTypeSpec(proc)}) {
+ return type->AsDerived();
+ } else {
+ return nullptr;
+ }
+}
+
bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived,
const Scope *scope) {
if (const Scope * dtScope{derived.scope()}) {
@@ -1499,16 +1517,10 @@ bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived,
const auto &generic{iter->second->GetUltimate().get<GenericDetails>()};
for (auto ref : generic.specificProcs()) {
const Symbol &procSym{ref->GetUltimate()};
- if (const auto *subp{procSym.detailsIf<SubprogramDetails>()}) {
- if (!subp->dummyArgs().empty()) {
- if (const Symbol * first{subp->dummyArgs().at(0)}) {
- if (const DeclTypeSpec * dtSpec{first->GetType()}) {
- if (auto dyDummy{evaluate::DynamicType::From(*dtSpec)}) {
- if (dyDummy->IsTkCompatibleWith(dyDerived)) {
- return true; // GENERIC or INTERFACE not in type
- }
- }
- }
+ if (const DeclTypeSpec * dtSpec{GetDtvArgTypeSpec(procSym)}) {
+ if (auto dyDummy{evaluate::DynamicType::From(*dtSpec)}) {
+ if (dyDummy->IsTkCompatibleWith(dyDerived)) {
+ return true; // GENERIC or INTERFACE not in type
}
}
}
@@ -1519,4 +1531,55 @@ 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/runtime/io-api.cpp b/flang/runtime/io-api.cpp
index faf062cd8f596..dd27c6c54dd64 100644
--- a/flang/runtime/io-api.cpp
+++ b/flang/runtime/io-api.cpp
@@ -1379,6 +1379,61 @@ 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");
+}
+
+bool IONAME(InputDerivedType)(Cookie cookie, const Descriptor &descriptor,
+ void (*procedure)(), bool isPolymorphic) {
+ return DoDerivedTypeIo<Direction::Output>(
+ cookie, descriptor, procedure, isPolymorphic, "InputDerivedType");
+}
+
std::size_t IONAME(GetSize)(Cookie cookie) {
IoStatementState &io{*cookie};
IoErrorHandler &handler{io.GetIoErrorHandler()};
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
index d01e5c473d012..63939d7fd9bc4 100644
--- a/flang/runtime/type-info.h
+++ b/flang/runtime/type-info.h
@@ -133,6 +133,11 @@ 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} {}
+
static constexpr Which RankFinal(int rank) {
return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
}
diff --git a/flang/test/Semantics/generic05.F90 b/flang/test/Semantics/generic05.F90
index 5d19137f301be..d26d5c8feebc8 100644
--- a/flang/test/Semantics/generic05.F90
+++ b/flang/test/Semantics/generic05.F90
@@ -28,7 +28,7 @@ subroutine name(dtv, unit, iostat, iomsg); \
character(*), intent(in out) :: iomsg; \
read(unit, iostat=iostat, iomsg=iomsg) dtv%n; \
end subroutine name
- !ERROR: Derived type 't1' already has defined input/output procedure 'read(unformatted)'
+ !ERROR: Derived type 't1' has conflicting type-bound input/output procedure 'read(unformatted)'
DEFINE_READU(readt1a, t1)
DEFINE_READU(readt1b, t1)
DEFINE_READU(readt2a, t2)
diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index 3c9b8b7f35849..b5f26b606cddc 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -391,7 +391,7 @@ subroutine formattedReadProc(dtv,unit,iotype,v_list,iostat,iomsg)
end module
module m18
- ! Test the same defined input/output procedure specified as a type-bound
+ ! Test the same defined input/output procedure specified as a type-bound
! procedure and as a generic
type t
integer c
@@ -435,7 +435,7 @@ subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
character(*),intent(inout) :: iomsg
read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
end subroutine
- !ERROR: Derived type 't' already has defined input/output procedure 'read(unformatted)'
+ !ERROR: Derived type 't' has conflicting type-bound input/output procedure 'read(unformatted)'
subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
class(t),intent(inout) :: dtv
integer,intent(in) :: unit
@@ -499,7 +499,7 @@ subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
character(*),intent(inout) :: iomsg
read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
end subroutine
- !ERROR: Derived type 't' already has defined input/output procedure 'read(unformatted)'
+ !ERROR: Derived type 't' has conflicting type-bound input/output procedure 'read(unformatted)'
subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
class(t(4)),intent(inout) :: dtv
integer,intent(in) :: unit
@@ -510,7 +510,7 @@ subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
end module
module m22
- ! Test read and write defined input/output procedures specified as a
+ ! Test read and write defined input/output procedures specified as a
! type-bound procedure and as a generic for the same derived type with a
! KIND type parameter where they have
diff erent values
type t(typeParam)
@@ -542,10 +542,10 @@ subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
module m23
type t(typeParam)
- ! Test read and write defined input/output procedures specified as a
+ ! Test read and write defined input/output procedures specified as a
! type-bound procedure and as a generic for the same derived type with a
- ! LEN type parameter where they have
diff erent values
- integer, len :: typeParam = 4
+ ! KIND type parameter where they have
diff erent values
+ integer, kind :: typeParam = 4
integer c
contains
procedure :: unformattedReadProc
@@ -556,7 +556,7 @@ module m23
end interface
contains
subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
- class(t(*)),intent(inout) :: dtv
+ class(t(2)),intent(inout) :: dtv
integer,intent(in) :: unit
integer,intent(out) :: iostat
character(*),intent(inout) :: iomsg
@@ -571,10 +571,42 @@ subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
end subroutine
end module
+module m23a
+ type t(typeParam)
+ ! Test read and write defined input/output procedures specified as a
+ ! type-bound procedure and as a generic for the same derived type with a
+ ! KIND type parameter where they have the same value
+ integer, kind :: typeParam = 4
+ integer c
+ contains
+ procedure :: unformattedReadProc
+ generic :: read(unformatted) => unformattedReadProc
+ end type
+ interface read(unformatted)
+ module procedure unformattedReadProc1
+ end interface
+contains
+ subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
+ class(t),intent(inout) :: dtv
+ integer,intent(in) :: unit
+ integer,intent(out) :: iostat
+ character(*),intent(inout) :: iomsg
+ read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
+ end subroutine
+ !ERROR: Derived type 't' has conflicting type-bound input/output procedure 'read(unformatted)'
+ subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
+ class(t(4)),intent(inout) :: dtv
+ integer,intent(in) :: unit
+ integer,intent(out) :: iostat
+ character(*),intent(inout) :: iomsg
+ read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
+ end subroutine
+end module
+
module m24
! Test read and write defined input/output procedures specified as a
! type-bound procedure and as a generic for the same derived type with a
- ! LEN type parameter where they have the same value
+ ! LEN type parameter where they are both assumed
type t(typeParam)
integer, len :: typeParam = 4
integer c
@@ -593,7 +625,7 @@ subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
character(*),intent(inout) :: iomsg
read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
end subroutine
- !ERROR: Derived type 't' already has defined input/output procedure 'read(unformatted)'
+ !ERROR: Derived type 't' has conflicting type-bound input/output procedure 'read(unformatted)'
subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
class(t(*)),intent(inout) :: dtv
integer,intent(in) :: unit
More information about the flang-commits
mailing list