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()}) { if (const auto *binding2{ - iter2->first->detailsIf()}) { + ultimate2->detailsIf()}) { 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() && + ultimate2->has() && + ultimate->name() == ultimate2->name()) { + continue; // override, possibly of DEFERRED } auto distinguishable{kind.IsName() ? evaluate::characteristics::Distinguishable : evaluate::characteristics::DistinguishableOpOrAssign}; std::optional 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