[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

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 &);

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" ||

flang/lib/Evaluate/type.cpp

@@ -334,20 +334,53 @@ static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
   }
 }
 
+static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
+    bool ignoreTypeParameterValues) {
+  if (x.IsUnlimitedPolymorphic()) {
+    return true;
+  } else if (y.IsUnlimitedPolymorphic()) {
+    return false;
+  } 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 {
-  if (IsUnlimitedPolymorphic()) {
-    return true;
-  } else if (that.IsUnlimitedPolymorphic()) {
-    return false;
-  } else if (category_ != that.category_) {
-    return false;
-  } else if (derived_) {
-    return that.derived_ &&
-        AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()) &&
-        AreTypeParamCompatible(*derived_, *that.derived_);
+  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 {
-    return kind_ == that.kind_;
+    // 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 (that.IsPolymorphic()) {
+    return std::nullopt; // unknown
+  } else {
+    return true;
   }
 }
 

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