[flang-commits] [flang] 3968655 - [flang] Accommodate module subprograms defined in the same module
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Mar 2 13:07:28 PST 2022
Author: Peter Klausler
Date: 2022-03-02T13:07:16-08:00
New Revision: 396865576f9fabfd03d03249d0e1a97e3b49798d
URL: https://github.com/llvm/llvm-project/commit/396865576f9fabfd03d03249d0e1a97e3b49798d
DIFF: https://github.com/llvm/llvm-project/commit/396865576f9fabfd03d03249d0e1a97e3b49798d.diff
LOG: [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
Added:
flang/test/Semantics/separate-mp03.f90
Modified:
flang/include/flang/Semantics/symbol.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/symbol.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/nullify02.f90
flang/test/Semantics/separate-mp02.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index b9d041e335039..40753a8c084a4 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/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 &);
};
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index fdbbcaba55ae6..830342dc565e0 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/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,
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 544b5d333e458..4da150599c88a 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/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();
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 14cd9ef724867..ad80f901fb72c 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/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;
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index b2de64efc8862..1a2d931825bf4 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/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;
}
}
}
diff --git a/flang/test/Semantics/nullify02.f90 b/flang/test/Semantics/nullify02.f90
index 81d108ac6d220..92126dce7d85e 100644
--- a/flang/test/Semantics/nullify02.f90
+++ b/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
diff --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90
index 576a3b4825d75..b1f2a0dfb0e29 100644
--- a/flang/test/Semantics/separate-mp02.f90
+++ b/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'
diff --git a/flang/test/Semantics/separate-mp03.f90 b/flang/test/Semantics/separate-mp03.f90
new file mode 100644
index 0000000000000..33bf1cf8e414f
--- /dev/null
+++ b/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
More information about the flang-commits
mailing list