[flang-commits] [flang] 069aee0 - [flang] Rework F'2023 constraint C1167 checking (#83888)
via flang-commits
flang-commits at lists.llvm.org
Tue Mar 5 11:28:15 PST 2024
Author: Peter Klausler
Date: 2024-03-05T11:28:11-08:00
New Revision: 069aee0793064b800f130e740e37dd7d264b7802
URL: https://github.com/llvm/llvm-project/commit/069aee0793064b800f130e740e37dd7d264b7802
DIFF: https://github.com/llvm/llvm-project/commit/069aee0793064b800f130e740e37dd7d264b7802.diff
LOG: [flang] Rework F'2023 constraint C1167 checking (#83888)
The code that verifies that the type in a TYPE IS or CLASS IS clause is
a match or an extension of the type of the SELECT TYPE selector needs
rework to avoid emitting a bogus error for a test.
Fixes https://github.com/llvm/llvm-project/issues/83612.
Added:
flang/test/Semantics/selecttype04.f90
Modified:
flang/include/flang/Semantics/type.h
flang/lib/Semantics/check-select-type.cpp
flang/lib/Semantics/type.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index 8965d29d8889da..5520b02e6790d0 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 6515cf25e0d7df..94d16a719277af 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 e812283fc6f190..44e49673300bfd 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -231,27 +231,36 @@ ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
const_cast<const DerivedTypeSpec *>(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<TypeParamDetails>() : 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<DerivedTypeDetails>().paramDecls()) {
+ if (ref->get<TypeParamDetails>().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 00000000000000..535576b0ac9aa5
--- /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
More information about the flang-commits
mailing list