Merge commit '5ea0ba2c13af' from llvm.org/main into next

Author: git apple-llvm automerger

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