[flang] Fold real-valued DIM()

[klausler]

Summary

Fold references to the intrinsic function DIM with constant real
arguments. And clean up folding of comparisons with NaNs to address
a problem noticed in testing -- NaNs should successfully compare
unequal to all values, including themselves, instead of failing all
comparisons.

flang/include/flang/Evaluate/common.h

static constexpr bool Satisfies(RelationalOperator op, Relation relation) {
   switch (relation) {
   case Relation::Less:
     return Satisfies(op, Ordering::Less);
   case Relation::Equal:
     return Satisfies(op, Ordering::Equal);
   case Relation::Greater:
     return Satisfies(op, Ordering::Greater);
   case Relation::Unordered:
-    return false;
+    return op == RelationalOperator::NE;
   }
   return false; // silence g++ warning
 }
 
 ENUM_CLASS(
     RealFlag, Overflow, DivideByZero, InvalidArgument, Underflow, Inexact)
 
 using RealFlags = common::EnumSet<RealFlag, RealFlag_enumSize>;

flang/include/flang/Evaluate/real.h

public:
   // NEAREST(), IEEE_NEXT_AFTER(), IEEE_NEXT_UP(), and IEEE_NEXT_DOWN()
   ValueWithRealFlags<Real> NEAREST(bool upward) const;
 
   // HYPOT(x,y)=SQRT(x**2 + y**2) computed so as to avoid spurious
   // intermediate overflows.
   ValueWithRealFlags<Real> HYPOT(
       const Real &, Rounding rounding = defaultRounding) const;
 
+  // DIM(X,Y) = MAX(X-Y, 0)
+  ValueWithRealFlags<Real> DIM(
+      const Real &, Rounding rounding = defaultRounding) const;
+
   template <typename INT> constexpr INT EXPONENT() const {
     if (Exponent() == maxExponent) {
       return INT::HUGE();
     } else if (IsZero()) {
       return {0};
     } else {
       return {UnbiasedExponent() + 1};
     }

flang/lib/Evaluate/fold-real.cpp

return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
                              const Scalar<T> &x) -> Scalar<T> {
           ValueWithRealFlags<Scalar<T>> y{x.ToWholeNumber(mode)};
           if (y.flags.test(RealFlag::Overflow)) {
             context.messages().Say(
                 "%s intrinsic folding overflow"_warn_en_US, name);
           }
           return y.value;
         }));
+  } else if (name == "dim") {
+    return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
+        ScalarFunc<T, T, T>(
+            [](const Scalar<T> &x, const Scalar<T> &y) -> Scalar<T> {
+              return x.DIM(y).value;
+            }));
   } else if (name == "dprod") {
     if (auto scalars{GetScalarConstantArguments<T, T>(context, args)}) {
       return Fold(context,
           Expr<T>{Multiply<T>{
               Expr<T>{std::get<0>(*scalars)}, Expr<T>{std::get<1>(*scalars)}}});
     }
   } else if (name == "epsilon") {
     return Expr<T>{Scalar<T>::EPSILON()};
return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
                 "%s intrinsic folding overflow"_warn_en_US, iName);
           } else if (result.flags.test(RealFlag::InvalidArgument)) {
             context.messages().Say(
                 "%s intrinsic folding: bad argument"_warn_en_US, iName);
           }
           return result.value;
         }));
   }
-  // TODO: dim, dot_product, fraction, matmul,
-  // modulo, norm2, set_exponent, transfer,
+  // TODO: dot_product, fraction, matmul, norm2, set_exponent, transfer
   return Expr<T>{std::move(funcRef)};
 }
 
 template <int KIND>
 Expr<Type<TypeCategory::Real, KIND>> FoldOperation(
     FoldingContext &context, ComplexComponent<KIND> &&x) {
   using Operand = Type<TypeCategory::Complex, KIND>;
   using Result = Type<TypeCategory::Real, KIND>;

flang/lib/Evaluate/real.cpp

if (IsNotANumber() || y.IsNotANumber()) {
     if (inexact) {
       result.flags.set(RealFlag::Inexact);
     }
   }
   return result;
 }
 
 template <typename W, int P>
+ValueWithRealFlags<Real<W, P>> Real<W, P>::DIM(
+    const Real &y, Rounding rounding) const {
+  ValueWithRealFlags<Real> result;
+  if (IsNotANumber() || y.IsNotANumber()) {
+    result.flags.set(RealFlag::InvalidArgument);
+    result.value = NotANumber();
+  } else if (Compare(y) == Relation::Greater) {
+    result = Subtract(y, rounding);
+  } else {
+    // result is already zero
+  }
+  return result;
+}
+
+template <typename W, int P>
 ValueWithRealFlags<Real<W, P>> Real<W, P>::ToWholeNumber(
     common::RoundingMode mode) const {
   ValueWithRealFlags<Real> result{*this};
   if (IsNotANumber()) {
     result.flags.set(RealFlag::InvalidArgument);
     result.value = NotANumber();
   } else if (IsInfinite()) {
     result.flags.set(RealFlag::Overflow);

flang/test/Evaluate/fold-dim.f90

+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of DIM()
+module m
+  logical, parameter :: test_i1 = dim(0, 0) == 0
+  logical, parameter :: test_i2 = dim(1, 2) == 0
+  logical, parameter :: test_i3 = dim(2, 1) == 1
+  logical, parameter :: test_i4 = dim(2, -1) == 3
+  logical, parameter :: test_i5 = dim(-1, 2) == 0
+  logical, parameter :: test_a1 = dim(0., 0.) == 0.
+  logical, parameter :: test_a2 = dim(1., 2.) == 0.
+  logical, parameter :: test_a3 = dim(2., 1.) == 1.
+  logical, parameter :: test_a4 = dim(2., -1.) == 3.
+  logical, parameter :: test_a5 = dim(-1., 2.) == 0.
+  !WARN: warning: invalid argument on division
+  real, parameter :: nan = 0./0.
+  logical, parameter :: test_a6 = dim(nan, 1.) /= dim(nan, 1.)
+end module

flang/test/Evaluate/folding03.f90

module real_tests
   real(4), parameter :: r4_nan = 0._4/0._4
   TEST_ISNAN(r4_nan)
   !WARN: warning: division by zero
   real(4), parameter :: r4_pinf = 1._4/0._4
   !WARN: warning: division by zero
   real(4), parameter :: r4_ninf = -1._4/0._4
 
   logical, parameter :: test_r4_nan_parentheses1 = .NOT.(((r4_nan)).EQ.r4_nan)
-  logical, parameter :: test_r4_nan_parentheses2 = .NOT.(((r4_nan)).NE.r4_nan)
+  logical, parameter :: test_r4_nan_parentheses2 = .NOT.(((r4_nan)).LT.r4_nan)
+  logical, parameter :: test_r4_nan_parentheses3 = .NOT.(((r4_nan)).GT.r4_nan)
+  logical, parameter :: test_r4_nan_parentheses4 = ((r4_nan)).NE.r4_nan
   logical, parameter :: test_r4_pinf_parentheses = ((r4_pinf)).EQ.r4_pinf
   logical, parameter :: test_r4_ninf_parentheses = ((r4_ninf)).EQ.r4_ninf
 
   ! No warnings expected
   logical, parameter :: test_r4_negation1 = (-r4_pmax).EQ.r4_nmax
   logical, parameter :: test_r4_negation2 = (-r4_nmax).EQ.r4_pmax
   logical, parameter :: test_r4_negation3 = (-r4_pinf).EQ.r4_ninf
   logical, parameter :: test_r4_negation4 = (-r4_ninf).EQ.r4_pinf
module real_tests
 
   logical, parameter :: test_inf_r4_le1 = r4_pinf.LE.r4_pinf
   logical, parameter :: test_inf_r4_le2 = r4_ninf.LE.r4_ninf
   logical, parameter :: test_inf_r4_le3 = .NOT.(r4_pinf.LE.r4_ninf)
   logical, parameter :: test_inf_r4_le4 = .NOT.(r4_pinf.LE.r4_pmax)
 
   ! Invalid relational argument
   logical, parameter :: test_nan_r4_eq1 = .NOT.(r4_nan.EQ.r4_nan)
-  logical, parameter :: test_nan_r4_ne1 = .NOT.(r4_nan.NE.r4_nan)
+  logical, parameter :: test_nan_r4_lt1 = .NOT.(r4_nan.LE.r4_nan)
+  logical, parameter :: test_nan_r4_gt1 = .NOT.(r4_nan.GT.r4_nan)
+  logical, parameter :: test_nan_r4_ne1 = r4_nan.NE.r4_nan
 
 end module
 
 ! TODO: edge case conversions
 ! TODO: complex tests (or is real tests enough?)
 
 ! Logical operation (with logical arguments) cannot overflow or be invalid.
 ! CHARACTER folding operations may cause host memory exhaustion if the
 ! string are very large. This will cause a fatal error for the program
 ! doing folding (e.g. f18), so there is nothing very interesting to test here.