[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

3 files changed, 465 insertions, 0 deletions

diff --git a/flang/test/Semantics/bindings05.f90 b/flang/test/Semantics/bindings05.f90
new file mode 100644
index 000000000000..9deffb55dcca
--- /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 000000000000..0ff5d62b2bed
--- /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 000000000000..f757020feff1
--- /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