[flang] Accommodate module subprograms defined in the same module

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.

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

flang/include/flang/Semantics/symbol.h

@@ -94,6 +94,9 @@ class SubprogramDetails : public WithBindName {
   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
@@ -102,6 +105,11 @@ class SubprogramDetails : public WithBindName {
   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 &);
 };

flang/lib/Semantics/check-declarations.cpp

@@ -2136,6 +2136,21 @@ void SubprogramMatchHelper::Check(
   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,

flang/lib/Semantics/resolve-names.cpp

@@ -3317,13 +3317,21 @@ bool SubprogramVisitor::BeginMpSubprogram(const parser::Name &name) {
     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();
@@ -3349,14 +3357,34 @@ bool SubprogramVisitor::BeginSubprogram(
         "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);
-    return false;
+  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;
+      }
+    }
+  }
+  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);
+    }
   }
-  PushSubprogramScope(name, subpFlag);
   if (IsFunction(currScope())) {
     funcInfoStack_.emplace_back();
   }
@@ -7059,7 +7087,12 @@ void ResolveNamesVisitor::AddSubpNames(ProgramTree &node) {
       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();

flang/lib/Semantics/symbol.cpp

@@ -70,6 +70,11 @@ static void DumpList(llvm::raw_ostream &os, const char *label, const T &list) {
   }
 }
 
+void SubprogramDetails::set_moduleInterface(Symbol &symbol) {
+  CHECK(!moduleInterface_);
+  moduleInterface_ = &symbol;
+}
+
 const Scope *ModuleDetails::parent() const {
   return isSubmodule_ && scope_ ? &scope_->parent() : nullptr;
 }
@@ -117,6 +122,9 @@ llvm::raw_ostream &operator<<(
   if (x.stmtFunction_) {
     os << " -> " << x.stmtFunction_->AsFortran();
   }
+  if (x.moduleInterface_) {
+    os << " moduleInterface: " << *x.moduleInterface_;
+  }
   return os;
 }
 

flang/lib/Semantics/tools.cpp

@@ -1058,14 +1058,9 @@ const DeclTypeSpec &FindOrInstantiateDerivedType(
 
 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 iface;
       }
     }
   }

flang/test/Semantics/nullify02.f90

@@ -34,7 +34,7 @@
 ! that has reported errors
 module badNullify
   interface
-    module function ptrFun()
+    function ptrFun()
       integer, pointer :: ptrFun
     end function
   end interface

flang/test/Semantics/separate-mp02.f90

@@ -149,9 +149,11 @@ module subroutine s6() bind(c)
   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'

flang/test/Semantics/separate-mp03.f90

@@ -0,0 +1,99 @@
+! 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