diff options
| -rw-r--r-- | flang/include/flang/Evaluate/type.h | 5 | ||||
| -rw-r--r-- | flang/lib/Evaluate/fold-logical.cpp | 24 | ||||
| -rw-r--r-- | flang/lib/Evaluate/type.cpp | 53 | ||||
| -rw-r--r-- | flang/test/Evaluate/fold-type.f90 | 43 |
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 |