[flang] Fold intrinsic inquiry functions SAME_TYPE_AS() and EXTENDS_TYPE_OF()

When the result can be known at compilation time, fold it.
Success depends on whether the operands are polymorphic.
When neither one is polymorphic, the result is known and can
be either .TRUE. or .FALSE.; when either one is polymorphic,
a .FALSE. result still can be discerned.

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

4 files changed, 115 insertions, 10 deletions

diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index c413e24cf319..08c9e94c9d89 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -186,6 +186,11 @@ public:
   // relation.  Kind type parameters must match.
   bool IsTkCompatibleWith(const DynamicType &) const;
 
+  // EXTENDS_TYPE_OF (16.9.76); ignores type parameter values
+  std::optional<bool> ExtendsTypeOf(const DynamicType &) const;
+  // SAME_TYPE_AS (16.9.165); ignores type parameter values
+  std::optional<bool> SameTypeAs(const DynamicType &) const;
+
   // Result will be missing when a symbol is absent or
   // has an erroneous type, e.g., REAL(KIND=666).
   static std::optional<DynamicType> From(const semantics::DeclTypeSpec &);
diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp
index fe18ae211bd2..2b25f07bfc01 100644
--- a/flang/lib/Evaluate/fold-logical.cpp
+++ b/flang/lib/Evaluate/fold-logical.cpp
@@ -109,6 +109,18 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
           },
           ix->u);
     }
+  } else if (name == "extends_type_of") {
+    // Type extension testing with EXTENDS_TYPE_OF() ignores any type
+    // parameters. Returns a constant truth value when the result is known now.
+    if (args[0] && args[1]) {
+      auto t0{args[0]->GetType()};
+      auto t1{args[1]->GetType()};
+      if (t0 && t1) {
+        if (auto result{t0->ExtendsTypeOf(*t1)}) {
+          return Expr<T>{*result};
+        }
+      }
+    }
   } else if (name == "isnan" || name == "__builtin_ieee_is_nan") {
     // A warning about an invalid argument is discarded from converting
     // the argument of isnan() / IEEE_IS_NAN().
@@ -160,6 +172,18 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
     }
   } else if (name == "merge") {
     return FoldMerge<T>(context, std::move(funcRef));
+  } else if (name == "same_type_as") {
+    // Type equality testing with SAME_TYPE_AS() ignores any type parameters.
+    // Returns a constant truth value when the result is known now.
+    if (args[0] && args[1]) {
+      auto t0{args[0]->GetType()};
+      auto t1{args[1]->GetType()};
+      if (t0 && t1) {
+        if (auto result{t0->SameTypeAs(*t1)}) {
+          return Expr<T>{*result};
+        }
+      }
+    }
   } else if (name == "__builtin_ieee_support_datatype" ||
       name == "__builtin_ieee_support_denormal" ||
       name == "__builtin_ieee_support_divide" ||
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 3ccb25b94010..626bfaa93cb6 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -334,20 +334,53 @@ static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
   }
 }
 
-// See 7.3.2.3 (5) & 15.5.2.4
-bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
-  if (IsUnlimitedPolymorphic()) {
+static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
+    bool ignoreTypeParameterValues) {
+  if (x.IsUnlimitedPolymorphic()) {
     return true;
-  } else if (that.IsUnlimitedPolymorphic()) {
+  } else if (y.IsUnlimitedPolymorphic()) {
     return false;
-  } else if (category_ != that.category_) {
+  } else if (x.category() != y.category()) {
+    return false;
+  } else if (x.category() != TypeCategory::Derived) {
+    return x.kind() == y.kind();
+  } else {
+    const auto *xdt{GetDerivedTypeSpec(x)};
+    const auto *ydt{GetDerivedTypeSpec(y)};
+    return AreCompatibleDerivedTypes(xdt, ydt, x.IsPolymorphic()) &&
+        (ignoreTypeParameterValues ||
+            (xdt && ydt && AreTypeParamCompatible(*xdt, *ydt)));
+  }
+}
+
+// See 7.3.2.3 (5) & 15.5.2.4
+bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
+  return AreCompatibleTypes(*this, that, false);
+}
+
+// 16.9.165
+std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
+  bool x{AreCompatibleTypes(*this, that, true)};
+  bool y{AreCompatibleTypes(that, *this, true)};
+  if (x == y) {
+    return x;
+  } else {
+    // If either is unlimited polymorphic, the result is unknown.
+    return std::nullopt;
+  }
+}
+
+// 16.9.76
+std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
+  if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
+    return std::nullopt; // unknown
+  } else if (!AreCompatibleDerivedTypes(evaluate::GetDerivedTypeSpec(that),
+                 evaluate::GetDerivedTypeSpec(*this), true)) {
     return false;
-  } else if (derived_) {
-    return that.derived_ &&
-        AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()) &&
-        AreTypeParamCompatible(*derived_, *that.derived_);
+  } else if (that.IsPolymorphic()) {
+    return std::nullopt; // unknown
   } else {
-    return kind_ == that.kind_;
+    return true;
   }
 }
 
diff --git a/flang/test/Evaluate/fold-type.f90 b/flang/test/Evaluate/fold-type.f90
new file mode 100644
index 000000000000..3ea59efc0ae4
--- /dev/null
+++ b/flang/test/Evaluate/fold-type.f90
@@ -0,0 +1,43 @@
+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of SAME_TYPE_AS() and EXTENDS_TYPE_OF()
+module m
+
+  type :: t1
+    real :: x
+  end type
+  type :: t2(k)
+    integer, kind :: k
+    real(kind=k) :: x
+  end type
+  type :: t3
+    real :: x
+  end type
+  type, extends(t1) :: t4
+    integer :: y
+  end type
+
+  type(t1) :: x1, y1
+  type(t2(4)) :: x24, y24
+  type(t2(8)) :: x28
+  type(t3) :: x3
+  type(t4) :: x4
+  class(t1), allocatable :: a1
+  class(t3), allocatable :: a3
+
+  logical, parameter :: test_1 = same_type_as(x1, x1)
+  logical, parameter :: test_2 = same_type_as(x1, y1)
+  logical, parameter :: test_3 = same_type_as(x24, x24)
+  logical, parameter :: test_4 = same_type_as(x24, y24)
+  logical, parameter :: test_5 = same_type_as(x24, x28) ! ignores parameter
+  logical, parameter :: test_6 = .not. same_type_as(x1, x3)
+  logical, parameter :: test_7 = .not. same_type_as(a1, a3)
+
+  logical, parameter :: test_11 = extends_type_of(x1, y1)
+  logical, parameter :: test_12 = extends_type_of(x24, x24)
+  logical, parameter :: test_13 = extends_type_of(x24, y24)
+  logical, parameter :: test_14 = extends_type_of(x24, x28) ! ignores parameter
+  logical, parameter :: test_15 = .not. extends_type_of(x1, x3)
+  logical, parameter :: test_16 = .not. extends_type_of(a1, a3)
+  logical, parameter :: test_17 = .not. extends_type_of(x1, x4)
+  logical, parameter :: test_18 = extends_type_of(x4, x1)
+end module