[flang-commits] [flang] 142cbd5 - [flang] Fix TYPE/CLASS IS (T(...)) in SELECT TYPE

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-04-14T16:20:37-07:00
New Revision: 142cbd500b1a635d8933e033b7a5fc5c5e0f04b3

URL: https://github.com/llvm/llvm-project/commit/142cbd500b1a635d8933e033b7a5fc5c5e0f04b3
DIFF: https://github.com/llvm/llvm-project/commit/142cbd500b1a635d8933e033b7a5fc5c5e0f04b3.diff

LOG: [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

Added: 
    

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

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index f616d088a1bd5..f526c95bb6ae7 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -109,6 +109,7 @@ class ParamValue {
   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 @@ class DerivedTypeSpec {
   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 ce675fa2f1dbe..af547ae77e2f5 100644
--- a/flang/lib/Semantics/check-select-type.cpp
+++ b/flang/lib/Semantics/check-select-type.cpp
@@ -136,7 +136,7 @@ class TypeCaseValues {
       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 790ab7d460f2b..9c06cd327d0ee 100644
--- 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 62b3504b50873..b2da4e95cd5da 100644
--- 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