From 1444e5acfb75630c23b118c39454a05cf3792d35 Mon Sep 17 00:00:00 2001
From: Peter Klausler <35819229+klausler@users.noreply.github.com>
Date: Mon, 22 Apr 2024 15:46:00 -0700
Subject: [PATCH] [flang] Complete implementation of OUT_OF_RANGE() (#89334)
The intrinsic function OUT_OF_RANGE() lacks support in lowering and the
runtime. This patch obviates a need for any such support by implementing
OUT_OF_RANGE() via rewriting in semantics. This rewriting of
OUT_OF_RANGE() calls replaces the existing code that folds
OUT_OF_RANGE() calls with constant arguments.
Some changes and fixes were necessary outside of OUT_OF_RANGE()'s
folding code (now rewriting code), whose testing exposed some other
issues worth fixing.
- The common::RealDetails<> template class was recoded in terms of a new
base class with a constexpr constructor, so that the the characteristics
of the various REAL kinds could be queried dynamically as well. This
affected some client usage.
- There were bugs in the code that folds TRANSFER() when the type of X
or MOLD was REAL(10) -- this is a type that occupies 16 bytes per
element in execution memory but only 10 bytes (was 12) in the data of
std::vector<Scalar<>> in a Constant<>.
- Folds of REAL->REAL conversions weren't preserving infinities.
---
flang/include/flang/Common/real.h | 49 +-
.../flang/Decimal/binary-floating-point.h | 27 +-
flang/include/flang/Evaluate/complex.h | 2 +-
flang/include/flang/Evaluate/integer.h | 15 +-
flang/include/flang/Evaluate/real.h | 27 +-
flang/include/flang/Evaluate/type.h | 5 +-
flang/lib/Decimal/big-radix-floating-point.h | 2 +
flang/lib/Evaluate/complex.cpp | 2 +-
flang/lib/Evaluate/fold-logical.cpp | 689 +++++++++++++++---
flang/lib/Evaluate/integer.cpp | 2 +-
flang/lib/Evaluate/real.cpp | 2 +-
flang/test/Evaluate/fold-out_of_range.f90 | 66 +-
flang/test/Evaluate/rewrite-out_of_range.F90 | 208 ++++++
13 files changed, 911 insertions(+), 185 deletions(-)
create mode 100644 flang/test/Evaluate/rewrite-out_of_range.F90
diff --git a/flang/include/flang/Common/real.h b/flang/include/flang/Common/real.h
index 49c400b368a2..b527deda0e3b 100644
--- a/flang/include/flang/Common/real.h
+++ b/flang/include/flang/Common/real.h
@@ -108,7 +108,27 @@ static constexpr int PrecisionOfRealKind(int kind) {
}
}
-template <int BINARY_PRECISION> class RealDetails {
+// RealCharacteristics is constexpr, but also useful when constructed
+// with a non-constant precision argument.
+class RealCharacteristics {
+public:
+ explicit constexpr RealCharacteristics(int p) : binaryPrecision{p} {}
+
+ int binaryPrecision;
+ int bits{BitsForBinaryPrecision(binaryPrecision)};
+ bool isImplicitMSB{binaryPrecision != 64 /*x87*/};
+ int significandBits{binaryPrecision - isImplicitMSB};
+ int exponentBits{bits - significandBits - 1 /*sign*/};
+ int maxExponent{(1 << exponentBits) - 1};
+ int exponentBias{maxExponent / 2};
+ int decimalPrecision{LogBaseTwoToLogBaseTen(binaryPrecision - 1)};
+ int decimalRange{LogBaseTwoToLogBaseTen(exponentBias - 1)};
+ // Number of significant decimal digits in the fraction of the
+ // exact conversion of the least nonzero subnormal.
+ int maxDecimalConversionDigits{MaxDecimalConversionDigits(binaryPrecision)};
+ int maxHexadecimalConversionDigits{
+ MaxHexadecimalConversionDigits(binaryPrecision)};
+
private:
// Converts bit widths to whole decimal digits
static constexpr int LogBaseTwoToLogBaseTen(int logb2) {
@@ -118,33 +138,6 @@ private:
(logb2 * LogBaseTenOfTwoTimesTenToThe12th) / TenToThe12th};
return static_cast<int>(logb10);
}
-
-public:
- RT_OFFLOAD_VAR_GROUP_BEGIN
- static constexpr int binaryPrecision{BINARY_PRECISION};
- static constexpr int bits{BitsForBinaryPrecision(binaryPrecision)};
- static constexpr bool isImplicitMSB{binaryPrecision != 64 /*x87*/};
- static constexpr int significandBits{binaryPrecision - isImplicitMSB};
- static constexpr int exponentBits{bits - significandBits - 1 /*sign*/};
- static constexpr int maxExponent{(1 << exponentBits) - 1};
- static constexpr int exponentBias{maxExponent / 2};
-
- static constexpr int decimalPrecision{
- LogBaseTwoToLogBaseTen(binaryPrecision - 1)};
- static constexpr int decimalRange{LogBaseTwoToLogBaseTen(exponentBias - 1)};
-
- // Number of significant decimal digits in the fraction of the
- // exact conversion of the least nonzero subnormal.
- static constexpr int maxDecimalConversionDigits{
- MaxDecimalConversionDigits(binaryPrecision)};
-
- static constexpr int maxHexadecimalConversionDigits{
- MaxHexadecimalConversionDigits(binaryPrecision)};
- RT_OFFLOAD_VAR_GROUP_END
-
- static_assert(binaryPrecision > 0);
- static_assert(exponentBits > 1);
- static_assert(exponentBits <= 15);
};
} // namespace Fortran::common
diff --git a/flang/include/flang/Decimal/binary-floating-point.h b/flang/include/flang/Decimal/binary-floating-point.h
index 4919c1f9d240..1e0cde97d98e 100644
--- a/flang/include/flang/Decimal/binary-floating-point.h
+++ b/flang/include/flang/Decimal/binary-floating-point.h
@@ -30,21 +30,20 @@ enum FortranRounding {
RoundCompatible, /* RC: like RN, but ties go away from 0 */
};
-template <int BINARY_PRECISION>
-class BinaryFloatingPointNumber : public common::RealDetails<BINARY_PRECISION> {
+template <int BINARY_PRECISION> class BinaryFloatingPointNumber {
public:
- using Details = common::RealDetails<BINARY_PRECISION>;
- using Details::binaryPrecision;
- using Details::bits;
- using Details::decimalPrecision;
- using Details::decimalRange;
- using Details::exponentBias;
- using Details::exponentBits;
- using Details::isImplicitMSB;
- using Details::maxDecimalConversionDigits;
- using Details::maxExponent;
- using Details::maxHexadecimalConversionDigits;
- using Details::significandBits;
+ static constexpr common::RealCharacteristics realChars{BINARY_PRECISION};
+ static constexpr int binaryPrecision{BINARY_PRECISION};
+ static constexpr int bits{realChars.bits};
+ static constexpr int isImplicitMSB{realChars.isImplicitMSB};
+ static constexpr int significandBits{realChars.significandBits};
+ static constexpr int exponentBits{realChars.exponentBits};
+ static constexpr int exponentBias{realChars.exponentBias};
+ static constexpr int maxExponent{realChars.maxExponent};
+ static constexpr int decimalPrecision{realChars.decimalPrecision};
+ static constexpr int decimalRange{realChars.decimalRange};
+ static constexpr int maxDecimalConversionDigits{
+ realChars.maxDecimalConversionDigits};
using RawType = common::HostUnsignedIntType<bits>;
static_assert(CHAR_BIT * sizeof(RawType) >= bits);
diff --git a/flang/include/flang/Evaluate/complex.h b/flang/include/flang/Evaluate/complex.h
index 200965ed9212..06eef8424109 100644
--- a/flang/include/flang/Evaluate/complex.h
+++ b/flang/include/flang/Evaluate/complex.h
@@ -104,7 +104,7 @@ extern template class Complex<Real<Integer<16>, 11>>;
extern template class Complex<Real<Integer<16>, 8>>;
extern template class Complex<Real<Integer<32>, 24>>;
extern template class Complex<Real<Integer<64>, 53>>;
-extern template class Complex<Real<Integer<80>, 64>>;
+extern template class Complex<Real<X87IntegerContainer, 64>>;
extern template class Complex<Real<Integer<128>, 113>>;
} // namespace Fortran::evaluate::value
#endif // FORTRAN_EVALUATE_COMPLEX_H_
diff --git a/flang/include/flang/Evaluate/integer.h b/flang/include/flang/Evaluate/integer.h
index b62e2bcb90f2..10a13115a39e 100644
--- a/flang/include/flang/Evaluate/integer.h
+++ b/flang/include/flang/Evaluate/integer.h
@@ -50,9 +50,12 @@ namespace Fortran::evaluate::value {
// named accordingly in ALL CAPS so that they can be referenced easily in
// the language standard.
template <int BITS, bool IS_LITTLE_ENDIAN = isHostLittleEndian,
- int PARTBITS = BITS <= 32 ? BITS : 32,
+ int PARTBITS = BITS <= 32 ? BITS
+ : BITS % 32 == 0 ? 32
+ : BITS % 16 == 0 ? 16
+ : 8,
typename PART = HostUnsignedInt<PARTBITS>,
- typename BIGPART = HostUnsignedInt<PARTBITS * 2>>
+ typename BIGPART = HostUnsignedInt<PARTBITS * 2>, int ALIGNMENT = BITS>
class Integer {
public:
static constexpr int bits{BITS};
@@ -79,6 +82,8 @@ private:
static_assert((parts - 1) * partBits + topPartBits == bits);
static constexpr Part partMask{static_cast<Part>(~0) >> extraPartBits};
static constexpr Part topPartMask{static_cast<Part>(~0) >> extraTopPartBits};
+ static constexpr int partsWithAlignment{
+ (ALIGNMENT + partBits - 1) / partBits};
public:
// Some types used for member function results
@@ -1043,14 +1048,16 @@ private:
}
}
- Part part_[parts]{};
+ Part part_[partsWithAlignment]{};
};
extern template class Integer<8>;
extern template class Integer<16>;
extern template class Integer<32>;
extern template class Integer<64>;
-extern template class Integer<80>;
+using X87IntegerContainer =
+ Integer<80, true, 16, std::uint16_t, std::uint32_t, 128>;
+extern template class Integer<80, true, 16, std::uint16_t, std::uint32_t, 128>;
extern template class Integer<128>;
} // namespace Fortran::evaluate::value
#endif // FORTRAN_EVALUATE_INTEGER_H_
diff --git a/flang/include/flang/Evaluate/real.h b/flang/include/flang/Evaluate/real.h
index 6f2466c9da67..cb3c0036e0cf 100644
--- a/flang/include/flang/Evaluate/real.h
+++ b/flang/include/flang/Evaluate/real.h
@@ -35,20 +35,19 @@ static constexpr std::int64_t ScaledLogBaseTenOfTwo{301029995664};
// class template must be (or look like) an instance of Integer<>;
// the second specifies the number of effective bits (binary precision)
// in the fraction.
-template <typename WORD, int PREC>
-class Real : public common::RealDetails<PREC> {
+template <typename WORD, int PREC> class Real {
public:
using Word = WORD;
static constexpr int binaryPrecision{PREC};
- using Details = common::RealDetails<PREC>;
- using Details::exponentBias;
- using Details::exponentBits;
- using Details::isImplicitMSB;
- using Details::maxExponent;
- using Details::significandBits;
+ static constexpr common::RealCharacteristics realChars{PREC};
+ static constexpr int exponentBias{realChars.exponentBias};
+ static constexpr int exponentBits{realChars.exponentBits};
+ static constexpr int isImplicitMSB{realChars.isImplicitMSB};
+ static constexpr int maxExponent{realChars.maxExponent};
+ static constexpr int significandBits{realChars.significandBits};
static constexpr int bits{Word::bits};
- static_assert(bits >= Details::bits);
+ static_assert(bits >= realChars.bits);
using Fraction = Integer<binaryPrecision>; // all bits made explicit
template <typename W, int P> friend class Real;
@@ -205,8 +204,8 @@ public:
}
static constexpr int DIGITS{binaryPrecision};
- static constexpr int PRECISION{Details::decimalPrecision};
- static constexpr int RANGE{Details::decimalRange};
+ static constexpr int PRECISION{realChars.decimalPrecision};
+ static constexpr int RANGE{realChars.decimalRange};
static constexpr int MAXEXPONENT{maxExponent - exponentBias};
static constexpr int MINEXPONENT{2 - exponentBias};
Real RRSPACING() const;
@@ -371,6 +370,10 @@ public:
return result;
}
bool isNegative{x.IsNegative()};
+ if (x.IsInfinite()) {
+ result.value = Infinity(isNegative);
+ return result;
+ }
A absX{x};
if (isNegative) {
absX = x.Negate();
@@ -493,7 +496,7 @@ extern template class Real<Integer<16>, 11>; // IEEE half format
extern template class Real<Integer<16>, 8>; // the "other" half format
extern template class Real<Integer<32>, 24>; // IEEE single
extern template class Real<Integer<64>, 53>; // IEEE double
-extern template class Real<Integer<80>, 64>; // 80387 extended precision
+extern template class Real<X87IntegerContainer, 64>; // 80387 extended precision
extern template class Real<Integer<128>, 113>; // IEEE quad
// N.B. No "double-double" support.
} // namespace Fortran::evaluate::value
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index da6efea6f8a7..93a0f21fa914 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -296,7 +296,10 @@ class Type<TypeCategory::Real, KIND>
public:
static constexpr int precision{common::PrecisionOfRealKind(KIND)};
static constexpr int bits{common::BitsForBinaryPrecision(precision)};
- using Scalar = value::Real<value::Integer<bits>, precision>;
+ using Scalar =
+ value::Real<std::conditional_t<precision == 64,
+ value::X87IntegerContainer, value::Integer<bits>>,
+ precision>;
};
// The KIND type parameter on COMPLEX is the kind of each of its components.
diff --git a/flang/lib/Decimal/big-radix-floating-point.h b/flang/lib/Decimal/big-radix-floating-point.h
index 6ce8ae7925c1..f9afebf5b3d7 100644
--- a/flang/lib/Decimal/big-radix-floating-point.h
+++ b/flang/lib/Decimal/big-radix-floating-point.h
@@ -83,6 +83,8 @@ public:
return *this;
}
+ RT_API_ATTRS bool IsInteger() const { return exponent_ >= 0; }
+
// Converts decimal floating-point to binary.
RT_API_ATTRS ConversionToBinaryResult<PREC> ConvertToBinary();
diff --git a/flang/lib/Evaluate/complex.cpp b/flang/lib/Evaluate/complex.cpp
index e683d7e0229c..ab83f193e3f3 100644
--- a/flang/lib/Evaluate/complex.cpp
+++ b/flang/lib/Evaluate/complex.cpp
@@ -120,6 +120,6 @@ template class Complex<Real<Integer<16>, 11>>;
template class Complex<Real<Integer<16>, 8>>;
template class Complex<Real<Integer<32>, 24>>;
template class Complex<Real<Integer<64>, 53>>;
-template class Complex<Real<Integer<80>, 64>>;
+template class Complex<Real<X87IntegerContainer, 64>>;
template class Complex<Real<Integer<128>, 113>>;
} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp
index 5a9596f3c274..4c1afe9a0f29 100644
--- a/flang/lib/Evaluate/fold-logical.cpp
+++ b/flang/lib/Evaluate/fold-logical.cpp
@@ -41,6 +41,586 @@ static Expr<T> FoldAllAnyParity(FoldingContext &context, FunctionRef<T> &&ref,
return Expr<T>{std::move(ref)};
}
+// OUT_OF_RANGE(x,mold[,round]) references are entirely rewritten here into
+// expressions, which are then folded into constants when 'x' and 'round'
+// are constant. It is guaranteed that 'x' is evaluated at most once.
+
+template <int X_RKIND, int MOLD_IKIND>
+Expr<SomeReal> RealToIntBoundHelper(bool round, bool negate) {
+ using RType = Type<TypeCategory::Real, X_RKIND>;
+ using RealType = Scalar<RType>;
+ using IntType = Scalar<Type<TypeCategory::Integer, MOLD_IKIND>>;
+ RealType result{}; // 0.
+ common::RoundingMode roundingMode{round
+ ? common::RoundingMode::TiesAwayFromZero
+ : common::RoundingMode::ToZero};
+ // Add decreasing powers of two to the result to find the largest magnitude
+ // value that can be converted to the integer type without overflow.
+ RealType at{RealType::FromInteger(IntType{negate ? -1 : 1}).value};
+ bool decrement{true};
+ while (!at.template ToInteger<IntType>(roundingMode)
+ .flags.test(RealFlag::Overflow)) {
+ auto tmp{at.SCALE(IntType{1})};
+ if (tmp.flags.test(RealFlag::Overflow)) {
+ decrement = false;
+ break;
+ }
+ at = tmp.value;
+ }
+ while (true) {
+ if (decrement) {
+ at = at.SCALE(IntType{-1}).value;
+ } else {
+ decrement = true;
+ }
+ auto tmp{at.Add(result)};
+ if (tmp.flags.test(RealFlag::Inexact)) {
+ break;
+ } else if (!tmp.value.template ToInteger<IntType>(roundingMode)
+ .flags.test(RealFlag::Overflow)) {
+ result = tmp.value;
+ }
+ }
+ return AsCategoryExpr(Constant<RType>{std::move(result)});
+}
+
+static Expr<SomeReal> RealToIntBound(
+ int xRKind, int moldIKind, bool round, bool negate) {
+ switch (xRKind) {
+#define ICASES(RK) \
+ switch (moldIKind) { \
+ case 1: \
+ return RealToIntBoundHelper<RK, 1>(round, negate); \
+ break; \
+ case 2: \
+ return RealToIntBoundHelper<RK, 2>(round, negate); \
+ break; \
+ case 4: \
+ return RealToIntBoundHelper<RK, 4>(round, negate); \
+ break; \
+ case 8: \
+ return RealToIntBoundHelper<RK, 8>(round, negate); \
+ break; \
+ case 16: \
+ return RealToIntBoundHelper<RK, 16>(round, negate); \
+ break; \
+ } \
+ break
+ case 2:
+ ICASES(2);
+ break;
+ case 3:
+ ICASES(3);
+ break;
+ case 4:
+ ICASES(4);
+ break;
+ case 8:
+ ICASES(8);
+ break;
+ case 10:
+ ICASES(10);
+ break;
+ case 16:
+ ICASES(16);
+ break;
+ }
+ DIE("RealToIntBound: no case");
+#undef ICASES
+}
+
+class RealToIntLimitHelper {
+public:
+ using Result = std::optional<Expr<SomeReal>>;
+ using Types = RealTypes;
+ RealToIntLimitHelper(
+ FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo)
+ : context_{context}, hi_{std::move(hi)}, lo_{lo} {}
+ template <typename T> Result Test() {
+ if (UnwrapExpr<Expr<T>>(hi_)) {
+ bool promote{T::kind < 16};
+ Result constResult;
+ if (auto hiV{GetScalarConstantValue<T>(hi_)}) {
+ auto loV{GetScalarConstantValue<T>(lo_)};
+ CHECK(loV.has_value());
+ auto diff{hiV->Subtract(*loV, Rounding{common::RoundingMode::ToZero})};
+ promote = promote &&
+ (diff.flags.test(RealFlag::Overflow) ||
+ diff.flags.test(RealFlag::Inexact));
+ constResult = AsCategoryExpr(Constant<T>{std::move(diff.value)});
+ }
+ if (promote) {
+ constexpr int nextKind{T::kind < 4 ? 4 : T::kind == 4 ? 8 : 16};
+ using T2 = Type<TypeCategory::Real, nextKind>;
+ hi_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(hi_)))};
+ lo_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(lo_)))};
+ if (constResult) {
+ // Use promoted constants on next iteration of SearchTypes
+ return std::nullopt;
+ }
+ }
+ if (constResult) {
+ return constResult;
+ } else {
+ return AsCategoryExpr(std::move(hi_) - Expr<SomeReal>{lo_});
+ }
+ } else {
+ return std::nullopt;
+ }
+ }
+
+private:
+ FoldingContext &context_;
+ Expr<SomeReal> hi_;
+ Expr<SomeReal> &lo_;
+};
+
+static std::optional<Expr<SomeReal>> RealToIntLimit(
+ FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) {
+ return common::SearchTypes(RealToIntLimitHelper{context, std::move(hi), lo});
+}
+
+// RealToRealBounds() returns a pair (HUGE(x),REAL(HUGE(mold),KIND(x)))
+// when REAL(HUGE(x),KIND(mold)) overflows, and std::nullopt otherwise.
+template <int X_RKIND, int MOLD_RKIND>
+std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>
+RealToRealBoundsHelper() {
+ using RType = Type<TypeCategory::Real, X_RKIND>;
+ using RealType = Scalar<RType>;
+ using MoldRealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;
+ if (!MoldRealType::Convert(RealType::HUGE()).flags.test(RealFlag::Overflow)) {
+ return std::nullopt;
+ } else {
+ return std::make_pair(AsCategoryExpr(Constant<RType>{
+ RealType::Convert(MoldRealType::HUGE()).value}),
+ AsCategoryExpr(Constant<RType>{RealType::HUGE()}));
+ }
+}
+
+static std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>
+RealToRealBounds(int xRKind, int moldRKind) {
+ switch (xRKind) {
+#define RCASES(RK) \
+ switch (moldRKind) { \
+ case 2: \
+ return RealToRealBoundsHelper<RK, 2>(); \
+ break; \
+ case 3: \
+ return RealToRealBoundsHelper<RK, 3>(); \
+ break; \
+ case 4: \
+ return RealToRealBoundsHelper<RK, 4>(); \
+ break; \
+ case 8: \
+ return RealToRealBoundsHelper<RK, 8>(); \
+ break; \
+ case 10: \
+ return RealToRealBoundsHelper<RK, 10>(); \
+ break; \
+ case 16: \
+ return RealToRealBoundsHelper<RK, 16>(); \
+ break; \
+ } \
+ break
+ case 2:
+ RCASES(2);
+ break;
+ case 3:
+ RCASES(3);
+ break;
+ case 4:
+ RCASES(4);
+ break;
+ case 8:
+ RCASES(8);
+ break;
+ case 10:
+ RCASES(10);
+ break;
+ case 16:
+ RCASES(16);
+ break;
+ }
+ DIE("RealToRealBounds: no case");
+#undef RCASES
+}
+
+template <int X_IKIND, int MOLD_RKIND>
+std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) {
+ using IType = Type<TypeCategory::Integer, X_IKIND>;
+ using IntType = Scalar<IType>;
+ using RealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;
+ IntType result{}; // 0
+ while (true) {
+ std::optional<IntType> next;
+ for (int bit{0}; bit < IntType::bits; ++bit) {
+ IntType power{IntType{}.IBSET(bit)};
+ if (power.IsNegative()) {
+ if (!negate) {
+ break;
+ }
+ } else if (negate) {
+ power = power.Negate().value;
+ }
+ auto tmp{power.AddSigned(result)};
+ if (tmp.overflow ||
+ RealType::FromInteger(tmp.value).flags.test(RealFlag::Overflow)) {
+ break;
+ }
+ next = tmp.value;
+ }
+ if (next) {
+ CHECK(result.CompareSigned(*next) != Ordering::Equal);
+ result = *next;
+ } else {
+ break;
+ }
+ }
+ if (result.CompareSigned(IntType::HUGE()) == Ordering::Equal) {
+ return std::nullopt;
+ } else {
+ return AsCategoryExpr(Constant<IType>{std::move(result)});
+ }
+}
+
+static std::optional<Expr<SomeInteger>> IntToRealBound(
+ int xIKind, int moldRKind, bool negate) {
+ switch (xIKind) {
+#define RCASES(IK) \
+ switch (moldRKind) { \
+ case 2: \
+ return IntToRealBoundHelper<IK, 2>(negate); \
+ break; \
+ case 3: \
+ return IntToRealBoundHelper<IK, 3>(negate); \
+ break; \
+ case 4: \
+ return IntToRealBoundHelper<IK, 4>(negate); \
+ break; \
+ case 8: \
+ return IntToRealBoundHelper<IK, 8>(negate); \
+ break; \
+ case 10: \
+ return IntToRealBoundHelper<IK, 10>(negate); \
+ break; \
+ case 16: \
+ return IntToRealBoundHelper<IK, 16>(negate); \
+ break; \
+ } \
+ break
+ case 1:
+ RCASES(1);
+ break;
+ case 2:
+ RCASES(2);
+ break;
+ case 4:
+ RCASES(4);
+ break;
+ case 8:
+ RCASES(8);
+ break;
+ case 16:
+ RCASES(16);
+ break;
+ }
+ DIE("IntToRealBound: no case");
+#undef RCASES
+}
+
+template <int X_IKIND, int MOLD_IKIND>
+std::optional<Expr<SomeInteger>> IntToIntBoundHelper() {
+ if constexpr (X_IKIND <= MOLD_IKIND) {
+ return std::nullopt;
+ } else {
+ using XIType = Type<TypeCategory::Integer, X_IKIND>;
+ using IntegerType = Scalar<XIType>;
+ using MoldIType = Type<TypeCategory::Integer, MOLD_IKIND>;
+ using MoldIntegerType = Scalar<MoldIType>;
+ return AsCategoryExpr(Constant<XIType>{
+ IntegerType::ConvertSigned(MoldIntegerType::HUGE()).value});
+ }
+}
+
+static std::optional<Expr<SomeInteger>> IntToIntBound(
+ int xIKind, int moldIKind) {
+ switch (xIKind) {
+#define ICASES(IK) \
+ switch (moldIKind) { \
+ case 1: \
+ return IntToIntBoundHelper<IK, 1>(); \
+ break; \
+ case 2: \
+ return IntToIntBoundHelper<IK, 2>(); \
+ break; \
+ case 4: \
+ return IntToIntBoundHelper<IK, 4>(); \
+ break; \
+ case 8: \
+ return IntToIntBoundHelper<IK, 8>(); \
+ break; \
+ case 16: \
+ return IntToIntBoundHelper<IK, 16>(); \
+ break; \
+ } \
+ break
+ case 1:
+ ICASES(1);
+ break;
+ case 2:
+ ICASES(2);
+ break;
+ case 4:
+ ICASES(4);
+ break;
+ case 8:
+ ICASES(8);
+ break;
+ case 16:
+ ICASES(16);
+ break;
+ }
+ DIE("IntToIntBound: no case");
+#undef ICASES
+}
+
+// ApplyIntrinsic() constructs the typed expression representation
+// for a specific intrinsic function reference.
+// TODO: maybe move into tools.h?
+class IntrinsicCallHelper {
+public:
+ explicit IntrinsicCallHelper(SpecificCall &&call) : call_{call} {
+ CHECK(proc_.IsFunction());
+ typeAndShape_ = proc_.functionResult->GetTypeAndShape();
+ CHECK(typeAndShape_ != nullptr);
+ }
+ using Result = std::optional<Expr<SomeType>>;
+ using Types = LengthlessIntrinsicTypes;
+ template <typename T> Result Test() {
+ if (T::category == typeAndShape_->type().category() &&
+ T::kind == typeAndShape_->type().kind()) {
+ return AsGenericExpr(FunctionRef<T>{
+ ProcedureDesignator{std::move(call_.specificIntrinsic)},
+ std::move(call_.arguments)});
+ } else {
+ return std::nullopt;
+ }
+ }
+
+private:
+ SpecificCall call_;
+ const characteristics::Procedure &proc_{
+ call_.specificIntrinsic.characteristics.value()};
+ const characteristics::TypeAndShape *typeAndShape_{nullptr};
+};
+
+static Expr<SomeType> ApplyIntrinsic(
+ FoldingContext &context, const std::string &func, ActualArguments &&args) {
+ auto found{
+ context.intrinsics().Probe(CallCharacteristics{func}, args, context)};
+ CHECK(found.has_value());
+ auto result{common::SearchTypes(IntrinsicCallHelper{std::move(*found)})};
+ CHECK(result.has_value());
+ return *result;
+}
+
+static Expr<LogicalResult> CompareUnsigned(FoldingContext &context,
+ const char *intrin, Expr<SomeType> &&x, Expr<SomeType> &&y) {
+ Expr<SomeType> result{ApplyIntrinsic(context, intrin,
+ ActualArguments{
+ ActualArgument{std::move(x)}, ActualArgument{std::move(y)}})};
+ return DEREF(UnwrapExpr<Expr<LogicalResult>>(result));
+}
+
+// Determines the right kind of INTEGER to hold the bits of a REAL type.
+static Expr<SomeType> IntTransferMold(
+ const TargetCharacteristics &target, DynamicType realType, bool asVector) {
+ CHECK(realType.category() == TypeCategory::Real);
+ int rKind{realType.kind()};
+ int iKind{std::max<int>(target.GetAlignment(TypeCategory::Real, rKind),
+ target.GetByteSize(TypeCategory::Real, rKind))};
+ CHECK(target.CanSupportType(TypeCategory::Integer, iKind));
+ DynamicType iType{TypeCategory::Integer, iKind};
+ ConstantSubscripts shape;
+ if (asVector) {
+ shape = ConstantSubscripts{1};
+ }
+ Constant<SubscriptInteger> value{
+ std::vector<Scalar<SubscriptInteger>>{0}, std::move(shape)};
+ auto expr{ConvertToType(iType, AsGenericExpr(std::move(value)))};
+ CHECK(expr.has_value());
+ return std::move(*expr);
+}
+
+static Expr<SomeType> GetRealBits(FoldingContext &context, Expr<SomeReal> &&x) {
+ auto xType{x.GetType()};
+ CHECK(xType.has_value());
+ bool asVector{x.Rank() > 0};
+ return ApplyIntrinsic(context, "transfer",
+ ActualArguments{ActualArgument{AsGenericExpr(std::move(x))},
+ ActualArgument{IntTransferMold(
+ context.targetCharacteristics(), *xType, asVector)}});
+}
+
+template <int KIND>
+static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
+ FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {
+ using ResultType = Type<TypeCategory::Logical, KIND>;
+ ActualArguments &args{funcRef.arguments()};
+ // Fold x= and round= unconditionally
+ if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {
+ *args[0] = Fold(context, std::move(*x));
+ }
+ if (args.size() >= 3) {
+ if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) {
+ *args[2] = Fold(context, std::move(*round));
+ }
+ }
+ if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {
+ x = UnwrapExpr<Expr<SomeType>>(args[0]);
+ CHECK(x != nullptr);
+ if (const auto *mold{UnwrapExpr<Expr<SomeType>>(args[1])}) {
+ DynamicType xType{x->GetType().value()};
+ DynamicType moldType{mold->GetType().value()};
+ std::optional<Expr<LogicalResult>> result;
+ bool alwaysFalse{false};
+ if (auto *iXExpr{UnwrapExpr<Expr<SomeInteger>>(*x)}) {
+ DynamicType iXType{iXExpr->GetType().value()};
+ int iXKind{iXExpr->GetType().value().kind()};
+ if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) {
+ // INTEGER -> INTEGER
+ int iMoldKind{iMoldExpr->GetType().value().kind()};
+ if (auto hi{IntToIntBound(iXKind, iMoldKind)}) {
+ // 'hi' is INT(HUGE(mold), KIND(x))
+ // OUT_OF_RANGE(x,mold) = (x + (hi + 1)) .UGT. (2*hi + 1)
+ auto one{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(
+ xType, AsGenericExpr(Constant<SubscriptInteger>{1}))))};
+ auto lhs{std::move(*iXExpr) +
+ (Expr<SomeInteger>{*hi} + Expr<SomeInteger>{one})};
+ auto two{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(
+ xType, AsGenericExpr(Constant<SubscriptInteger>{2}))))};
+ auto rhs{std::move(two) * std::move(*hi) + std::move(one)};
+ result = CompareUnsigned(context, "bgt",
+ Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});
+ } else {
+ alwaysFalse = true;
+ }
+ } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) {
+ // INTEGER -> REAL
+ int rMoldKind{rMoldExpr->GetType().value().kind()};
+ if (auto hi{IntToRealBound(iXKind, rMoldKind, /*negate=*/false)}) {
+ // OUT_OF_RANGE(x,mold) = (x - lo) .UGT. (hi - lo)
+ auto lo{IntToRealBound(iXKind, rMoldKind, /*negate=*/true)};
+ CHECK(lo.has_value());
+ auto lhs{std::move(*iXExpr) - Expr<SomeInteger>{*lo}};
+ auto rhs{std::move(*hi) - std::move(*lo)};
+ result = CompareUnsigned(context, "bgt",
+ Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});
+ } else {
+ alwaysFalse = true;
+ }
+ }
+ } else if (auto *rXExpr{UnwrapExpr<Expr<SomeReal>>(*x)}) {
+ DynamicType rXType{rXExpr->GetType().value()};
+ int rXKind{rXExpr->GetType().value().kind()};
+ if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) {
+ // REAL -> INTEGER
+ int iMoldKind{iMoldExpr->GetType().value().kind()};
+ auto hi{RealToIntBound(rXKind, iMoldKind, false, false)};
+ auto lo{RealToIntBound(rXKind, iMoldKind, false, true)};
+ if (args.size() >= 3) {
+ // Bounds depend on round= value
+ if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) {
+ if (const Symbol * whole{UnwrapWholeSymbolDataRef(*round)};
+ whole && semantics::IsOptional(whole->GetUltimate())) {
+ if (auto source{args[2]->sourceLocation()}) {
+ context.messages().Say(*source,
+ "ROUND= argument to OUT_OF_RANGE() is an optional dummy argument that must be present at execution"_warn_en_US);
+ }
+ }
+ auto rlo{RealToIntBound(rXKind, iMoldKind, true, true)};
+ auto rhi{RealToIntBound(rXKind, iMoldKind, true, false)};
+ auto mlo{Fold(context,
+ ApplyIntrinsic(context, "merge",
+ ActualArguments{
+ ActualArgument{Expr<SomeType>{std::move(rlo)}},
+ ActualArgument{Expr<SomeType>{std::move(lo)}},
+ ActualArgument{Expr<SomeType>{*round}}}))};
+ auto mhi{Fold(context,
+ ApplyIntrinsic(context, "merge",
+ ActualArguments{
+ ActualArgument{Expr<SomeType>{std::move(rhi)}},
+ ActualArgument{Expr<SomeType>{std::move(hi)}},
+ ActualArgument{std::move(*round)}}))};
+ lo = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mlo)));
+ hi = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mhi)));
+ }
+ }
+ // OUT_OF_RANGE(x,mold[,round]) =
+ // TRANSFER(x - lo, int) .UGT. TRANSFER(hi - lo, int)
+ hi = Fold(context, std::move(hi));
+ lo = Fold(context, std::move(lo));
+ if (auto rhs{RealToIntLimit(context, std::move(hi), lo)}) {
+ Expr<SomeReal> lhs{std::move(*rXExpr) - std::move(lo)};
+ result = CompareUnsigned(context, "bgt",
+ GetRealBits(context, std::move(lhs)),
+ GetRealBits(context, std::move(*rhs)));
+ }
+ } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) {
+ // REAL -> REAL
+ // Only finite arguments with ABS(x) > HUGE(mold) are .TRUE.
+ // OUT_OF_RANGE(x,mold) =
+ // TRANSFER(ABS(x) - HUGE(mold), int) - 1 .ULT.
+ // TRANSFER(HUGE(mold), int)
+ // Note that OUT_OF_RANGE(+/-Inf or NaN,mold) =
+ // TRANSFER(+Inf or Nan, int) - 1 .ULT. TRANSFER(HUGE(mold), int)
+ int rMoldKind{rMoldExpr->GetType().value().kind()};
+ if (auto bounds{RealToRealBounds(rXKind, rMoldKind)}) {
+ auto &[moldHuge, xHuge]{*bounds};
+ Expr<SomeType> abs{ApplyIntrinsic(context, "abs",
+ ActualArguments{
+ ActualArgument{Expr<SomeType>{std::move(*rXExpr)}}})};
+ auto &absR{DEREF(UnwrapExpr<Expr<SomeReal>>(abs))};
+ Expr<SomeType> diffBits{
+ GetRealBits(context, std::move(absR) - std::move(moldHuge))};
+ auto &diffBitsI{DEREF(UnwrapExpr<Expr<SomeInteger>>(diffBits))};
+ Expr<SomeType> decr{std::move(diffBitsI) -
+ Expr<SomeInteger>{Expr<SubscriptInteger>{1}}};
+ result = CompareUnsigned(context, "blt", std::move(decr),
+ GetRealBits(context, std::move(xHuge)));
+ } else {
+ alwaysFalse = true;
+ }
+ }
+ }
+ if (alwaysFalse) {
+ // xType can never overflow moldType, so
+ // OUT_OF_RANGE(x) = (x /= 0) .AND. .FALSE.
+ // which has the same shape as x.
+ Expr<LogicalResult> scalarFalse{
+ Constant<LogicalResult>{Scalar<LogicalResult>{false}}};
+ if (x->Rank() > 0) {
+ if (auto nez{Relate(context.messages(), RelationalOperator::NE,
+ std::move(*x),
+ AsGenericExpr(Constant<SubscriptInteger>{0}))}) {
+ result = Expr<LogicalResult>{LogicalOperation<LogicalResult::kind>{
+ LogicalOperator::And, std::move(*nez), std::move(scalarFalse)}};
+ }
+ } else {
+ result = std::move(scalarFalse);
+ }
+ }
+ if (result) {
+ auto restorer{context.messages().DiscardMessages()};
+ return Fold(
+ context, AsExpr(ConvertToType<ResultType>(std::move(*result))));
+ }
+ }
+ }
+ return AsExpr(std::move(funcRef));
+}
+
template <int KIND>
Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
FoldingContext &context,
@@ -236,114 +816,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
} else if (name == "matmul") {
return FoldMatmul(context, std::move(funcRef));
} else if (name == "out_of_range") {
- if (Expr<SomeType> * cx{UnwrapExpr<Expr<SomeType>>(args[0])}) {
- auto restorer{context.messages().DiscardMessages()};
- *args[0] = Fold(context, std::move(*cx));
- if (Expr<SomeType> & folded{DEREF(args[0].value().UnwrapExpr())};
- IsActuallyConstant(folded)) {
- std::optional<std::vector<typename T::Scalar>> result;
- if (Expr<SomeReal> * realMold{UnwrapExpr<Expr<SomeReal>>(args[1])}) {
- if (const auto *xInt{UnwrapExpr<Expr<SomeInteger>>(folded)}) {
- result.emplace();
- std::visit(
- [&](const auto &mold, const auto &x) {
- using RealType =
- typename std::decay_t<decltype(mold)>::Result;
- static_assert(RealType::category == TypeCategory::Real);
- using Scalar = typename RealType::Scalar;
- using xType = typename std::decay_t<decltype(x)>::Result;
- const auto &xConst{DEREF(UnwrapExpr<Constant<xType>>(x))};
- for (const auto &elt : xConst.values()) {
- result->emplace_back(
- Scalar::template FromInteger(elt).flags.test(
- RealFlag::Overflow));
- }
- },
- realMold->u, xInt->u);
- } else if (const auto *xReal{UnwrapExpr<Expr<SomeReal>>(folded)}) {
- result.emplace();
- std::visit(
- [&](const auto &mold, const auto &x) {
- using RealType =
- typename std::decay_t<decltype(mold)>::Result;
- static_assert(RealType::category == TypeCategory::Real);
- using Scalar = typename RealType::Scalar;
- using xType = typename std::decay_t<decltype(x)>::Result;
- const auto &xConst{DEREF(UnwrapExpr<Constant<xType>>(x))};
- for (const auto &elt : xConst.values()) {
- result->emplace_back(elt.IsFinite() &&
- Scalar::template Convert(elt).flags.test(
- RealFlag::Overflow));
- }
- },
- realMold->u, xReal->u);
- }
- } else if (Expr<SomeInteger> *
- intMold{UnwrapExpr<Expr<SomeInteger>>(args[1])}) {
- if (const auto *xInt{UnwrapExpr<Expr<SomeInteger>>(folded)}) {
- result.emplace();
- std::visit(
- [&](const auto &mold, const auto &x) {
- using IntType = typename std::decay_t<decltype(mold)>::Result;
- static_assert(IntType::category == TypeCategory::Integer);
- using Scalar = typename IntType::Scalar;
- using xType = typename std::decay_t<decltype(x)>::Result;
- const auto &xConst{DEREF(UnwrapExpr<Constant<xType>>(x))};
- for (const auto &elt : xConst.values()) {
- result->emplace_back(
- Scalar::template ConvertSigned(elt).overflow);
- }
- },
- intMold->u, xInt->u);
- } else if (Expr<SomeLogical> *
- cRound{args.size() >= 3
- ? UnwrapExpr<Expr<SomeLogical>>(args[2])
- : nullptr};
- !cRound || IsActuallyConstant(*args[2]->UnwrapExpr())) {
- if (const auto *xReal{UnwrapExpr<Expr<SomeReal>>(folded)}) {
- common::RoundingMode roundingMode{common::RoundingMode::ToZero};
- if (cRound &&
- common::visit(
- [](const auto &x) {
- using xType =
- typename std::decay_t<decltype(x)>::Result;
- return GetScalarConstantValue<xType>(x)
- .value()
- .IsTrue();
- },
- cRound->u)) {
- // ROUND=.TRUE. - convert with NINT()
- roundingMode = common::RoundingMode::TiesAwayFromZero;
- }
- result.emplace();
- std::visit(
- [&](const auto &mold, const auto &x) {
- using IntType =
- typename std::decay_t<decltype(mold)>::Result;
- static_assert(IntType::category == TypeCategory::Integer);
- using Scalar = typename IntType::Scalar;
- using xType = typename std::decay_t<decltype(x)>::Result;
- const auto &xConst{DEREF(UnwrapExpr<Constant<xType>>(x))};
- for (const auto &elt : xConst.values()) {
- // Note that OUT_OF_RANGE(Inf/NaN) is .TRUE. for the
- // real->integer case, but not for real->real.
- result->emplace_back(!elt.IsFinite() ||
- elt.template ToInteger<Scalar>(roundingMode)
- .flags.test(RealFlag::Overflow));
- }
- },
- intMold->u, xReal->u);
- }
- }
- }
- if (result) {
- if (auto extents{GetConstantExtents(context, folded)}) {
- return Expr<T>{
- Constant<T>{std::move(*result), std::move(*extents)}};
- }
- }
- }
- }
+ return RewriteOutOfRange<KIND>(context, std::move(funcRef));
} else if (name == "parity") {
return FoldAllAnyParity(
context, std::move(funcRef), &Scalar<T>::NEQV, Scalar<T>{false});
diff --git a/flang/lib/Evaluate/integer.cpp b/flang/lib/Evaluate/integer.cpp
index e8173b44e873..b982a3a0796c 100644
--- a/flang/lib/Evaluate/integer.cpp
+++ b/flang/lib/Evaluate/integer.cpp
@@ -14,7 +14,7 @@ template class Integer<8>;
template class Integer<16>;
template class Integer<32>;
template class Integer<64>;
-template class Integer<80>;
+template class Integer<80, true, 16, std::uint16_t, std::uint32_t, 128>;
template class Integer<128>;
// Sanity checks against misconfiguration bugs
diff --git a/flang/lib/Evaluate/real.cpp b/flang/lib/Evaluate/real.cpp
index de4b21b7ca5f..223f67fee41d 100644
--- a/flang/lib/Evaluate/real.cpp
+++ b/flang/lib/Evaluate/real.cpp
@@ -788,6 +788,6 @@ template class Real<Integer<16>, 11>;
template class Real<Integer<16>, 8>;
template class Real<Integer<32>, 24>;
template class Real<Integer<64>, 53>;
-template class Real<Integer<80>, 64>;
+template class Real<X87IntegerContainer, 64>;
template class Real<Integer<128>, 113>;
} // namespace Fortran::evaluate::value
diff --git a/flang/test/Evaluate/fold-out_of_range.f90 b/flang/test/Evaluate/fold-out_of_range.f90
index de66c803b103..30665b9021a9 100644
--- a/flang/test/Evaluate/fold-out_of_range.f90
+++ b/flang/test/Evaluate/fold-out_of_range.f90
@@ -90,35 +90,65 @@ module m
logical, parameter :: test_r2r8 = .not. any(out_of_range(r2v, 1._8))
logical, parameter :: test_r2r10 = .not. any(out_of_range(r2v, 1._10))
logical, parameter :: test_r2r16 = .not. any(out_of_range(r2v, 1._16))
- logical, parameter :: test_r3r2 = all(out_of_range(r3v, 1._2) .eqv. finites)
+ logical, parameter :: test_r3r2 = all(out_of_range(r3v, 1._2) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(2) to REAL(3) conversion
+ logical, parameter :: test_r3r2b = .not. any(out_of_range(real(r2v, 3), 1._2))
logical, parameter :: test_r3r3 = .not. any(out_of_range(r3v, 1._3))
logical, parameter :: test_r3r4 = .not. any(out_of_range(r3v, 1._4))
logical, parameter :: test_r3r8 = .not. any(out_of_range(r3v, 1._8))
logical, parameter :: test_r3r10 = .not. any(out_of_range(r3v, 1._10))
logical, parameter :: test_r3r16 = .not. any(out_of_range(r3v, 1._16))
- logical, parameter :: test_r4r2 = all(out_of_range(r4v, 1._2) .eqv. finites)
- logical, parameter :: test_r4r3 = all(out_of_range(r4v, 1._3) .eqv. finites)
+ logical, parameter :: test_r4r2 = all(out_of_range(r4v, 1._2) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(2) to REAL(4) conversion
+ logical, parameter :: test_r4r2b = .not. any(out_of_range(real(r2v, 4), 1._2))
+ logical, parameter :: test_r4r3 = all(out_of_range(r4v, 1._3) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(3) to REAL(4) conversion
+ logical, parameter :: test_r4r3b = .not. any(out_of_range(real(r3v, 4), 1._3))
logical, parameter :: test_r4r4 = .not. any(out_of_range(r4v, 1._4))
logical, parameter :: test_r4r8 = .not. any(out_of_range(r4v, 1._8))
logical, parameter :: test_r4r10 = .not. any(out_of_range(r4v, 1._10))
logical, parameter :: test_r4r16 = .not. any(out_of_range(r4v, 1._16))
- logical, parameter :: test_r8r2 = all(out_of_range(r8v, 1._2) .eqv. finites)
- logical, parameter :: test_r8r3 = all(out_of_range(r8v, 1._3) .eqv. finites)
- logical, parameter :: test_r8r4 = all(out_of_range(r8v, 1._4) .eqv. finites)
+ logical, parameter :: test_r8r2 = all(out_of_range(r8v, 1._2) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(2) to REAL(8) conversion
+ logical, parameter :: test_r8r2b = .not. any(out_of_range(real(r2v, 8), 1._2))
+ logical, parameter :: test_r8r3 = all(out_of_range(r8v, 1._3) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(3) to REAL(8) conversion
+ logical, parameter :: test_r8r3b = .not. any(out_of_range(real(r3v, 8), 1._3))
+ logical, parameter :: test_r8r4 = all(out_of_range(r8v, 1._4) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(4) to REAL(8) conversion
+ logical, parameter :: test_r8r4b = .not. any(out_of_range(real(r4v, 8), 1._4))
logical, parameter :: test_r8r8 = .not. any(out_of_range(r8v, 1._8))
logical, parameter :: test_r8r10 = .not. any(out_of_range(r8v, 1._10))
logical, parameter :: test_r8r16 = .not. any(out_of_range(r8v, 1._16))
- logical, parameter :: test_r10r2 = all(out_of_range(r10v, 1._2) .eqv. finites)
- logical, parameter :: test_r10r3 = all(out_of_range(r10v, 1._3) .eqv. finites)
- logical, parameter :: test_r10r4 = all(out_of_range(r10v, 1._4) .eqv. finites)
- logical, parameter :: test_r10r8 = all(out_of_range(r10v, 1._8) .eqv. finites)
+ logical, parameter :: test_r10r2 = all(out_of_range(r10v, 1._2) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(2) to REAL(10) conversion
+ logical, parameter :: test_r10r2b = .not. any(out_of_range(real(r2v, 10), 1._2))
+ logical, parameter :: test_r10r3 = all(out_of_range(r10v, 1._3) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(3) to REAL(10) conversion
+ logical, parameter :: test_r10r3b = .not. any(out_of_range(real(r3v, 10), 1._3))
+ logical, parameter :: test_r10r4 = all(out_of_range(r10v, 1._4) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(4) to REAL(10) conversion
+ logical, parameter :: test_r10r4b = .not. any(out_of_range(real(r4v, 10), 1._4))
+ logical, parameter :: test_r10r8 = all(out_of_range(r10v, 1._8) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(8) to REAL(10) conversion
+ logical, parameter :: test_r10r8b = .not. any(out_of_range(real(r8v, 10), 1._8))
logical, parameter :: test_r10r10 = .not. any(out_of_range(r10v, 1._10))
logical, parameter :: test_r10r16 = .not. any(out_of_range(r10v, 1._16))
- logical, parameter :: test_r16r2 = all(out_of_range(r16v, 1._2) .eqv. finites)
- logical, parameter :: test_r16r3 = all(out_of_range(r16v, 1._3) .eqv. finites)
- logical, parameter :: test_r16r4 = all(out_of_range(r16v, 1._4) .eqv. finites)
- logical, parameter :: test_r16r8 = all(out_of_range(r16v, 1._8) .eqv. finites)
+ logical, parameter :: test_r16r2 = all(out_of_range(r16v, 1._2) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(2) to REAL(16) conversion
+ logical, parameter :: test_r16r2b = .not. any(out_of_range(real(r2v, 16), 1._2))
+ logical, parameter :: test_r16r3 = all(out_of_range(r16v, 1._3) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(3) to REAL(16) conversion
+ logical, parameter :: test_r16r3b = .not. any(out_of_range(real(r3v, 16), 1._3))
+ logical, parameter :: test_r16r4 = all(out_of_range(r16v, 1._4) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(4) to REAL(16) conversion
+ logical, parameter :: test_r16r4b = .not. any(out_of_range(real(r4v, 16), 1._4))
+ logical, parameter :: test_r16r8 = all(out_of_range(r16v, 1._8) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(8) to REAL(16) conversion
+ logical, parameter :: test_r16r8b = .not. any(out_of_range(real(r8v, 16), 1._8))
logical, parameter :: test_r16r10 = all(out_of_range(r16v, 1._10) .eqv. finites)
+ !WARN: warning: invalid argument on REAL(10) to REAL(16) conversion
+ logical, parameter :: test_r16r10b= .not. any(out_of_range(real(r10v, 16), 1._10))
logical, parameter :: test_r16r16 = .not. any(out_of_range(r16v, 1._16))
logical, parameter :: test_r2i1 = all(out_of_range(r2v, 1_1))
@@ -320,4 +350,12 @@ module m
logical, parameter :: test_r16i16ur = all(out_of_range(real(i16v, kind=16)+.5_16, 1_16, .true.) .eqv. [.false., .true.])
logical, parameter :: test_r16i16d = all(out_of_range(real(i16v, kind=16)-.5_16, 1_16, .false.) .eqv. [.false., .true.])
logical, parameter :: test_r16i16dr = all(out_of_range(real(i16v, kind=16)-.5_16, 1_16, .true.) .eqv. [.false., .true.])
+
+ contains
+ subroutine s(x, r)
+ real(8), intent(in) :: x
+ logical, intent(in), optional :: r
+ !WARN: warning: ROUND= argument to OUT_OF_RANGE() is an optional dummy argument that must be present at execution
+ print *, out_of_range(x, 1, round=r)
+ end
end
diff --git a/flang/test/Evaluate/rewrite-out_of_range.F90 b/flang/test/Evaluate/rewrite-out_of_range.F90
new file mode 100644
index 000000000000..a5cd09cb2853
--- /dev/null
+++ b/flang/test/Evaluate/rewrite-out_of_range.F90
@@ -0,0 +1,208 @@
+! Tests rewriting of OUT_OF_RANGE()
+! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+
+logical round
+
+#define T1(XT,XK,MT,MK) \
+block; \
+ XT(XK) x; \
+ MT(MK) mold; \
+ print *, #XT, XK, #MT, MK, out_of_range(x,mold); \
+end block
+
+#define T2(XT,XK,MT,MK) \
+block; \
+ XT(XK) x; \
+ MT(MK) mold; \
+ print *, #XT, XK, #MT, MK, 'round', out_of_range(x,mold,round); \
+end block
+
+#define INTMOLDS(M,XT,XK) \
+ M(XT,XK,integer,1); \
+ M(XT,XK,integer,2); \
+ M(XT,XK,integer,4); \
+ M(XT,XK,integer,8); \
+ M(XT,XK,integer,16)
+
+#define REALMOLDS(M,XT,XK) \
+ M(XT,XK,real,2); \
+ M(XT,XK,real,3); \
+ M(XT,XK,real,4); \
+ M(XT,XK,real,8); \
+ M(XT,XK,real,10); \
+ M(XT,XK,real,16)
+
+#define INTXS(M1,M2) \
+ M1(M2, integer, 1); \
+ M1(M2, integer, 2); \
+ M1(M2, integer, 4); \
+ M1(M2, integer, 8); \
+ M1(M2, integer, 16)
+
+#define REALXS(M1,M2) \
+ M1(M2, real, 2); \
+ M1(M2, real, 3); \
+ M1(M2, real, 4); \
+ M1(M2, real, 8); \
+ M1(M2, real, 10); \
+ M1(M2, real, 16)
+
+INTXS(INTMOLDS, T1)
+INTXS(REALMOLDS, T1)
+REALXS(INTMOLDS, T1)
+REALXS(INTMOLDS, T2)
+REALXS(REALMOLDS, T1)
+
+end
+
+!CHECK: PRINT *, " integer", 1_4, "integer", 1_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "integer", 2_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "integer", 4_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "integer", 8_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "integer", 16_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "integer", 1_4, bgt(x+128_2,255_2)
+!CHECK: PRINT *, " integer", 2_4, "integer", 2_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "integer", 4_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "integer", 8_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "integer", 16_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "integer", 1_4, bgt(x+128_4,255_4)
+!CHECK: PRINT *, " integer", 4_4, "integer", 2_4, bgt(x+32768_4,65535_4)
+!CHECK: PRINT *, " integer", 4_4, "integer", 4_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "integer", 8_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "integer", 16_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "integer", 1_4, bgt(x+128_8,255_8)
+!CHECK: PRINT *, " integer", 8_4, "integer", 2_4, bgt(x+32768_8,65535_8)
+!CHECK: PRINT *, " integer", 8_4, "integer", 4_4, bgt(x+2147483648_8,4294967295_8)
+!CHECK: PRINT *, " integer", 8_4, "integer", 8_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "integer", 16_4, .false._4
+!CHECK: PRINT *, " integer", 16_4, "integer", 1_4, bgt(x+128_16,255_16)
+!CHECK: PRINT *, " integer", 16_4, "integer", 2_4, bgt(x+32768_16,65535_16)
+!CHECK: PRINT *, " integer", 16_4, "integer", 4_4, bgt(x+2147483648_16,4294967295_16)
+!CHECK: PRINT *, " integer", 16_4, "integer", 8_4, bgt(x+9223372036854775808_16,18446744073709551615_16)
+!CHECK: PRINT *, " integer", 16_4, "integer", 16_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "real", 2_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " integer", 1_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "real", 2_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " integer", 2_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "real", 2_4, bgt(x--65519_4,131038_4)
+!CHECK: PRINT *, " integer", 4_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " integer", 4_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "real", 2_4, bgt(x--65519_8,131038_8)
+!CHECK: PRINT *, " integer", 8_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " integer", 8_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " integer", 16_4, "real", 2_4, bgt(x--65519_16,131038_16)
+!CHECK: PRINT *, " integer", 16_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " integer", 16_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " integer", 16_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " integer", 16_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " integer", 16_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " real", 2_4, "integer", 1_4, bgt(transfer(real(x,kind=4)--1.28875e2_4,0_4),1132488704_4)
+!CHECK: PRINT *, " real", 2_4, "integer", 2_4, bgt(transfer(real(x,kind=4)--3.2768e4_4,0_4),1199566848_4)
+!CHECK: PRINT *, " real", 2_4, "integer", 4_4, bgt(transfer(real(x,kind=4)--6.5504e4_4,0_4),1207951360_4)
+!CHECK: PRINT *, " real", 2_4, "integer", 8_4, bgt(transfer(real(x,kind=4)--6.5504e4_4,0_4),1207951360_4)
+!CHECK: PRINT *, " real", 2_4, "integer", 16_4, bgt(transfer(real(x,kind=4)--6.5504e4_4,0_4),1207951360_4)
+!CHECK: PRINT *, " real", 3_4, "integer", 1_4, bgt(transfer(real(x,kind=4)--1.28e2_4,0_4),1132429312_4)
+!CHECK: PRINT *, " real", 3_4, "integer", 2_4, bgt(transfer(real(x,kind=4)--3.2768e4_4,0_4),1199538176_4)
+!CHECK: PRINT *, " real", 3_4, "integer", 4_4, bgt(transfer(real(x,kind=4)--2.147483648e9_4,0_4),1333755904_4)
+!CHECK: PRINT *, " real", 3_4, "integer", 8_4, bgt(transfer(real(x,kind=4)--9.223372036854775808e18_4,0_4),1602191360_4)
+!CHECK: PRINT *, " real", 3_4, "integer", 16_4, bgt(transfer(real(x,kind=4)--1.70141183460469231731687303715884105728e38_4,0_4),2139062272_4)
+!CHECK: PRINT *, " real", 4_4, "integer", 1_4, bgt(transfer(real(x,kind=8)--1.289999847412109375e2_8,0_8),4643228807602372608_8)
+!CHECK: PRINT *, " real", 4_4, "integer", 2_4, bgt(transfer(real(x,kind=8)--3.276899609375e4_8,0_8),4679240081154768896_8)
+!CHECK: PRINT *, " real", 4_4, "integer", 4_4, bgt(transfer(real(x,kind=8)--2.147483648e9_8,0_8),4751297606607437824_8)
+!CHECK: PRINT *, " real", 4_4, "integer", 8_4, bgt(transfer(real(x,kind=8)--9.223372036854775808e18_8,0_8),4895412794683293696_8)
+!CHECK: PRINT *, " real", 4_4, "integer", 16_4, bgt(transfer(real(x,kind=8)--1.70141183460469231731687303715884105728e38_8,0_8),5183643170835005440_8)
+!CHECK: PRINT *, " real", 8_4, "integer", 1_4, bgt(transfer(real(x,kind=16)--1.28999999999999971578290569595992565155029296875e2_16,0_16),85106958090653963310049098151042744320_16)
+!CHECK: PRINT *, " real", 8_4, "integer", 2_4, bgt(transfer(real(x,kind=16)--3.27689999999999927240423858165740966796875e4_16,0_16),85148476262340800793671255767969169408_16)
+!CHECK: PRINT *, " real", 8_4, "integer", 4_4, bgt(transfer(real(x,kind=16)--2.147483648999999523162841796875e9_16,0_16),85231552932850404447283020744867446784_16)
+!CHECK: PRINT *, " real", 8_4, "integer", 8_4, bgt(transfer(real(x,kind=16)--9.223372036854775808e18_16,0_16),85397706432322310005864612374379495424_16)
+!CHECK: PRINT *, " real", 8_4, "integer", 16_4, bgt(transfer(real(x,kind=16)--1.70141183460469231731687303715884105728e38_16,0_16),85730013431268538974090564139449581568_16)
+!CHECK: PRINT *, " real", 10_4, "integer", 1_4, bgt(transfer(real(x,kind=16)--1.2899999999999999998612221219218554324470460414886474609375e2_16,0_16),85106958090653963310913367067032813568_16)
+!CHECK: PRINT *, " real", 10_4, "integer", 2_4, bgt(transfer(real(x,kind=16)--3.2768999999999999996447286321199499070644378662109375e4_16,0_16),85148476262340800794535524683959238656_16)
+!CHECK: PRINT *, " real", 10_4, "integer", 4_4, bgt(transfer(real(x,kind=16)--2.14748364899999999976716935634613037109375e9_16,0_16),85231552932850404448147289660857516032_16)
+!CHECK: PRINT *, " real", 10_4, "integer", 8_4, bgt(transfer(real(x,kind=16)--9.223372036854775808e18_16,0_16),85397706432322310006440791651706208256_16)
+!CHECK: PRINT *, " real", 10_4, "integer", 16_4, bgt(transfer(real(x,kind=16)--1.70141183460469231731687303715884105728e38_16,0_16),85730013431268538974666743416776294400_16)
+!CHECK: PRINT *, " real", 16_4, "integer", 1_4, bgt(transfer(x--1.28999999999999999999999999999999975348096711843381080883482334912930322712298902843031100928783416748046875e2_16,0_16),85106958090653963310913789279497879551_16)
+!CHECK: PRINT *, " real", 16_4, "integer", 2_4, bgt(transfer(x--3.27689999999999999999999999999999936891127582319055567061714777377101626143485191278159618377685546875e4_16,0_16),85148476262340800794535946896424304639_16)
+!CHECK: PRINT *, " real", 16_4, "integer", 4_4, bgt(transfer(x--2.147483648999999999999999999999999586409693723486162564295653965018573217093944549560546875e9_16,0_16),85231552932850404448147711873322582015_16)
+!CHECK: PRINT *, " real", 16_4, "integer", 8_4, bgt(transfer(x--9.2233720368547758089999999999999982236431605997495353221893310546875e18_16,0_16),85397706432322310006441354601659629567_16)
+!CHECK: PRINT *, " real", 16_4, "integer", 16_4, bgt(transfer(x--1.70141183460469231731687303715884105728e38_16,0_16),85730013431268538974667024891753005055_16)
+!CHECK: PRINT *, " real", 2_4, "integer", 1_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-1.28375e2_2,-1.28875e2_2,round),kind=4),0_4),transfer(real(merge(1.274375e2_2,1.279375e2_2,round),kind=4)-real(merge(-1.28375e2_2,-1.28875e2_2,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 2_4, "integer", 2_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-3.2768e4_2,-3.2768e4_2,round),kind=4),0_4),transfer(real(merge(3.2752e4_2,3.2752e4_2,round),kind=4)-real(merge(-3.2768e4_2,-3.2768e4_2,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 2_4, "integer", 4_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-6.5504e4_2,-6.5504e4_2,round),kind=4),0_4),transfer(real(merge(6.5504e4_2,6.5504e4_2,round),kind=4)-real(merge(-6.5504e4_2,-6.5504e4_2,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 2_4, "integer", 8_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-6.5504e4_2,-6.5504e4_2,round),kind=4),0_4),transfer(real(merge(6.5504e4_2,6.5504e4_2,round),kind=4)-real(merge(-6.5504e4_2,-6.5504e4_2,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 2_4, "integer", 16_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-6.5504e4_2,-6.5504e4_2,round),kind=4),0_4),transfer(real(merge(6.5504e4_2,6.5504e4_2,round),kind=4)-real(merge(-6.5504e4_2,-6.5504e4_2,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 3_4, "integer", 1_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-1.28e2_3,-1.28e2_3,round),kind=4),0_4),transfer(real(merge(1.27e2_3,1.275e2_3,round),kind=4)-real(merge(-1.28e2_3,-1.28e2_3,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 3_4, "integer", 2_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-3.2768e4_3,-3.2768e4_3,round),kind=4),0_4),transfer(real(merge(3.264e4_3,3.264e4_3,round),kind=4)-real(merge(-3.2768e4_3,-3.2768e4_3,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 3_4, "integer", 4_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-2.147483648e9_3,-2.147483648e9_3,round),kind=4),0_4),transfer(real(merge(2.13909504e9_3,2.13909504e9_3,round),kind=4)-real(merge(-2.147483648e9_3,-2.147483648e9_3,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 3_4, "integer", 8_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-9.223372036854775808e18_3,-9.223372036854775808e18_3,round),kind=4),0_4),transfer(real(merge(9.18734323983581184e18_3,9.18734323983581184e18_3,round),kind=4)-real(merge(-9.223372036854775808e18_3,-9.223372036854775808e18_3,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 3_4, "integer", 16_4, "round", bgt(transfer(real(x,kind=4)-real(merge(-1.70141183460469231731687303715884105728e38_3,-1.70141183460469231731687303715884105728e38_3,round),kind=4),0_4),transfer(real(merge(1.6947656946257677379523540018574393344e38_3,1.6947656946257677379523540018574393344e38_3,round),kind=4)-real(merge(-1.70141183460469231731687303715884105728e38_3,-1.70141183460469231731687303715884105728e38_3,round),kind=4),0_4))
+!CHECK: PRINT *, " real", 4_4, "integer", 1_4, "round", bgt(transfer(real(x,kind=8)-real(merge(-1.284999847412109375e2_4,-1.289999847412109375e2_4,round),kind=8),0_8),transfer(real(merge(1.2749999237060546875e2_4,1.2799999237060546875e2_4,round),kind=8)-real(merge(-1.284999847412109375e2_4,-1.289999847412109375e2_4,round),kind=8),0_8))
+!CHECK: PRINT *, " real", 4_4, "integer", 2_4, "round", bgt(transfer(real(x,kind=8)-real(merge(-3.276849609375e4_4,-3.276899609375e4_4,round),kind=8),0_8),transfer(real(merge(3.2767498046875e4_4,3.2767998046875e4_4,round),kind=8)-real(merge(-3.276849609375e4_4,-3.276899609375e4_4,round),kind=8),0_8))
+!CHECK: PRINT *, " real", 4_4, "integer", 4_4, "round", bgt(transfer(real(x,kind=8)-real(merge(-2.147483648e9_4,-2.147483648e9_4,round),kind=8),0_8),transfer(real(merge(2.14748352e9_4,2.14748352e9_4,round),kind=8)-real(merge(-2.147483648e9_4,-2.147483648e9_4,round),kind=8),0_8))
+!CHECK: PRINT *, " real", 4_4, "integer", 8_4, "round", bgt(transfer(real(x,kind=8)-real(merge(-9.223372036854775808e18_4,-9.223372036854775808e18_4,round),kind=8),0_8),transfer(real(merge(9.22337148709896192e18_4,9.22337148709896192e18_4,round),kind=8)-real(merge(-9.223372036854775808e18_4,-9.223372036854775808e18_4,round),kind=8),0_8))
+!CHECK: PRINT *, " real", 4_4, "integer", 16_4, "round", bgt(transfer(real(x,kind=8)-real(merge(-1.70141183460469231731687303715884105728e38_4,-1.70141183460469231731687303715884105728e38_4,round),kind=8),0_8),transfer(real(merge(1.7014117331926442990585209174225846272e38_4,1.7014117331926442990585209174225846272e38_4,round),kind=8)-real(merge(-1.70141183460469231731687303715884105728e38_4,-1.70141183460469231731687303715884105728e38_4,round),kind=8),0_8))
+!CHECK: PRINT *, " real", 8_4, "integer", 1_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-1.28499999999999971578290569595992565155029296875e2_8,-1.28999999999999971578290569595992565155029296875e2_8,round),kind=16),0_16),transfer(real(merge(1.274999999999999857891452847979962825775146484375e2_8,1.279999999999999857891452847979962825775146484375e2_8,round),kind=16)-real(merge(-1.28499999999999971578290569595992565155029296875e2_8,-1.28999999999999971578290569595992565155029296875e2_8,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 8_4, "integer", 2_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-3.27684999999999927240423858165740966796875e4_8,-3.27689999999999927240423858165740966796875e4_8,round),kind=16),0_16),transfer(real(merge(3.276749999999999636202119290828704833984375e4_8,3.276799999999999636202119290828704833984375e4_8,round),kind=16)-real(merge(-3.27684999999999927240423858165740966796875e4_8,-3.27689999999999927240423858165740966796875e4_8,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 8_4, "integer", 4_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-2.147483648499999523162841796875e9_8,-2.147483648999999523162841796875e9_8,round),kind=16),0_16),transfer(real(merge(2.1474836474999997615814208984375e9_8,2.1474836479999997615814208984375e9_8,round),kind=16)-real(merge(-2.147483648499999523162841796875e9_8,-2.147483648999999523162841796875e9_8,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 8_4, "integer", 8_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-9.223372036854775808e18_8,-9.223372036854775808e18_8,round),kind=16),0_16),transfer(real(merge(9.223372036854774784e18_8,9.223372036854774784e18_8,round),kind=16)-real(merge(-9.223372036854775808e18_8,-9.223372036854775808e18_8,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 8_4, "integer", 16_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-1.70141183460469231731687303715884105728e38_8,-1.70141183460469231731687303715884105728e38_8,round),kind=16),0_16),transfer(real(merge(1.70141183460469212842221372237303250944e38_8,1.70141183460469212842221372237303250944e38_8,round),kind=16)-real(merge(-1.70141183460469231731687303715884105728e38_8,-1.70141183460469231731687303715884105728e38_8,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 10_4, "integer", 1_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-1.2849999999999999998612221219218554324470460414886474609375e2_10,-1.2899999999999999998612221219218554324470460414886474609375e2_10,round),kind=16),0_16),transfer(real(merge(1.27499999999999999993061106096092771622352302074432373046875e2_10,1.27999999999999999993061106096092771622352302074432373046875e2_10,round),kind=16)-real(merge(-1.2849999999999999998612221219218554324470460414886474609375e2_10,-1.2899999999999999998612221219218554324470460414886474609375e2_10,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 10_4, "integer", 2_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-3.2768499999999999996447286321199499070644378662109375e4_10,-3.2768999999999999996447286321199499070644378662109375e4_10,round),kind=16),0_16),transfer(real(merge(3.27674999999999999982236431605997495353221893310546875e4_10,3.27679999999999999982236431605997495353221893310546875e4_10,round),kind=16)-real(merge(-3.2768499999999999996447286321199499070644378662109375e4_10,-3.2768999999999999996447286321199499070644378662109375e4_10,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 10_4, "integer", 4_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-2.14748364849999999976716935634613037109375e9_10,-2.14748364899999999976716935634613037109375e9_10,round),kind=16),0_16),transfer(real(merge(2.147483647499999999883584678173065185546875e9_10,2.147483647999999999883584678173065185546875e9_10,round),kind=16)-real(merge(-2.14748364849999999976716935634613037109375e9_10,-2.14748364899999999976716935634613037109375e9_10,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 10_4, "integer", 8_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-9.223372036854775808e18_10,-9.223372036854775808e18_10,round),kind=16),0_16),transfer(real(merge(9.223372036854775807e18_10,9.2233720368547758075e18_10,round),kind=16)-real(merge(-9.223372036854775808e18_10,-9.223372036854775808e18_10,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 10_4, "integer", 16_4, "round", bgt(transfer(real(x,kind=16)-real(merge(-1.70141183460469231731687303715884105728e38_10,-1.70141183460469231731687303715884105728e38_10,round),kind=16),0_16),transfer(real(merge(1.7014118346046923172246393167902932992e38_10,1.7014118346046923172246393167902932992e38_10,round),kind=16)-real(merge(-1.70141183460469231731687303715884105728e38_10,-1.70141183460469231731687303715884105728e38_10,round),kind=16),0_16))
+!CHECK: PRINT *, " real", 16_4, "integer", 1_4, "round", bgt(transfer(x-merge(-1.28499999999999999999999999999999975348096711843381080883482334912930322712298902843031100928783416748046875e2_16,-1.28999999999999999999999999999999975348096711843381080883482334912930322712298902843031100928783416748046875e2_16,round),0_16),transfer(merge(1.274999999999999999999999999999999876740483559216905404417411674564651613561494514215155504643917083740234375e2_16,1.279999999999999999999999999999999876740483559216905404417411674564651613561494514215155504643917083740234375e2_16,round)-merge(-1.28499999999999999999999999999999975348096711843381080883482334912930322712298902843031100928783416748046875e2_16,-1.28999999999999999999999999999999975348096711843381080883482334912930322712298902843031100928783416748046875e2_16,round),0_16))
+!CHECK: PRINT *, " real", 16_4, "integer", 2_4, "round", bgt(transfer(x-merge(-3.27684999999999999999999999999999936891127582319055567061714777377101626143485191278159618377685546875e4_16,-3.27689999999999999999999999999999936891127582319055567061714777377101626143485191278159618377685546875e4_16,round),0_16),transfer(merge(3.276749999999999999999999999999999684455637911595277835308573886885508130717425956390798091888427734375e4_16,3.276799999999999999999999999999999684455637911595277835308573886885508130717425956390798091888427734375e4_16,round)-merge(-3.27684999999999999999999999999999936891127582319055567061714777377101626143485191278159618377685546875e4_16,-3.27689999999999999999999999999999936891127582319055567061714777377101626143485191278159618377685546875e4_16,round),0_16))
+!CHECK: PRINT *, " real", 16_4, "integer", 4_4, "round", bgt(transfer(x-merge(-2.147483648499999999999999999999999586409693723486162564295653965018573217093944549560546875e9_16,-2.147483648999999999999999999999999586409693723486162564295653965018573217093944549560546875e9_16,round),0_16),transfer(merge(2.1474836474999999999999999999999997932048468617430812821478269825092866085469722747802734375e9_16,2.1474836479999999999999999999999997932048468617430812821478269825092866085469722747802734375e9_16,round)-merge(-2.147483648499999999999999999999999586409693723486162564295653965018573217093944549560546875e9_16,-2.147483648999999999999999999999999586409693723486162564295653965018573217093944549560546875e9_16,round),0_16))
+!CHECK: PRINT *, " real", 16_4, "integer", 8_4, "round", bgt(transfer(x-merge(-9.2233720368547758084999999999999982236431605997495353221893310546875e18_16,-9.2233720368547758089999999999999982236431605997495353221893310546875e18_16,round),0_16),transfer(merge(9.22337203685477580749999999999999911182158029987476766109466552734375e18_16,9.22337203685477580799999999999999911182158029987476766109466552734375e18_16,round)-merge(-9.2233720368547758084999999999999982236431605997495353221893310546875e18_16,-9.2233720368547758089999999999999982236431605997495353221893310546875e18_16,round),0_16))
+!CHECK: PRINT *, " real", 16_4, "integer", 16_4, "round", bgt(transfer(x-merge(-1.70141183460469231731687303715884105728e38_16,-1.70141183460469231731687303715884105728e38_16,round),0_16),transfer(merge(1.70141183460469231731687303715884089344e38_16,1.70141183460469231731687303715884089344e38_16,round)-merge(-1.70141183460469231731687303715884105728e38_16,-1.70141183460469231731687303715884105728e38_16,round),0_16))
+!CHECK: PRINT *, " real", 2_4, "real", 2_4, .false._4
+!CHECK: PRINT *, " real", 2_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " real", 2_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " real", 2_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " real", 2_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " real", 2_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " real", 3_4, "real", 2_4, blt(int(transfer(abs(x)-6.5536e4_3,0_2),kind=8)-1_8,32639_2)
+!CHECK: PRINT *, " real", 3_4, "real", 3_4, .false._4
+!CHECK: PRINT *, " real", 3_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " real", 3_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " real", 3_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " real", 3_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " real", 4_4, "real", 2_4, blt(int(transfer(abs(x)-6.5504e4_4,0_4),kind=8)-1_8,2139095039_4)
+!CHECK: PRINT *, " real", 4_4, "real", 3_4, blt(int(transfer(abs(x)-3.3895313892515354759047080037148786688e38_4,0_4),kind=8)-1_8,2139095039_4)
+!CHECK: PRINT *, " real", 4_4, "real", 4_4, .false._4
+!CHECK: PRINT *, " real", 4_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " real", 4_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " real", 4_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " real", 8_4, "real", 2_4, blt(transfer(abs(x)-6.5504e4_8,0_8)-1_8,9218868437227405311_8)
+!CHECK: PRINT *, " real", 8_4, "real", 3_4, blt(transfer(abs(x)-3.3895313892515354759047080037148786688e38_8,0_8)-1_8,9218868437227405311_8)
+!CHECK: PRINT *, " real", 8_4, "real", 4_4, blt(transfer(abs(x)-3.4028234663852885981170418348451692544e38_8,0_8)-1_8,9218868437227405311_8)
+!CHECK: PRINT *, " real", 8_4, "real", 8_4, .false._4
+!CHECK: PRINT *, " real", 8_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " real", 8_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " real", 10_4, "real", 2_4, blt(transfer(abs(x)-6.5504e4_10,0_16)-1_16,604444463063240877801471_16)
+!CHECK: PRINT *, " real", 10_4, "real", 3_4, blt(transfer(abs(x)-3.3895313892515354759047080037148786688e38_10,0_16)-1_16,604444463063240877801471_16)
+!CHECK: PRINT *, " real", 10_4, "real", 4_4, blt(transfer(abs(x)-3.4028234663852885981170418348451692544e38_10,0_16)-1_16,604444463063240877801471_16)
+!CHECK: PRINT *, " real", 10_4, "real", 8_4, blt(transfer(abs(x)-1.79769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368e308_10,0_16)-1_16,604444463063240877801471_16)
+!CHECK: PRINT *, " real", 10_4, "real", 10_4, .false._4
+!CHECK: PRINT *, " real", 10_4, "real", 16_4, .false._4
+!CHECK: PRINT *, " real", 16_4, "real", 2_4, blt(transfer(abs(x)-6.5504e4_16,0_16)-1_16,170135991163610696904058773219554885631_16)
+!CHECK: PRINT *, " real", 16_4, "real", 3_4, blt(transfer(abs(x)-3.3895313892515354759047080037148786688e38_16,0_16)-1_16,170135991163610696904058773219554885631_16)
+!CHECK: PRINT *, " real", 16_4, "real", 4_4, blt(transfer(abs(x)-3.4028234663852885981170418348451692544e38_16,0_16)-1_16,170135991163610696904058773219554885631_16)
+!CHECK: PRINT *, " real", 16_4, "real", 8_4, blt(transfer(abs(x)-1.79769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368e308_16,0_16)-1_16,170135991163610696904058773219554885631_16)
+!CHECK: PRINT *, " real", 16_4, "real", 10_4, blt(transfer(abs(x)-1.18973149535723176502126385303097020516906332229462420044032373389173700552297072261641029033652888285354569780749557731442744315367028843419812557385374367867359320070697326320191591828296152436552951064679108661431179063216977883889613478656060039914875343321145491116008867984515486651285234014977303760000912547939396622315138362241783854274391783813871780588948754057516822634765923557697480511372564902088485522249479139937758502601177354918009979622602685950855888360815984690023564513234659447638493985927645628457966177293040780660922910271504608538808795932778162298682754783076808004015069494230341172895777710033571401055977524212405734700738625166011082837911962300846927720096515350020847447079244384854591288672300061908512647211195136146752763351956292759795725027800298079590419313960302147099703527646744553092202267965628099149823208332964124103850923918473478612192169721054348428704835340811304257300221642134891734717423480071488075100206439051723424765600472176809648610799494341570347632064355862420744350442438056613601760883747816538902780957697597728686007148702828795556714140463261583262360276289631617397848425448686060994827086796804807870251185893083854658422304090880599629459458620190376604844679092600222541053077590106576067134720012584640695703025713896098375799892695455305236856075868317922311363951946885088077187210470520395758748001314313144425494391994017575316933939236688185618912993172910425292123683515992232205099800167710278403536014082929639811512287776813570604578934353545169653956125404884644716978689321167108722908808277835051822885764606221873970285165508372099234948333443522898475123275372663606621390228126470623407535207172405866507951821730346378263135339370677490195019784169044182473806316282858685774143258116536404021840272491339332094921949842244273042701987304453662035026238695780468200360144729199712309553005720614186697485284685618651483271597448120312194675168637934309618961510733006555242148519520176285859509105183947250286387163249416761380499631979144187025430270675849519200883791516940158174004671147787720145964446117520405945350476472180797576111172084627363927960033967047003761337450955318415007379641260504792325166135484129188421134082301547330475406707281876350361733290800595189632520707167390454777712968226520622565143991937680440029238090311243791261477625596469422198137514696707944687035800439250765945161837981185939204954403611491531078225107269148697980924094677214272701240437718740921675661363493890045123235166814608932240069799317601780533819184998193300841098599393876029260139091141452600372028487213241195542428210183120421610446740462163533690058366460659115629876474552506814500393294140413149540067760295100596225302282300363147382468105964844244132486457313743759509641616804802412935187620466813563687753281467553879887177183651289394719533506188500326760735438867336800207438784965701457609034985757124304510203873049485425670247933932280911052604153852899484920399109194612991249163328991799809438033787952209313146694614970593966415237594928589096048991612194498998638483702248667224914892467841020618336462741696957630763248023558797524525373703543388296086275342774001633343405508353704850737454481975472222897528108302089868263302028525992308416805453968791141829762998896457648276528750456285492426516521775079951625966922911497778896235667095662713848201819134832168799586365263762097828507009933729439678463987902491451422274252700636394232799848397673998715441855420156224415492665301451550468548925862027608576183712976335876121538256512963353814166394951655600026415918655485005705261143195291991880795452239464962763563017858089669222640623538289853586759599064700838568712381032959192649484625076899225841930548076362021508902214922052806984201835084058693849381549890944546197789302911357651677540623227829831403347327660395223160342282471752818181884430488092132193355086987339586127607367086665237555567580317149010847732009642431878007000879734603290627894355374356444885190719161645514115576193939969076741515640282654366402676009508752394550734155613586793306603174472092444651353236664764973540085196704077110364053815007348689179836404957060618953500508984091382686953509006678332447257871219660441528492484004185093281190896363417573989716659600075948780061916409485433875852065711654107226099628815012314437794400874930194474433078438899570184271000480830501217712356062289507626904285680004771889315808935851559386317665294808903126774702966254511086154895839508779675546413794489596052797520987481383976257859210575628440175934932416214833956535018919681138909184379573470326940634289008780584694035245347939808067427323629788710086717580253156130235606487870925986528841635097252953709111431720488774740553905400942537542411931794417513706468964386151771884986701034153254238591108962471088538580868883777725864856414593426212108664758848926003176234596076950884914966244415660441955208681198977024e4932_16,0_16)-1_16,170135991163610696904058773219554885631_16)
+!CHECK: PRINT *, " real", 16_4, "real", 16_4, .false._4