[flang] Refine checking of type-bound generics (#129292)

I merged a patch yesterday
(https://github.com/llvm/llvm-project/pull/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.
This commit is contained in:
Peter Klausler
2025-03-03 14:46:08 -08:00
committed by GitHub
parent dfc5f37e3a
commit b2ba43a9c1
2 changed files with 109 additions and 6 deletions

View File

@@ -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());
}
}
}

View File

@@ -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