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

[klausler]

Summary

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.

[klausler]

Address comment; don't use explicit name string lengths.

flang/include/flang/Semantics/symbol.h

struct GenericKind {
   GenericKind() : u{OtherKind::Name} {}
   template <typename T> GenericKind(const T &x) { u = x; }
   bool IsName() const { return Is(OtherKind::Name); }
   bool IsAssignment() const { return Is(OtherKind::Assignment); }
   bool IsDefinedOperator() const { return Is(OtherKind::DefinedOp); }
   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;
 
 private:
   template <typename T> bool Has() const {
     return std::holds_alternative<T>(u);
   }

flang/include/flang/Semantics/tools.h

 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
     const DerivedTypeSpec &);
 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
 FindPolymorphicAllocatableNonCoarrayUltimateComponent(const DerivedTypeSpec &);
 
 // The LabelEnforce class (given a set of labels) provides an error message if
 // there is a branch to a label which is not in the given set.
 class LabelEnforce {
const std::optional<parser::Name> &MaybeGetNodeName(
     const ConstructNode &construct);
 
 // Convert evaluate::GetShape() result into an ArraySpec
 std::optional<ArraySpec> ToArraySpec(
     evaluate::FoldingContext &, const evaluate::Shape &);
 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.h

private:
   void CheckForProhibitedSpecifier(IoSpecKind, bool, const std::string &) const;
   void CheckForProhibitedSpecifier(bool, const std::string &, IoSpecKind) const;
 
   template <typename A>
   void CheckForDefinableVariable(const A &var, const std::string &s) const;
 
   void CheckForPureSubprogram() const;
 
+  void CheckForBadIoComponent(
+      const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const;
+
   void Init(IoStmtKind s) {
     stmt_ = s;
     specifierSet_.reset();
     flags_.reset();
   }
 
   void Done() { stmt_ = IoStmtKind::None; }
 
   SemanticsContext &context_;
   IoStmtKind stmt_{IoStmtKind::None};
   common::EnumSet<IoSpecKind, common::IoSpecKind_enumSize> specifierSet_;
   common::EnumSet<Flag, Flag_enumSize> flags_;
 };
 
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_CHECK_IO_H_

flang/lib/Semantics/check-io.cpp

 
 void IoChecker::Enter(const parser::InputItem &spec) {
   flags_.set(Flag::DataList);
   const parser::Variable *var{std::get_if<parser::Variable>(&spec.u)};
   if (!var) {
     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) {
   // InquireSpec context FileNameExpr
   if (std::get_if<parser::FileNameExpr>(&spec.u)) {
     SetSpecifier(IoSpecKind::File);
   }
 }
if (const auto *expr{GetExpr(*x)}) {
         context_.Say(parser::FindSourceLocation(*x), // C7109
             "Output item must not be a BOZ literal constant"_err_en_US);
       }
       const Symbol *last{GetLastSymbol(*expr)};
       if (last && IsProcedurePointer(*last)) {
         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));
     }
   }
 }
 
 void IoChecker::Enter(const parser::StatusExpr &spec) {
   SetSpecifier(IoSpecKind::Status);
   if (const std::optional<std::string> charConst{
           GetConstExpr<std::string>(spec)}) {
if (const Scope *
       scope{context_.globalScope().FindScope(*context_.location())}) {
     if (FindPureProcedureContaining(*scope)) {
       context_.Say(
           "External I/O is not allowed in a pure subprogram"_err_en_US);
     }
   }
 }
 
+// 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/runtime-type-info.cpp

private:
   std::vector<evaluate::StructureConstructor> DescribeBindings(
       const Scope &dtScope, Scope &);
   void DescribeGeneric(
       const GenericDetails &, std::map<int, evaluate::StructureConstructor> &);
   void DescribeSpecialProc(std::map<int, evaluate::StructureConstructor> &,
       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>
   evaluate::StructureConstructor GetValue(
       const A &x, const SymbolVector *parameters) {
     if (x.isExplicit()) {
       return GetValue(x.GetExplicit(), parameters);
     } else {
AddValue(dtValues, derivedTypeSchema_, "binding"s,
                 static_cast<evaluate::ConstantSubscript>(bindings.size())}));
     // Describe "special" bindings to defined assignments, FINAL subroutines,
     // and user-defined derived type I/O subroutines.
     const DerivedTypeDetails &dtDetails{dtSymbol->get<DerivedTypeDetails>()};
     for (const auto &pair : dtDetails.finals()) {
       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.
     std::vector<evaluate::StructureConstructor> sortedSpecials;
     std::uint32_t specialBitSet{0};
     for (auto &pair : specials) {
       auto bit{std::uint32_t{1} << pair.first};
       CHECK(!(specialBitSet & bit));
AddValue(values, specialSchema_, "proc"s,
         SomeExpr{evaluate::ProcedureDesignator{specific}});
     auto pair{specials.try_emplace(
         *index, DEREF(specialSchema_.AsDerived()), std::move(values))};
     CHECK(pair.second); // ensure not already present
   }
 }
 
 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()};
       const auto &genericDetails{generic.get<GenericDetails>()};
       CHECK(std::holds_alternative<GenericKind::DefinedIo>(
           genericDetails.kind().u));
       CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
           definedIo);

flang/lib/Semantics/symbol.cpp

 //===-- lib/Semantics/symbol.cpp ------------------------------------------===//
 //
 // 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 "flang/Semantics/symbol.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
+#include <cstring>
 #include <string>
 #include <type_traits>
 
 namespace Fortran::semantics {
 
 template <typename T>
 static void DumpOptional(llvm::raw_ostream &os, const char *label, const T &x) {
   if (x) {

 bool GenericKind::IsOperator() const {
   return IsDefinedOperator() || IsIntrinsicOperator();
 }
 
 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);
             },
             [](const common::LogicalOperator &x) {
               return common::EnumToString(x);
             },
             [](const common::RelationalOperator &x) {
               return common::EnumToString(x);
             },
 #else
             [](const auto &x) { return common::EnumToString(x); },
 #endif
       },
       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) {
     if (yCommon) {
       const SymbolSourcePositionCompare sourceCmp;
       if (sourceCmp(*xCommon, *yCommon)) {
         return true;
       } else if (sourceCmp(*yCommon, *xCommon)) {
bool SymbolOffsetCompare::operator()(const SymbolRef &x, const SymbolRef &y) const {
   } else if (x->offset() == y->offset()) {
     return x->size() > y->size();
   } else {
     return x->offset() < y->offset();
   }
   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});
 }
 
 } // namespace Fortran::semantics

flang/lib/Semantics/tools.cpp

 }
 
 UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
     const DerivedTypeSpec &derived) {
   UltimateComponentIterator ultimates{derived};
   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};
   return std::find_if(
       ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable);
 }
 
 UltimateComponentIterator::const_iterator
std::optional<ArraySpec> ToArraySpec(
   }
 }
 
 std::optional<ArraySpec> ToArraySpec(evaluate::FoldingContext &context,
     const std::optional<evaluate::Shape> &shape) {
   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

+! 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
+