[flang] Improve handling of generics with same name as type or procedure

Create symbols for generics in a pre-pass over the specification part so
it is easier to handle cases when they have the same name as a derived
type or subprogram. This is done by calling `PreSpecificationConstruct`
on each `SpecificationConstruct` of a specification part before we
continue walking it. The generics symbols are created there and the same
mechanism will be used to handle forward references to derived types.

Report an error when the same name is used for a generic interface,
derived type, and subprogram.

Improve the error message issued when a procedure and generic interface
have the same name but the procedure is not a specific of the generic.

Change `SayAlreadyDeclared` to report the error on the second occurence
of the name when possible. This can arise for declarations the are
processed out of order, e.g. contained subprograms and generic interfaces.

Avoid multiple "already declared" errors for the case when a contained
subprogram has the same name as a declared entity. We first create the
symbol with SubprogramNameDetails, then replace it with the entity (and
report the error), then replace it with the real subprogram (and get the
error again). By setting and checking the error flag we avoid the second
error.

Original-commit: flang-compiler/f18@48fc076783
Reviewed-on: https://github.com/flang-compiler/f18/pull/614
Tree-same-pre-rewrite: false

flang/lib/semantics/resolve-names.cc

@@ -430,8 +430,9 @@ public:
 
   // Special messages: already declared; referencing symbol's declaration;
   // about a type; two names & locations
-  void SayAlreadyDeclared(const SourceName &, Symbol &);
   void SayAlreadyDeclared(const parser::Name &, Symbol &);
+  void SayAlreadyDeclared(const SourceName &, Symbol &);
+  void SayAlreadyDeclared(const SourceName &, const SourceName &);
   void SayWithReason(
       const parser::Name &, Symbol &, MessageFixedText &&, MessageFixedText &&);
   void SayWithDecl(const parser::Name &, Symbol &, MessageFixedText &&);
@@ -489,6 +490,7 @@ public:
     }
     if constexpr (std::is_same_v<DerivedTypeDetails, D>) {
       if (auto *d{symbol->detailsIf<GenericDetails>()}) {
+        if (!d->specific()) {
           // derived type with same name as a generic
           auto *derivedType{d->derivedType()};
           if (!derivedType) {
@@ -501,6 +503,7 @@ public:
           return *derivedType;
         }
       }
+    }
     if (symbol->CanReplaceDetails(details)) {
       // update the existing symbol
       symbol->attrs() |= attrs;
@@ -513,7 +516,9 @@ public:
       SayAlreadyDeclared(name, *symbol);
       // replace the old symbol with a new one with correct details
       EraseSymbol(*symbol);
-      return MakeSymbol(name, attrs, std::move(details));
+      auto &result{MakeSymbol(name, attrs, std::move(details))};
+      context().SetError(result);
+      return result;
     }
   }
 
@@ -1029,7 +1034,7 @@ public:
   template<typename T> bool Pre(const T &) { return true; }
   template<typename T> void Post(const T &) {}
 
-  void Post(const parser::SpecificationPart &);
+  bool Pre(const parser::SpecificationPart &);
   void Post(const parser::Program &);
   bool Pre(const parser::ImplicitStmt &);
   void Post(const parser::PointerObject &);
@@ -1065,6 +1070,9 @@ private:
   std::optional<Symbol::Flag> expectedProcFlag_;
   const SourceName *prevImportStmt_{nullptr};
 
+  void PreSpecificationConstruct(const parser::SpecificationConstruct &);
+  void CreateGeneric(const parser::GenericSpec &);
+  void FinishSpecificationPart();
   void CheckImports();
   void CheckImport(const SourceName &, const SourceName &);
   void HandleCall(Symbol::Flag, const parser::Call &);
@@ -1517,17 +1525,27 @@ void ScopeHandler::SayAlreadyDeclared(const parser::Name &name, Symbol &prev) {
   SayAlreadyDeclared(name.source, prev);
 }
 void ScopeHandler::SayAlreadyDeclared(const SourceName &name, Symbol &prev) {
-  auto &msg{
-      Say(name, "'%s' is already declared in this scoping unit"_err_en_US)};
-  if (const auto *details{prev.detailsIf<UseDetails>()}) {
-    msg.Attach(details->location(),
+  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(), details->module().name());
   } else {
-    msg.Attach(prev.name(), "Previous declaration of '%s'"_en_US, prev.name());
+    SayAlreadyDeclared(name, prev.name());
   }
   context().SetError(prev);
 }
+void ScopeHandler::SayAlreadyDeclared(
+    const SourceName &name1, const SourceName &name2) {
+  if (name1.begin() < name2.begin()) {
+    SayAlreadyDeclared(name2, name1);
+  } else {
+    Say(name1, "'%s' is already declared in this scoping unit"_err_en_US)
+        .Attach(name2, "Previous declaration of '%s'"_en_US, name2);
+  }
+}
 
 void ScopeHandler::SayWithReason(const parser::Name &name, Symbol &symbol,
     MessageFixedText &&msg1, MessageFixedText &&msg2) {
@@ -2067,65 +2085,9 @@ void InterfaceVisitor::Post(const parser::EndInterfaceStmt &) {
 
 // Create a symbol in genericSymbol_ for this GenericSpec.
 bool InterfaceVisitor::Pre(const parser::GenericSpec &x) {
-  auto info{GenericSpecInfo{x}};
-  const SourceName &symbolName{info.symbolName()};
-  if (IsLogicalConstant(context(), symbolName)) {
-    Say(symbolName,
-        "Logical constant '%s' may not be used as a defined operator"_err_en_US);
-    return false;
-  }
-  Symbol *symbol{currScope().FindSymbol(symbolName)};
-  if (symbol) {
-    if (symbol->has<DerivedTypeDetails>()) {
-      // A generic and derived type with same name: create a generic symbol
-      // and save derived type in it.
-      CHECK(symbol->scope()->symbol() == symbol);
-      GenericDetails details;
-      details.set_derivedType(*symbol);
-      EraseSymbol(*symbol);
-      symbol = &MakeSymbol(symbolName);
-      symbol->set_details(details);
-      // preserve access attributes
-      symbol->attrs() |=
-          details.derivedType()->attrs() & Attrs{Attr::PUBLIC, Attr::PRIVATE};
-    } else if (symbol->has<UnknownDetails>()) {
-      // okay
-    } else if (!symbol->IsSubprogram()) {
-      SayAlreadyDeclared(symbolName, *symbol);
-      EraseSymbol(*symbol);
-      symbol = nullptr;
-    } else if (symbol->has<UseDetails>()) {
-      // copy the USEd symbol into this scope so we can modify it
-      const Symbol &ultimate{symbol->GetUltimate()};
-      EraseSymbol(*symbol);
-      symbol = &CopySymbol(symbolName, ultimate);
-      if (const auto *details{ultimate.detailsIf<GenericDetails>()}) {
-        symbol->set_details(GenericDetails{details->specificProcs()});
-      } else if (const auto *details{ultimate.detailsIf<SubprogramDetails>()}) {
-        symbol->set_details(SubprogramDetails{*details});
-      } else {
-        DIE("unexpected kind of symbol");
-      }
-    }
-  }
-  if (!symbol || symbol->has<UnknownDetails>()) {
-    symbol = &MakeSymbol(symbolName);
-    symbol->set_details(GenericDetails{});
-  }
-  if (symbol->has<GenericDetails>()) {
-    // okay
-  } else if (symbol->has<SubprogramDetails>() ||
-      symbol->has<SubprogramNameDetails>()) {
-    GenericDetails genericDetails;
-    genericDetails.set_specific(*symbol);
-    EraseSymbol(*symbol);
-    symbol = &MakeSymbol(symbolName);
-    symbol->set_details(genericDetails);
-  } else {
-    common::die("unexpected kind of symbol");
-  }
-  info.Resolve(symbol);
+  if (auto *symbol{currScope().FindSymbol(GenericSpecInfo{x}.symbolName())}) {
     SetGenericSymbol(*symbol);
+  }
   return false;
 }
 
@@ -2237,7 +2199,14 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
   ResolveSpecificsInGeneric(generic);
   auto &details{generic.get<GenericDetails>()};
   if (auto *proc{details.CheckSpecific()}) {
-    SayAlreadyDeclared(generic.name(), *proc);
+    auto msg{
+        "'%s' may not be the name of both a generic interface and a"
+        " procedure unless it is a specific procedure of the generic"_err_en_US};
+    if (proc->name().begin() > generic.name().begin()) {
+      Say(proc->name(), std::move(msg));
+    } else {
+      Say(generic.name(), std::move(msg));
+    }
   }
   auto &specifics{details.specificProcs()};
   if (specifics.empty()) {
@@ -5027,7 +4996,77 @@ static bool NeedsExplicitType(const Symbol &symbol) {
   }
 }
 
-void ResolveNamesVisitor::Post(const parser::SpecificationPart &) {
+bool ResolveNamesVisitor::Pre(const parser::SpecificationPart &x) {
+  Walk(std::get<0>(x.t));
+  Walk(std::get<1>(x.t));
+  Walk(std::get<2>(x.t));
+  Walk(std::get<3>(x.t));
+  const std::list<parser::DeclarationConstruct> &decls{std::get<4>(x.t)};
+  for (const auto &decl : decls) {
+    if (const auto *spec{
+            std::get_if<parser::SpecificationConstruct>(&decl.u)}) {
+      PreSpecificationConstruct(*spec);
+    }
+  }
+  Walk(decls);
+  FinishSpecificationPart();
+  return false;
+}
+
+// Initial processing on specification constructs, before visiting them.
+void ResolveNamesVisitor::PreSpecificationConstruct(
+    const parser::SpecificationConstruct &spec) {
+  std::visit(
+      common::visitors{
+          [&](const Indirection<parser::DerivedTypeDef> &y) {},
+          [&](const parser::Statement<Indirection<parser::GenericStmt>> &y) {
+            CreateGeneric(std::get<parser::GenericSpec>(y.statement.value().t));
+          },
+          [&](const Indirection<parser::InterfaceBlock> &y) {
+            const auto &stmt{std::get<parser::Statement<parser::InterfaceStmt>>(
+                y.value().t)};
+            const auto *spec{std::get_if<std::optional<parser::GenericSpec>>(
+                &stmt.statement.u)};
+            if (spec && spec->has_value()) {
+              CreateGeneric(**spec);
+            }
+          },
+          [&](const auto &) {},
+      },
+      spec.u);
+}
+
+void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) {
+  auto info{GenericSpecInfo{x}};
+  const SourceName &symbolName{info.symbolName()};
+  if (IsLogicalConstant(context(), symbolName)) {
+    Say(symbolName,
+        "Logical constant '%s' may not be used as a defined operator"_err_en_US);
+    return;
+  }
+  GenericDetails genericDetails;
+  if (Symbol * existing{currScope().FindSymbol(symbolName)}) {
+    if (existing->has<GenericDetails>()) {
+      info.Resolve(existing);
+      return;  // already have generic, add to it
+    }
+    Symbol &ultimate{existing->GetUltimate()};
+    if (ultimate.has<GenericDetails>()) {
+      genericDetails.AddSpecificProcsFrom(ultimate);
+    } else if (ultimate.has<SubprogramDetails>() ||
+        ultimate.has<SubprogramNameDetails>()) {
+      genericDetails.set_specific(ultimate);
+    } else if (ultimate.has<DerivedTypeDetails>()) {
+      genericDetails.set_derivedType(ultimate);
+    } else {
+      SayAlreadyDeclared(symbolName, *existing);
+    }
+    EraseSymbol(*existing);
+  }
+  info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails)));
+}
+
+void ResolveNamesVisitor::FinishSpecificationPart() {
   badStmtFuncFound_ = false;
   CheckImports();
   bool inModule{currScope().kind() == Scope::Kind::Module};

flang/lib/semantics/rewrite-parse-tree.cc

@@ -57,6 +57,7 @@ public:
   // Don't bother resolving names in end statements.
   bool Pre(parser::EndBlockDataStmt &) { return false; }
   bool Pre(parser::EndFunctionStmt &) { return false; }
+  bool Pre(parser::EndInterfaceStmt &) { return false; }
   bool Pre(parser::EndModuleStmt &) { return false; }
   bool Pre(parser::EndMpSubprogramStmt &) { return false; }
   bool Pre(parser::EndProgramStmt &) { return false; }

flang/lib/semantics/symbol.cc

@@ -157,9 +157,11 @@ GenericDetails::GenericDetails(const SymbolVector &specificProcs)
 
 void GenericDetails::set_specific(Symbol &specific) {
   CHECK(!specific_);
+  CHECK(!derivedType_);
   specific_ = &specific;
 }
 void GenericDetails::set_derivedType(Symbol &derivedType) {
+  CHECK(!specific_);
   CHECK(!derivedType_);
   derivedType_ = &derivedType;
 }
@@ -417,6 +419,9 @@ std::ostream &operator<<(std::ostream &os, const Details &details) {
           [](const HostAssocDetails &) {},
           [&](const GenericDetails &x) {
             os << ' ' << EnumToString(x.kind());
+            DumpBool(os, "(specific)", x.specific() != nullptr);
+            DumpBool(os, "(derivedType)", x.derivedType() != nullptr);
+            os << " procs:";
             DumpSymbolVector(os, x.specificProcs());
           },
           [&](const ProcBindingDetails &x) {

flang/lib/semantics/symbol.h

@@ -402,11 +402,11 @@ public:
   void add_specificProc(const Symbol &proc) { specificProcs_.push_back(&proc); }
   void AddSpecificProcsFrom(const Symbol &generic);
 
+  // specific and derivedType indicate a specific procedure or derived type
+  // with the same name as this generic. Only one of them may be set.
   Symbol *specific() { return specific_; }
   const Symbol *specific() const { return specific_; }
   void set_specific(Symbol &specific);
-
-  // Derived type with same name as generic, if any.
   Symbol *derivedType() { return derivedType_; }
   const Symbol *derivedType() const { return derivedType_; }
   void set_derivedType(Symbol &derivedType);

flang/test/semantics/modfile07.f90

@@ -80,9 +80,6 @@ module m2
   interface foo
     procedure foo
   end interface
-  type :: foo
-    real :: x
-  end type
 contains
   complex function foo()
     foo = 1.0
@@ -91,9 +88,6 @@ end
 !Expect: m2.mod
 !module m2
 ! generic::foo=>foo
-! type::foo
-!  real(4)::x
-! end type
 !contains
 ! function foo()
 !  complex(4)::foo

flang/test/semantics/resolve17.f90

@@ -21,17 +21,16 @@ module m
 end module
 
 module m2
-  !Note: PGI and GNU allow this; Intel, NAG, and Sun do not
-  !ERROR: 's' is already declared in this scoping unit
   interface s
   end interface
 contains
+  !ERROR: 's' may not be the name of both a generic interface and a procedure unless it is a specific procedure of the generic
   subroutine s
   end subroutine
 end module
 
 module m3
-  ! This is okay: so is generic and specific
+  ! This is okay: s is generic and specific
   interface s
     procedure s2
   end interface

flang/test/semantics/resolve18.f90

@@ -1,4 +1,4 @@
-! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+! Copyright (c) 2018-2019, NVIDIA CORPORATION.  All rights reserved.
 !
 ! Licensed under the Apache License, Version 2.0 (the "License");
 ! you may not use this file except in compliance with the License.
@@ -24,7 +24,7 @@ end module
 module m2
   use m1
   implicit none
-  !ERROR: 'foo' is already declared in this scoping unit
+  !ERROR: 'foo' may not be the name of both a generic interface and a procedure unless it is a specific procedure of the generic
   interface foo
     module procedure s
   end interface
@@ -43,3 +43,36 @@ subroutine bar
   !ERROR: Cannot use-associate 'bar'; it is already declared in this scope
   use m1, bar => foo
 end
+
+!OK to use-associate a type with the same name as a generic
+module m3a
+  type :: foo
+  end type
+end
+module m3b
+  use m3a
+  interface foo
+  end interface
+end
+
+! Can't have derived type and function with same name
+module m4a
+  type :: foo
+  end type
+contains
+  !ERROR: 'foo' is already declared in this scoping unit
+  function foo(x)
+  end
+end
+! Even if there is also a generic interface of that name
+module m4b
+  type :: foo
+  end type
+  !ERROR: 'foo' is already declared in this scoping unit
+  interface foo
+    procedure :: foo
+  end interface foo
+contains
+  function foo(x)
+  end
+end

flang/test/semantics/resolve36.f90

@@ -49,7 +49,6 @@ module m2
     module integer function fun1()
     end function
   end interface
-  !ERROR: 't' is already declared in this scoping unit
   type t
   end type
   !ERROR: Declaration of 'i' conflicts with its use as module procedure
@@ -61,6 +60,7 @@ contains
   !ERROR: 'missing2' was not declared a separate module procedure
   module subroutine missing2
   end
+  !ERROR: 't' is already declared in this scoping unit
   !ERROR: 't' was not declared a separate module procedure
   module procedure t
   end