[flang] Catch I/O of bad derived type at compile time

Derived types with allocatable and pointer components cannot
be used in I/O data transfer statements unless they have defined
I/O procedures available (as type-bound or regular generics).
These cases are caught as errors by the I/O runtime library,
but it would be better if they were flagged during compilation.

(Address comment in review: don't use explicit name string lengths.)

Differential Revision: https://reviews.llvm.org/D120675

flang/include/flang/Semantics/symbol.h

@@ -423,6 +423,7 @@ struct GenericKind {
   bool IsIntrinsicOperator() const;
   bool IsOperator() const;
   std::string ToString() const;
+  static SourceName AsFortran(DefinedIo);
   std::variant<OtherKind, common::NumericOperator, common::LogicalOperator,
       common::RelationalOperator, DefinedIo>
       u;

flang/include/flang/Semantics/tools.h

@@ -528,6 +528,8 @@ UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
     const DerivedTypeSpec &);
+DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent(
+    const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator
 FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator
@@ -583,5 +585,15 @@ 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.
+bool HasDefinedIo(
+    GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr);
+// Seeks out an allocatable or pointer ultimate component that is not
+// nested in a nonallocatable/nonpointer component with a specific
+// defined I/O procedure.
+const Symbol *FindUnsafeIoDirectComponent(
+    GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr);
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TOOLS_H_

flang/lib/Semantics/check-io.cpp

@@ -319,6 +319,12 @@ void IoChecker::Enter(const parser::InputItem &spec) {
     return;
   }
   CheckForDefinableVariable(*var, "Input");
+  if (auto expr{AnalyzeExpr(context_, *var)}) {
+    CheckForBadIoComponent(*expr,
+        flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted
+                                    : GenericKind::DefinedIo::ReadUnformatted,
+        var->GetSource());
+  }
 }
 
 void IoChecker::Enter(const parser::InquireSpec &spec) {
@@ -580,6 +586,11 @@ void IoChecker::Enter(const parser::OutputItem &item) {
         context_.Say(parser::FindSourceLocation(*x),
             "Output item must not be a procedure pointer"_err_en_US); // C1233
       }
+      CheckForBadIoComponent(*expr,
+          flags_.test(Flag::FmtOrNml)
+              ? GenericKind::DefinedIo::WriteFormatted
+              : GenericKind::DefinedIo::WriteUnformatted,
+          parser::FindSourceLocation(item));
     }
   }
 }
@@ -987,4 +998,20 @@ void IoChecker::CheckForPureSubprogram() const { // C1597
   }
 }
 
+// Fortran 2018, 12.6.3 paragraph 7
+void IoChecker::CheckForBadIoComponent(const SomeExpr &expr,
+    GenericKind::DefinedIo which, parser::CharBlock where) const {
+  if (auto type{expr.GetType()}) {
+    if (type->category() == TypeCategory::Derived &&
+        !type->IsUnlimitedPolymorphic()) {
+      if (const Symbol *
+          bad{FindUnsafeIoDirectComponent(
+              which, type->GetDerivedTypeSpec(), &context_.FindScope(where))}) {
+        context_.SayWithDecl(*bad, where,
+            "Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O"_err_en_US);
+      }
+    }
+  }
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/check-io.h

@@ -126,6 +126,9 @@ private:
 
   void CheckForPureSubprogram() const;
 
+  void CheckForBadIoComponent(
+      const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const;
+
   void Init(IoStmtKind s) {
     stmt_ = s;
     specifierSet_.reset();

flang/lib/Semantics/runtime-type-info.cpp

@@ -74,8 +74,8 @@ private:
       const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
       std::optional<GenericKind::DefinedIo>);
   void IncorporateDefinedIoGenericInterfaces(
-      std::map<int, evaluate::StructureConstructor> &, SourceName,
-      GenericKind::DefinedIo, const Scope *);
+      std::map<int, evaluate::StructureConstructor> &, GenericKind::DefinedIo,
+      const Scope *);
 
   // Instantiated for ParamValue and Bound
   template <typename A>
@@ -523,18 +523,14 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
       DescribeSpecialProc(
           specials, *pair.second, false /*!isAssignment*/, true, std::nullopt);
     }
-    IncorporateDefinedIoGenericInterfaces(specials,
-        SourceName{"read(formatted)", 15},
-        GenericKind::DefinedIo::ReadFormatted, &scope);
-    IncorporateDefinedIoGenericInterfaces(specials,
-        SourceName{"read(unformatted)", 17},
-        GenericKind::DefinedIo::ReadUnformatted, &scope);
-    IncorporateDefinedIoGenericInterfaces(specials,
-        SourceName{"write(formatted)", 16},
-        GenericKind::DefinedIo::WriteFormatted, &scope);
-    IncorporateDefinedIoGenericInterfaces(specials,
-        SourceName{"write(unformatted)", 18},
-        GenericKind::DefinedIo::WriteUnformatted, &scope);
+    IncorporateDefinedIoGenericInterfaces(
+        specials, GenericKind::DefinedIo::ReadFormatted, &scope);
+    IncorporateDefinedIoGenericInterfaces(
+        specials, GenericKind::DefinedIo::ReadUnformatted, &scope);
+    IncorporateDefinedIoGenericInterfaces(
+        specials, GenericKind::DefinedIo::WriteFormatted, &scope);
+    IncorporateDefinedIoGenericInterfaces(
+        specials, GenericKind::DefinedIo::WriteUnformatted, &scope);
     // Pack the special procedure bindings in ascending order of their "which"
     // code values, and compile a little-endian bit-set of those codes for
     // use in O(1) look-up at run time.
@@ -1072,8 +1068,9 @@ void RuntimeTableBuilder::DescribeSpecialProc(
 }
 
 void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
-    std::map<int, evaluate::StructureConstructor> &specials, SourceName name,
+    std::map<int, evaluate::StructureConstructor> &specials,
     GenericKind::DefinedIo definedIo, const Scope *scope) {
+  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()};

flang/lib/Semantics/symbol.cpp

@@ -13,6 +13,7 @@
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
+#include <cstring>
 #include <string>
 #include <type_traits>
 
@@ -657,7 +658,7 @@ std::string GenericKind::ToString() const {
   return std::visit(
       common::visitors {
         [](const OtherKind &x) { return EnumToString(x); },
-            [](const DefinedIo &x) { return EnumToString(x); },
+            [](const DefinedIo &x) { return AsFortran(x).ToString(); },
 #if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2
             [](const common::NumericOperator &x) {
               return common::EnumToString(x);
@@ -675,13 +676,32 @@ 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;
+  }
+  return {name, std::strlen(name)};
+}
+
 bool GenericKind::Is(GenericKind::OtherKind x) const {
   const OtherKind *y{std::get_if<OtherKind>(&u)};
   return y && *y == x;
 }
 
-bool SymbolOffsetCompare::operator()(
-    const SymbolRef &x, const SymbolRef &y) const {
+bool SymbolOffsetCompare::operator()(const SymbolRef &x, const SymbolRef &y) const {
   const Symbol *xCommon{FindCommonBlockContaining(*x)};
   const Symbol *yCommon{FindCommonBlockContaining(*y)};
   if (xCommon) {
@@ -709,6 +729,7 @@ bool SymbolOffsetCompare::operator()(
   return x->GetSemanticsContext().allCookedSources().Precedes(
       x->name(), y->name());
 }
+
 bool SymbolOffsetCompare::operator()(
     const MutableSymbolRef &x, const MutableSymbolRef &y) const {
   return (*this)(SymbolRef{*x}, SymbolRef{*y});

flang/lib/Semantics/tools.cpp

@@ -1273,6 +1273,12 @@ UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
   return std::find_if(ultimates.begin(), ultimates.end(), IsAllocatable);
 }
 
+DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent(
+    const DerivedTypeSpec &derived) {
+  DirectComponentIterator directs{derived};
+  return std::find_if(directs.begin(), directs.end(), IsAllocatableOrPointer);
+}
+
 UltimateComponentIterator::const_iterator
 FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) {
   UltimateComponentIterator ultimates{derived};
@@ -1458,4 +1464,75 @@ std::optional<ArraySpec> ToArraySpec(evaluate::FoldingContext &context,
   return shape ? ToArraySpec(context, *shape) : std::nullopt;
 }
 
+bool HasDefinedIo(GenericKind::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 (*io == which) {
+            return true; // type-bound GENERIC exists
+          }
+        }
+      }
+    }
+  }
+  if (scope) {
+    SourceName name{GenericKind::AsFortran(which)};
+    evaluate::DynamicType dyDerived{derived};
+    for (; scope && !scope->IsGlobal(); scope = &scope->parent()) {
+      auto iter{scope->find(name)};
+      if (iter != scope->end()) {
+        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
+                    }
+                  }
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+  return false;
+}
+
+const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which,
+    const DerivedTypeSpec &derived, const Scope *scope) {
+  if (HasDefinedIo(which, derived, scope)) {
+    return nullptr;
+  }
+  if (const Scope * dtScope{derived.scope()}) {
+    for (const auto &pair : *dtScope) {
+      const Symbol &symbol{*pair.second};
+      if (IsAllocatableOrPointer(symbol)) {
+        return &symbol;
+      }
+      if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+        if (const DeclTypeSpec * type{details->type()}) {
+          if (type->category() == DeclTypeSpec::Category::TypeDerived) {
+            if (const Symbol *
+                bad{FindUnsafeIoDirectComponent(
+                    which, type->derivedTypeSpec(), scope)}) {
+              return bad;
+            }
+          }
+        }
+      }
+    }
+  }
+  return nullptr;
+}
+
 } // namespace Fortran::semantics

flang/test/Semantics/io12.f90

@@ -0,0 +1,76 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests for I/O of derived types without defined I/O procedures
+! but with exposed allocatable/pointer components that would fail
+! at run time.
+
+module m1
+  type :: poison
+    real, allocatable :: allocatableComponent(:)
+  end type
+  type :: ok
+    integer :: x
+    type(poison) :: pill
+   contains
+    procedure :: wuf1
+    generic :: write(unformatted) => wuf1
+  end type
+  type :: maybeBad
+    integer :: x
+    type(poison) :: pill
+  end type
+ contains
+  subroutine wuf1(dtv, unit, iostat, iomsg)
+    class(ok), intent(in) :: dtv
+    integer, intent(in) :: unit
+    integer, intent(out) :: iostat
+    character(*), intent(in out) :: iomsg
+    write(unit) dtv%x
+  end subroutine
+end module
+
+module m2
+  use m1
+  interface write(unformatted)
+    module procedure wuf2
+  end interface
+ contains
+  subroutine wuf2(dtv, unit, iostat, iomsg)
+    class(maybeBad), intent(in) :: dtv
+    integer, intent(in) :: unit
+    integer, intent(out) :: iostat
+    character(*), intent(in out) :: iomsg
+    write(unit) dtv%x
+  end subroutine
+end module
+
+module m3
+  use m1
+ contains
+  subroutine test3(u)
+    integer, intent(in) :: u
+    type(ok) :: x
+    type(maybeBad) :: y
+    type(poison) :: z
+    write(u) x ! always ok
+    !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O
+    write(u) y ! bad here
+    !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O
+    write(u) z ! bad
+  end subroutine
+end module
+
+module m4
+  use m2
+ contains
+  subroutine test4(u)
+    integer, intent(in) :: u
+    type(ok) :: x
+    type(maybeBad) :: y
+    type(poison) :: z
+    write(u) x ! always ok
+    write(u) y ! ok here
+    !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O
+    write(u) z ! bad
+  end subroutine
+end module
+