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

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.

Differential Revision: https://reviews.llvm.org/D123721

diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index f616d08..f526c95 100644 (file)
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -109,6 +109,7 @@ public:
   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:
@@ -299,6 +300,9 @@ public:
   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:

diff --git a/flang/lib/Semantics/check-select-type.cpp b/flang/lib/Semantics/check-select-type.cpp
index ce675fa..af547ae 100644 (file)
--- a/flang/lib/Semantics/check-select-type.cpp
+++ b/flang/lib/Semantics/check-select-type.cpp
@@ -136,7 +136,7 @@ private:
       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"

diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 790ab7d..9c06cd3 100644 (file)
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -201,6 +201,29 @@ 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;
+    }
+    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} {}

diff --git a/flang/test/Semantics/selecttype01.f90 b/flang/test/Semantics/selecttype01.f90
index 62b3504..b2da4e9 100644 (file)
--- a/flang/test/Semantics/selecttype01.f90
+++ b/flang/test/Semantics/selecttype01.f90
@@ -186,6 +186,24 @@ subroutine CheckC1162
   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