diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp index 9c9daafcce3a4..12e931afddf4d 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -283,18 +283,53 @@ using SetOfDerivedTypePairs = std::set>; +static bool AreSameDerivedType(const semantics::DerivedTypeSpec &, + const semantics::DerivedTypeSpec &, bool ignoreTypeParameterValues, + bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress); + +// F2023 7.5.3.2 static bool AreSameComponent(const semantics::Symbol &x, - const semantics::Symbol &y, - SetOfDerivedTypePairs & /* inProgress - not yet used */) { + const semantics::Symbol &y, SetOfDerivedTypePairs &inProgress) { if (x.attrs() != y.attrs()) { return false; } if (x.attrs().test(semantics::Attr::PRIVATE)) { return false; } - // TODO: compare types, parameters, bounds, &c. - return x.has() == - y.has(); + if (x.size() && y.size()) { + if (x.offset() != y.offset() || x.size() != y.size()) { + return false; + } + } + const auto *xObj{x.detailsIf()}; + const auto *yObj{y.detailsIf()}; + const auto *xProc{x.detailsIf()}; + const auto *yProc{y.detailsIf()}; + if (!xObj != !yObj || !xProc != !yProc) { + return false; + } + auto xType{DynamicType::From(x)}; + auto yType{DynamicType::From(y)}; + if (xType && yType) { + if (xType->category() == TypeCategory::Derived) { + if (yType->category() != TypeCategory::Derived || + !xType->IsUnlimitedPolymorphic() != + !yType->IsUnlimitedPolymorphic() || + (!xType->IsUnlimitedPolymorphic() && + !AreSameDerivedType(xType->GetDerivedTypeSpec(), + yType->GetDerivedTypeSpec(), false, false, inProgress))) { + return false; + } + } else if (!xType->IsTkLenCompatibleWith(*yType)) { + return false; + } + } else if (xType || yType || !(xProc && yProc)) { + return false; + } + if (xProc) { + // TODO: compare argument types, &c. + } + return true; } // TODO: These utilities were cloned out of Semantics to avoid a cyclic @@ -403,6 +438,7 @@ static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x, return true; } +// F2023 7.5.3.2 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues, bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) { @@ -413,8 +449,8 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x, !AreTypeParamCompatible(x, y, ignoreLenParameters)) { return false; } - const auto &xSymbol{x.typeSymbol()}; - const auto &ySymbol{y.typeSymbol()}; + const auto &xSymbol{x.typeSymbol().GetUltimate()}; + const auto &ySymbol{y.typeSymbol().GetUltimate()}; if (xSymbol == ySymbol) { return true; } @@ -432,7 +468,7 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x, !(xSymbol.attrs().test(semantics::Attr::BIND_C) && ySymbol.attrs().test(semantics::Attr::BIND_C))) { // PGI does not enforce this requirement; all other Fortran - // processors do with a hard error when violations are caught. + // compilers do with a hard error when violations are caught. return false; } // Compare the component lists in their orders of declaration. diff --git a/flang/test/Semantics/generic05.f90 b/flang/test/Semantics/generic05.f90 new file mode 100644 index 0000000000000..885697e4b5a97 --- /dev/null +++ b/flang/test/Semantics/generic05.f90 @@ -0,0 +1,74 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module m + type :: t1 + sequence + real :: x + end type + type :: t2 + sequence + real :: x + end type + type :: t3 + real :: x + end type + type :: t4 + real, private :: x + end type + contains + subroutine s1a(x) + type(t1), intent(in) :: x + end + subroutine s2a(x) + type(t2), intent(in) :: x + end + subroutine s3a(x) + type(t3), intent(in) :: x + end + subroutine s4a(x) + type(t4), intent(in) :: x + end +end + +program test + use m, only: s1a, s2a, s3a, s4a + type :: t1 + sequence + integer :: x ! distinct type + end type + type :: t2 + sequence + real :: x + end type + type :: t3 ! no SEQUENCE + real :: x + end type + type :: t4 + real :: x ! not PRIVATE + end type + interface distinguishable1 + procedure :: s1a, s1b + end interface + interface distinguishable2 + procedure :: s1a, s1b + end interface + interface distinguishable3 + procedure :: s1a, s1b + end interface + !ERROR: Generic 'indistinguishable' may not have specific procedures 's2a' and 's2b' as their interfaces are not distinguishable + interface indistinguishable + procedure :: s2a, s2b + end interface + contains + subroutine s1b(x) + type(t1), intent(in) :: x + end + subroutine s2b(x) + type(t2), intent(in) :: x + end + subroutine s3b(x) + type(t3), intent(in) :: x + end + subroutine s4b(x) + type(t4), intent(in) :: x + end +end