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

[klausler]

Summary

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.

[jeanPerier]

Looks good

flang/include/flang/Evaluate/type.h

#endif
   bool HasDeferredTypeParameter() const;
 
   // 7.3.2.3 & 15.5.2.4 type compatibility.
   // x.IsTkCompatibleWith(y) is true if "x => y" or passing actual y to
   // dummy argument x would be valid.  Be advised, this is not a reflexive
   // 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 &);
   static std::optional<DynamicType> From(const semantics::Symbol &);
 
   template <typename A> static std::optional<DynamicType> From(const A &x) {
     return x.GetType();
   }

flang/lib/Evaluate/fold-logical.cpp

if (const auto *ix{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
                             "POS=%jd out of range for BTEST"_err_en_US,
                             static_cast<std::intmax_t>(posVal));
                       }
                       return Scalar<T>{x.BTEST(posVal)};
                     }));
           },
           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().
     auto restorer{context.messages().DiscardMessages()};
     using DefaultReal = Type<TypeCategory::Real, 4>;
     return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
         ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
           return Scalar<T>{x.IsNotANumber()};
if (cx0 && cx1) {
                   ConvertToType<Ascii>(std::move(*cx1)))));
     }
   } else if (name == "logical") {
     if (auto *expr{UnwrapExpr<Expr<SomeLogical>>(args[0])}) {
       return Fold(context, ConvertToType<T>(std::move(*expr)));
     }
   } 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" ||
       name == "__builtin_ieee_support_divide" ||
       name == "__builtin_ieee_support_inf" ||
       name == "__builtin_ieee_support_io" ||
       name == "__builtin_ieee_support_nan" ||
       name == "__builtin_ieee_support_sqrt" ||

flang/lib/Evaluate/type.cpp

if (AreSameDerivedType(*x, *y, inProgress)) {
       return true;
     } else {
       return isPolymorphic &&
           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
     }
   }
 }
 
-// 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 (derived_) {
-    return that.derived_ &&
-        AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()) &&
-        AreTypeParamCompatible(*derived_, *that.derived_);
+  } else if (x.category() != TypeCategory::Derived) {
+    return x.kind() == y.kind();
   } else {
-    return kind_ == that.kind_;
+    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 (that.IsPolymorphic()) {
+    return std::nullopt; // unknown
+  } else {
+    return true;
   }
 }
 
 std::optional<DynamicType> DynamicType::From(
     const semantics::DeclTypeSpec &type) {
   if (const auto *intrinsic{type.AsIntrinsic()}) {
     if (auto kind{ToInt64(intrinsic->kind())}) {
       TypeCategory category{intrinsic->category()};

flang/test/Evaluate/fold-type.f90

+! 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