[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 #83612.

Author: klausler

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;
 

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;
         }
       }
     }

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 {

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