[flang] Fix edge case in USE-associated generics

It is generally an error when a USE-associated name clashes
with a name defined locally, but not in all cases; a generic
interface can be both USE-associated and locally defined.
This works, but not when there is also a local subprogram
with the same name, which is valid when that subprogram is
a specific of the local generic.  A bogus error issues at
the point of the USE because name resolution will have already
defined a symbol for the local subprogram.

The solution is to collect the names of local generics when
creating the program tree, and then create their symbols as
well if their names are also local subprograms, prior to any
USE association processing.

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

Author: klausler

flang/lib/Semantics/program-tree.cpp

@@ -44,6 +44,37 @@ static void GetEntryStmts(
   }
 }
 
+// Collects generics that define simple names that could include
+// identically-named subprograms as specific procedures.
+static void GetGenerics(
+    ProgramTree &node, const parser::SpecificationPart &spec) {
+  for (const auto &decl :
+      std::get<std::list<parser::DeclarationConstruct>>(spec.t)) {
+    if (const auto *spec{
+            std::get_if<parser::SpecificationConstruct>(&decl.u)}) {
+      if (const auto *generic{std::get_if<
+              parser::Statement<common::Indirection<parser::GenericStmt>>>(
+              &spec->u)}) {
+        const parser::GenericStmt &genericStmt{generic->statement.value()};
+        const auto &genericSpec{std::get<parser::GenericSpec>(genericStmt.t)};
+        node.AddGeneric(genericSpec);
+      } else if (const auto *interface{
+                     std::get_if<common::Indirection<parser::InterfaceBlock>>(
+                         &spec->u)}) {
+        const parser::InterfaceBlock &interfaceBlock{interface->value()};
+        const parser::InterfaceStmt &interfaceStmt{
+            std::get<parser::Statement<parser::InterfaceStmt>>(interfaceBlock.t)
+                .statement};
+        const auto *genericSpec{
+            std::get_if<std::optional<parser::GenericSpec>>(&interfaceStmt.u)};
+        if (genericSpec && genericSpec->has_value()) {
+          node.AddGeneric(**genericSpec);
+        }
+      }
+    }
+  }
+}
+
 template <typename T>
 static ProgramTree BuildSubprogramTree(const parser::Name &name, const T &x) {
   const auto &spec{std::get<parser::SpecificationPart>(x.t)};
@@ -53,6 +84,7 @@ static ProgramTree BuildSubprogramTree(const parser::Name &name, const T &x) {
   ProgramTree node{name, spec, &exec};
   GetEntryStmts(node, spec);
   GetEntryStmts(node, exec);
+  GetGenerics(node, spec);
   if (subps) {
     for (const auto &subp :
         std::get<std::list<parser::InternalSubprogram>>(subps->t)) {
@@ -75,6 +107,7 @@ static ProgramTree BuildModuleTree(const parser::Name &name, const T &x) {
   const auto &spec{std::get<parser::SpecificationPart>(x.t)};
   const auto &subps{std::get<std::optional<parser::ModuleSubprogramPart>>(x.t)};
   ProgramTree node{name, spec};
+  GetGenerics(node, spec);
   if (subps) {
     for (const auto &subp :
         std::get<std::list<parser::ModuleSubprogram>>(subps->t)) {
@@ -230,4 +263,8 @@ void ProgramTree::AddEntry(const parser::EntryStmt &entryStmt) {
   entryStmts_.emplace_back(entryStmt);
 }
 
+void ProgramTree::AddGeneric(const parser::GenericSpec &generic) {
+  genericSpecs_.emplace_back(generic);
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/program-tree.h

@@ -30,6 +30,8 @@ class Scope;
 class ProgramTree {
 public:
   using EntryStmtList = std::list<common::Reference<const parser::EntryStmt>>;
+  using GenericSpecList =
+      std::list<common::Reference<const parser::GenericSpec>>;
 
   // Build the ProgramTree rooted at one of these program units.
   static ProgramTree Build(const parser::ProgramUnit &);
@@ -71,17 +73,17 @@ class ProgramTree {
   const parser::ExecutionPart *exec() const { return exec_; }
   std::list<ProgramTree> &children() { return children_; }
   const std::list<ProgramTree> &children() const { return children_; }
-  const std::list<common::Reference<const parser::EntryStmt>> &
-  entryStmts() const {
-    return entryStmts_;
-  }
+  const EntryStmtList &entryStmts() const { return entryStmts_; }
+  const GenericSpecList &genericSpecs() const { return genericSpecs_; }
+
   Symbol::Flag GetSubpFlag() const;
   bool IsModule() const; // Module or Submodule
   bool HasModulePrefix() const; // in function or subroutine stmt
   Scope *scope() const { return scope_; }
   void set_scope(Scope &);
   void AddChild(ProgramTree &&);
   void AddEntry(const parser::EntryStmt &);
+  void AddGeneric(const parser::GenericSpec &);
 
   template <typename T>
   ProgramTree &set_stmt(const parser::Statement<T> &stmt) {
@@ -102,6 +104,7 @@ class ProgramTree {
   const parser::ExecutionPart *exec_{nullptr};
   std::list<ProgramTree> children_;
   EntryStmtList entryStmts_;
+  GenericSpecList genericSpecs_;
   Scope *scope_{nullptr};
   const parser::CharBlock *endStmt_{nullptr};
   bool isSpecificationPartResolved_{false};

flang/lib/Semantics/resolve-names.cpp

@@ -7054,6 +7054,18 @@ void ResolveNamesVisitor::AddSubpNames(ProgramTree &node) {
       symbol.set(child.GetSubpFlag());
     }
   }
+  for (const auto &generic : node.genericSpecs()) {
+    if (const auto *name{std::get_if<parser::Name>(&generic->u)}) {
+      if (currScope().find(name->source) != currScope().end()) {
+        // If this scope has both a generic interface and a contained
+        // subprogram with the same name, create the generic's symbol
+        // now so that any other generics of the same name that are pulled
+        // into scope later via USE association will properly merge instead
+        // of raising a bogus error due a conflict with the subprogram.
+        CreateGeneric(*generic);
+      }
+    }
+  }
 }
 
 // Push a new scope for this node or return false on error.

flang/test/Semantics/resolve18.f90

@@ -182,3 +182,29 @@ end function f13
   function f13()
   end function f13
 end module m13
+
+! Not an error
+module m14
+  interface gen1
+    module procedure s
+  end interface
+  generic :: gen2 => s
+ contains
+  subroutine s(x)
+    integer(1) :: x
+  end subroutine s
+end module m14
+module m15
+  use m14
+  interface gen1
+    module procedure gen1
+  end interface
+  generic :: gen2 => gen2
+ contains
+  subroutine gen1(x)
+    integer(2) :: x
+  end subroutine gen1
+  subroutine gen2(x)
+    integer(4) :: x
+  end subroutine gen2
+end module m15