[flang] Refine checking of type-bound generics

[klausler]

I merged a patch yesterday (#128980) that strengthened error detection of indistinguishable specific procedures in a type-bound generic procedure, and broke a couple of tests. Refine the check so that it doesn't flag valid cases of overridden bindings, and add a thorough test with all of the boundary cases that I can think of.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

I merged a patch yesterday (#128980) that strengthened error detection of indistinguishable specific procedures in a type-bound generic procedure, and broke a couple of tests. Refine the check so that it doesn't flag valid cases of overridden bindings, and add a thorough test with all of the boundary cases that I can think of.

---

Full diff: https://github.com/llvm/llvm-project/pull/129292.diff

2 Files Affected:

• (modified) flang/lib/Semantics/check-declarations.cpp (+13-6)
• (added) flang/test/Semantics/generic13.f90 (+96)

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index c30c15a290b84..070b27ed639e8 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3998,26 +3998,33 @@ void DistinguishabilityHelper::Check(const Scope &scope) {
       const auto &[ultimate, procInfo]{*iter1};
       const auto &[kind, proc]{procInfo};
       for (auto iter2{iter1}; ++iter2 != info.end();) {
-        if (&*ultimate == &*iter2->first) {
-          continue; // ok, actually the same procedure
+        const auto &[ultimate2, procInfo2]{*iter2};
+        if (&*ultimate == &*ultimate2) {
+          continue; // ok, actually the same procedure/binding
         } else if (const auto *binding1{
                        ultimate->detailsIf<ProcBindingDetails>()}) {
           if (const auto *binding2{
-                  iter2->first->detailsIf<ProcBindingDetails>()}) {
+                  ultimate2->detailsIf<ProcBindingDetails>()}) {
             if (&binding1->symbol().GetUltimate() ==
                 &binding2->symbol().GetUltimate()) {
-              continue; // ok, bindings resolve identically
+              continue; // ok, (NOPASS) bindings resolve identically
+            } else if (ultimate->name() == ultimate2->name()) {
+              continue; // override, possibly of DEFERRED
             }
           }
+        } else if (ultimate->has<ProcBindingDetails>() &&
+            ultimate2->has<ProcBindingDetails>() &&
+            ultimate->name() == ultimate2->name()) {
+          continue; // override, possibly of DEFERRED
         }
         auto distinguishable{kind.IsName()
                 ? evaluate::characteristics::Distinguishable
                 : evaluate::characteristics::DistinguishableOpOrAssign};
         std::optional<bool> distinct{distinguishable(
-            context_.languageFeatures(), proc, iter2->second.procedure)};
+            context_.languageFeatures(), proc, procInfo2.procedure)};
         if (!distinct.value_or(false)) {
           SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,
-              *ultimate, *iter2->first, distinct.has_value());
+              *ultimate, *ultimate2, distinct.has_value());
         }
       }
     }
diff --git a/flang/test/Semantics/generic13.f90 b/flang/test/Semantics/generic13.f90
new file mode 100644
index 0000000000000..633541763790b
--- /dev/null
+++ b/flang/test/Semantics/generic13.f90
@@ -0,0 +1,96 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m1
+  type, abstract :: ta1
+   contains
+    procedure(ta1p1), deferred :: ta1p1
+    generic :: gen => ta1p1
+  end type
+  abstract interface
+    subroutine ta1p1(x)
+      import ta1
+      class(ta1), intent(in) :: x
+    end
+  end interface
+  type :: tb1
+   contains
+    procedure tb1p1
+    generic :: gen => tb1p1
+  end type
+  type :: tc1
+   contains
+    procedure tc1p1
+    generic, private :: gen => tc1p1
+  end type
+  type :: td1
+   contains
+    procedure, nopass :: td1p1
+    generic :: gen => td1p1
+  end type
+ contains
+  subroutine tb1p1(x)
+    class(tb1), intent(in) :: x
+  end
+  subroutine tb1p2(x)
+    class(tb1), intent(in) :: x
+  end
+  subroutine tc1p1(x)
+    class(tc1), intent(in) :: x
+  end
+  subroutine td1p1
+  end
+end
+
+module m2
+  use m1
+  type, extends(ta1) :: ta2a
+   contains
+    procedure :: ta1p1 => ta2ap1 ! ok
+  end type
+  type, extends(ta1) :: ta2b
+   contains
+    procedure :: ta1p1 => ta2bp1
+    generic :: gen => ta1p1 ! ok, overidden deferred
+  end type
+  type, extends(tb1) :: tb2a
+   contains
+    generic :: gen => tb1p1 ! ok, same binding
+  end type
+  type, extends(tb1) :: tb2b
+   contains
+    procedure :: tb1p1 => tb2bp2
+    generic :: gen => tb1p1 ! ok, overridden
+  end type
+  type, extends(tb1) :: tb2c
+   contains
+    procedure tb2cp1
+    !ERROR: Generic 'gen' may not have specific procedures 'tb1p1' and 'tb2cp1' as their interfaces are not distinguishable
+    generic :: gen => tb2cp1
+  end type
+  type, extends(tc1) :: tc2
+   contains
+    procedure tc2p1
+    !ERROR: 'gen' does not have the same accessibility as its previous declaration
+    generic :: gen => tc2p1
+  end type
+  type, extends(td1) :: td2
+   contains
+    procedure, nopass :: td2p1 => td1p1
+    generic :: gen => td2p1 ! ok, same procedure
+  end type
+ contains
+  subroutine ta2ap1(x)
+    class(ta2a), intent(in) :: x
+  end
+  subroutine ta2bp1(x)
+    class(ta2b), intent(in) :: x
+  end
+  subroutine tb2bp2(x)
+    class(tb2b), intent(in) :: x
+  end
+  subroutine tb2cp1(x)
+    class(tb2c), intent(in) :: x
+  end
+  subroutine tc2p1(x)
+    class(tc2), intent(in) :: x
+  end
+end

[DanielCChen]

LGTM.
Thanks for the fix!