[flang] Fix TYPE/CLASS IS (T(...)) in SELECT TYPE

[klausler]

Summary

TYPE IS and CLASS IS guards in SELECT TYPE constructs are
allowed to specify the same type as the type of the selector
but f18's implementation of that predicate required strict
equality of the derived type representations. We need to
allow for assumed values of LEN type parameters to match
explicit and deferred type parameter values in the selector
and require equality for KIND type parameters. Implement
DerivedTypeSpec::Match() to perform this more relaxed type
comparison, and use it in check-select-type.cpp.

flang/include/flang/Semantics/type.h

public:
   const MaybeIntExpr &GetExplicit() const { return expr_; }
   void SetExplicit(SomeIntExpr &&);
   bool isKind() const { return attr_ == common::TypeParamAttr::Kind; }
   bool isLen() const { return attr_ == common::TypeParamAttr::Len; }
   void set_attr(common::TypeParamAttr attr) { attr_ = attr; }
   bool operator==(const ParamValue &that) const {
     return category_ == that.category_ && expr_ == that.expr_;
   }
+  bool operator!=(const ParamValue &that) const { return !(*this == that); }
   std::string AsFortran() const;
 
 private:
   enum class Category { Explicit, Deferred, Assumed };
   ParamValue(Category category, common::TypeParamAttr attr)
       : category_{category}, attr_{attr} {}
   Category category_{Category::Explicit};
   common::TypeParamAttr attr_{common::TypeParamAttr::Kind};
const ParamValue *FindParameter(SourceName target) const {
     }
   }
   bool operator==(const DerivedTypeSpec &that) const {
     return RawEquals(that) && parameters_ == that.parameters_;
   }
   bool operator!=(const DerivedTypeSpec &that) const {
     return !(*this == that);
   }
+  // For TYPE IS & CLASS IS: kind type parameters must be
+  // explicit and equal, len type parameters are ignored.
+  bool Match(const DerivedTypeSpec &) const;
   std::string AsFortran() const;
 
 private:
   SourceName name_;
   const Symbol &typeSymbol_;
   const Scope *scope_{nullptr}; // same as typeSymbol_.scope() unless PDT
   bool cooked_{false};
   bool evaluated_{false};

flang/lib/Semantics/check-select-type.cpp

if (!IsExtensibleType(&derived)) { // C1161
           "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 == *selDerivedTypeSpec) &&
+          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;
           }
         }

flang/lib/Semantics/type.cpp

return bool{std::find_if(
       })};
 }
 
 ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
   return const_cast<ParamValue *>(
       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;
+    }
+    const ParamValue &value{pair.second};
+    auto iter{that.parameters_.find(pair.first)};
+    if (iter == that.parameters_.end() || iter->second != value) {
+      return false;
+    }
+  }
+  return true;
+}
+
 class InstantiateHelper {
 public:
   InstantiateHelper(Scope &scope) : scope_{scope} {}
   // Instantiate components from fromScope into scope_
   void InstantiateComponents(const Scope &);
 
 private:
   SemanticsContext &context() const { return scope_.context(); }

flang/test/Semantics/selecttype01.f90

subroutine CheckC1162
   !Unlimited polymorphic objects are allowed.
   unlim_polymorphic => rect_obj
   select type (unlim_polymorphic)
     type is (shape)
     type is (unrelated)
   end select
 end
 
+module c1162a
+  type pdt(kind,len)
+    integer, kind :: kind
+    integer, len :: len
+  end type
+ contains
+  subroutine foo(x)
+    class(pdt(kind=1,len=:)), allocatable :: x
+    select type (x)
+    type is (pdt(kind=1, len=*))
+    !ERROR: Type specification 'pdt(kind=2_4,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
+    type is (pdt(kind=2, len=*))
+    !ERROR: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
+    type is (pdt(kind=*, len=*))
+    end select
+  end subroutine
+end module
+
 subroutine CheckC1163
   use m1
   !assign dynamically
   shape_lim_polymorphic => rect_obj
   unlim_polymorphic => shape_obj
   select type (shape_lim_polymorphic)
     type is (shape)
     !ERROR: Type specification 'shape' conflicts with previous type specification