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

[klausler]

Summary

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.

flang/include/flang/Semantics/semantics.h

public:
   template <typename... A>
   parser::Message &Say(parser::CharBlock at, A &&...args) {
     return messages_.Say(at, std::forward<A>(args)...);
   }
   parser::Message &Say(parser::Message &&msg) {
     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;
   Scope &FindScope(parser::CharBlock);
 
   bool IsInModuleFile(parser::CharBlock) const;
 
   const ConstructStack &constructStack() const { return constructStack_; }

flang/include/flang/Semantics/tools.h

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);
 
 // Some intrinsic operators have more than one name (e.g. `operator(.eq.)` and
 // `operator(==)`). GetAllNames() returns them all, including symbolName.
 std::forward_list<std::string> GetAllNames(
     const SemanticsContext &, const SourceName &);
 
 } // 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(
+  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;
     specifierSet_.reset();
     flags_.reset();
   }
 
   void Done() { stmt_ = IoStmtKind::None; }

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,
+    CheckForBadIoType(*expr,
         flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted
                                     : GenericKind::DefinedIo::ReadUnformatted,
         var->GetSource());
   }
 }
 
 void IoChecker::Enter(const parser::InquireSpec &spec) {
   // InquireSpec context FileNameExpr
if (const auto *expr{GetExpr(context_, *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,
+      CheckForBadIoType(*expr,
           flags_.test(Flag::FmtOrNml)
               ? GenericKind::DefinedIo::WriteFormatted
               : GenericKind::DefinedIo::WriteUnformatted,
           parser::FindSourceLocation(item));
     }
   }
 }
 
void IoChecker::Leave(const parser::OpenStmt &) {
   Done();
 }
 
 void IoChecker::Leave(const parser::PrintStmt &) {
   CheckForPureSubprogram();
   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 *
         variable{std::get_if<parser::Variable>(&item.u)}) {
       context.CheckIndexVarRedefine(*variable);
     }
   }
 }
 
 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();
     return;
   }
   LeaveReadWrite();
   CheckForProhibitedSpecifier(IoSpecKind::Delim); // C1212
   CheckForProhibitedSpecifier(IoSpecKind::Sign); // C1212

 
 void IoChecker::Leave(const parser::WaitStmt &) {
   CheckForRequiredSpecifier(
       flags_.test(Flag::NumberUnit), "UNIT number"); // C1237
   CheckForPureSubprogram();
   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
   CheckForProhibitedSpecifier(IoSpecKind::Eor); // C1213
   CheckForProhibitedSpecifier(IoSpecKind::Pad); // C1213
   CheckForProhibitedSpecifier(IoSpecKind::Size); // C1213
   CheckForRequiredSpecifier(
       IoSpecKind::Sign, flags_.test(Flag::FmtOrNml), "FMT or NML"); // C1227
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()) {
+// 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, 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);
+                    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 (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{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/resolve-names.cpp

public:
   void Post(const parser::SelectRankStmt &);
   bool Pre(const parser::SelectTypeConstruct &);
   void Post(const parser::SelectTypeConstruct &);
   bool Pre(const parser::SelectTypeConstruct::TypeCase &);
   void Post(const parser::SelectTypeConstruct::TypeCase &);
   // 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 &);
   void Post(const parser::EndChangeTeamStmt &);
   void Post(const parser::CoarrayAssociation &);
 
   // Definitions of construct names
   bool Pre(const parser::WhereConstructStmt &x) { return CheckDef(x.t); }

 bool ConstructVisitor::Pre(const parser::SelectRankConstruct::RankCase &) {
   PushScope(Scope::Kind::OtherConstruct, nullptr);
   return true;
 }
 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)) {
       SetTypeFromAssociation(*symbol);
     } else if (const auto *type{GetDeclTypeSpec()}) {
       symbol->SetType(*type);
     }
     SetAttrsFromAssociation(*symbol);

flang/lib/Semantics/tools.cpp

for (; scope && !scope->IsGlobal(); scope = &scope->parent()) {
           }
         }
       }
     }
   }
   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

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

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

flang/test/Semantics/io15.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test visibility restrictions
+module m
+  type t1
+    integer, private :: ip1 = 123
+   contains
+    procedure :: fwrite1
+    generic :: write(formatted) => fwrite1
+  end type t1
+  type t2
+    integer, private :: ip2 = 234
+    type(t1) x1
+  end type t2
+  type t3
+    type(t1) x1
+    type(t2) x2
+  end type t3
+  type, extends(t2) :: t4
+  end type t4
+ contains
+  subroutine fwrite1(x, unit, iotype, vlist, iostat, iomsg)
+    class(t1), 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%ip1, ')'
+  end subroutine
+  subroutine local ! all OK since type is local
+    type(t1) :: x1
+    type(t2) :: x2
+    type(t3) :: x3
+    type(t4) :: x4
+    print *, x1
+    print *, x2
+    print *, x3
+    print *, x4
+  end subroutine
+end module
+
+program main
+  use m
+  type(t1) :: x1
+  type(t2) :: x2
+  type(t3) :: x3
+  type(t4) :: x4
+  print *, x1 ! ok
+  !ERROR: I/O of the derived type 't2' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible
+  print *, x2
+  !ERROR: I/O of the derived type 't3' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible
+  print *, x3
+  !ERROR: I/O of the derived type 't4' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible
+  print *, x4
+end

flang/test/Semantics/symbol11.f90

  !REF: /s3/t1
  !DEF: /s3/x POINTER ObjectEntity CLASS(t1)
  class(t1), pointer :: x
  !REF: /s3/x
  select type (y => x)
   !REF: /s3/t2
   class is (t2)
    !REF: /s3/i
-   !DEF: /s3/OtherConstruct1/y TARGET AssocEntity TYPE(t2)
+   !DEF: /s3/OtherConstruct1/y TARGET AssocEntity CLASS(t2)
    !REF: /s3/t2/a2
    i = y%a2
   !REF: /s3/t1
   type is (t1)
    !REF: /s3/i
    !DEF: /s3/OtherConstruct2/y TARGET AssocEntity TYPE(t1)
    !REF: /s3/t1/a1
    i = y%a1
   class default
    !DEF: /s3/OtherConstruct3/y TARGET AssocEntity CLASS(t1)
-   print *, y
+   !REF:/s3/t1/a1
+   print *, y%a1
  end select
 end subroutine
 
 !DEF: /s4 (Subroutine) Subprogram
 subroutine s4
  !DEF: /s4/t1 DerivedType
  type :: t1
   !DEF: /s4/t1/a ObjectEntity REAL(4)