[flang-commits] [flang] 7f7bbc7 - [flang] Correct overriding (or not) of inaccessible bindings
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue May 16 14:32:54 PDT 2023
Author: Peter Klausler
Date: 2023-05-16T14:32:48-07:00
New Revision: 7f7bbc73175d94f63cba905191a4ecc341b9fdba
URL: https://github.com/llvm/llvm-project/commit/7f7bbc73175d94f63cba905191a4ecc341b9fdba
DIFF: https://github.com/llvm/llvm-project/commit/7f7bbc73175d94f63cba905191a4ecc341b9fdba.diff
LOG: [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
Added:
flang/test/Semantics/bindings05.f90
flang/test/Semantics/bindings06.f90
flang/test/Semantics/bindings07.f90
Modified:
flang/include/flang/Semantics/symbol.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/ConvertCall.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/runtime-type-info.cpp
flang/lib/Semantics/symbol.cpp
flang/lib/Semantics/tools.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 02d7136728c54..5b011e76cbdce 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -347,9 +347,13 @@ class ProcBindingDetails : public WithPassArg {
explicit ProcBindingDetails(const Symbol &symbol) : symbol_{symbol} {}
const Symbol &symbol() const { return symbol_; }
void ReplaceSymbol(const Symbol &symbol) { symbol_ = symbol; }
+ int numPrivatesNotOverridden() const { return numPrivatesNotOverridden_; }
+ void set_numPrivatesNotOverridden(int n) { numPrivatesNotOverridden_ = n; }
private:
SymbolRef symbol_; // procedure bound to; may be forward
+ // Homonymous private bindings in ancestor types from other modules
+ int numPrivatesNotOverridden_{0};
};
class NamelistDetails {
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index c1dbac108b887..875f8624e4487 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -227,13 +227,14 @@ class DispatchTableConverter {
builder.createBlock(&dt.getRegion());
for (const Fortran::semantics::SymbolRef &binding : bindings) {
- const auto *details =
- binding.get().detailsIf<Fortran::semantics::ProcBindingDetails>();
- std::string bindingName = converter.mangleName(details->symbol());
+ const auto &details =
+ binding.get().get<Fortran::semantics::ProcBindingDetails>();
+ std::string tbpName = binding.get().name().ToString();
+ if (details.numPrivatesNotOverridden() > 0)
+ tbpName += "."s + std::to_string(details.numPrivatesNotOverridden());
+ std::string bindingName = converter.mangleName(details.symbol());
builder.create<fir::DTEntryOp>(
- info.loc,
- mlir::StringAttr::get(builder.getContext(),
- binding.get().name().ToString()),
+ info.loc, mlir::StringAttr::get(builder.getContext(), tbpName),
mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
}
if (!bindings.empty())
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 674e2c8c3ae96..d2d91735e21ab 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -376,11 +376,16 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// fir.dispatch.
// Get the raw procedure name. The procedure name is not mangled in the
- // binding table.
+ // binding table, but there can be a suffix to distinguish bindings of
+ // the same name (which happens only when PRIVATE bindings exist in
+ // ancestor types in other modules).
const auto &ultimateSymbol =
caller.getCallDescription().proc().GetSymbol()->GetUltimate();
- auto procName = toStringRef(ultimateSymbol.name());
-
+ std::string procName = ultimateSymbol.name().ToString();
+ if (const auto &binding{
+ ultimateSymbol.get<Fortran::semantics::ProcBindingDetails>()};
+ binding.numPrivatesNotOverridden() > 0)
+ procName += "."s + std::to_string(binding.numPrivatesNotOverridden());
fir::DispatchOp dispatch;
if (std::optional<unsigned> passArg = caller.getPassArgIndex()) {
// PASS, PASS(arg-name)
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index b946409d47837..afd92674ed293 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2199,6 +2199,7 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
}
if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
if (sym->has<semantics::GenericDetails>()) {
+ const Symbol &generic{*sym};
auto dyType{dtExpr->GetType()};
AdjustActuals adjustment{
[&](const Symbol &proc, ActualArguments &actuals) {
@@ -2207,25 +2208,46 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
}
return true;
}};
- auto pair{ResolveGeneric(*sym, arguments, adjustment, isSubroutine)};
+ auto pair{
+ ResolveGeneric(generic, arguments, adjustment, isSubroutine)};
sym = pair.first;
- if (sym) {
- // re-resolve the name to the specific binding
- CHECK(sym->has<semantics::ProcBindingDetails>());
- // Use the most recent override of the binding, if any
- CHECK(dyType && dyType->category() == TypeCategory::Derived &&
- !dyType->IsUnlimitedPolymorphic());
- if (const Symbol *latest{
- DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
- .FindComponent(sym->name())}) {
+ if (!sym) {
+ EmitGenericResolutionError(generic, pair.second, isSubroutine);
+ return std::nullopt;
+ }
+ // re-resolve the name to the specific binding
+ CHECK(sym->has<semantics::ProcBindingDetails>());
+ // Use the most recent override of a binding, respecting
+ // the rule that inaccessible bindings may not be overridden
+ // outside their module. Fortran doesn't allow a PUBLIC
+ // binding to be overridden by a PRIVATE one.
+ CHECK(dyType && dyType->category() == TypeCategory::Derived &&
+ !dyType->IsUnlimitedPolymorphic());
+ if (const Symbol *
+ latest{DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
+ .FindComponent(sym->name())}) {
+ if (sym->attrs().test(semantics::Attr::PRIVATE)) {
+ const auto *bindingModule{FindModuleContaining(generic.owner())};
+ const Symbol *s{latest};
+ while (s && FindModuleContaining(s->owner()) != bindingModule) {
+ if (const auto *parent{s->owner().GetDerivedTypeParent()}) {
+ s = parent->FindComponent(sym->name());
+ } else {
+ s = nullptr;
+ }
+ }
+ if (s && !s->attrs().test(semantics::Attr::PRIVATE)) {
+ // The latest override in the same module as the binding
+ // is public, so it can be overridden.
+ } else {
+ latest = s;
+ }
+ }
+ if (latest) {
sym = latest;
}
- sc.component.symbol = const_cast<Symbol *>(sym);
- } else {
- EmitGenericResolutionError(
- *sc.component.symbol, pair.second, isSubroutine);
- return std::nullopt;
}
+ sc.component.symbol = const_cast<Symbol *>(sym);
}
std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
if (dataRef && !CheckDataRef(*dataRef)) {
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index acd3c49b39098..5f62a0870745c 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -964,12 +964,13 @@ SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
SymbolVector CollectBindings(const Scope &dtScope) {
SymbolVector result;
- std::map<SourceName, const Symbol *> localBindings;
+ std::map<SourceName, Symbol *> localBindings;
// Collect local bindings
for (auto pair : dtScope) {
- const Symbol &symbol{*pair.second};
- if (symbol.has<ProcBindingDetails>()) {
+ Symbol &symbol{const_cast<Symbol &>(*pair.second)};
+ if (auto *binding{symbol.detailsIf<ProcBindingDetails>()}) {
localBindings.emplace(symbol.name(), &symbol);
+ binding->set_numPrivatesNotOverridden(0);
}
}
if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
@@ -977,10 +978,20 @@ SymbolVector CollectBindings(const Scope &dtScope) {
// Apply overrides from the local bindings of the extended type
for (auto iter{result.begin()}; iter != result.end(); ++iter) {
const Symbol &symbol{**iter};
- auto overridden{localBindings.find(symbol.name())};
- if (overridden != localBindings.end()) {
- *iter = *overridden->second;
- localBindings.erase(overridden);
+ auto overriderIter{localBindings.find(symbol.name())};
+ if (overriderIter != localBindings.end()) {
+ Symbol &overrider{*overriderIter->second};
+ if (symbol.attrs().test(Attr::PRIVATE) &&
+ FindModuleContaining(symbol.owner()) !=
+ FindModuleContaining(dtScope)) {
+ // Don't override inaccessible PRIVATE bindings
+ auto &binding{overrider.get<ProcBindingDetails>()};
+ binding.set_numPrivatesNotOverridden(
+ binding.numPrivatesNotOverridden() + 1);
+ } else {
+ *iter = overrider;
+ localBindings.erase(overriderIter);
+ }
}
}
}
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index d35938971d753..83d73f2d0a7a4 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -518,6 +518,10 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Details &details) {
[&](const ProcBindingDetails &x) {
os << " => " << x.symbol().name();
DumpOptional(os, "passName", x.passName());
+ if (x.numPrivatesNotOverridden() > 0) {
+ os << " numPrivatesNotOverridden: "
+ << x.numPrivatesNotOverridden();
+ }
},
[&](const NamelistDetails &x) {
os << ':';
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 711537ec4947b..d7ef29951e8cc 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -515,7 +515,15 @@ const Symbol *FindOverriddenBinding(const Symbol &symbol) {
if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) {
if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) {
if (const Scope * parentScope{parentDerived->typeSymbol().scope()}) {
- return parentScope->FindComponent(symbol.name());
+ if (const Symbol *
+ overridden{parentScope->FindComponent(symbol.name())}) {
+ // 7.5.7.3 p1: only accessible bindings are overridden
+ if (!overridden->attrs().test(Attr::PRIVATE) ||
+ (FindModuleContaining(overridden->owner()) ==
+ FindModuleContaining(symbol.owner()))) {
+ return overridden;
+ }
+ }
}
}
}
diff --git a/flang/test/Semantics/bindings05.f90 b/flang/test/Semantics/bindings05.f90
new file mode 100644
index 0000000000000..9deffb55dcca1
--- /dev/null
+++ b/flang/test/Semantics/bindings05.f90
@@ -0,0 +1,123 @@
+! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+module m1
+ type base
+ contains
+ procedure, private :: binding => basesub
+ generic :: generic => binding
+ end type
+ type, extends(base) :: ext1
+ contains
+ procedure, private :: binding => ext1sub
+ end type
+ contains
+ subroutine basesub(x)
+ class(base), intent(in) :: x
+ end
+ subroutine ext1sub(x)
+ class(ext1), intent(in) :: x
+ end
+ subroutine test1
+ type(ext1) x
+!CHECK: CALL ext1sub(x)
+ call x%generic
+ end
+end
+
+module m2
+ use m1
+ type, extends(ext1) :: ext2
+ contains
+ procedure :: binding => ext2sub
+ end type
+ contains
+ subroutine ext2sub(x)
+ class(ext2), intent(in) :: x
+ end
+ subroutine test2
+ type(ext2) x
+!CHECK: CALL ext1sub(x)
+ call x%generic ! private binding not overridable
+ end
+end
+
+module m3
+ type base
+ contains
+ procedure, public :: binding => basesub
+ generic :: generic => binding
+ end type
+ type, extends(base) :: ext1
+ contains
+ procedure, public :: binding => ext1sub
+ end type
+ contains
+ subroutine basesub(x)
+ class(base), intent(in) :: x
+ end
+ subroutine ext1sub(x)
+ class(ext1), intent(in) :: x
+ end
+ subroutine test1
+ type(ext1) x
+!CHECK: CALL ext1sub(x)
+ call x%generic
+ end
+end
+
+module m4
+ use m3
+ type, extends(ext1) :: ext2
+ contains
+ procedure :: binding => ext2sub
+ end type
+ contains
+ subroutine ext2sub(x)
+ class(ext2), intent(in) :: x
+ end
+ subroutine test2
+ type(ext2) x
+!CHECK: CALL ext2sub(x)
+ call x%generic ! public binding is overridable
+ end
+end
+
+module m5
+ type base
+ contains
+ procedure, private :: binding => basesub
+ generic :: generic => binding
+ end type
+ type, extends(base) :: ext1
+ contains
+ procedure, public :: binding => ext1sub
+ end type
+ contains
+ subroutine basesub(x)
+ class(base), intent(in) :: x
+ end
+ subroutine ext1sub(x)
+ class(ext1), intent(in) :: x
+ end
+ subroutine test1
+ type(ext1) x
+!CHECK: CALL ext1sub(x)
+ call x%generic
+ end
+end
+
+module m6
+ use m5
+ type, extends(ext1) :: ext2
+ contains
+ procedure :: binding => ext2sub
+ end type
+ contains
+ subroutine ext2sub(x)
+ class(ext2), intent(in) :: x
+ end
+ subroutine test2
+ type(ext2) x
+!CHECK: CALL ext2sub(x)
+ call x%generic ! public binding is overridable
+ end
+end
diff --git a/flang/test/Semantics/bindings06.f90 b/flang/test/Semantics/bindings06.f90
new file mode 100644
index 0000000000000..0ff5d62b2bede
--- /dev/null
+++ b/flang/test/Semantics/bindings06.f90
@@ -0,0 +1,81 @@
+! RUN: %flang_fc1 -fdebug-dump-symbols %s 2>&1 | FileCheck %s
+module ma
+ type a
+ contains
+ procedure, private, nopass :: tbp_private => sub_a1
+ procedure, public, nopass :: tbp_public => sub_a2
+ generic, public :: gen => tbp_private, tbp_public
+ end type
+ contains
+ subroutine sub_a1(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> a1'
+ end
+ subroutine sub_a2(w, j)
+ character*(*), intent(in) :: w
+ integer, intent(in) :: j
+ print *, w, ' -> a2'
+ end
+ subroutine test_mono_a
+ type(a) x
+ call x%tbp_private('type(a) tbp_private')
+ call x%tbp_public('type(a) tbp_public', 0)
+ call x%gen('type(a) gen 1')
+ call x%gen('type(a) gen 2', 0)
+ end
+ subroutine test_poly_a(x, w)
+ class(a), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp_private('class(a) (' // w // ') tbp_private')
+ call x%tbp_public('class(a) (' // w // ') tbp_public', 0)
+ call x%gen('class(a) (' // w // ') gen 1')
+ call x%gen('class(a) (' // w // ') gen 2', 0)
+ end
+end
+
+module mb
+ use ma
+ type, extends(a) :: ab
+ contains
+ procedure, private, nopass :: tbp_private => sub_ab1
+ procedure, public, nopass :: tbp_public => sub_ab2
+ end type
+ contains
+ subroutine sub_ab1(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> ab1'
+ end
+ subroutine sub_ab2(w, j)
+ character*(*), intent(in) :: w
+ integer, intent(in) :: j
+ print *, w, ' -> ab2'
+ end
+ subroutine test_mono_ab
+ type(ab) x
+ call x%tbp_private('type(ab) tbp_private')
+ call x%tbp_public('type(ab) tbp_public', 0)
+ call x%gen('type(ab) gen 1')
+ call x%gen('type(ab) gen 2', 0)
+ end
+ subroutine test_poly_ab(x, w)
+ class(ab), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp_private('class(ab) (' // w // ') tbp_private')
+ call x%tbp_public('class(ab) (' // w // ') tbp_public', 0)
+ call x%gen('class(ab) (' // w // ') gen 1')
+ call x%gen('class(ab) (' // w // ') gen 2', 0)
+ end
+end
+
+program main
+ use mb
+ call test_mono_a
+ call test_mono_ab
+ call test_poly_a(a(), 'a')
+ call test_poly_a(ab(), 'ab')
+ call test_poly_ab(ab(), 'ab')
+end
+
+!CHECK: .v.a, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=sub_a1,name=.n.tbp_private),binding(proc=sub_a2,name=.n.tbp_public)]
+!CHECK: .v.ab, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:2_8 init:[binding::binding(proc=sub_a1,name=.n.tbp_private),binding(proc=sub_ab2,name=.n.tbp_public),binding(proc=sub_ab1,name=.n.tbp_private)]
+!CHECK: tbp_private, NOPASS, PRIVATE: ProcBinding => sub_ab1 numPrivatesNotOverridden: 1
diff --git a/flang/test/Semantics/bindings07.f90 b/flang/test/Semantics/bindings07.f90
new file mode 100644
index 0000000000000..f757020feff18
--- /dev/null
+++ b/flang/test/Semantics/bindings07.f90
@@ -0,0 +1,261 @@
+! RUN: %flang_fc1 -fdebug-dump-symbols %s 2>&1 | FileCheck %s
+module ma
+ type a
+ contains
+ procedure, private, nopass :: tbp => sub_a
+ generic :: gen => tbp
+ end type
+ type, extends(a) :: aa
+ contains
+ procedure, private, nopass :: tbp => sub_aa
+ end type
+ type, extends(aa) :: aaa
+ contains
+ procedure, public, nopass :: tbp => sub_aaa
+ end type
+ contains
+ subroutine sub_a(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> a'
+ end
+ subroutine sub_aa(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aa'
+ end
+ subroutine sub_aaa(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aaa'
+ end
+ subroutine mono1
+ type(a) :: xa
+ type(aa) :: xaa
+ call xa%tbp('type(a) tbp')
+ call xaa%tbp('type(aa) tbp')
+ end
+ subroutine pa(x, w)
+ class(a), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(a) ' // w // ' tbp')
+ call x%gen('class(a) ' // w // ' gen')
+ end
+ subroutine pta1
+ call pa(a(), 'a')
+ call pa(aa(), 'aa')
+ end
+ subroutine paa(x, w)
+ class(aa), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aa) ' // w // ' tbp')
+ call x%gen('class(aa) ' // w // ' gen')
+ end
+ subroutine ptaa1
+ call paa(aa(), 'aa')
+ end
+ subroutine paaa(x, w)
+ class(aaa), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aaa) ' // w // ' tbp')
+ call x%gen('class(aaa) ' // w // ' gen')
+ end
+ subroutine ptaaa1
+ call paaa(aaa(), 'aaa')
+ end
+end
+
+module mb
+ use ma
+ type, extends(a) :: ab
+ contains
+ procedure, public, nopass :: tbp => sub_ab
+ end type
+ type, extends(aa) :: aab
+ contains
+ procedure, public, nopass :: tbp => sub_aab
+ end type
+ type, extends(aaa) :: aaab
+ contains
+ procedure, public, nopass :: tbp => sub_aaab
+ end type
+ type, extends(ab) :: aba
+ contains
+ procedure, public, nopass :: tbp => sub_aba
+ end type
+ type, extends(aab) :: aaba
+ contains
+ procedure, public, nopass :: tbp => sub_aaba
+ end type
+ type, extends(aaab) :: aaaba
+ contains
+ procedure, public, nopass :: tbp => sub_aaaba
+ end type
+ contains
+ subroutine sub_ab(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> ab'
+ end
+ subroutine sub_aab(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aab'
+ end
+ subroutine sub_aaab(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aaab'
+ end
+ subroutine sub_aba(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aba'
+ end
+ subroutine sub_aaba(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aaba'
+ end
+ subroutine sub_aaaba(w)
+ character*(*), intent(in) :: w
+ print *, w, ' -> aaaba'
+ end
+end
+
+module t
+ use mb
+ contains
+ subroutine mono2
+ type(a) :: xa
+ type(aa) :: xaa
+ type(aaa) :: xaaa
+ type(ab) :: xab
+ type(aab) :: xaab
+ type(aaab) :: xaaab
+ type(aba) :: xaba
+ type(aaba) :: xaaba
+ type(aaaba) :: xaaaba
+ call xa%gen('type(a) gen')
+ call xaa%gen('type(aa) gen')
+ call xaaa%tbp('type(aaa) tbp')
+ call xaaa%gen('type(aaa) gen')
+ call xab%tbp('type(ab) tbp')
+ call xab%gen('type(ab) gen')
+ call xaab%tbp('type(aab) tbp')
+ call xaab%gen('type(aab) gen')
+ call xaaab%tbp('type(aaab) tbp')
+ call xaaab%gen('type(aaab) gen')
+ call xaba%tbp('type(aba) tbp')
+ call xaba%gen('type(aba) gen')
+ call xaaba%tbp('type(aaba) tbp')
+ call xaaba%gen('type(aaba) gen')
+ call xaaaba%tbp('type(aaaba) tbp')
+ call xaaaba%gen('type(aaaba) gen')
+ end
+ subroutine pta2
+ call pa(a(), 'a')
+ call pa(aa(), 'aa')
+ call pa(aaa(), 'aaa')
+ call pa(ab(), 'ab')
+ call pa(aab(), 'aab')
+ call pa(aaab(), 'aaab')
+ call pa(aba(), 'aba')
+ call pa(aaba(), 'aaba')
+ call pa(aaaba(), 'aaaba')
+ end
+ subroutine ptaa2
+ call paa(aa(), 'aa')
+ call paa(aaa(), 'aaa')
+ call paa(aab(), 'aab')
+ call paa(aaab(), 'aaab')
+ call paa(aaba(), 'aaba')
+ call paa(aaaba(), 'aaaba')
+ end
+ subroutine ptaaa2
+ call paaa(aaa(), 'aaa')
+ call paaa(aaab(), 'aaab')
+ call paaa(aaaba(), 'aaaba')
+ end
+ subroutine pab(x, w)
+ class(ab), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(ab) ' // w // ' tbp')
+ call x%gen('class(ab) ' // w // ' gen')
+ end
+ subroutine ptab
+ call pab(ab(), 'ab')
+ call pab(aba(), 'aba')
+ end
+ subroutine paab(x, w)
+ class(aab), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aab) ' // w // ' tbp')
+ call x%gen('class(aab) ' // w // ' gen')
+ end
+ subroutine ptaab
+ call pa(aab(), 'aab')
+ call pa(aaba(), 'aaba')
+ end
+ subroutine paaab(x, w)
+ class(aaab), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aaab) ' // w // ' tbp')
+ call x%gen('class(aaab) ' // w // ' gen')
+ end
+ subroutine ptaaab
+ call pa(aaab(), 'aaab')
+ call pa(aaaba(), 'aaaba')
+ end
+ subroutine paba(x, w)
+ class(aba), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aba) ' // w // ' tbp')
+ call x%gen('class(aba) ' // w // ' gen')
+ end
+ subroutine ptaba
+ call paba(aba(), 'aba')
+ end
+ subroutine paaba(x, w)
+ class(aaba), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aaba) ' // w // ' tbp')
+ call x%gen('class(aaba) ' // w // ' gen')
+ end
+ subroutine ptaaba
+ call paaba(aaba(), 'aaba')
+ end
+ subroutine paaaba(x, w)
+ class(aaaba), intent(in) :: x
+ character*(*), intent(in) :: w
+ call x%tbp('class(aaaba) ' // w // ' tbp')
+ call x%gen('class(aaaba) ' // w // ' gen')
+ end
+ subroutine ptaaaba
+ call pa(aaaba(), 'aaaba')
+ end
+end
+
+program main
+ use t
+ call mono1
+ call mono2
+ call pta1
+ call ptaa1
+ call ptaaa1
+ call pta2
+ call ptaa2
+ call ptaaa2
+ call ptab
+ call ptaab
+ call ptaaab
+ call ptaba
+ call ptaaba
+ call ptaaaba
+end
+
+!CHECK: .v.a, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=sub_a,name=.n.tbp)]
+!CHECK: .v.aa, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=sub_aa,name=.n.tbp)]
+!CHECK: .v.aaa, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=sub_aaa,name=.n.tbp)]
+!CHECK: .v.aaab, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=sub_aaab,name=.n.tbp)]
+!CHECK: .v.aaaba, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=sub_aaaba,name=.n.tbp)]
+!CHECK: .v.aab, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=sub_aa,name=.n.tbp),binding(proc=sub_aab,name=.n.tbp)]
+!CHECK: .v.aaba, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=sub_aa,name=.n.tbp),binding(proc=sub_aaba,name=.n.tbp)]
+!CHECK: .v.ab, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=sub_a,name=.n.tbp),binding(proc=sub_ab,name=.n.tbp)]
+!CHECK: .v.aba, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=sub_a,name=.n.tbp),binding(proc=sub_aba,name=.n.tbp)]
+!CHECK: tbp, NOPASS, PUBLIC: ProcBinding => sub_ab numPrivatesNotOverridden: 1
+!CHECK: tbp, NOPASS, PUBLIC: ProcBinding => sub_aab numPrivatesNotOverridden: 1
+!CHECK: tbp, NOPASS, PUBLIC: ProcBinding => sub_aba numPrivatesNotOverridden: 1
+!CHECK: tbp, NOPASS, PUBLIC: ProcBinding => sub_aaba numPrivatesNotOverridden: 1
More information about the flang-commits
mailing list