[flang] Correct overriding (or not) of inaccessible bindings

[klausler]

Summary

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.

[clementval]

LGTM

flang/include/flang/Semantics/symbol.h

friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const DerivedTypeDetails &);
 };
 
 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; }
+  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 {
 public:
   const SymbolVector &objects() const { return objects_; }
   void add_object(const Symbol &object) { objects_.push_back(object); }
   void add_objects(const SymbolVector &objects) {
     objects_.insert(objects_.end(), objects.begin(), objects.end());

flang/lib/Lower/Bridge.cpp

for (const DispatchTableInfo &info : registeredDispatchTableInfo) {
         scope = info.typeSpec->typeSymbol().scope();
       Fortran::semantics::SymbolVector bindings =
           Fortran::semantics::CollectBindings(*scope);
 
       if (!bindings.empty())
         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())
         builder.create<fir::FirEndOp>(info.loc);
       builder.restoreInsertionPoint(insertPt);
     }
     registeredDispatchTableInfo.clear();
   }

flang/lib/Lower/ConvertCall.cpp

fir::ExtendedValue Fortran::lower::genCallOpAndResult(
 
   mlir::Value callResult;
   unsigned callNumResults;
   if (caller.requireDispatchCall()) {
     // Procedure call requiring a dynamic dispatch. Call is created with
     // 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)
       dispatch = builder.create<fir::DispatchOp>(
           loc, funcType.getResults(), builder.getStringAttr(procName),
           operands[*passArg], operands, builder.getI32IntegerAttr(*passArg));
     } else {
       // NOPASS

flang/lib/Semantics/expression.cpp

if (const Symbol *sym{sc.component.symbol}) {
         AttachDeclaration(
             Say(sc.component.source, "'%s' is not a procedure"_err_en_US,
                 sc.component.source),
             *sym);
         return std::nullopt;
       }
       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) {
                 if (!proc.attrs().test(semantics::Attr::NOPASS)) {
                   AddPassArg(actuals, std::move(*dtExpr), proc);
                 }
                 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())
+          if (!sym) {
+            EmitGenericResolutionError(generic, pair.second, isSubroutine);
+            return std::nullopt;
+          }
+          // 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.
+          if (const Symbol *
+              latest{DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
                          .FindComponent(sym->name())}) {
-              sym = latest;
+            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;
                 }
-            sc.component.symbol = const_cast<Symbol *>(sym);
+              }
+              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 {
-            EmitGenericResolutionError(
-                *sc.component.symbol, pair.second, isSubroutine);
-            return std::nullopt;
+                latest = s;
               }
             }
+            if (latest) {
+              sym = latest;
+            }
+          }
+          sc.component.symbol = const_cast<Symbol *>(sym);
+        }
         std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
         if (dataRef && !CheckDataRef(*dataRef)) {
           return std::nullopt;
         }
         if (dataRef && dataRef->Rank() > 0) {
           if (sym->has<semantics::ProcBindingDetails>() &&
               sym->attrs().test(semantics::Attr::NOPASS)) {
             // C1529 seems unnecessary and most compilers don't enforce it.

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

 
 SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
     const SomeExpr &genre, std::int64_t n) const {
   return StructureExpr(PackageIntValue(genre, n));
 }
 
 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()}) {
     result = CollectBindings(*parentScope);
     // 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);
+        }
       }
     }
   }
   // Add remaining (non-overriding) local bindings in name order to the result
   for (auto pair : localBindings) {
     result.push_back(*pair.second);
   }
   return result;

flang/lib/Semantics/symbol.cpp

common::visit( //
                  << location;
               sep = ',';
             }
           },
           [](const HostAssocDetails &) {},
           [&](const ProcBindingDetails &x) {
             os << " => " << x.symbol().name();
             DumpOptional(os, "passName", x.passName());
+            if (x.numPrivatesNotOverridden() > 0) {
+              os << " numPrivatesNotOverridden: "
+                 << x.numPrivatesNotOverridden();
+            }
           },
           [&](const NamelistDetails &x) {
             os << ':';
             DumpSymbolVector(os, x.objects());
           },
           [&](const CommonBlockDetails &x) {
             DumpOptional(os, "bindName", x.bindName());
             if (x.alignment()) {

flang/lib/Semantics/tools.cpp

return common::visit(
       symbol.details());
 }
 
 const Symbol *FindOverriddenBinding(const Symbol &symbol) {
   if (symbol.has<ProcBindingDetails>()) {
     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;
+            }
+          }
         }
       }
     }
   }
   return nullptr;
 }
 
 const Symbol *FindGlobal(const Symbol &original) {

flang/test/Semantics/bindings05.f90

+! 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

flang/test/Semantics/bindings06.f90

+! 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

flang/test/Semantics/bindings07.f90

+! 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