[flang-commits] [PATCH] D123721: [flang] Fix TYPE/CLASS IS (T(...)) in SELECT TYPE

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: vdonaldson.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

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.


https://reviews.llvm.org/D123721

Files:
  flang/include/flang/Semantics/type.h
  flang/lib/Semantics/check-select-type.cpp
  flang/lib/Semantics/type.cpp
  flang/test/Semantics/selecttype01.f90


Index: flang/test/Semantics/selecttype01.f90
===================================================================
--- flang/test/Semantics/selecttype01.f90
+++ flang/test/Semantics/selecttype01.f90
@@ -186,6 +186,24 @@
   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
Index: flang/lib/Semantics/type.cpp
===================================================================
--- flang/lib/Semantics/type.cpp
+++ flang/lib/Semantics/type.cpp
@@ -201,6 +201,29 @@
       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} {}
Index: flang/lib/Semantics/check-select-type.cpp
===================================================================
--- flang/lib/Semantics/check-select-type.cpp
+++ flang/lib/Semantics/check-select-type.cpp
@@ -136,7 +136,7 @@
       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"
Index: flang/include/flang/Semantics/type.h
===================================================================
--- flang/include/flang/Semantics/type.h
+++ flang/include/flang/Semantics/type.h
@@ -109,6 +109,7 @@
   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 @@
   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:


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D123721.422620.patch
Type: text/x-patch
Size: 3392 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220413/360ce7af/attachment.bin>