[flang-commits] [flang] 17f32bd - [flang] Fix checking of TBP bindings
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Mar 10 09:59:14 PST 2023
Author: Peter Klausler
Date: 2023-03-10T09:59:06-08:00
New Revision: 17f32bdd37363c1b1f14a263b160345d4a0804bd
URL: https://github.com/llvm/llvm-project/commit/17f32bdd37363c1b1f14a263b160345d4a0804bd
DIFF: https://github.com/llvm/llvm-project/commit/17f32bdd37363c1b1f14a263b160345d4a0804bd.diff
LOG: [flang] Fix checking of TBP bindings
Non-DEFERRED procedure binding checking can't blindly accept
all procedures defined in modules -- they can't be ABSTRACT
interfaces. And GetUltimate() must be used rather than
FindSubprogram(); the latter will resolve to a procedure's
interface in the case of "procedure(interface) :: external",
not "external".
Differential Revision: https://reviews.llvm.org/D145749
Added:
Modified:
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/resolve32.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 6a480b44d5a8a..e2a771251e6b5 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -337,6 +337,7 @@ class ProcBindingDetails : public WithPassArg {
public:
explicit ProcBindingDetails(const Symbol &symbol) : symbol_{symbol} {}
const Symbol &symbol() const { return symbol_; }
+ void ReplaceSymbol(const Symbol &symbol) { symbol_ = symbol; }
private:
SymbolRef symbol_; // procedure bound to; may be forward
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index a652ac94b025d..2de6e1f8c9ddd 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -108,7 +108,7 @@ bool IsBindCProcedure(const Scope &);
// Returns a pointer to the function's symbol when true, else null
const Symbol *IsFunctionResultWithSameNameAsFunction(const Symbol &);
bool IsOrContainsEventOrLockComponent(const Symbol &);
-bool CanBeTypeBoundProc(const Symbol *);
+bool CanBeTypeBoundProc(const Symbol &);
// Does a non-PARAMETER symbol have explicit initialization with =value or
// =>target in its declaration (but not in a DATA statement)? (Being
// ALLOCATABLE or having a derived type with default component initialization
@@ -253,7 +253,7 @@ const Symbol *FindExternallyVisibleObject(
expr.u);
}
-// Apply GetUltimate(), then if the symbol is a generic procedure shadowing a
+// Applies GetUltimate(), then if the symbol is a generic procedure shadowing a
// specific procedure of the same name, return it instead.
const Symbol &BypassGeneric(const Symbol &);
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index f90a4862c4b12..f5bbced783fc7 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -4000,9 +4000,8 @@ Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name,
}
if (isGeneric()) {
Symbol &genericSymbol{GetGenericSymbol()};
- if (genericSymbol.has<GenericDetails>()) {
- genericSymbol.get<GenericDetails>().AddSpecificProc(
- *symbol, name.source);
+ if (auto *details{genericSymbol.detailsIf<GenericDetails>()}) {
+ details->AddSpecificProc(*symbol, name.source);
} else {
CHECK(context().HasError(genericSymbol));
}
@@ -5147,8 +5146,8 @@ void DeclarationVisitor::Post(
procedure = NoteInterfaceName(procedureName);
}
if (procedure) {
- if (auto *s{
- MakeTypeSymbol(bindingName, ProcBindingDetails{*procedure})}) {
+ const Symbol &bindTo{BypassGeneric(*procedure)};
+ if (auto *s{MakeTypeSymbol(bindingName, ProcBindingDetails{bindTo})}) {
SetPassNameOn(*s);
if (GetAttrs().test(Attr::DEFERRED)) {
context().SetError(*s);
@@ -5165,7 +5164,11 @@ void DeclarationVisitor::CheckBindings(
auto &bindingName{std::get<parser::Name>(declaration.t)};
if (Symbol * binding{FindInScope(bindingName)}) {
if (auto *details{binding->detailsIf<ProcBindingDetails>()}) {
- const Symbol *procedure{FindSubprogram(details->symbol())};
+ const Symbol &ultimate{details->symbol().GetUltimate()};
+ const Symbol &procedure{BypassGeneric(ultimate)};
+ if (&procedure != &ultimate) {
+ details->ReplaceSymbol(procedure);
+ }
if (!CanBeTypeBoundProc(procedure)) {
if (details->symbol().name() != binding->name()) {
Say(binding->name(),
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 25d1f6c9fa490..b4178975f567b 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -611,16 +611,19 @@ bool IsOrContainsEventOrLockComponent(const Symbol &original) {
}
// Check this symbol suitable as a type-bound procedure - C769
-bool CanBeTypeBoundProc(const Symbol *symbol) {
- if (!symbol || IsDummy(*symbol) || IsProcedurePointer(*symbol)) {
+bool CanBeTypeBoundProc(const Symbol &symbol) {
+ if (IsDummy(symbol) || IsProcedurePointer(symbol)) {
return false;
- } else if (symbol->has<SubprogramNameDetails>()) {
- return symbol->owner().kind() == Scope::Kind::Module;
- } else if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
- return symbol->owner().kind() == Scope::Kind::Module ||
- details->isInterface();
- } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
- return !symbol->attrs().test(Attr::INTRINSIC) &&
+ } else if (symbol.has<SubprogramNameDetails>()) {
+ return symbol.owner().kind() == Scope::Kind::Module;
+ } else if (auto *details{symbol.detailsIf<SubprogramDetails>()}) {
+ if (details->isInterface()) {
+ return !symbol.attrs().test(Attr::ABSTRACT);
+ } else {
+ return symbol.owner().kind() == Scope::Kind::Module;
+ }
+ } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+ return !symbol.attrs().test(Attr::INTRINSIC) &&
proc->HasExplicitInterface();
} else {
return false;
diff --git a/flang/test/Semantics/resolve32.f90 b/flang/test/Semantics/resolve32.f90
index 060b29ec40b5a..948493b1615e6 100644
--- a/flang/test/Semantics/resolve32.f90
+++ b/flang/test/Semantics/resolve32.f90
@@ -18,6 +18,10 @@ module m
subroutine foo
end subroutine
end interface
+ abstract interface
+ subroutine absfoo
+ end subroutine
+ end interface
integer :: i
type t1
integer :: c
@@ -34,6 +38,8 @@ subroutine foo
!ERROR: 's3' must be either an accessible module procedure or an external procedure with an explicit interface
procedure, nopass :: s3
procedure, nopass :: foo
+ !ERROR: 'absfoo' must be either an accessible module procedure or an external procedure with an explicit interface
+ procedure, nopass :: absfoo
!ERROR: 'bar' must be either an accessible module procedure or an external procedure with an explicit interface
procedure, nopass :: bar
!ERROR: 'i' must be either an accessible module procedure or an external procedure with an explicit interface
More information about the flang-commits
mailing list