[flang] Add isnan() extension intrinsic function, with folding

[klausler]

Summary

It's nonstandard, but commonly implemented.

[jeanPerier]

Looks good to me

flang/docs/Extensions.md

* When a dummy argument is `POINTER` or `ALLOCATABLE` and is `INTENT(IN)`, we
   hold true for definable arguments.
 * Assignment of `LOGICAL` to `INTEGER` and vice versa (but not other types) is
   allowed.  The values are normalized.
 * An effectively empty source file (no program unit) is accepted and
   produces an empty relocatable output file.
 * A `RETURN` statement may appear in a main program.
 * DATA statement initialization is allowed for procedure pointers outside
   structure constructors.
+* Nonstandard intrinsic functions: ISNAN
 
 ### Extensions supported when enabled by options
 
 * C-style backslash escape sequences in quoted CHARACTER literals
   (but not Hollerith) [-fbackslash]
 * Logical abbreviations `.T.`, `.F.`, `.N.`, `.A.`, `.O.`, and `.X.`
   [-flogical-abbreviations]
 * `.XOR.` as a synonym for `.NEQV.` [-fxor-operator]

flang/include/flang/Evaluate/real.h

if (result.flags.test(RealFlag::Overflow)) {
           IsSignBitSet() ? result.value.MASKL(1) : result.value.HUGE();
     }
     return result;
   }
 
   template <typename A>
   static ValueWithRealFlags<Real> Convert(
       const A &x, Rounding rounding = defaultRounding) {
+    ValueWithRealFlags<Real> result;
+    if (x.IsNotANumber()) {
+      result.flags.set(RealFlag::InvalidArgument);
+      result.value = NotANumber();
+      return result;
+    }
     bool isNegative{x.IsNegative()};
     A absX{x};
     if (isNegative) {
       absX = x.Negate();
     }
-    ValueWithRealFlags<Real> result;
     int exponent{exponentBias + x.UnbiasedExponent()};
     int bitsLost{A::binaryPrecision - binaryPrecision};
     if (exponent < 1) {
       bitsLost += 1 - exponent;
       exponent = 1;
     }
     typename A::Fraction xFraction{x.GetFraction()};
     if (bitsLost <= 0) {

flang/lib/Evaluate/common.cpp

 namespace Fortran::evaluate {
 
 void RealFlagWarnings(
     FoldingContext &context, const RealFlags &flags, const char *operation) {
   if (flags.test(RealFlag::Overflow)) {
     context.messages().Say("overflow on %s"_en_US, operation);
   }
   if (flags.test(RealFlag::DivideByZero)) {
-    context.messages().Say("division by zero on %s"_en_US, operation);
+    if (std::strcmp(operation, "division") == 0) {
+      context.messages().Say("division by zero"_en_US);
+    } else {
+      context.messages().Say("division on %s"_en_US);
+    }
   }
   if (flags.test(RealFlag::InvalidArgument)) {
     context.messages().Say("invalid argument on %s"_en_US, operation);
   }
   if (flags.test(RealFlag::Underflow)) {
     context.messages().Say("underflow on %s"_en_US, operation);
   }
 }

flang/lib/Evaluate/fold-logical.cpp

if (name == "bge") { // done in fptr declaration
       common::die("missing case to fold intrinsic function %s", name.c_str());
     }
     return FoldElementalIntrinsic<T, LargestInt, LargestInt>(context,
         std::move(funcRef),
         ScalarFunc<T, LargestInt, LargestInt>(
             [&fptr](const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {
               return Scalar<T>{std::invoke(fptr, i, j)};
             }));
+  } else if (name == "isnan") {
+    // A warning about an invalid argument is discarded from converting
+    // the argument of isnan().
+    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()};
+        }));
   } else if (name == "is_contiguous") {
     if (args.at(0)) {
       if (auto *expr{args[0]->UnwrapExpr()}) {
         if (IsSimplyContiguous(*expr, context.intrinsics())) {
           return Expr<T>{true};
         }
       }
     }

flang/lib/Evaluate/intrinsics.cpp

static const IntrinsicInterface genericIntrinsicFunction[]{
     {"int_ptr_kind", {}, DefaultInt, Rank::scalar},
     {"ior", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}}, SameInt},
     {"ior", {{"i", BOZ}, {"j", SameInt}}, SameInt},
     {"ishft", {{"i", SameInt}, {"shift", AnyInt}}, SameInt},
     {"ishftc",
         {{"i", SameInt}, {"shift", AnyInt},
             {"size", AnyInt, Rank::elemental, Optionality::optional}},
         SameInt},
+    {"isnan", {{"a", AnyFloating}}, DefaultLogical},
     {"is_contiguous", {{"array", Addressable, Rank::anyOrAssumedRank}},
         DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
     {"is_iostat_end", {{"i", AnyInt}}, DefaultLogical},
     {"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical},
     {"kind", {{"x", AnyIntrinsic}}, DefaultInt, Rank::elemental,
         IntrinsicClass::inquiryFunction},
     {"lbound",
         {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM,

 //   COSHAPE
 // TODO: Non-standard intrinsic functions
 //  AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT,
 //  COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,
 //  QCMPLX, DFLOAT, QEXT, QFLOAT, QREAL, DNUM,
 //  INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF,
 //  MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR
 //  IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE,
-//  EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC
+//  EOF, FP_CLASS, INT_PTR_KIND, MALLOC
 //  probably more (these are PGI + Intel, possibly incomplete)
 // TODO: Optionally warn on use of non-standard intrinsics:
 //  LOC, probably others
 // TODO: Optionally warn on operand promotion extension
 
 // The following table contains the intrinsic functions listed in
 // Tables 16.2 and 16.3 in Fortran 2018.  The "unrestricted" functions
 // in Table 16.2 can be used as actual arguments, PROCEDURE() interfaces,

flang/test/Evaluate/folding03.f90

 module real_tests
   ! Test real(4) operation folding on edge cases (inf and NaN)
 
   real(4), parameter :: r4_pmax = 3.4028235E38
   real(4), parameter :: r4_nmax = -3.4028235E38
   !WARN: invalid argument on division
   real(4), parameter :: r4_nan = 0._4/0._4
   TEST_ISNAN(r4_nan)
-  !WARN: division by zero on division
+  !WARN: division by zero
   real(4), parameter :: r4_pinf = 1._4/0._4
-  !WARN: division by zero on division
+  !WARN: 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_pinf_parentheses = ((r4_pinf)).EQ.r4_pinf
   logical, parameter :: test_r4_ninf_parentheses = ((r4_ninf)).EQ.r4_ninf
 
   ! No warnings expected

flang/test/Evaluate/folding04.f90

 ! RUN: %S/test_folding.sh %s %t %f18
 ! Test intrinsic function folding edge case (both expected value and messages)
 ! These tests make assumptions regarding real(4) extrema.
 
 #define TEST_ISNAN(v) logical, parameter :: test_##v =.NOT.(v.EQ.v)
 
 
 module real_tests
   ! Test real(4) intrinsic folding on edge cases (inf and NaN)
 
   real(4), parameter :: r4_pmax = 3.4028235E38
   real(4), parameter :: r4_nmax = -3.4028235E38
   !WARN: invalid argument on division
   real(4), parameter :: r4_nan = 0._4/0._4
-  !WARN: division by zero on division
+  !WARN: division by zero
   real(4), parameter :: r4_pinf = 1._4/0._4
-  !WARN: division by zero on division
+  !WARN: division by zero
   real(4), parameter :: r4_ninf = -1._4/0._4
 
   !WARN: invalid argument on intrinsic function
   real(4), parameter :: nan_r4_acos1 = acos(1.1)
   TEST_ISNAN(nan_r4_acos1)
   !WARN: invalid argument on intrinsic function
   real(4), parameter :: nan_r4_acos2 = acos(r4_pmax)
   TEST_ISNAN(nan_r4_acos2)

flang/test/Evaluate/folding14.f90

+! RUN: %S/test_folding.sh %s %t %f18
+! Test folding of isnan() extension
+module m1
+  logical, parameter :: results(*) = isnan([ &
+    0., &
+    -0., &
+!WARN: division by zero
+    1./0., &
+!WARN: invalid argument on division
+    0./0., &
+    real(z'7ff80001',kind=4), &
+    real(z'fff80001',kind=4), &
+    real(z'7ffc0000',kind=4), &
+    real(z'7ffe0000',kind=4) ])
+  logical, parameter :: expected(*) = [ &
+    .false., .false., .false., .true., .true., .true., .true., .true. ]
+  logical, parameter :: test_isnan = all(results .eqv. expected)
+end module