[flang] Better error messages & more cases caught for bad forward refs

[klausler]

Summary

Subclause 10.1.12 in F'2018 prohibits forward references from
a specification expression to an object declared later in the
same specification part. Catch this error better and emit
specific error messages about the violation.

flang/lib/Semantics/resolve-names.cpp

       symbol->attrs() |= attrs;
       return *symbol;
     } else {
-      SayAlreadyDeclared(name, *symbol);
+      if (!CheckPossibleBadForwardRef(*symbol)) {
+        SayAlreadyDeclared(name, *symbol);
+      }
       // replace the old symbol with a new one with correct details
       EraseSymbol(*symbol);
       auto &result{MakeSymbol(name, attrs, std::move(details))};

       TypeCategory, const std::optional<parser::KindSelector> &);
   const DeclTypeSpec &MakeLogicalType(
       const std::optional<parser::KindSelector> &);
+  void NotePossibleBadForwardRef(const parser::Name &);
+  std::optional<SourceName> HadForwardRef(const Symbol &) const;
+  bool CheckPossibleBadForwardRef(const Symbol &);
 
   bool inExecutionPart_{false};
+  bool inSpecificationPart_{false};
+  std::set<SourceName> specPartForwardRefs_;
 
 private:
   Scope *currScope_{nullptr};

         SayWithDecl(
             name, symbol, "'%s' is already declared as an object"_err_en_US);
       }
-    } else {
+    } else if (!CheckPossibleBadForwardRef(symbol)) {
       SayAlreadyDeclared(name, symbol);
     }
     context().SetError(symbol);

 void ScopeHandler::SayAlreadyDeclared(const SourceName &name, Symbol &prev) {
   if (context().HasError(prev)) {
     // don't report another error about prev
-  } else if (const auto *details{prev.detailsIf<UseDetails>()}) {
-    Say(name, "'%s' is already declared in this scoping unit"_err_en_US)
-        .Attach(details->location(),
-            "It is use-associated with '%s' in module '%s'"_err_en_US,
-            details->symbol().name(), GetUsedModule(*details).name());
   } else {
-    SayAlreadyDeclared(name, prev.name());
+    if (const auto *details{prev.detailsIf<UseDetails>()}) {
+      Say(name, "'%s' is already declared in this scoping unit"_err_en_US)
+          .Attach(details->location(),
+              "It is use-associated with '%s' in module '%s'"_err_en_US,
+              details->symbol().name(), GetUsedModule(*details).name());
+    } else {
+      SayAlreadyDeclared(name, prev.name());
+    }
+    context().SetError(prev);
   }
-  context().SetError(prev);
 }
 void ScopeHandler::SayAlreadyDeclared(
     const SourceName &name1, const SourceName &name2) {

   }
 }
 
+void ScopeHandler::NotePossibleBadForwardRef(const parser::Name &name) {
+  if (inSpecificationPart_ && name.symbol) {
+    auto kind{currScope().kind()};
+    if ((kind == Scope::Kind::Subprogram && !currScope().IsStmtFunction()) ||
+        kind == Scope::Kind::Block) {
+      bool isHostAssociated{&name.symbol->owner() == &currScope()
+              ? name.symbol->has<HostAssocDetails>()
+              : name.symbol->owner().Contains(currScope())};
+      if (isHostAssociated) {
+        specPartForwardRefs_.insert(name.source);
+      }
+    }
+  }
+}
+
+std::optional<SourceName> ScopeHandler::HadForwardRef(
+    const Symbol &symbol) const {
+  auto iter{specPartForwardRefs_.find(symbol.name())};
+  if (iter != specPartForwardRefs_.end()) {
+    return *iter;
+  }
+  return std::nullopt;
+}
+
+bool ScopeHandler::CheckPossibleBadForwardRef(const Symbol &symbol) {
+  if (!context().HasError(symbol)) {
+    if (auto fwdRef{HadForwardRef(symbol)}) {
+      Say(*fwdRef,
+          "Forward reference to '%s' is not allowed in the same specification part"_err_en_US,
+          *fwdRef)
+          .Attach(symbol.name(), "Later declaration of '%s'"_en_US, *fwdRef);
+      context().SetError(symbol);
+      return true;
+    }
+  }
+  return false;
+}
+
 void ScopeHandler::MakeExternal(Symbol &symbol) {
   if (!symbol.attrs().test(Attr::EXTERNAL)) {
     symbol.attrs().set(Attr::EXTERNAL);

     symbol.SetType(type);
   } else if (symbol.has<UseDetails>()) {
     // error recovery case, redeclaration of use-associated name
+  } else if (HadForwardRef(symbol)) {
+    // error recovery after use of host-associated name
   } else if (!symbol.test(Symbol::Flag::Implicit)) {
     SayWithDecl(
         name, symbol, "The type of '%s' has already been declared"_err_en_US);

 const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
   FindSymbol(name);
   if (CheckForHostAssociatedImplicit(name)) {
+    NotePossibleBadForwardRef(name);
     return &name;
   }
   if (Symbol * symbol{name.symbol}) {
     if (CheckUseError(name)) {
       return nullptr; // reported an error
     }
+    NotePossibleBadForwardRef(name);
     symbol->set(Symbol::Flag::ImplicitOrError, false);
     if (IsUplevelReference(*symbol)) {
       MakeHostAssocSymbol(name, *symbol);

   }
   ConvertToObjectEntity(*symbol);
   ApplyImplicitRules(*symbol);
+  NotePossibleBadForwardRef(name);
   return &name;
 }
 

   Scope *host{GetHostProcedure()};
   if (!host || isImplicitNoneType(*host)) {
     return false;
-  } else if (!name.symbol) {
+  }
+  if (!name.symbol) {
     hostSymbol = &MakeSymbol(*host, name.source, Attrs{});
     ConvertToObjectEntity(*hostSymbol);
     ApplyImplicitRules(*hostSymbol);

 bool ResolveNamesVisitor::Pre(const parser::SpecificationPart &x) {
   const auto &[accDecls, ompDecls, compilerDirectives, useStmts, importStmts,
       implicitPart, decls] = x.t;
+  auto flagRestorer{common::ScopedSet(inSpecificationPart_, true)};
   Walk(accDecls);
   Walk(ompDecls);
   Walk(compilerDirectives);
   Walk(useStmts);
   Walk(importStmts);
   Walk(implicitPart);
+  auto setRestorer{
+      common::ScopedSet(specPartForwardRefs_, std::set<SourceName>{})};
   for (const auto &decl : decls) {
     if (const auto *spec{
             std::get_if<parser::SpecificationConstruct>(&decl.u)}) {

       symbol.set(
           symbol.GetType() ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
     }
+    if (!symbol.has<HostAssocDetails>()) {
+      CheckPossibleBadForwardRef(symbol);
+    }
   }
   currScope().InstantiateDerivedTypes(context());
   for (const auto &decl : decls) {

flang/test/Semantics/resolve97.f90

+! RUN: %S/test_errors.sh %s %t %f18
+
+! Check errors from illegal (10.1.12 para 2) forward references
+! in specification expressions to entities declared later in the
+! same specification part.
+
+module m1
+  integer :: m1j1, m1j2, m1j3, m1j4
+ contains
+  subroutine s1
+    !ERROR: Forward reference to 'm1j1' is not allowed in the same specification part
+    integer(kind=kind(m1j1)) :: t_s1m1j1
+    integer(kind=kind(m1s1j1)) :: t_s1j1 ! implicitly typed in s1
+    integer :: m1j1, m1s1j1, m1s1j2, m1s1j4
+    block
+      !ERROR: Forward reference to 'm1j2' is not allowed in the same specification part
+      integer(kind=kind(m1j2)) :: t_s1bm1j2
+      !ERROR: Forward reference to 'm1s1j2' is not allowed in the same specification part
+      integer(kind=kind(m1s1j2)) :: t_s1bm1s1j2
+      !ERROR: Forward reference to 'm1s1j3' is not allowed in the same specification part
+      integer(kind=kind(m1s1j3)) :: t_m1s1j3 ! m1s1j3 implicitly typed in s1
+      integer :: m1j2, m1s1j2, m1s1j3
+    end block
+   contains
+    subroutine s2
+      !ERROR: Forward reference to 'm1j3' is not allowed in the same specification part
+      integer(kind=kind(m1j3)) :: t_m1j3
+      !ERROR: Forward reference to 'm1s1j3' is not allowed in the same specification part
+      integer(kind=kind(m1s1j3)) :: t_m1s1j3
+      integer :: m1j3, m1s1j3, m1s2j1
+      block
+        !ERROR: Forward reference to 'm1j4' is not allowed in the same specification part
+        integer(kind=kind(m1j4)) :: t_m1j4
+        !ERROR: Forward reference to 'm1s1j4' is not allowed in the same specification part
+        integer(kind=kind(m1s1j4)) :: t_m1s1j4
+        !ERROR: Forward reference to 'm1s2j1' is not allowed in the same specification part
+        integer(kind=kind(m1s2j1)) :: t_m1s2j1
+        !ERROR: Forward reference to 'm1s2j2' is not allowed in the same specification part
+        integer(kind=kind(m1s2j2)) :: t_m1s2j2 ! m1s2j2 implicitly typed in s2
+        integer :: m1j4, m1s1j4, m1s2j1, m1s2j2
+      end block
+    end subroutine
+  end subroutine
+end module
+
+module m2
+  implicit none
+  integer :: m2j1, m2j2, m2j3, m2j4
+ contains
+  subroutine s1
+    !ERROR: Forward reference to 'm2j1' is not allowed in the same specification part
+    integer(kind=kind(m2j1)) :: t_s1m2j1
+    !ERROR: No explicit type declared for 'm2s1j1'
+    integer(kind=kind(m2s1j1)) :: t_s1j1
+    integer :: m2j1, m2s1j1, m2s1j2, m2s1j4
+    block
+      !ERROR: Forward reference to 'm2j2' is not allowed in the same specification part
+      integer(kind=kind(m2j2)) :: t_s1bm2j2
+      !ERROR: Forward reference to 'm2s1j2' is not allowed in the same specification part
+      integer(kind=kind(m2s1j2)) :: t_s1bm2s1j2
+      !ERROR: No explicit type declared for 'm2s1j3'
+      integer(kind=kind(m2s1j3)) :: t_m2s1j3
+      integer :: m2j2, m2s1j2, m2s1j3
+    end block
+   contains
+    subroutine s2
+      !ERROR: Forward reference to 'm2j3' is not allowed in the same specification part
+      integer(kind=kind(m2j3)) :: t_m2j3
+      !ERROR: No explicit type declared for 'm2s1j3'
+      integer(kind=kind(m2s1j3)) :: t_m2s1j3
+      integer :: m2j3, m2s1j3, m2s2j1
+      block
+        !ERROR: Forward reference to 'm2j4' is not allowed in the same specification part
+        integer(kind=kind(m2j4)) :: t_m2j4
+        !ERROR: Forward reference to 'm2s1j4' is not allowed in the same specification part
+        integer(kind=kind(m2s1j4)) :: t_m2s1j4
+        !ERROR: Forward reference to 'm2s2j1' is not allowed in the same specification part
+        integer(kind=kind(m2s2j1)) :: t_m2s2j1
+        !ERROR: No explicit type declared for 'm2s2j2'
+        integer(kind=kind(m2s2j2)) :: t_m2s2j2
+        integer :: m2j4, m2s1j4, m2s2j1, m2s2j2
+      end block
+    end subroutine
+  end subroutine
+end module
+
+! Case that elicited bad errors
+SUBROUTINE KEEL
+  INTEGER NODES
+ CONTAINS
+  SUBROUTINE SGEOM
+    REAL :: RADIUS(nodes)
+  END SUBROUTINE
+END SUBROUTINE KEEL