[flang] Accommodate module subprograms defined in the same module

[klausler]

Summary

The symbol table, name resolution, and semantic checks for module
subprograms -- esp. for MODULE FUNCTION and MODULE SUBROUTINE, but
also MODULE PROCEDURE -- essentially assumed that the subprogram
would be defined in a submodule of the (sub)module containing its
interface. However, it is conforming to instead declare a module
subprogram in the *same* (sub)module as its interface, and we need
to handle that case.

Since this case involves two symbols in the same scope with the same
name, the symbol table details for subprograms have been extended
with a pointer to the original module interface, rather than relying
on searching in scopes.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Semantics/symbol.h

void set_result(Symbol &result) {
     CHECK(!result_);
     result_ = &result;
   }
   const std::vector<Symbol *> &dummyArgs() const { return dummyArgs_; }
   void add_dummyArg(Symbol &symbol) { dummyArgs_.push_back(&symbol); }
   void add_alternateReturn() { dummyArgs_.push_back(nullptr); }
   const MaybeExpr &stmtFunction() const { return stmtFunction_; }
   void set_stmtFunction(SomeExpr &&expr) { stmtFunction_ = std::move(expr); }
+  Symbol *moduleInterface() { return moduleInterface_; }
+  const Symbol *moduleInterface() const { return moduleInterface_; }
+  void set_moduleInterface(Symbol &);
 
 private:
   bool isInterface_{false}; // true if this represents an interface-body
   bool isDummy_{false}; // true when interface of dummy procedure
   std::vector<Symbol *> dummyArgs_; // nullptr -> alternate return indicator
   Symbol *result_{nullptr};
   Scope *entryScope_{nullptr}; // if ENTRY, points to subprogram's scope
   MaybeExpr stmtFunction_;
+  // For MODULE FUNCTION or SUBROUTINE, this is the symbol of its declared
+  // interface.  For MODULE PROCEDURE, this is the declared interface if it
+  // appeared in an ancestor (sub)module.
+  Symbol *moduleInterface_{nullptr};
+
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const SubprogramDetails &);
 };
 
 // For SubprogramNameDetails, the kind indicates whether it is the name
 // of a module subprogram or an internal subprogram or ENTRY.
 ENUM_CLASS(SubprogramKind, Module, Internal)
 

flang/lib/Semantics/check-declarations.cpp

Say(symbol1, symbol2,
         " interface body has '%s'"_err_en_US,
         *details1.bindName(), *details2.bindName());
   }
   const Procedure *proc1{checkHelper.Characterize(symbol1)};
   const Procedure *proc2{checkHelper.Characterize(symbol2)};
   if (!proc1 || !proc2) {
     return;
   }
+  if (proc1->attrs.test(Procedure::Attr::Pure) !=
+      proc2->attrs.test(Procedure::Attr::Pure)) {
+    Say(symbol1, symbol2,
+        "Module subprogram '%s' and its corresponding interface body are not both PURE"_err_en_US);
+  }
+  if (proc1->attrs.test(Procedure::Attr::Elemental) !=
+      proc2->attrs.test(Procedure::Attr::Elemental)) {
+    Say(symbol1, symbol2,
+        "Module subprogram '%s' and its corresponding interface body are not both ELEMENTAL"_err_en_US);
+  }
+  if (proc1->attrs.test(Procedure::Attr::BindC) !=
+      proc2->attrs.test(Procedure::Attr::BindC)) {
+    Say(symbol1, symbol2,
+        "Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US);
+  }
   if (proc1->functionResult && proc2->functionResult &&
       *proc1->functionResult != *proc2->functionResult) {
     Say(symbol1, symbol2,
         "Return type of function '%s' does not match return type of"
         " the corresponding interface body"_err_en_US);
   }
   for (int i{0}; i < nargs1; ++i) {
     const Symbol *arg1{args1[i]};

flang/lib/Semantics/resolve-names.cpp

bool SubprogramVisitor::BeginMpSubprogram(const parser::Name &name) {
   auto *symbol{FindSymbol(name)};
   if (symbol && symbol->has<SubprogramNameDetails>()) {
     symbol = FindSymbol(currScope().parent(), name);
   }
   if (!IsSeparateModuleProcedureInterface(symbol)) {
     Say(name, "'%s' was not declared a separate module procedure"_err_en_US);
     return false;
   }
-  if (symbol->owner() == currScope()) {
-    PushScope(Scope::Kind::Subprogram, symbol);
+  if (symbol->owner() == currScope() && symbol->scope()) {
+    // This is a MODULE PROCEDURE whose interface appears in its host.
+    // Convert the module procedure's interface into a subprogram.
+    SetScope(DEREF(symbol->scope()));
+    symbol->get<SubprogramDetails>().set_isInterface(false);
+    if (IsFunction(*symbol)) {
+      funcInfoStack_.emplace_back(); // just to be popped later
+    }
   } else {
+    // Copy the interface into a new subprogram scope.
     Symbol &newSymbol{MakeSymbol(name, SubprogramDetails{})};
     PushScope(Scope::Kind::Subprogram, &newSymbol);
     const auto &details{symbol->get<SubprogramDetails>()};
     auto &newDetails{newSymbol.get<SubprogramDetails>()};
+    newDetails.set_moduleInterface(*symbol);
     for (const Symbol *dummyArg : details.dummyArgs()) {
       if (!dummyArg) {
         newDetails.add_alternateReturn();
       } else if (Symbol * copy{currScope().CopySymbol(*dummyArg)}) {
         newDetails.add_dummyArg(*copy);
       }
     }
     if (details.isFunction()) {

 bool SubprogramVisitor::BeginSubprogram(
     const parser::Name &name, Symbol::Flag subpFlag, bool hasModulePrefix) {
   if (hasModulePrefix && currScope().IsGlobal()) { // C1547
     Say(name,
         "'%s' is a MODULE procedure which must be declared within a "
         "MODULE or SUBMODULE"_err_en_US);
     return false;
   }
-
-  if (hasModulePrefix && !inInterfaceBlock() &&
-      !IsSeparateModuleProcedureInterface(
-          FindSymbol(currScope().parent(), name))) {
-    Say(name, "'%s' was not declared a separate module procedure"_err_en_US);
+  Symbol *moduleInterface{nullptr};
+  if (hasModulePrefix && !inInterfaceBlock()) {
+    moduleInterface = FindSymbol(currScope(), name);
+    if (IsSeparateModuleProcedureInterface(moduleInterface)) {
+      // Subprogram is MODULE FUNCTION or MODULE SUBROUTINE with an interface
+      // previously defined in the same scope.
+      currScope().erase(moduleInterface->name());
+    } else {
+      moduleInterface = nullptr;
+    }
+    if (!moduleInterface) {
+      moduleInterface = FindSymbol(currScope().parent(), name);
+      if (!IsSeparateModuleProcedureInterface(moduleInterface)) {
+        Say(name,
+            "'%s' was not declared a separate module procedure"_err_en_US);
         return false;
       }
-  PushSubprogramScope(name, subpFlag);
+    }
+  }
+  Symbol &newSymbol{PushSubprogramScope(name, subpFlag)};
+  if (moduleInterface) {
+    newSymbol.get<SubprogramDetails>().set_moduleInterface(*moduleInterface);
+    if (moduleInterface->attrs().test(Attr::PRIVATE)) {
+      newSymbol.attrs().set(Attr::PRIVATE);
+    } else if (moduleInterface->attrs().test(Attr::PUBLIC)) {
+      newSymbol.attrs().set(Attr::PUBLIC);
+    }
+  }
   if (IsFunction(currScope())) {
     funcInfoStack_.emplace_back();
   }
   return true;
 }
 
 void SubprogramVisitor::EndSubprogram() {
   if (IsFunction(currScope())) {

 
 // Add SubprogramNameDetails symbols for module and internal subprograms and
 // their ENTRY statements.
 void ResolveNamesVisitor::AddSubpNames(ProgramTree &node) {
   auto kind{
       node.IsModule() ? SubprogramKind::Module : SubprogramKind::Internal};
   for (auto &child : node.children()) {
     auto &symbol{MakeSymbol(child.name(), SubprogramNameDetails{kind, child})};
-    symbol.set(child.GetSubpFlag());
+    auto childKind{child.GetKind()};
+    if (childKind == ProgramTree::Kind::Function) {
+      symbol.set(Symbol::Flag::Function);
+    } else if (childKind == ProgramTree::Kind::Subroutine) {
+      symbol.set(Symbol::Flag::Subroutine);
+    }
     for (const auto &entryStmt : child.entryStmts()) {
       SubprogramNameDetails details{kind, child};
       details.set_isEntryStmt();
       auto &symbol{
           MakeSymbol(std::get<parser::Name>(entryStmt->t), std::move(details))};
       symbol.set(child.GetSubpFlag());
     }
   }

flang/lib/Semantics/symbol.cpp

if (!list.empty()) {
     char sep{' '};
     for (const auto &elem : list) {
       os << sep << elem;
       sep = ',';
     }
   }
 }
 
+void SubprogramDetails::set_moduleInterface(Symbol &symbol) {
+  CHECK(!moduleInterface_);
+  moduleInterface_ = &symbol;
+}
+
 const Scope *ModuleDetails::parent() const {
   return isSubmodule_ && scope_ ? &scope_->parent() : nullptr;
 }
 const Scope *ModuleDetails::ancestor() const {
   return isSubmodule_ && scope_ ? FindModuleContaining(*scope_) : nullptr;
 }
 void ModuleDetails::set_scope(const Scope *scope) {
   CHECK(!scope_);
for (const Symbol *arg : x.dummyArgs_) {
     } else {
       os << '*';
     }
   }
   os << (sep == '(' ? "()" : ")");
   if (x.stmtFunction_) {
     os << " -> " << x.stmtFunction_->AsFortran();
   }
+  if (x.moduleInterface_) {
+    os << " moduleInterface: " << *x.moduleInterface_;
+  }
   return os;
 }
 
 void EntityDetails::set_type(const DeclTypeSpec &type) {
   CHECK(!type_);
   type_ = &type;
 }
 

flang/lib/Semantics/tools.cpp

const DeclTypeSpec &FindOrInstantiateDerivedType(
   // for this particular distinct set of actual parameter values.
   DeclTypeSpec &type{scope.MakeDerivedType(category, std::move(spec))};
   type.derivedTypeSpec().Instantiate(scope);
   return type;
 }
 
 const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) {
   if (proc) {
-    if (const Symbol * submodule{proc->owner().symbol()}) {
-      if (const auto *details{submodule->detailsIf<ModuleDetails>()}) {
-        if (const Scope * ancestor{details->ancestor()}) {
-          const Symbol *iface{ancestor->FindSymbol(proc->name())};
-          if (IsSeparateModuleProcedureInterface(iface)) {
-            return iface;
-          }
-        }
-      }
-    }
-  }
+    if (const auto *subprogram{proc->detailsIf<SubprogramDetails>()}) {
+      if (const Symbol * iface{subprogram->moduleInterface()}) {
   return nullptr;
 }
 
 ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
   const Symbol &ultimate{symbol.GetUltimate()};
   if (ultimate.attrs().test(Attr::INTRINSIC)) {
     return ProcedureDefinitionClass::Intrinsic;
   } else if (ultimate.attrs().test(Attr::EXTERNAL)) {

flang/test/Semantics/nullify02.f90

 Nullify(maxvalue)
 
 End Program
 
 ! Make sure that the compiler doesn't crash when NULLIFY is used in a context
 ! that has reported errors
 module badNullify
   interface
-    module function ptrFun()
+    function ptrFun()
       integer, pointer :: ptrFun
     end function
   end interface
 contains
   !ERROR: 'ptrfun' was not declared a separate module procedure
   module function ptrFun()
     integer, pointer :: ptrFun
     real :: realVar
     nullify(ptrFun)
     nullify(realVar)
   end function
 end module

flang/test/Semantics/separate-mp02.f90

interface
     end
   end interface
 end
 
 submodule(m2b) sm2b
   character(*), parameter :: suffix = "_xxx"
 contains
   !ERROR: Module subprogram 's1' has a binding label but the corresponding interface body does not
+  !ERROR: Module subprogram 's1' and its corresponding interface body are not both BIND(C)
   module subroutine s1() bind(c, name="s1")
   end
   !ERROR: Module subprogram 's2' does not have a binding label but the corresponding interface body does
+  !ERROR: Module subprogram 's2' and its corresponding interface body are not both BIND(C)
   module subroutine s2()
   end
   !ERROR: Module subprogram 's3' has binding label 's3_xxx' but the corresponding interface body has 's3'
   module subroutine s3() bind(c, name="s3" // suffix)
   end
   module subroutine s4() bind(c, name="s4  ")
   end
   module subroutine s5() bind(c, name=" s5")

flang/test/Semantics/separate-mp03.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests module procedures declared and defined in the same module.
+
+! These cases are correct.
+module m1
+  interface
+    integer module function f1(x)
+      real, intent(in) :: x
+    end function
+    integer module function f2(x)
+      real, intent(in) :: x
+    end function
+    module function f3(x) result(res)
+      integer :: res
+      real, intent(in) :: x
+    end function
+    module function f4(x) result(res)
+      integer :: res
+      real, intent(in) :: x
+    end function
+    module subroutine s1
+    end subroutine
+    pure module subroutine s2
+    end subroutine
+    module subroutine s3
+    end subroutine
+  end interface
+ contains
+  integer module function f1(x)
+    real, intent(in) :: x
+    f1 = x
+  end function
+  module procedure f2
+    f2 = x
+  end procedure
+  module function f3(x) result(res)
+    integer :: res
+    real, intent(in) :: x
+    res = x
+  end function
+  module procedure f4
+    res = x
+  end procedure
+  module subroutine s1
+  end subroutine
+  pure module subroutine s2
+  end subroutine
+  module procedure s3
+  end procedure
+end module
+
+! Error cases
+
+module m2
+  interface
+    integer module function f1(x)
+      real, intent(in) :: x
+    end function
+    integer module function f2(x)
+      real, intent(in) :: x
+    end function
+    module function f3(x) result(res)
+      integer :: res
+      real, intent(in) :: x
+    end function
+    module function f4(x) result(res)
+      integer :: res
+      real, intent(in) :: x
+    end function
+    module subroutine s1
+    end subroutine
+    pure module subroutine s2
+    end subroutine
+  end interface
+ contains
+  integer module function f1(x)
+    !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has type REAL(4)
+    integer, intent(in) :: x
+    f1 = x
+  end function
+  !ERROR: 'notf2' was not declared a separate module procedure
+  module procedure notf2
+  end procedure
+  !ERROR: Return type of function 'f3' does not match return type of the corresponding interface body
+  module function f3(x) result(res)
+    real :: res
+    real, intent(in) :: x
+    res = x
+  end function
+  !ERROR: Module subroutine 'f4' was declared as a function in the corresponding interface body
+  module subroutine f4
+  end subroutine
+  !ERROR: Module function 's1' was declared as a subroutine in the corresponding interface body
+  module function s1
+  end function
+  !ERROR: Module subprogram 's2' and its corresponding interface body are not both PURE
+  impure module subroutine s2
+  end subroutine
+end module