diff options
author | Peter Klausler <pklausler@nvidia.com> | 2023-07-17 16:35:34 -0700 |
---|---|---|
committer | Peter Klausler <pklausler@nvidia.com> | 2023-07-21 12:01:54 -0700 |
commit | f6026f65be7113953c72720182562c3d67d2312e (patch) | |
tree | a16e2a2249590cfbf7aeb02c49a7ad4f484cfda0 /flang | |
parent | bf98aaae00465c1e52376f8e138e4c51eb526d12 (diff) | |
download | llvm-f6026f65be7113953c72720182562c3d67d2312e.zip llvm-f6026f65be7113953c72720182562c3d67d2312e.tar.gz llvm-f6026f65be7113953c72720182562c3d67d2312e.tar.bz2 |
[flang] Compare component types In AreSameComponent()
The subroutine AreSameComponent() of the predicate AreSameDerivedType()
had a TODO about checking component types that needed completion in order
to properly detect that two specific procedures of a generic are
distinguishable in the llvm-test-suite/Fortran/gfortran/regression
test import7.f90.
Differential Revision: https://reviews.llvm.org/D155962
Diffstat (limited to 'flang')
-rw-r--r-- | flang/lib/Evaluate/type.cpp | 52 | ||||
-rw-r--r-- | flang/test/Semantics/generic05.f90 | 74 |
2 files changed, 118 insertions, 8 deletions
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp index 9c9daaf..12e931a 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -283,18 +283,53 @@ using SetOfDerivedTypePairs = std::set<std::pair<const semantics::DerivedTypeSpec *, const semantics::DerivedTypeSpec *>>; +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<semantics::ObjectEntityDetails>() == - y.has<semantics::ObjectEntityDetails>(); + if (x.size() && y.size()) { + if (x.offset() != y.offset() || x.size() != y.size()) { + return false; + } + } + const auto *xObj{x.detailsIf<semantics::ObjectEntityDetails>()}; + const auto *yObj{y.detailsIf<semantics::ObjectEntityDetails>()}; + const auto *xProc{x.detailsIf<semantics::ProcEntityDetails>()}; + const auto *yProc{y.detailsIf<semantics::ProcEntityDetails>()}; + 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 0000000..885697e --- /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 |