[flang] Catch type-bound generic with inherited indistinguishable spe… (#128980)

…cific

When checking generic procedures for indistinguishable specific
procedures, don't neglect to include specific procedures from any
accessible instance of the generic procedure inherited from its parent
type..

Fixes #128760.

Author: klausler

flang/lib/Semantics/check-declarations.cpp

@@ -33,6 +33,8 @@ using characteristics::DummyProcedure;
 using characteristics::FunctionResult;
 using characteristics::Procedure;
 
+class DistinguishabilityHelper;
+
 class CheckHelper {
 public:
   explicit CheckHelper(SemanticsContext &c) : context_{c} {}
@@ -89,6 +91,8 @@ class CheckHelper {
       const SourceName &, const Symbol &, const Procedure &, std::size_t);
   bool CheckDefinedAssignment(const Symbol &, const Procedure &);
   bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
+  void CollectSpecifics(
+      DistinguishabilityHelper &, const Symbol &, const GenericDetails &);
   void CheckSpecifics(const Symbol &, const GenericDetails &);
   void CheckEquivalenceSet(const EquivalenceSet &);
   void CheckEquivalenceObject(const EquivalenceObject &);
@@ -1931,10 +1935,9 @@ void CheckHelper::CheckGeneric(
 }
 
 // Check that the specifics of this generic are distinguishable from each other
-void CheckHelper::CheckSpecifics(
+void CheckHelper::CollectSpecifics(DistinguishabilityHelper &helper,
     const Symbol &generic, const GenericDetails &details) {
   GenericKind kind{details.kind()};
-  DistinguishabilityHelper helper{context_};
   for (const Symbol &specific : details.specificProcs()) {
     if (specific.attrs().test(Attr::ABSTRACT)) {
       if (auto *msg{messages_.Say(generic.name(),
@@ -1989,6 +1992,23 @@ void CheckHelper::CheckSpecifics(
       }
     }
   }
+  if (const Scope * parent{generic.owner().GetDerivedTypeParent()}) {
+    if (const Symbol * inherited{parent->FindComponent(generic.name())}) {
+      if (IsAccessible(*inherited, generic.owner().parent())) {
+        if (const auto *details{inherited->detailsIf<GenericDetails>()}) {
+          // Include specifics of inherited generic of the same name, too
+          CollectSpecifics(helper, *inherited, *details);
+        }
+      }
+    }
+  }
+}
+
+void CheckHelper::CheckSpecifics(
+    const Symbol &generic, const GenericDetails &details) {
+  GenericKind kind{details.kind()};
+  DistinguishabilityHelper helper{context_};
+  CollectSpecifics(helper, generic, details);
   helper.Check(generic.owner());
 }
 
@@ -3947,10 +3967,11 @@ evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
 }
 
 void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,
-    const Symbol &ultimateSpecific, const Procedure &procedure) {
-  if (!context_.HasError(ultimateSpecific)) {
+    const Symbol &specific, const Procedure &procedure) {
+  const Symbol &ultimate{specific.GetUltimate()};
+  if (!context_.HasError(ultimate)) {
     nameToSpecifics_[generic.name()].emplace(
-        &ultimateSpecific, ProcedureInfo{kind, procedure});
+        &ultimate, ProcedureInfo{kind, procedure});
   }
 }
 
@@ -3965,6 +3986,18 @@ 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
+        } else if (const auto *binding1{
+                       ultimate->detailsIf<ProcBindingDetails>()}) {
+          if (const auto *binding2{
+                  iter2->first->detailsIf<ProcBindingDetails>()}) {
+            if (&binding1->symbol().GetUltimate() ==
+                &binding2->symbol().GetUltimate()) {
+              continue; // ok, bindings resolve identically
+            }
+          }
+        }
         auto distinguishable{kind.IsName()
                 ? evaluate::characteristics::Distinguishable
                 : evaluate::characteristics::DistinguishableOpOrAssign};

flang/test/Semantics/generic07.f90

@@ -74,7 +74,7 @@ program test
   interface distinguishable3
     procedure :: s1a, s1b
   end interface
-  !ERROR: Generic 'indistinguishable' may not have specific procedures 's2b' and 's2a' as their interfaces are not distinguishable
+  !ERROR: Generic 'indistinguishable' may not have specific procedures 's2a' and 's2b' as their interfaces are not distinguishable
   interface indistinguishable
     procedure :: s2a, s2b
   end interface

flang/test/Semantics/resolve117.f90

@@ -5,23 +5,28 @@ module m
     integer, kind :: k = 4
     real x
    contains
-    procedure, nopass :: tbp => sub
-    generic :: gen => tbp
+    procedure, nopass :: tbp => sub1
+    generic :: gen1 => tbp
+    generic :: gen2 => tbp
   end type
   type, extends(base1) :: ext1
    contains
-    procedure, nopass :: sub
+    procedure, nopass :: sub1, sub2
     !ERROR: Type parameter, component, or procedure binding 'base1' already defined in this type
-    generic :: base1 => sub
+    generic :: base1 => sub1
     !ERROR: Type bound generic procedure 'k' may not have the same name as a non-generic symbol inherited from an ancestor type
-    generic :: k => sub
+    generic :: k => sub1
     !ERROR: Type bound generic procedure 'x' may not have the same name as a non-generic symbol inherited from an ancestor type
-    generic :: x => sub
+    generic :: x => sub1
     !ERROR: Type bound generic procedure 'tbp' may not have the same name as a non-generic symbol inherited from an ancestor type
-    generic :: tbp => sub
-    generic :: gen => sub ! ok
+    generic :: tbp => sub1
+    generic :: gen1 => sub1 ! ok
+    !ERROR: Generic 'gen2' may not have specific procedures 'tbp' and 'sub2' as their interfaces are not distinguishable
+    generic :: gen2 => sub2
   end type
  contains
-  subroutine sub
+  subroutine sub1
+  end
+  subroutine sub2
   end
 end