[flang] Enforce more restrictions on I/O data list items

12.6.3p5 requires an I/O data list item to have a defined I/O procedure
if it is polymorphic.  (We could defer this checking to the runtime,
but no other Fortran compiler does so, and we would also have to be
able to catch the case of an allocatable or pointer direct component
in the absence of a defined I/O subroutine.)

Also includes a patch to name resolution that ensures that a
SELECT TYPE construct entity is polymorphic in the domain of a
CLASS IS guard.

Also ensures that non-defined I/O of types with PRIVATE components
is caught.

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

Author: klausler

flang/include/flang/Semantics/semantics.h

@@ -168,10 +168,12 @@ class SemanticsContext {
     return messages_.Say(std::move(msg));
   }
   template <typename... A>
-  void SayWithDecl(const Symbol &symbol, const parser::CharBlock &at,
-      parser::MessageFixedText &&msg, A &&...args) {
+  parser::Message &SayWithDecl(const Symbol &symbol,
+      const parser::CharBlock &at, parser::MessageFixedText &&msg,
+      A &&...args) {
     auto &message{Say(at, std::move(msg), args...)};
     evaluate::AttachDeclaration(&message, symbol);
+    return message;
   }
 
   const Scope &FindScope(parser::CharBlock) const;

flang/include/flang/Semantics/tools.h

@@ -610,11 +610,6 @@ std::optional<ArraySpec> ToArraySpec(
 // 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);
 
 // Some intrinsic operators have more than one name (e.g. `operator(.eq.)` and
 // `operator(==)`). GetAllNames() returns them all, including symbolName.

flang/lib/Semantics/check-io.cpp

@@ -323,7 +323,7 @@ void IoChecker::Enter(const parser::InputItem &spec) {
   }
   CheckForDefinableVariable(*var, "Input");
   if (auto expr{AnalyzeExpr(context_, *var)}) {
-    CheckForBadIoComponent(*expr,
+    CheckForBadIoType(*expr,
         flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted
                                     : GenericKind::DefinedIo::ReadUnformatted,
         var->GetSource());
@@ -616,7 +616,7 @@ 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,
+      CheckForBadIoType(*expr,
           flags_.test(Flag::FmtOrNml)
               ? GenericKind::DefinedIo::WriteFormatted
               : GenericKind::DefinedIo::WriteUnformatted,
@@ -738,29 +738,21 @@ void IoChecker::Leave(const parser::PrintStmt &) {
   Done();
 }
 
-static void CheckForDoVariableInNamelist(const Symbol &namelist,
-    SemanticsContext &context, parser::CharBlock namelistLocation) {
-  const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
-  for (const Symbol &object : details.objects()) {
-    context.CheckIndexVarRedefine(namelistLocation, object);
-  }
-}
-
-static void CheckForDoVariableInNamelistSpec(
-    const parser::ReadStmt &readStmt, SemanticsContext &context) {
-  const std::list<parser::IoControlSpec> &controls{readStmt.controls};
+static const parser::Name *FindNamelist(
+    const std::list<parser::IoControlSpec> &controls) {
   for (const auto &control : controls) {
-    if (const auto *namelist{std::get_if<parser::Name>(&control.u)}) {
-      if (const Symbol * symbol{namelist->symbol}) {
-        CheckForDoVariableInNamelist(*symbol, context, namelist->source);
+    if (const parser::Name * namelist{std::get_if<parser::Name>(&control.u)}) {
+      if (namelist->symbol &&
+          namelist->symbol->GetUltimate().has<NamelistDetails>()) {
+        return namelist;
       }
     }
   }
+  return nullptr;
 }
 
 static void CheckForDoVariable(
     const parser::ReadStmt &readStmt, SemanticsContext &context) {
-  CheckForDoVariableInNamelistSpec(readStmt, context);
   const std::list<parser::InputItem> &items{readStmt.items};
   for (const auto &item : items) {
     if (const parser::Variable *
@@ -774,6 +766,12 @@ void IoChecker::Leave(const parser::ReadStmt &readStmt) {
   if (!flags_.test(Flag::InternalUnit)) {
     CheckForPureSubprogram();
   }
+  if (const parser::Name * namelist{FindNamelist(readStmt.controls)}) {
+    if (namelist->symbol) {
+      CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::ReadFormatted,
+          namelist->source);
+    }
+  }
   CheckForDoVariable(readStmt, context_);
   if (!flags_.test(Flag::IoControlList)) {
     Done();
@@ -807,10 +805,16 @@ void IoChecker::Leave(const parser::WaitStmt &) {
   Done();
 }
 
-void IoChecker::Leave(const parser::WriteStmt &) {
+void IoChecker::Leave(const parser::WriteStmt &writeStmt) {
   if (!flags_.test(Flag::InternalUnit)) {
     CheckForPureSubprogram();
   }
+  if (const parser::Name * namelist{FindNamelist(writeStmt.controls)}) {
+    if (namelist->symbol) {
+      CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::WriteFormatted,
+          namelist->source);
+    }
+  }
   LeaveReadWrite();
   CheckForProhibitedSpecifier(IoSpecKind::Blank); // C1213
   CheckForProhibitedSpecifier(IoSpecKind::End); // C1213
@@ -1030,20 +1034,139 @@ void IoChecker::CheckForPureSubprogram() const { // C1597
   }
 }
 
-// Fortran 2018, 12.6.3 paragraph 7
-void IoChecker::CheckForBadIoComponent(const SomeExpr &expr,
+// Seeks out an allocatable or pointer ultimate component that is not
+// nested in a nonallocatable/nonpointer component with a specific
+// defined I/O procedure.
+static 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) {
+            const DerivedTypeSpec &componentDerived{type->derivedTypeSpec()};
+            if (const Symbol *
+                bad{FindUnsafeIoDirectComponent(
+                    which, componentDerived, scope)}) {
+              return bad;
+            }
+          }
+        }
+      }
+    }
+  }
+  return nullptr;
+}
+
+// For a type that does not have a defined I/O subroutine, finds a direct
+// component that is a witness to an accessibility violation outside the module
+// in which the type was defined.
+static const Symbol *FindInaccessibleComponent(GenericKind::DefinedIo which,
+    const DerivedTypeSpec &derived, const Scope &scope) {
+  if (const Scope * dtScope{derived.scope()}) {
+    if (const Scope * module{FindModuleContaining(*dtScope)}) {
+      for (const auto &pair : *dtScope) {
+        const Symbol &symbol{*pair.second};
+        if (IsAllocatableOrPointer(symbol)) {
+          continue; // already an error
+        }
+        if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+          const DerivedTypeSpec *componentDerived{nullptr};
+          if (const DeclTypeSpec * type{details->type()}) {
+            if (type->category() == DeclTypeSpec::Category::TypeDerived) {
+              componentDerived = &type->derivedTypeSpec();
+            }
+          }
+          if (componentDerived &&
+              HasDefinedIo(which, *componentDerived, &scope)) {
+            continue; // this component and its descendents are fine
+          }
+          if (symbol.attrs().test(Attr::PRIVATE) &&
+              !symbol.test(Symbol::Flag::ParentComp)) {
+            if (!DoesScopeContain(module, scope)) {
+              return &symbol;
+            }
+          }
+          if (componentDerived) {
+            if (const Symbol *
+                bad{FindInaccessibleComponent(
+                    which, *componentDerived, scope)}) {
+              return bad;
+            }
+          }
+        }
+      }
+    }
+  }
+  return nullptr;
+}
+
+// Fortran 2018, 12.6.3 paragraphs 5 & 7
+parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
     GenericKind::DefinedIo which, parser::CharBlock where) const {
-  if (auto type{expr.GetType()}) {
-    if (type->category() == TypeCategory::Derived &&
-        !type->IsUnlimitedPolymorphic()) {
+  if (type.IsUnlimitedPolymorphic()) {
+    return &context_.Say(
+        where, "I/O list item may not be unlimited polymorphic"_err_en_US);
+  } else if (type.category() == TypeCategory::Derived) {
+    const auto &derived{type.GetDerivedTypeSpec()};
+    const Scope &scope{context_.FindScope(where)};
+    if (const Symbol *
+        bad{FindUnsafeIoDirectComponent(which, derived, scope)}) {
+      return &context_.SayWithDecl(*bad, where,
+          "Derived type '%s' in I/O cannot have an allocatable or pointer direct component '%s' unless using defined I/O"_err_en_US,
+          derived.name(), bad->name());
+    }
+    if (!HasDefinedIo(which, derived, &scope)) {
+      if (type.IsPolymorphic()) {
+        return &context_.Say(where,
+            "Derived type '%s' in I/O may not be polymorphic unless using defined I/O"_err_en_US,
+            derived.name());
+      }
       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);
+          bad{FindInaccessibleComponent(which, derived, scope)}) {
+        return &context_.Say(where,
+            "I/O of the derived type '%s' may not be performed without defined I/O in a scope in which a direct component like '%s' is inaccessible"_err_en_US,
+            derived.name(), bad->name());
       }
     }
   }
+  return nullptr;
+}
+
+void IoChecker::CheckForBadIoType(const SomeExpr &expr,
+    GenericKind::DefinedIo which, parser::CharBlock where) const {
+  if (auto type{expr.GetType()}) {
+    CheckForBadIoType(*type, which, where);
+  }
+}
+
+parser::Message *IoChecker::CheckForBadIoType(const Symbol &symbol,
+    GenericKind::DefinedIo which, parser::CharBlock where) const {
+  if (auto type{evaluate::DynamicType::From(symbol)}) {
+    if (auto *msg{CheckForBadIoType(*type, which, where)}) {
+      evaluate::AttachDeclaration(*msg, symbol);
+      return msg;
+    }
+  }
+  return nullptr;
+}
+
+void IoChecker::CheckNamelist(const Symbol &namelist,
+    GenericKind::DefinedIo which, parser::CharBlock namelistLocation) const {
+  const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
+  for (const Symbol &object : details.objects()) {
+    context_.CheckIndexVarRedefine(namelistLocation, object);
+    if (auto *msg{CheckForBadIoType(object, which, namelistLocation)}) {
+      evaluate::AttachDeclaration(*msg, namelist);
+    }
+  }
 }
 
 } // namespace Fortran::semantics

flang/lib/Semantics/check-io.h

@@ -126,8 +126,15 @@ class IoChecker : public virtual BaseChecker {
 
   void CheckForPureSubprogram() const;
 
-  void CheckForBadIoComponent(
+  parser::Message *CheckForBadIoType(const evaluate::DynamicType &,
+      GenericKind::DefinedIo, parser::CharBlock) const;
+  void CheckForBadIoType(
       const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const;
+  parser::Message *CheckForBadIoType(
+      const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const;
+
+  void CheckNamelist(
+      const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const;
 
   void Init(IoStmtKind s) {
     stmt_ = s;

flang/lib/Semantics/resolve-names.cpp

@@ -1194,6 +1194,7 @@ class ConstructVisitor : public virtual DeclarationVisitor {
   // Creates Block scopes with neither symbol name nor symbol details.
   bool Pre(const parser::SelectRankConstruct::RankCase &);
   void Post(const parser::SelectRankConstruct::RankCase &);
+  bool Pre(const parser::TypeGuardStmt::Guard &);
   void Post(const parser::TypeGuardStmt::Guard &);
   void Post(const parser::SelectRankCaseStmt::Rank &);
   bool Pre(const parser::ChangeTeamStmt &);
@@ -6407,6 +6408,14 @@ void ConstructVisitor::Post(const parser::SelectRankConstruct::RankCase &) {
   PopScope();
 }
 
+bool ConstructVisitor::Pre(const parser::TypeGuardStmt::Guard &x) {
+  if (std::holds_alternative<parser::DerivedTypeSpec>(x.u)) {
+    // CLASS IS (t)
+    SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived);
+  }
+  return true;
+}
+
 void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
   if (auto *symbol{MakeAssocEntity()}) {
     if (std::holds_alternative<parser::Default>(x.u)) {

flang/lib/Semantics/tools.cpp

@@ -1514,31 +1514,4 @@ bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived,
   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

@@ -52,9 +52,9 @@ subroutine test3(u)
     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
+    !ERROR: Derived type 'maybebad' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' 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
+    !ERROR: Derived type 'poison' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O
     write(u) z ! bad
   end subroutine
 end module
@@ -69,7 +69,7 @@ subroutine test4(u)
     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
+    !ERROR: Derived type 'poison' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O
     write(u) z ! bad
   end subroutine
 end module

flang/test/Semantics/io14.f90

@@ -0,0 +1,37 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test polymorphic restrictions
+module m
+  type base
+  end type
+  type, extends(base) :: t
+    integer n
+   contains
+    procedure :: fwrite
+    generic :: write(formatted) => fwrite
+  end type
+ contains
+  subroutine fwrite(x, unit, iotype, vlist, iostat, iomsg)
+    class(t), intent(in) :: x
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: vlist(:)
+    integer, intent(out) :: iostat
+    character(*), intent(in out) :: iomsg
+    write(unit, *, iostat=iostat, iomsg=iomsg) '(', iotype, ':', vlist, ':', x%n, ')'
+  end subroutine
+  subroutine subr(x, y, z)
+    class(t), intent(in) :: x
+    class(base), intent(in) :: y
+    class(*), intent(in) :: z
+    print *, x ! ok
+    !ERROR: Derived type 'base' in I/O may not be polymorphic unless using defined I/O
+    print *, y
+    !ERROR: I/O list item may not be unlimited polymorphic
+    print *, z
+  end subroutine
+end
+
+program main
+  use m
+  call subr(t(123),t(234),t(345))
+end