[flang] Handle dynamic and remotely scoped non-type-bound UDDTIO subroutines

klausler · klausler · commit 09b00ab48984 · 2023-03-27T14:56:25.000-07:00
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
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 different 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 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 @@ 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
