From 17f32bdd37363c1b1f14a263b160345d4a0804bd Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Mon, 6 Mar 2023 17:32:12 -0800 Subject: [PATCH] [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 --- flang/include/flang/Semantics/symbol.h | 1 + flang/include/flang/Semantics/tools.h | 4 ++-- flang/lib/Semantics/resolve-names.cpp | 15 +++++++++------ flang/lib/Semantics/tools.cpp | 21 ++++++++++++--------- flang/test/Semantics/resolve32.f90 | 6 ++++++ 5 files changed, 30 insertions(+), 17 deletions(-) diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 6a480b4..e2a7712 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 a652ac9..2de6e1f 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 f90a486..f5bbced 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()) { - genericSymbol.get().AddSpecificProc( - *symbol, name.source); + if (auto *details{genericSymbol.detailsIf()}) { + 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(declaration.t)}; if (Symbol * binding{FindInScope(bindingName)}) { if (auto *details{binding->detailsIf()}) { - 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 25d1f6c..b417897 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()) { - return symbol->owner().kind() == Scope::Kind::Module; - } else if (auto *details{symbol->detailsIf()}) { - return symbol->owner().kind() == Scope::Kind::Module || - details->isInterface(); - } else if (const auto *proc{symbol->detailsIf()}) { - return !symbol->attrs().test(Attr::INTRINSIC) && + } else if (symbol.has()) { + return symbol.owner().kind() == Scope::Kind::Module; + } else if (auto *details{symbol.detailsIf()}) { + if (details->isInterface()) { + return !symbol.attrs().test(Attr::ABSTRACT); + } else { + return symbol.owner().kind() == Scope::Kind::Module; + } + } else if (const auto *proc{symbol.detailsIf()}) { + 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 060b29e..948493b 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 @@ module m !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 -- 2.7.4