Skip to content

Commit 7f7bbc7

Browse files
klauslerklausler
committed
[flang] Correct overriding (or not) of inaccessible bindings
Fortran doesn't allow inaccessible procedure bindings to be overridden, and this needs to apply to generic resolution. When resolving a type-bound generic procedure from another module, ensure only that the most extended override from its module is used if it is PRIVATE, not a later apparent override from another module. Differential Revision: https://reviews.llvm.org/D150721
1 parent fcaccf8 commit 7f7bbc7

File tree

10 files changed

+552
-32
lines changed

10 files changed

+552
-32
lines changed

‎flang/include/flang/Semantics/symbol.h

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -347,9 +347,13 @@ class ProcBindingDetails : public WithPassArg {
347347
explicit ProcBindingDetails(const Symbol &symbol) : symbol_{symbol} {}
348348
const Symbol &symbol() const { return symbol_; }
349349
void ReplaceSymbol(const Symbol &symbol) { symbol_ = symbol; }
350+
int numPrivatesNotOverridden() const { return numPrivatesNotOverridden_; }
351+
void set_numPrivatesNotOverridden(int n) { numPrivatesNotOverridden_ = n; }
350352

351353
private:
352354
SymbolRef symbol_; // procedure bound to; may be forward
355+
// Homonymous private bindings in ancestor types from other modules
356+
int numPrivatesNotOverridden_{0};
353357
};
354358

355359
class NamelistDetails {

‎flang/lib/Lower/Bridge.cpp

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -227,13 +227,14 @@ class DispatchTableConverter {
227227
builder.createBlock(&dt.getRegion());
228228

229229
for (const Fortran::semantics::SymbolRef &binding : bindings) {
230-
const auto *details =
231-
binding.get().detailsIf<Fortran::semantics::ProcBindingDetails>();
232-
std::string bindingName = converter.mangleName(details->symbol());
230+
const auto &details =
231+
binding.get().get<Fortran::semantics::ProcBindingDetails>();
232+
std::string tbpName = binding.get().name().ToString();
233+
if (details.numPrivatesNotOverridden() > 0)
234+
tbpName += "."s + std::to_string(details.numPrivatesNotOverridden());
235+
std::string bindingName = converter.mangleName(details.symbol());
233236
builder.create<fir::DTEntryOp>(
234-
info.loc,
235-
mlir::StringAttr::get(builder.getContext(),
236-
binding.get().name().ToString()),
237+
info.loc, mlir::StringAttr::get(builder.getContext(), tbpName),
237238
mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
238239
}
239240
if (!bindings.empty())

‎flang/lib/Lower/ConvertCall.cpp

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -376,11 +376,16 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
376376
// fir.dispatch.
377377

378378
// Get the raw procedure name. The procedure name is not mangled in the
379-
// binding table.
379+
// binding table, but there can be a suffix to distinguish bindings of
380+
// the same name (which happens only when PRIVATE bindings exist in
381+
// ancestor types in other modules).
380382
const auto &ultimateSymbol =
381383
caller.getCallDescription().proc().GetSymbol()->GetUltimate();
382-
auto procName = toStringRef(ultimateSymbol.name());
383-
384+
std::string procName = ultimateSymbol.name().ToString();
385+
if (const auto &binding{
386+
ultimateSymbol.get<Fortran::semantics::ProcBindingDetails>()};
387+
binding.numPrivatesNotOverridden() > 0)
388+
procName += "."s + std::to_string(binding.numPrivatesNotOverridden());
384389
fir::DispatchOp dispatch;
385390
if (std::optional<unsigned> passArg = caller.getPassArgIndex()) {
386391
// PASS, PASS(arg-name)

‎flang/lib/Semantics/expression.cpp

Lines changed: 37 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -2199,6 +2199,7 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
21992199
}
22002200
if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
22012201
if (sym->has<semantics::GenericDetails>()) {
2202+
const Symbol &generic{*sym};
22022203
auto dyType{dtExpr->GetType()};
22032204
AdjustActuals adjustment{
22042205
[&](const Symbol &proc, ActualArguments &actuals) {
@@ -2207,25 +2208,46 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
22072208
}
22082209
return true;
22092210
}};
2210-
auto pair{ResolveGeneric(*sym, arguments, adjustment, isSubroutine)};
2211+
auto pair{
2212+
ResolveGeneric(generic, arguments, adjustment, isSubroutine)};
22112213
sym = pair.first;
2212-
if (sym) {
2213-
// re-resolve the name to the specific binding
2214-
CHECK(sym->has<semantics::ProcBindingDetails>());
2215-
// Use the most recent override of the binding, if any
2216-
CHECK(dyType && dyType->category() == TypeCategory::Derived &&
2217-
!dyType->IsUnlimitedPolymorphic());
2218-
if (const Symbol *latest{
2219-
DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
2220-
.FindComponent(sym->name())}) {
2214+
if (!sym) {
2215+
EmitGenericResolutionError(generic, pair.second, isSubroutine);
2216+
return std::nullopt;
2217+
}
2218+
// re-resolve the name to the specific binding
2219+
CHECK(sym->has<semantics::ProcBindingDetails>());
2220+
// Use the most recent override of a binding, respecting
2221+
// the rule that inaccessible bindings may not be overridden
2222+
// outside their module. Fortran doesn't allow a PUBLIC
2223+
// binding to be overridden by a PRIVATE one.
2224+
CHECK(dyType && dyType->category() == TypeCategory::Derived &&
2225+
!dyType->IsUnlimitedPolymorphic());
2226+
if (const Symbol *
2227+
latest{DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
2228+
.FindComponent(sym->name())}) {
2229+
if (sym->attrs().test(semantics::Attr::PRIVATE)) {
2230+
const auto *bindingModule{FindModuleContaining(generic.owner())};
2231+
const Symbol *s{latest};
2232+
while (s && FindModuleContaining(s->owner()) != bindingModule) {
2233+
if (const auto *parent{s->owner().GetDerivedTypeParent()}) {
2234+
s = parent->FindComponent(sym->name());
2235+
} else {
2236+
s = nullptr;
2237+
}
2238+
}
2239+
if (s && !s->attrs().test(semantics::Attr::PRIVATE)) {
2240+
// The latest override in the same module as the binding
2241+
// is public, so it can be overridden.
2242+
} else {
2243+
latest = s;
2244+
}
2245+
}
2246+
if (latest) {
22212247
sym = latest;
22222248
}
2223-
sc.component.symbol = const_cast<Symbol *>(sym);
2224-
} else {
2225-
EmitGenericResolutionError(
2226-
*sc.component.symbol, pair.second, isSubroutine);
2227-
return std::nullopt;
22282249
}
2250+
sc.component.symbol = const_cast<Symbol *>(sym);
22292251
}
22302252
std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
22312253
if (dataRef && !CheckDataRef(*dataRef)) {

‎flang/lib/Semantics/runtime-type-info.cpp

Lines changed: 18 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -964,23 +964,34 @@ SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
964964

965965
SymbolVector CollectBindings(const Scope &dtScope) {
966966
SymbolVector result;
967-
std::map<SourceName, const Symbol *> localBindings;
967+
std::map<SourceName, Symbol *> localBindings;
968968
// Collect local bindings
969969
for (auto pair : dtScope) {
970-
const Symbol &symbol{*pair.second};
971-
if (symbol.has<ProcBindingDetails>()) {
970+
Symbol &symbol{const_cast<Symbol &>(*pair.second)};
971+
if (auto *binding{symbol.detailsIf<ProcBindingDetails>()}) {
972972
localBindings.emplace(symbol.name(), &symbol);
973+
binding->set_numPrivatesNotOverridden(0);
973974
}
974975
}
975976
if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
976977
result = CollectBindings(*parentScope);
977978
// Apply overrides from the local bindings of the extended type
978979
for (auto iter{result.begin()}; iter != result.end(); ++iter) {
979980
const Symbol &symbol{**iter};
980-
auto overridden{localBindings.find(symbol.name())};
981-
if (overridden != localBindings.end()) {
982-
*iter = *overridden->second;
983-
localBindings.erase(overridden);
981+
auto overriderIter{localBindings.find(symbol.name())};
982+
if (overriderIter != localBindings.end()) {
983+
Symbol &overrider{*overriderIter->second};
984+
if (symbol.attrs().test(Attr::PRIVATE) &&
985+
FindModuleContaining(symbol.owner()) !=
986+
FindModuleContaining(dtScope)) {
987+
// Don't override inaccessible PRIVATE bindings
988+
auto &binding{overrider.get<ProcBindingDetails>()};
989+
binding.set_numPrivatesNotOverridden(
990+
binding.numPrivatesNotOverridden() + 1);
991+
} else {
992+
*iter = overrider;
993+
localBindings.erase(overriderIter);
994+
}
984995
}
985996
}
986997
}

‎flang/lib/Semantics/symbol.cpp

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -518,6 +518,10 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Details &details) {
518518
[&](const ProcBindingDetails &x) {
519519
os << " => " << x.symbol().name();
520520
DumpOptional(os, "passName", x.passName());
521+
if (x.numPrivatesNotOverridden() > 0) {
522+
os << " numPrivatesNotOverridden: "
523+
<< x.numPrivatesNotOverridden();
524+
}
521525
},
522526
[&](const NamelistDetails &x) {
523527
os << ':';

‎flang/lib/Semantics/tools.cpp

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -515,7 +515,15 @@ const Symbol *FindOverriddenBinding(const Symbol &symbol) {
515515
if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) {
516516
if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) {
517517
if (const Scope * parentScope{parentDerived->typeSymbol().scope()}) {
518-
return parentScope->FindComponent(symbol.name());
518+
if (const Symbol *
519+
overridden{parentScope->FindComponent(symbol.name())}) {
520+
// 7.5.7.3 p1: only accessible bindings are overridden
521+
if (!overridden->attrs().test(Attr::PRIVATE) ||
522+
(FindModuleContaining(overridden->owner()) ==
523+
FindModuleContaining(symbol.owner()))) {
524+
return overridden;
525+
}
526+
}
519527
}
520528
}
521529
}

‎flang/test/Semantics/bindings05.f90

Lines changed: 123 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,123 @@
1+
! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
2+
module m1
3+
type base
4+
contains
5+
procedure, private :: binding => basesub
6+
generic :: generic => binding
7+
end type
8+
type, extends(base) :: ext1
9+
contains
10+
procedure, private :: binding => ext1sub
11+
end type
12+
contains
13+
subroutine basesub(x)
14+
class(base), intent(in) :: x
15+
end
16+
subroutine ext1sub(x)
17+
class(ext1), intent(in) :: x
18+
end
19+
subroutine test1
20+
type(ext1) x
21+
!CHECK: CALL ext1sub(x)
22+
call x%generic
23+
end
24+
end
25+
26+
module m2
27+
use m1
28+
type, extends(ext1) :: ext2
29+
contains
30+
procedure :: binding => ext2sub
31+
end type
32+
contains
33+
subroutine ext2sub(x)
34+
class(ext2), intent(in) :: x
35+
end
36+
subroutine test2
37+
type(ext2) x
38+
!CHECK: CALL ext1sub(x)
39+
call x%generic ! private binding not overridable
40+
end
41+
end
42+
43+
module m3
44+
type base
45+
contains
46+
procedure, public :: binding => basesub
47+
generic :: generic => binding
48+
end type
49+
type, extends(base) :: ext1
50+
contains
51+
procedure, public :: binding => ext1sub
52+
end type
53+
contains
54+
subroutine basesub(x)
55+
class(base), intent(in) :: x
56+
end
57+
subroutine ext1sub(x)
58+
class(ext1), intent(in) :: x
59+
end
60+
subroutine test1
61+
type(ext1) x
62+
!CHECK: CALL ext1sub(x)
63+
call x%generic
64+
end
65+
end
66+
67+
module m4
68+
use m3
69+
type, extends(ext1) :: ext2
70+
contains
71+
procedure :: binding => ext2sub
72+
end type
73+
contains
74+
subroutine ext2sub(x)
75+
class(ext2), intent(in) :: x
76+
end
77+
subroutine test2
78+
type(ext2) x
79+
!CHECK: CALL ext2sub(x)
80+
call x%generic ! public binding is overridable
81+
end
82+
end
83+
84+
module m5
85+
type base
86+
contains
87+
procedure, private :: binding => basesub
88+
generic :: generic => binding
89+
end type
90+
type, extends(base) :: ext1
91+
contains
92+
procedure, public :: binding => ext1sub
93+
end type
94+
contains
95+
subroutine basesub(x)
96+
class(base), intent(in) :: x
97+
end
98+
subroutine ext1sub(x)
99+
class(ext1), intent(in) :: x
100+
end
101+
subroutine test1
102+
type(ext1) x
103+
!CHECK: CALL ext1sub(x)
104+
call x%generic
105+
end
106+
end
107+
108+
module m6
109+
use m5
110+
type, extends(ext1) :: ext2
111+
contains
112+
procedure :: binding => ext2sub
113+
end type
114+
contains
115+
subroutine ext2sub(x)
116+
class(ext2), intent(in) :: x
117+
end
118+
subroutine test2
119+
type(ext2) x
120+
!CHECK: CALL ext2sub(x)
121+
call x%generic ! public binding is overridable
122+
end
123+
end

0 commit comments

Comments
 (0)