diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h index 8965d29d8889d..5520b02e6790d 100644 --- a/flang/include/flang/Semantics/type.h +++ b/flang/include/flang/Semantics/type.h @@ -306,7 +306,7 @@ class DerivedTypeSpec { } // For TYPE IS & CLASS IS: kind type parameters must be // explicit and equal, len type parameters are ignored. - bool Match(const DerivedTypeSpec &) const; + bool MatchesOrExtends(const DerivedTypeSpec &) const; std::string AsFortran() const; std::string VectorTypeAsFortran() const; diff --git a/flang/lib/Semantics/check-select-type.cpp b/flang/lib/Semantics/check-select-type.cpp index 6515cf25e0d7d..94d16a719277a 100644 --- a/flang/lib/Semantics/check-select-type.cpp +++ b/flang/lib/Semantics/check-select-type.cpp @@ -120,31 +120,25 @@ class TypeCaseValues { bool PassesDerivedTypeChecks(const semantics::DerivedTypeSpec &derived, parser::CharBlock sourceLoc) const { for (const auto &pair : derived.parameters()) { - if (pair.second.isLen() && !pair.second.isAssumed()) { // C1160 + if (pair.second.isLen() && !pair.second.isAssumed()) { // F'2023 C1165 context_.Say(sourceLoc, - "The type specification statement must have " - "LEN type parameter as assumed"_err_en_US); + "The type specification statement must have LEN type parameter as assumed"_err_en_US); return false; } } - if (!IsExtensibleType(&derived)) { // C1161 + if (!IsExtensibleType(&derived)) { // F'2023 C1166 context_.Say(sourceLoc, - "The type specification statement must not specify " - "a type with a SEQUENCE attribute or a BIND attribute"_err_en_US); + "The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute"_err_en_US); return false; } - if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162 - if (const semantics::Scope * guardScope{derived.typeSymbol().scope()}) { - if (const auto *selDerivedTypeSpec{ - evaluate::GetDerivedTypeSpec(selectorType_)}) { - if (!derived.Match(*selDerivedTypeSpec) && - !guardScope->FindComponent(selDerivedTypeSpec->name())) { - context_.Say(sourceLoc, - "Type specification '%s' must be an extension" - " of TYPE '%s'"_err_en_US, - derived.AsFortran(), selDerivedTypeSpec->AsFortran()); - return false; - } + if (!selectorType_.IsUnlimitedPolymorphic()) { // F'2023 C1167 + if (const auto *selDerivedTypeSpec{ + evaluate::GetDerivedTypeSpec(selectorType_)}) { + if (!derived.MatchesOrExtends(*selDerivedTypeSpec)) { + context_.Say(sourceLoc, + "Type specification '%s' must be an extension of TYPE '%s'"_err_en_US, + derived.AsFortran(), selDerivedTypeSpec->AsFortran()); + return false; } } } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index e812283fc6f19..44e49673300bf 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -231,27 +231,36 @@ ParamValue *DerivedTypeSpec::FindParameter(SourceName target) { const_cast(this)->FindParameter(target)); } -bool DerivedTypeSpec::Match(const DerivedTypeSpec &that) const { - if (&typeSymbol_ != &that.typeSymbol_) { - return false; - } - for (const auto &pair : parameters_) { - const Symbol *tpSym{scope_ ? scope_->FindSymbol(pair.first) : nullptr}; - const auto *tpDetails{ - tpSym ? tpSym->detailsIf() : nullptr}; - if (!tpDetails) { - return false; - } - if (tpDetails->attr() != common::TypeParamAttr::Kind) { - continue; +static bool MatchKindParams(const Symbol &typeSymbol, + const DerivedTypeSpec &thisSpec, const DerivedTypeSpec &thatSpec) { + for (auto ref : typeSymbol.get().paramDecls()) { + if (ref->get().attr() == common::TypeParamAttr::Kind) { + const auto *thisValue{thisSpec.FindParameter(ref->name())}; + const auto *thatValue{thatSpec.FindParameter(ref->name())}; + if (!thisValue || !thatValue || *thisValue != *thatValue) { + return false; + } } - const ParamValue &value{pair.second}; - auto iter{that.parameters_.find(pair.first)}; - if (iter == that.parameters_.end() || iter->second != value) { + } + if (const DerivedTypeSpec * + parent{typeSymbol.GetParentTypeSpec(typeSymbol.scope())}) { + return MatchKindParams(parent->typeSymbol(), thisSpec, thatSpec); + } else { + return true; + } +} + +bool DerivedTypeSpec::MatchesOrExtends(const DerivedTypeSpec &that) const { + const Symbol *typeSymbol{&typeSymbol_}; + while (typeSymbol != &that.typeSymbol_) { + if (const DerivedTypeSpec * + parent{typeSymbol->GetParentTypeSpec(typeSymbol->scope())}) { + typeSymbol = &parent->typeSymbol_; + } else { return false; } } - return true; + return MatchKindParams(*typeSymbol, *this, that); } class InstantiateHelper { diff --git a/flang/test/Semantics/selecttype04.f90 b/flang/test/Semantics/selecttype04.f90 new file mode 100644 index 0000000000000..535576b0ac9aa --- /dev/null +++ b/flang/test/Semantics/selecttype04.f90 @@ -0,0 +1,31 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check F'2023 C1167 +module m + type :: base(kindparam, lenparam) + integer, kind :: kindparam + integer, len :: lenparam + end type + type, extends(base) :: ext1 + contains + procedure :: tbp + end type + type, extends(ext1) :: ext2 + end type + contains + function tbp(x) + class(ext1(123,*)), target :: x + class(ext1(123,:)), pointer :: tbp + tbp => x + end + subroutine test + type(ext1(123,456)), target :: var + select type (sel => var%tbp()) + type is (ext1(123,*)) ! ok + type is (ext2(123,*)) ! ok + !ERROR: Type specification 'ext1(kindparam=234_4,lenparam=*)' must be an extension of TYPE 'ext1(kindparam=123_4,lenparam=:)' + type is (ext1(234,*)) + !ERROR: Type specification 'ext2(kindparam=234_4,lenparam=*)' must be an extension of TYPE 'ext1(kindparam=123_4,lenparam=:)' + type is (ext2(234,*)) + end select + end +end