[flang] Prohibit multiple separate module procedure definitions

[klausler]

Summary

Ensure that non-BIND(C) separate module procedures are not
defined more than once.

flang/lib/Semantics/check-declarations.cpp

private:
   struct TypeWithDefinedIo {
     const DerivedTypeSpec &type;
     GenericKind::DefinedIo ioKind;
     const Symbol &proc;
     const Symbol &generic;
   };
   void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &,
       GenericKind::DefinedIo, const Symbol &, const Symbol &generic);
+  void CheckModuleProcedureDef(const Symbol &);
 
   SemanticsContext &context_;
   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
   parser::ContextualMessages &messages_{foldingContext_.messages()};
   const Scope *scope_{nullptr};
   bool scopeIsUninstantiatedPDT_{false};
   // This symbol is the one attached to the innermost enclosing scope
   // that has a symbol.
   const Symbol *innermostSymbol_{nullptr};
   // Cache of calls to Procedure::Characterize(Symbol)
   std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
       characterizeCache_;
   // Collection of symbols with BIND(C) names
   std::map<std::string, SymbolRef> bindC_;
+  // Collection of module procedure symbols with non-BIND(C)
+  // global names, qualified by their module.
+  std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
   // Derived types that have defined input/output procedures
   std::vector<TypeWithDefinedIo> seenDefinedIoTypes_;
 };
 
 class DistinguishabilityHelper {
 public:
   DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
   void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
void CheckHelper::CheckSubprogram(
   if (details.isInterface()) {
     if (!details.isDummy() && details.isFunction() &&
         IsAssumedLengthCharacter(details.result())) { // C721
       messages_.Say(details.result().name(),
           "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
     }
   }
   CheckLocalVsGlobal(symbol);
+  CheckModuleProcedureDef(symbol);
 }
 
 void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) {
   if (IsProcedure(symbol) && IsExternal(symbol)) {
     if (const Symbol *global{FindGlobal(symbol)}; global && global != &symbol) {
       std::string interfaceName{symbol.name().ToString()};
       if (const auto *bind{symbol.GetBindName()}) {
         interfaceName = *bind;
common::visit(common::visitors{
                     [&](const GenericKind::OtherKind &other) {
                       if (other == GenericKind::OtherKind::Name) {
                         CheckGenericVsIntrinsic(symbol, details);
                       }
                     },
                     [](const auto &) {},
                 },
       details.kind().u);
+  // Ensure that shadowed symbols are checked
+  if (details.specific()) {
+    Check(*details.specific());
+  }
+  if (details.derivedType()) {
+    Check(*details.derivedType());
+  }
 }
 
 // Check that the specifics of this generic are distinguishable from each other
 void CheckHelper::CheckSpecificsAreDistinguishable(
     const Symbol &generic, const GenericDetails &details) {
   GenericKind kind{details.kind()};
   if (!kind.IsName()) {
     return;
if (auto dyType{evaluate::DynamicType::From(symbol)}) {
         messages_.Say(
             "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
             symbol.name(), dyType->AsFortran());
       }
     }
   }
 }
 
+void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {
+  auto procClass{ClassifyProcedure(symbol)};
+  if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
+      subprogram &&
+      (procClass == ProcedureDefinitionClass::Module &&
+          symbol.attrs().test(Attr::MODULE)) &&
+      !subprogram->bindName() && !subprogram->isInterface()) {
+    const Symbol *module{nullptr};
+    if (const Scope * moduleScope{FindModuleContaining(symbol.owner())};
+        moduleScope && moduleScope->symbol()) {
+      if (const auto *details{
+              moduleScope->symbol()->detailsIf<ModuleDetails>()}) {
+        if (details->parent()) {
+          moduleScope = details->parent();
+        }
+        module = moduleScope->symbol();
+      }
+    }
+    if (module) {
+      std::pair<SourceName, const Symbol *> key{symbol.name(), module};
+      auto iter{moduleProcs_.find(key)};
+      if (iter == moduleProcs_.end()) {
+        moduleProcs_.emplace(std::move(key), symbol);
+      } else if (
+          auto *msg{messages_.Say(symbol.name(),
+              "Module procedure '%s' in module '%s' has multiple definitions"_err_en_US,
+              symbol.name(), module->name())}) {
+        msg->Attach(iter->second->name(), "Previous definition of '%s'"_en_US,
+            symbol.name());
+      }
+    }
+  }
+}
+
 void SubprogramMatchHelper::Check(
     const Symbol &symbol1, const Symbol &symbol2) {
   const auto details1{symbol1.get<SubprogramDetails>()};
   const auto details2{symbol2.get<SubprogramDetails>()};
   if (details1.isFunction() != details2.isFunction()) {
     Say(symbol1, symbol2,
         details1.isFunction()
             ? "Module function '%s' was declared as a subroutine in the"

flang/lib/Semantics/resolve-names.cpp

for (const auto &dummyArg : std::get<std::list<parser::DummyArg>>(stmt.t)) {
     }
   }
 }
 
 Symbol *ScopeHandler::FindSeparateModuleProcedureInterface(
     const parser::Name &name) {
   auto *symbol{FindSymbol(name)};
   if (symbol && symbol->has<SubprogramNameDetails>()) {
-    symbol = FindSymbol(currScope().parent(), name);
+    const Scope *parent{nullptr};
+    if (currScope().IsSubmodule()) {
+      parent = currScope().symbol()->get<ModuleDetails>().parent();
+    }
+    symbol = parent ? FindSymbol(*parent, name) : nullptr;
   }
   if (symbol) {
     if (auto *generic{symbol->detailsIf<GenericDetails>()}) {
       symbol = generic->specific();
     }
   }
+  if (const Symbol * defnIface{FindSeparateModuleSubprogramInterface(symbol)}) {
+    // Error recovery in case of multiple definitions
+    symbol = const_cast<Symbol *>(defnIface);
+  }
   if (!IsSeparateModuleProcedureInterface(symbol)) {
     Say(name, "'%s' was not declared a separate module procedure"_err_en_US);
     symbol = nullptr;
   }
   return symbol;
 }
 
 // A subprogram declared with MODULE PROCEDURE

flang/lib/Semantics/scope.cpp

Scope::size_type Scope::erase(const SourceName &name) {
   } else {
     return 0;
   }
 }
 Symbol *Scope::FindSymbol(const SourceName &name) const {
   auto it{find(name)};
   if (it != end()) {
     return &*it->second;
+  } else if (IsSubmodule()) {
+    const Scope *parent{symbol_->get<ModuleDetails>().parent()};
+    return parent ? parent->FindSymbol(name) : nullptr;
   } else if (CanImport(name)) {
     return parent_.FindSymbol(name);
   } else {
     return nullptr;
   }
 }
 
 Symbol *Scope::FindComponent(SourceName name) const {

flang/test/Semantics/separate-mp04.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Checks for multiple module procedure definitions
+
+module m1
+  interface
+    module subroutine x001
+    end subroutine
+    module subroutine x002
+    end subroutine
+    module subroutine x003
+    end subroutine
+  end interface
+end
+
+submodule(m1) sm1
+  interface
+    module subroutine x004
+    end subroutine
+  end interface
+ contains
+  module procedure x001 ! fine
+  end procedure
+  module subroutine x002
+  end subroutine
+  module subroutine x003
+  end subroutine
+end
+
+submodule(m1) sm2
+ contains
+  !ERROR: Module procedure 'x002' in module 'm1' has multiple definitions
+  module subroutine x002
+  end subroutine
+end
+
+submodule(m1:sm2) sm3
+ contains
+  !ERROR: Module procedure 'x002' in module 'm1' has multiple definitions
+  module subroutine x002
+  end subroutine
+  !ERROR: Module procedure 'x003' in module 'm1' has multiple definitions
+  module subroutine x003
+  end subroutine
+end
+
+submodule(m1:sm1) sm4
+ contains
+  module subroutine x004
+  end subroutine
+end
+
+submodule(m1:sm1) sm5
+ contains
+  !ERROR: Module procedure 'x004' in module 'm1' has multiple definitions
+  module subroutine x004
+  end subroutine
+end