Index: flang/include/flang/Runtime/io-api.h =================================================================== --- flang/include/flang/Runtime/io-api.h +++ flang/include/flang/Runtime/io-api.h @@ -275,6 +275,22 @@ 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(), Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -631,5 +631,20 @@ std::forward_list 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 FindNonTypeBoundDefinedIo( + const SemanticsContext, const parser::OutputItem &, bool isFormatted); +std::pair FindNonTypeBoundDefinedIo( + const SemanticsContext, const parser::InputItem &, bool isFormatted); + } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_TOOLS_H_ Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -161,8 +161,6 @@ std::map, SymbolRef> moduleProcs_; // Collection of symbols with global names, BIND(C) or otherwise std::map globalNames_; - // Derived types that have defined input/output procedures - std::vector seenDefinedIoTypes_; }; class DistinguishabilityHelper { @@ -2428,24 +2426,32 @@ 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().specificProcs()) { + const Symbol &specific{specRef->get().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, Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -1475,6 +1475,24 @@ return shape ? ToArraySpec(context, *shape) : std::nullopt; } +static const DeclTypeSpec *GetDtvArgTypeSpec(const Symbol &proc) { + if (const auto *subp{proc.detailsIf()}; + 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 @@ const auto &generic{iter->second->GetUltimate().get()}; for (auto ref : generic.specificProcs()) { const Symbol &procSym{ref->GetUltimate()}; - if (const auto *subp{procSym.detailsIf()}) { - 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 @@ return false; } +static std::pair +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()}) { + 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 FindNonTypeBoundDefinedIo( + const SemanticsContext &context, const parser::OutputItem &item, + bool isFormatted) { + if (const auto *expr{std::get_if(&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 FindNonTypeBoundDefinedIo( + const SemanticsContext &context, const parser::InputItem &item, + bool isFormatted) { + if (const auto *var{std::get_if(&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 Index: flang/runtime/io-api.cpp =================================================================== --- flang/runtime/io-api.cpp +++ flang/runtime/io-api.cpp @@ -1379,6 +1379,61 @@ return descr::DescriptorIO(*cookie, descriptor); } +template +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>()) { + 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>()) { + if (std::optional 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(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( + cookie, descriptor, procedure, isPolymorphic, "OutputDerivedType"); +} + +bool IONAME(InputDerivedType)(Cookie cookie, const Descriptor &descriptor, + void (*procedure)(), bool isPolymorphic) { + return DoDerivedTypeIo( + cookie, descriptor, procedure, isPolymorphic, "InputDerivedType"); +} + std::size_t IONAME(GetSize)(Cookie cookie) { IoStatementState &io{*cookie}; IoErrorHandler &handler{io.GetIoErrorHandler()}; Index: flang/runtime/type-info.h =================================================================== --- flang/runtime/type-info.h +++ flang/runtime/type-info.h @@ -133,6 +133,11 @@ // 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(static_cast(Which::ScalarFinal) + rank); } Index: flang/test/Semantics/generic05.F90 =================================================================== --- flang/test/Semantics/generic05.F90 +++ flang/test/Semantics/generic05.F90 @@ -28,7 +28,7 @@ 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) Index: flang/test/Semantics/io11.f90 =================================================================== --- flang/test/Semantics/io11.f90 +++ flang/test/Semantics/io11.f90 @@ -391,7 +391,7 @@ 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 @@ 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 @@ 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 @@ 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 different values type t(typeParam) @@ -542,10 +542,10 @@ 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 different values - integer, len :: typeParam = 4 + ! KIND type parameter where they have different values + integer, kind :: typeParam = 4 integer c contains procedure :: unformattedReadProc @@ -556,7 +556,7 @@ 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 @@ 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 @@ 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