From: FX <fxcoudert@gmail.com>
To: Fortran <fortran@gcc.gnu.org>
Cc: gcc-patches@gcc.gnu.org
Subject: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
Date: Fri, 2 Sep 2022 13:37:41 +0200 [thread overview]
Message-ID: <4E0DC1F3-FE18-4C6A-A767-E03A1BA6FCC6@gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 476 bytes --]
Hi,
These operations were added to Fortran 2018, and correspond to well-defined IEEE comparison operations, with defined signaling semantics for NaNs. All are implemented in terms of GCC expressions and built-ins, with no library support needed.
Bootstrapped and regtested on x86_64-linux, both 32- and 64-bit. Depends on a patch currently under review for the middle-end (https://gcc.gnu.org/pipermail/gcc-patches/2022-September/600840.html).
OK to commit?
FX
[-- Attachment #2: 0001-Fortran-add-IEEE_QUIET_-and-IEEE_SIGNALING_-comparis.patch --]
[-- Type: application/octet-stream, Size: 35122 bytes --]
From 525d068da6625ba8cfd15379b84a609b5a692233 Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Fri, 2 Sep 2022 13:27:38 +0200
Subject: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
Those operations were added to Fortran 2018, and correspond to
well-defined IEEE comparison operations, with defined signaling
semantics for NaNs. All are implemented in terms of GCC expressions and
built-ins, with no library support needed.
gcc/fortran/
* f95-lang.cc (gfc_init_builtin_functions): Add __builtin_iseqsig.
* trans-intrinsic.cc (conv_intrinsic_ieee_comparison): New
function.
(gfc_conv_ieee_arithmetic_function): Handle IEEE comparisons.
gcc/testsuite/
* gfortran.dg/ieee/comparisons_1.f90: New test.
* gfortran.dg/ieee/comparisons_2.f90: New test.
libgfortran/
* ieee/ieee_arithmetic.F90: Add IEEE_QUIET_* and
IEEE_SIGNALING_* functions.
---
gcc/fortran/f95-lang.cc | 2 +
gcc/fortran/trans-intrinsic.cc | 91 ++++++
.../gfortran.dg/ieee/comparisons_1.f90 | 282 ++++++++++++++++++
.../gfortran.dg/ieee/comparisons_2.f90 | 282 ++++++++++++++++++
libgfortran/ieee/ieee_arithmetic.F90 | 69 +++++
5 files changed, 726 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/ieee/comparisons_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/ieee/comparisons_2.f90
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 10ac8a95b87..361881d72c0 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -1033,6 +1033,8 @@ gfc_init_builtin_functions (void)
ATTR_CONST_NOTHROW_LEAF_LIST);
gfc_define_builtin ("__builtin_isunordered", ftype, BUILT_IN_ISUNORDERED,
"__builtin_isunordered", ATTR_CONST_NOTHROW_LEAF_LIST);
+ gfc_define_builtin ("__builtin_iseqsig", ftype, BUILT_IN_ISEQSIG,
+ "__builtin_iseqsig", ATTR_CONST_NOTHROW_LEAF_LIST);
#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index ec116fff26e..4cb54baf5d2 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10207,6 +10207,93 @@ conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
}
+/* Generate code for comparison functions IEEE_QUIET_* and
+ IEEE_SIGNALING_*. */
+
+static void
+conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
+ const char *name)
+{
+ tree args[2];
+ tree arg1, arg2, res;
+
+ /* Evaluate arguments only once. */
+ conv_ieee_function_args (se, expr, args, 2);
+ arg1 = gfc_evaluate_now (args[0], &se->pre);
+ arg2 = gfc_evaluate_now (args[1], &se->pre);
+
+ if (startswith (name, "eq"))
+ {
+ if (signaling)
+ res = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISEQSIG),
+ 2, arg1, arg2);
+ else
+ res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ arg1, arg2);
+ }
+ else if (startswith (name, "ne"))
+ {
+ if (signaling)
+ {
+ res = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISEQSIG),
+ 2, arg1, arg2);
+ res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+ logical_type_node, res);
+ }
+ else
+ res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ arg1, arg2);
+ }
+ else if (startswith (name, "ge"))
+ {
+ if (signaling)
+ res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ arg1, arg2);
+ else
+ res = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
+ 2, arg1, arg2);
+ }
+ else if (startswith (name, "gt"))
+ {
+ if (signaling)
+ res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+ arg1, arg2);
+ else
+ res = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISGREATER),
+ 2, arg1, arg2);
+ }
+ else if (startswith (name, "le"))
+ {
+ if (signaling)
+ res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
+ arg1, arg2);
+ else
+ res = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
+ 2, arg1, arg2);
+ }
+ else if (startswith (name, "lt"))
+ {
+ if (signaling)
+ res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+ arg1, arg2);
+ else
+ res = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISLESS),
+ 2, arg1, arg2);
+ }
+ else
+ gcc_unreachable ();
+
+ se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
+}
+
+
+
/* Generate code for an intrinsic function from the IEEE_ARITHMETIC
module. */
@@ -10241,6 +10328,10 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
conv_intrinsic_ieee_class (se, expr);
else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
conv_intrinsic_ieee_value (se, expr);
+ else if (startswith (name, "_gfortran_ieee_quiet_"))
+ conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
+ else if (startswith (name, "_gfortran_ieee_signaling_"))
+ conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
else
/* It is not among the functions we translate directly. We return
false, so a library function call is emitted. */
diff --git a/gcc/testsuite/gfortran.dg/ieee/comparisons_1.f90 b/gcc/testsuite/gfortran.dg/ieee/comparisons_1.f90
new file mode 100644
index 00000000000..8e166ec234c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/comparisons_1.f90
@@ -0,0 +1,282 @@
+! { dg-do run }
+program foo
+ use ieee_arithmetic
+ use iso_fortran_env
+ implicit none
+
+ ! This allows us to test REAL128 if it exists, and still compile
+ ! on platforms were it is not present
+ ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89639
+ integer, parameter :: large = merge(real128, real64, real128 > 0)
+
+ real :: rnan, rinf
+ double precision :: dnan, dinf
+ real(kind=large) :: lnan, linf
+
+ rinf = ieee_value(0., ieee_positive_inf)
+ rnan = ieee_value(0., ieee_quiet_nan)
+
+ dinf = ieee_value(0.d0, ieee_positive_inf)
+ dnan = ieee_value(0.d0, ieee_quiet_nan)
+
+ linf = ieee_value(0._large, ieee_positive_inf)
+ lnan = ieee_value(0._large, ieee_quiet_nan)
+
+ if (.not. ieee_quiet_eq (0., 0.)) call abort
+ if (.not. ieee_quiet_eq (0., -0.)) call abort
+ if (.not. ieee_quiet_eq (1., 1.)) call abort
+ if (.not. ieee_quiet_eq (rinf, rinf)) call abort
+ if (.not. ieee_quiet_eq (-rinf, -rinf)) call abort
+ if (ieee_quiet_eq (rnan, rnan)) call abort
+ if (ieee_quiet_eq (0., 1.)) call abort
+ if (ieee_quiet_eq (0., -1.)) call abort
+ if (ieee_quiet_eq (0., rnan)) call abort
+ if (ieee_quiet_eq (1., rnan)) call abort
+ if (ieee_quiet_eq (0., rinf)) call abort
+ if (ieee_quiet_eq (1., rinf)) call abort
+ if (ieee_quiet_eq (rinf, rnan)) call abort
+
+ if (.not. ieee_quiet_eq (0.d0, 0.d0)) call abort
+ if (.not. ieee_quiet_eq (0.d0, -0.d0)) call abort
+ if (.not. ieee_quiet_eq (1.d0, 1.d0)) call abort
+ if (.not. ieee_quiet_eq (dinf, dinf)) call abort
+ if (.not. ieee_quiet_eq (-dinf, -dinf)) call abort
+ if (ieee_quiet_eq (dnan, dnan)) call abort
+ if (ieee_quiet_eq (0.d0, 1.d0)) call abort
+ if (ieee_quiet_eq (0.d0, -1.d0)) call abort
+ if (ieee_quiet_eq (0.d0, dnan)) call abort
+ if (ieee_quiet_eq (1.d0, dnan)) call abort
+ if (ieee_quiet_eq (0.d0, dinf)) call abort
+ if (ieee_quiet_eq (1.d0, dinf)) call abort
+ if (ieee_quiet_eq (dinf, dnan)) call abort
+
+ if (.not. ieee_quiet_eq (0._large, 0._large)) call abort
+ if (.not. ieee_quiet_eq (0._large, -0._large)) call abort
+ if (.not. ieee_quiet_eq (1._large, 1._large)) call abort
+ if (.not. ieee_quiet_eq (linf, linf)) call abort
+ if (.not. ieee_quiet_eq (-linf, -linf)) call abort
+ if (ieee_quiet_eq (lnan, lnan)) call abort
+ if (ieee_quiet_eq (0._large, 1._large)) call abort
+ if (ieee_quiet_eq (0._large, -1._large)) call abort
+ if (ieee_quiet_eq (0._large, lnan)) call abort
+ if (ieee_quiet_eq (1._large, lnan)) call abort
+ if (ieee_quiet_eq (0._large, linf)) call abort
+ if (ieee_quiet_eq (1._large, linf)) call abort
+ if (ieee_quiet_eq (linf, lnan)) call abort
+
+
+ if (ieee_quiet_ne (0., 0.)) call abort
+ if (ieee_quiet_ne (0., -0.)) call abort
+ if (ieee_quiet_ne (1., 1.)) call abort
+ if (ieee_quiet_ne (rinf, rinf)) call abort
+ if (ieee_quiet_ne (-rinf, -rinf)) call abort
+ if (.not. ieee_quiet_ne (rnan, rnan)) call abort
+ if (.not. ieee_quiet_ne (0., 1.)) call abort
+ if (.not. ieee_quiet_ne (0., -1.)) call abort
+ if (.not. ieee_quiet_ne (0., rnan)) call abort
+ if (.not. ieee_quiet_ne (1., rnan)) call abort
+ if (.not. ieee_quiet_ne (0., rinf)) call abort
+ if (.not. ieee_quiet_ne (1., rinf)) call abort
+ if (.not. ieee_quiet_ne (rinf, rnan)) call abort
+
+ if (ieee_quiet_ne (0.d0, 0.d0)) call abort
+ if (ieee_quiet_ne (0.d0, -0.d0)) call abort
+ if (ieee_quiet_ne (1.d0, 1.d0)) call abort
+ if (ieee_quiet_ne (dinf, dinf)) call abort
+ if (ieee_quiet_ne (-dinf, -dinf)) call abort
+ if (.not. ieee_quiet_ne (dnan, dnan)) call abort
+ if (.not. ieee_quiet_ne (0.d0, 1.d0)) call abort
+ if (.not. ieee_quiet_ne (0.d0, -1.d0)) call abort
+ if (.not. ieee_quiet_ne (0.d0, dnan)) call abort
+ if (.not. ieee_quiet_ne (1.d0, dnan)) call abort
+ if (.not. ieee_quiet_ne (0.d0, dinf)) call abort
+ if (.not. ieee_quiet_ne (1.d0, dinf)) call abort
+ if (.not. ieee_quiet_ne (dinf, dnan)) call abort
+
+ if (ieee_quiet_ne (0._large, 0._large)) call abort
+ if (ieee_quiet_ne (0._large, -0._large)) call abort
+ if (ieee_quiet_ne (1._large, 1._large)) call abort
+ if (ieee_quiet_ne (linf, linf)) call abort
+ if (ieee_quiet_ne (-linf, -linf)) call abort
+ if (.not. ieee_quiet_ne (lnan, lnan)) call abort
+ if (.not. ieee_quiet_ne (0._large, 1._large)) call abort
+ if (.not. ieee_quiet_ne (0._large, -1._large)) call abort
+ if (.not. ieee_quiet_ne (0._large, lnan)) call abort
+ if (.not. ieee_quiet_ne (1._large, lnan)) call abort
+ if (.not. ieee_quiet_ne (0._large, linf)) call abort
+ if (.not. ieee_quiet_ne (1._large, linf)) call abort
+ if (.not. ieee_quiet_ne (linf, lnan)) call abort
+
+
+ if (.not. ieee_quiet_le (0., 0.)) call abort
+ if (.not. ieee_quiet_le (0., -0.)) call abort
+ if (.not. ieee_quiet_le (1., 1.)) call abort
+ if (.not. ieee_quiet_le (rinf, rinf)) call abort
+ if (.not. ieee_quiet_le (-rinf, -rinf)) call abort
+ if (ieee_quiet_le (rnan, rnan)) call abort
+ if (.not. ieee_quiet_le (0., 1.)) call abort
+ if (ieee_quiet_le (0., -1.)) call abort
+ if (ieee_quiet_le (0., rnan)) call abort
+ if (ieee_quiet_le (1., rnan)) call abort
+ if (.not. ieee_quiet_le (0., rinf)) call abort
+ if (.not. ieee_quiet_le (1., rinf)) call abort
+ if (ieee_quiet_le (rinf, rnan)) call abort
+
+ if (.not. ieee_quiet_le (0.d0, 0.d0)) call abort
+ if (.not. ieee_quiet_le (0.d0, -0.d0)) call abort
+ if (.not. ieee_quiet_le (1.d0, 1.d0)) call abort
+ if (.not. ieee_quiet_le (dinf, dinf)) call abort
+ if (.not. ieee_quiet_le (-dinf, -dinf)) call abort
+ if (ieee_quiet_le (dnan, dnan)) call abort
+ if (.not. ieee_quiet_le (0.d0, 1.d0)) call abort
+ if (ieee_quiet_le (0.d0, -1.d0)) call abort
+ if (ieee_quiet_le (0.d0, dnan)) call abort
+ if (ieee_quiet_le (1.d0, dnan)) call abort
+ if (.not. ieee_quiet_le (0.d0, dinf)) call abort
+ if (.not. ieee_quiet_le (1.d0, dinf)) call abort
+ if (ieee_quiet_le (dinf, dnan)) call abort
+
+ if (.not. ieee_quiet_le (0._large, 0._large)) call abort
+ if (.not. ieee_quiet_le (0._large, -0._large)) call abort
+ if (.not. ieee_quiet_le (1._large, 1._large)) call abort
+ if (.not. ieee_quiet_le (linf, linf)) call abort
+ if (.not. ieee_quiet_le (-linf, -linf)) call abort
+ if (ieee_quiet_le (lnan, lnan)) call abort
+ if (.not. ieee_quiet_le (0._large, 1._large)) call abort
+ if (ieee_quiet_le (0._large, -1._large)) call abort
+ if (ieee_quiet_le (0._large, lnan)) call abort
+ if (ieee_quiet_le (1._large, lnan)) call abort
+ if (.not. ieee_quiet_le (0._large, linf)) call abort
+ if (.not. ieee_quiet_le (1._large, linf)) call abort
+ if (ieee_quiet_le (linf, lnan)) call abort
+
+
+ if (.not. ieee_quiet_ge (0., 0.)) call abort
+ if (.not. ieee_quiet_ge (0., -0.)) call abort
+ if (.not. ieee_quiet_ge (1., 1.)) call abort
+ if (.not. ieee_quiet_ge (rinf, rinf)) call abort
+ if (.not. ieee_quiet_ge (-rinf, -rinf)) call abort
+ if (ieee_quiet_ge (rnan, rnan)) call abort
+ if (ieee_quiet_ge (0., 1.)) call abort
+ if (.not. ieee_quiet_ge (0., -1.)) call abort
+ if (ieee_quiet_ge (0., rnan)) call abort
+ if (ieee_quiet_ge (1., rnan)) call abort
+ if (ieee_quiet_ge (0., rinf)) call abort
+ if (ieee_quiet_ge (1., rinf)) call abort
+ if (ieee_quiet_ge (rinf, rnan)) call abort
+
+ if (.not. ieee_quiet_ge (0.d0, 0.d0)) call abort
+ if (.not. ieee_quiet_ge (0.d0, -0.d0)) call abort
+ if (.not. ieee_quiet_ge (1.d0, 1.d0)) call abort
+ if (.not. ieee_quiet_ge (dinf, dinf)) call abort
+ if (.not. ieee_quiet_ge (-dinf, -dinf)) call abort
+ if (ieee_quiet_ge (dnan, dnan)) call abort
+ if (ieee_quiet_ge (0.d0, 1.d0)) call abort
+ if (.not. ieee_quiet_ge (0.d0, -1.d0)) call abort
+ if (ieee_quiet_ge (0.d0, dnan)) call abort
+ if (ieee_quiet_ge (1.d0, dnan)) call abort
+ if (ieee_quiet_ge (0.d0, dinf)) call abort
+ if (ieee_quiet_ge (1.d0, dinf)) call abort
+ if (ieee_quiet_ge (dinf, dnan)) call abort
+
+ if (.not. ieee_quiet_ge (0._large, 0._large)) call abort
+ if (.not. ieee_quiet_ge (0._large, -0._large)) call abort
+ if (.not. ieee_quiet_ge (1._large, 1._large)) call abort
+ if (.not. ieee_quiet_ge (linf, linf)) call abort
+ if (.not. ieee_quiet_ge (-linf, -linf)) call abort
+ if (ieee_quiet_ge (lnan, lnan)) call abort
+ if (ieee_quiet_ge (0._large, 1._large)) call abort
+ if (.not. ieee_quiet_ge (0._large, -1._large)) call abort
+ if (ieee_quiet_ge (0._large, lnan)) call abort
+ if (ieee_quiet_ge (1._large, lnan)) call abort
+ if (ieee_quiet_ge (0._large, linf)) call abort
+ if (ieee_quiet_ge (1._large, linf)) call abort
+ if (ieee_quiet_ge (linf, lnan)) call abort
+
+
+ if (ieee_quiet_lt (0., 0.)) call abort
+ if (ieee_quiet_lt (0., -0.)) call abort
+ if (ieee_quiet_lt (1., 1.)) call abort
+ if (ieee_quiet_lt (rinf, rinf)) call abort
+ if (ieee_quiet_lt (-rinf, -rinf)) call abort
+ if (ieee_quiet_lt (rnan, rnan)) call abort
+ if (.not. ieee_quiet_lt (0., 1.)) call abort
+ if (ieee_quiet_lt (0., -1.)) call abort
+ if (ieee_quiet_lt (0., rnan)) call abort
+ if (ieee_quiet_lt (1., rnan)) call abort
+ if (.not. ieee_quiet_lt (0., rinf)) call abort
+ if (.not. ieee_quiet_lt (1., rinf)) call abort
+ if (ieee_quiet_lt (rinf, rnan)) call abort
+
+ if (ieee_quiet_lt (0.d0, 0.d0)) call abort
+ if (ieee_quiet_lt (0.d0, -0.d0)) call abort
+ if (ieee_quiet_lt (1.d0, 1.d0)) call abort
+ if (ieee_quiet_lt (dinf, dinf)) call abort
+ if (ieee_quiet_lt (-dinf, -dinf)) call abort
+ if (ieee_quiet_lt (dnan, dnan)) call abort
+ if (.not. ieee_quiet_lt (0.d0, 1.d0)) call abort
+ if (ieee_quiet_lt (0.d0, -1.d0)) call abort
+ if (ieee_quiet_lt (0.d0, dnan)) call abort
+ if (ieee_quiet_lt (1.d0, dnan)) call abort
+ if (.not. ieee_quiet_lt (0.d0, dinf)) call abort
+ if (.not. ieee_quiet_lt (1.d0, dinf)) call abort
+ if (ieee_quiet_lt (dinf, dnan)) call abort
+
+ if (ieee_quiet_lt (0._large, 0._large)) call abort
+ if (ieee_quiet_lt (0._large, -0._large)) call abort
+ if (ieee_quiet_lt (1._large, 1._large)) call abort
+ if (ieee_quiet_lt (linf, linf)) call abort
+ if (ieee_quiet_lt (-linf, -linf)) call abort
+ if (ieee_quiet_lt (lnan, lnan)) call abort
+ if (.not. ieee_quiet_lt (0._large, 1._large)) call abort
+ if (ieee_quiet_lt (0._large, -1._large)) call abort
+ if (ieee_quiet_lt (0._large, lnan)) call abort
+ if (ieee_quiet_lt (1._large, lnan)) call abort
+ if (.not. ieee_quiet_lt (0._large, linf)) call abort
+ if (.not. ieee_quiet_lt (1._large, linf)) call abort
+ if (ieee_quiet_lt (linf, lnan)) call abort
+
+
+ if (ieee_quiet_gt (0., 0.)) call abort
+ if (ieee_quiet_gt (0., -0.)) call abort
+ if (ieee_quiet_gt (1., 1.)) call abort
+ if (ieee_quiet_gt (rinf, rinf)) call abort
+ if (ieee_quiet_gt (-rinf, -rinf)) call abort
+ if (ieee_quiet_gt (rnan, rnan)) call abort
+ if (ieee_quiet_gt (0., 1.)) call abort
+ if (.not. ieee_quiet_gt (0., -1.)) call abort
+ if (ieee_quiet_gt (0., rnan)) call abort
+ if (ieee_quiet_gt (1., rnan)) call abort
+ if (ieee_quiet_gt (0., rinf)) call abort
+ if (ieee_quiet_gt (1., rinf)) call abort
+ if (ieee_quiet_gt (rinf, rnan)) call abort
+
+ if (ieee_quiet_gt (0.d0, 0.d0)) call abort
+ if (ieee_quiet_gt (0.d0, -0.d0)) call abort
+ if (ieee_quiet_gt (1.d0, 1.d0)) call abort
+ if (ieee_quiet_gt (dinf, dinf)) call abort
+ if (ieee_quiet_gt (-dinf, -dinf)) call abort
+ if (ieee_quiet_gt (dnan, dnan)) call abort
+ if (ieee_quiet_gt (0.d0, 1.d0)) call abort
+ if (.not. ieee_quiet_gt (0.d0, -1.d0)) call abort
+ if (ieee_quiet_gt (0.d0, dnan)) call abort
+ if (ieee_quiet_gt (1.d0, dnan)) call abort
+ if (ieee_quiet_gt (0.d0, dinf)) call abort
+ if (ieee_quiet_gt (1.d0, dinf)) call abort
+ if (ieee_quiet_gt (dinf, dnan)) call abort
+
+ if (ieee_quiet_gt (0._large, 0._large)) call abort
+ if (ieee_quiet_gt (0._large, -0._large)) call abort
+ if (ieee_quiet_gt (1._large, 1._large)) call abort
+ if (ieee_quiet_gt (linf, linf)) call abort
+ if (ieee_quiet_gt (-linf, -linf)) call abort
+ if (ieee_quiet_gt (lnan, lnan)) call abort
+ if (ieee_quiet_gt (0._large, 1._large)) call abort
+ if (.not. ieee_quiet_gt (0._large, -1._large)) call abort
+ if (ieee_quiet_gt (0._large, lnan)) call abort
+ if (ieee_quiet_gt (1._large, lnan)) call abort
+ if (ieee_quiet_gt (0._large, linf)) call abort
+ if (ieee_quiet_gt (1._large, linf)) call abort
+ if (ieee_quiet_gt (linf, lnan)) call abort
+
+end program foo
diff --git a/gcc/testsuite/gfortran.dg/ieee/comparisons_2.f90 b/gcc/testsuite/gfortran.dg/ieee/comparisons_2.f90
new file mode 100644
index 00000000000..788073f34a9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/comparisons_2.f90
@@ -0,0 +1,282 @@
+! { dg-do run }
+program foo
+ use ieee_arithmetic
+ use iso_fortran_env
+ implicit none
+
+ ! This allows us to test REAL128 if it exists, and still compile
+ ! on platforms were it is not present
+ ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89639
+ integer, parameter :: large = merge(real128, real64, real128 > 0)
+
+ real :: rnan, rinf
+ double precision :: dnan, dinf
+ real(kind=large) :: lnan, linf
+
+ rinf = ieee_value(0., ieee_positive_inf)
+ rnan = ieee_value(0., ieee_quiet_nan)
+
+ dinf = ieee_value(0.d0, ieee_positive_inf)
+ dnan = ieee_value(0.d0, ieee_quiet_nan)
+
+ linf = ieee_value(0._large, ieee_positive_inf)
+ lnan = ieee_value(0._large, ieee_quiet_nan)
+
+ if (.not. ieee_signaling_eq (0., 0.)) call abort
+ if (.not. ieee_signaling_eq (0., -0.)) call abort
+ if (.not. ieee_signaling_eq (1., 1.)) call abort
+ if (.not. ieee_signaling_eq (rinf, rinf)) call abort
+ if (.not. ieee_signaling_eq (-rinf, -rinf)) call abort
+ if (ieee_signaling_eq (rnan, rnan)) call abort
+ if (ieee_signaling_eq (0., 1.)) call abort
+ if (ieee_signaling_eq (0., -1.)) call abort
+ if (ieee_signaling_eq (0., rnan)) call abort
+ if (ieee_signaling_eq (1., rnan)) call abort
+ if (ieee_signaling_eq (0., rinf)) call abort
+ if (ieee_signaling_eq (1., rinf)) call abort
+ if (ieee_signaling_eq (rinf, rnan)) call abort
+
+ if (.not. ieee_signaling_eq (0.d0, 0.d0)) call abort
+ if (.not. ieee_signaling_eq (0.d0, -0.d0)) call abort
+ if (.not. ieee_signaling_eq (1.d0, 1.d0)) call abort
+ if (.not. ieee_signaling_eq (dinf, dinf)) call abort
+ if (.not. ieee_signaling_eq (-dinf, -dinf)) call abort
+ if (ieee_signaling_eq (dnan, dnan)) call abort
+ if (ieee_signaling_eq (0.d0, 1.d0)) call abort
+ if (ieee_signaling_eq (0.d0, -1.d0)) call abort
+ if (ieee_signaling_eq (0.d0, dnan)) call abort
+ if (ieee_signaling_eq (1.d0, dnan)) call abort
+ if (ieee_signaling_eq (0.d0, dinf)) call abort
+ if (ieee_signaling_eq (1.d0, dinf)) call abort
+ if (ieee_signaling_eq (dinf, dnan)) call abort
+
+ if (.not. ieee_signaling_eq (0._large, 0._large)) call abort
+ if (.not. ieee_signaling_eq (0._large, -0._large)) call abort
+ if (.not. ieee_signaling_eq (1._large, 1._large)) call abort
+ if (.not. ieee_signaling_eq (linf, linf)) call abort
+ if (.not. ieee_signaling_eq (-linf, -linf)) call abort
+ if (ieee_signaling_eq (lnan, lnan)) call abort
+ if (ieee_signaling_eq (0._large, 1._large)) call abort
+ if (ieee_signaling_eq (0._large, -1._large)) call abort
+ if (ieee_signaling_eq (0._large, lnan)) call abort
+ if (ieee_signaling_eq (1._large, lnan)) call abort
+ if (ieee_signaling_eq (0._large, linf)) call abort
+ if (ieee_signaling_eq (1._large, linf)) call abort
+ if (ieee_signaling_eq (linf, lnan)) call abort
+
+
+ if (ieee_signaling_ne (0., 0.)) call abort
+ if (ieee_signaling_ne (0., -0.)) call abort
+ if (ieee_signaling_ne (1., 1.)) call abort
+ if (ieee_signaling_ne (rinf, rinf)) call abort
+ if (ieee_signaling_ne (-rinf, -rinf)) call abort
+ if (.not. ieee_signaling_ne (rnan, rnan)) call abort
+ if (.not. ieee_signaling_ne (0., 1.)) call abort
+ if (.not. ieee_signaling_ne (0., -1.)) call abort
+ if (.not. ieee_signaling_ne (0., rnan)) call abort
+ if (.not. ieee_signaling_ne (1., rnan)) call abort
+ if (.not. ieee_signaling_ne (0., rinf)) call abort
+ if (.not. ieee_signaling_ne (1., rinf)) call abort
+ if (.not. ieee_signaling_ne (rinf, rnan)) call abort
+
+ if (ieee_signaling_ne (0.d0, 0.d0)) call abort
+ if (ieee_signaling_ne (0.d0, -0.d0)) call abort
+ if (ieee_signaling_ne (1.d0, 1.d0)) call abort
+ if (ieee_signaling_ne (dinf, dinf)) call abort
+ if (ieee_signaling_ne (-dinf, -dinf)) call abort
+ if (.not. ieee_signaling_ne (dnan, dnan)) call abort
+ if (.not. ieee_signaling_ne (0.d0, 1.d0)) call abort
+ if (.not. ieee_signaling_ne (0.d0, -1.d0)) call abort
+ if (.not. ieee_signaling_ne (0.d0, dnan)) call abort
+ if (.not. ieee_signaling_ne (1.d0, dnan)) call abort
+ if (.not. ieee_signaling_ne (0.d0, dinf)) call abort
+ if (.not. ieee_signaling_ne (1.d0, dinf)) call abort
+ if (.not. ieee_signaling_ne (dinf, dnan)) call abort
+
+ if (ieee_signaling_ne (0._large, 0._large)) call abort
+ if (ieee_signaling_ne (0._large, -0._large)) call abort
+ if (ieee_signaling_ne (1._large, 1._large)) call abort
+ if (ieee_signaling_ne (linf, linf)) call abort
+ if (ieee_signaling_ne (-linf, -linf)) call abort
+ if (.not. ieee_signaling_ne (lnan, lnan)) call abort
+ if (.not. ieee_signaling_ne (0._large, 1._large)) call abort
+ if (.not. ieee_signaling_ne (0._large, -1._large)) call abort
+ if (.not. ieee_signaling_ne (0._large, lnan)) call abort
+ if (.not. ieee_signaling_ne (1._large, lnan)) call abort
+ if (.not. ieee_signaling_ne (0._large, linf)) call abort
+ if (.not. ieee_signaling_ne (1._large, linf)) call abort
+ if (.not. ieee_signaling_ne (linf, lnan)) call abort
+
+
+ if (.not. ieee_signaling_le (0., 0.)) call abort
+ if (.not. ieee_signaling_le (0., -0.)) call abort
+ if (.not. ieee_signaling_le (1., 1.)) call abort
+ if (.not. ieee_signaling_le (rinf, rinf)) call abort
+ if (.not. ieee_signaling_le (-rinf, -rinf)) call abort
+ if (ieee_signaling_le (rnan, rnan)) call abort
+ if (.not. ieee_signaling_le (0., 1.)) call abort
+ if (ieee_signaling_le (0., -1.)) call abort
+ if (ieee_signaling_le (0., rnan)) call abort
+ if (ieee_signaling_le (1., rnan)) call abort
+ if (.not. ieee_signaling_le (0., rinf)) call abort
+ if (.not. ieee_signaling_le (1., rinf)) call abort
+ if (ieee_signaling_le (rinf, rnan)) call abort
+
+ if (.not. ieee_signaling_le (0.d0, 0.d0)) call abort
+ if (.not. ieee_signaling_le (0.d0, -0.d0)) call abort
+ if (.not. ieee_signaling_le (1.d0, 1.d0)) call abort
+ if (.not. ieee_signaling_le (dinf, dinf)) call abort
+ if (.not. ieee_signaling_le (-dinf, -dinf)) call abort
+ if (ieee_signaling_le (dnan, dnan)) call abort
+ if (.not. ieee_signaling_le (0.d0, 1.d0)) call abort
+ if (ieee_signaling_le (0.d0, -1.d0)) call abort
+ if (ieee_signaling_le (0.d0, dnan)) call abort
+ if (ieee_signaling_le (1.d0, dnan)) call abort
+ if (.not. ieee_signaling_le (0.d0, dinf)) call abort
+ if (.not. ieee_signaling_le (1.d0, dinf)) call abort
+ if (ieee_signaling_le (dinf, dnan)) call abort
+
+ if (.not. ieee_signaling_le (0._large, 0._large)) call abort
+ if (.not. ieee_signaling_le (0._large, -0._large)) call abort
+ if (.not. ieee_signaling_le (1._large, 1._large)) call abort
+ if (.not. ieee_signaling_le (linf, linf)) call abort
+ if (.not. ieee_signaling_le (-linf, -linf)) call abort
+ if (ieee_signaling_le (lnan, lnan)) call abort
+ if (.not. ieee_signaling_le (0._large, 1._large)) call abort
+ if (ieee_signaling_le (0._large, -1._large)) call abort
+ if (ieee_signaling_le (0._large, lnan)) call abort
+ if (ieee_signaling_le (1._large, lnan)) call abort
+ if (.not. ieee_signaling_le (0._large, linf)) call abort
+ if (.not. ieee_signaling_le (1._large, linf)) call abort
+ if (ieee_signaling_le (linf, lnan)) call abort
+
+
+ if (.not. ieee_signaling_ge (0., 0.)) call abort
+ if (.not. ieee_signaling_ge (0., -0.)) call abort
+ if (.not. ieee_signaling_ge (1., 1.)) call abort
+ if (.not. ieee_signaling_ge (rinf, rinf)) call abort
+ if (.not. ieee_signaling_ge (-rinf, -rinf)) call abort
+ if (ieee_signaling_ge (rnan, rnan)) call abort
+ if (ieee_signaling_ge (0., 1.)) call abort
+ if (.not. ieee_signaling_ge (0., -1.)) call abort
+ if (ieee_signaling_ge (0., rnan)) call abort
+ if (ieee_signaling_ge (1., rnan)) call abort
+ if (ieee_signaling_ge (0., rinf)) call abort
+ if (ieee_signaling_ge (1., rinf)) call abort
+ if (ieee_signaling_ge (rinf, rnan)) call abort
+
+ if (.not. ieee_signaling_ge (0.d0, 0.d0)) call abort
+ if (.not. ieee_signaling_ge (0.d0, -0.d0)) call abort
+ if (.not. ieee_signaling_ge (1.d0, 1.d0)) call abort
+ if (.not. ieee_signaling_ge (dinf, dinf)) call abort
+ if (.not. ieee_signaling_ge (-dinf, -dinf)) call abort
+ if (ieee_signaling_ge (dnan, dnan)) call abort
+ if (ieee_signaling_ge (0.d0, 1.d0)) call abort
+ if (.not. ieee_signaling_ge (0.d0, -1.d0)) call abort
+ if (ieee_signaling_ge (0.d0, dnan)) call abort
+ if (ieee_signaling_ge (1.d0, dnan)) call abort
+ if (ieee_signaling_ge (0.d0, dinf)) call abort
+ if (ieee_signaling_ge (1.d0, dinf)) call abort
+ if (ieee_signaling_ge (dinf, dnan)) call abort
+
+ if (.not. ieee_signaling_ge (0._large, 0._large)) call abort
+ if (.not. ieee_signaling_ge (0._large, -0._large)) call abort
+ if (.not. ieee_signaling_ge (1._large, 1._large)) call abort
+ if (.not. ieee_signaling_ge (linf, linf)) call abort
+ if (.not. ieee_signaling_ge (-linf, -linf)) call abort
+ if (ieee_signaling_ge (lnan, lnan)) call abort
+ if (ieee_signaling_ge (0._large, 1._large)) call abort
+ if (.not. ieee_signaling_ge (0._large, -1._large)) call abort
+ if (ieee_signaling_ge (0._large, lnan)) call abort
+ if (ieee_signaling_ge (1._large, lnan)) call abort
+ if (ieee_signaling_ge (0._large, linf)) call abort
+ if (ieee_signaling_ge (1._large, linf)) call abort
+ if (ieee_signaling_ge (linf, lnan)) call abort
+
+
+ if (ieee_signaling_lt (0., 0.)) call abort
+ if (ieee_signaling_lt (0., -0.)) call abort
+ if (ieee_signaling_lt (1., 1.)) call abort
+ if (ieee_signaling_lt (rinf, rinf)) call abort
+ if (ieee_signaling_lt (-rinf, -rinf)) call abort
+ if (ieee_signaling_lt (rnan, rnan)) call abort
+ if (.not. ieee_signaling_lt (0., 1.)) call abort
+ if (ieee_signaling_lt (0., -1.)) call abort
+ if (ieee_signaling_lt (0., rnan)) call abort
+ if (ieee_signaling_lt (1., rnan)) call abort
+ if (.not. ieee_signaling_lt (0., rinf)) call abort
+ if (.not. ieee_signaling_lt (1., rinf)) call abort
+ if (ieee_signaling_lt (rinf, rnan)) call abort
+
+ if (ieee_signaling_lt (0.d0, 0.d0)) call abort
+ if (ieee_signaling_lt (0.d0, -0.d0)) call abort
+ if (ieee_signaling_lt (1.d0, 1.d0)) call abort
+ if (ieee_signaling_lt (dinf, dinf)) call abort
+ if (ieee_signaling_lt (-dinf, -dinf)) call abort
+ if (ieee_signaling_lt (dnan, dnan)) call abort
+ if (.not. ieee_signaling_lt (0.d0, 1.d0)) call abort
+ if (ieee_signaling_lt (0.d0, -1.d0)) call abort
+ if (ieee_signaling_lt (0.d0, dnan)) call abort
+ if (ieee_signaling_lt (1.d0, dnan)) call abort
+ if (.not. ieee_signaling_lt (0.d0, dinf)) call abort
+ if (.not. ieee_signaling_lt (1.d0, dinf)) call abort
+ if (ieee_signaling_lt (dinf, dnan)) call abort
+
+ if (ieee_signaling_lt (0._large, 0._large)) call abort
+ if (ieee_signaling_lt (0._large, -0._large)) call abort
+ if (ieee_signaling_lt (1._large, 1._large)) call abort
+ if (ieee_signaling_lt (linf, linf)) call abort
+ if (ieee_signaling_lt (-linf, -linf)) call abort
+ if (ieee_signaling_lt (lnan, lnan)) call abort
+ if (.not. ieee_signaling_lt (0._large, 1._large)) call abort
+ if (ieee_signaling_lt (0._large, -1._large)) call abort
+ if (ieee_signaling_lt (0._large, lnan)) call abort
+ if (ieee_signaling_lt (1._large, lnan)) call abort
+ if (.not. ieee_signaling_lt (0._large, linf)) call abort
+ if (.not. ieee_signaling_lt (1._large, linf)) call abort
+ if (ieee_signaling_lt (linf, lnan)) call abort
+
+
+ if (ieee_signaling_gt (0., 0.)) call abort
+ if (ieee_signaling_gt (0., -0.)) call abort
+ if (ieee_signaling_gt (1., 1.)) call abort
+ if (ieee_signaling_gt (rinf, rinf)) call abort
+ if (ieee_signaling_gt (-rinf, -rinf)) call abort
+ if (ieee_signaling_gt (rnan, rnan)) call abort
+ if (ieee_signaling_gt (0., 1.)) call abort
+ if (.not. ieee_signaling_gt (0., -1.)) call abort
+ if (ieee_signaling_gt (0., rnan)) call abort
+ if (ieee_signaling_gt (1., rnan)) call abort
+ if (ieee_signaling_gt (0., rinf)) call abort
+ if (ieee_signaling_gt (1., rinf)) call abort
+ if (ieee_signaling_gt (rinf, rnan)) call abort
+
+ if (ieee_signaling_gt (0.d0, 0.d0)) call abort
+ if (ieee_signaling_gt (0.d0, -0.d0)) call abort
+ if (ieee_signaling_gt (1.d0, 1.d0)) call abort
+ if (ieee_signaling_gt (dinf, dinf)) call abort
+ if (ieee_signaling_gt (-dinf, -dinf)) call abort
+ if (ieee_signaling_gt (dnan, dnan)) call abort
+ if (ieee_signaling_gt (0.d0, 1.d0)) call abort
+ if (.not. ieee_signaling_gt (0.d0, -1.d0)) call abort
+ if (ieee_signaling_gt (0.d0, dnan)) call abort
+ if (ieee_signaling_gt (1.d0, dnan)) call abort
+ if (ieee_signaling_gt (0.d0, dinf)) call abort
+ if (ieee_signaling_gt (1.d0, dinf)) call abort
+ if (ieee_signaling_gt (dinf, dnan)) call abort
+
+ if (ieee_signaling_gt (0._large, 0._large)) call abort
+ if (ieee_signaling_gt (0._large, -0._large)) call abort
+ if (ieee_signaling_gt (1._large, 1._large)) call abort
+ if (ieee_signaling_gt (linf, linf)) call abort
+ if (ieee_signaling_gt (-linf, -linf)) call abort
+ if (ieee_signaling_gt (lnan, lnan)) call abort
+ if (ieee_signaling_gt (0._large, 1._large)) call abort
+ if (.not. ieee_signaling_gt (0._large, -1._large)) call abort
+ if (ieee_signaling_gt (0._large, lnan)) call abort
+ if (ieee_signaling_gt (1._large, lnan)) call abort
+ if (ieee_signaling_gt (0._large, linf)) call abort
+ if (ieee_signaling_gt (1._large, linf)) call abort
+ if (ieee_signaling_gt (linf, lnan)) call abort
+
+end program foo
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index c8ef3e2faeb..2304a104b92 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -343,6 +343,75 @@ UNORDERED_MACRO(4,4)
end interface
public :: IEEE_UNORDERED
+ ! IEEE_QUIET_* and IEEE_SIGNALING_* comparison functions
+
+#define COMP_MACRO(TYPE,OP,K) \
+ elemental logical function \
+ _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_/**/K (X,Y) ; \
+ real(kind = K), intent(in) :: X ; \
+ real(kind = K), intent(in) :: Y ; \
+ end function
+
+#ifdef HAVE_GFC_REAL_16
+# define EXPAND_COMP_MACRO_16(TYPE,OP) COMP_MACRO(TYPE,OP,16)
+#else
+# define EXPAND_COMP_MACRO_16(TYPE,OP)
+#endif
+
+#undef EXPAND_MACRO_10
+#ifdef HAVE_GFC_REAL_10
+# define EXPAND_COMP_MACRO_10(TYPE,OP) COMP_MACRO(TYPE,OP,10)
+#else
+# define EXPAND_COMP_MACRO_10(TYPE,OP)
+#endif
+
+#define COMP_FUNCTION(TYPE,OP) \
+ interface ; \
+ COMP_MACRO(TYPE,OP,4) ; \
+ COMP_MACRO(TYPE,OP,8) ; \
+ EXPAND_COMP_MACRO_10(TYPE,OP) ; \
+ EXPAND_COMP_MACRO_16(TYPE,OP) ; \
+ end interface
+
+#ifdef HAVE_GFC_REAL_16
+# define EXPAND_INTER_MACRO_16(TYPE,OP) _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_16
+#else
+# define EXPAND_INTER_MACRO_16(TYPE,OP)
+#endif
+
+#ifdef HAVE_GFC_REAL_10
+# define EXPAND_INTER_MACRO_10(TYPE,OP) _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_10
+#else
+# define EXPAND_INTER_MACRO_10(TYPE,OP)
+#endif
+
+#define COMP_INTERFACE(TYPE,OP) \
+ interface IEEE_/**/TYPE/**/_/**/OP ; \
+ procedure \
+ EXPAND_INTER_MACRO_16(TYPE,OP) , \
+ EXPAND_INTER_MACRO_10(TYPE,OP) , \
+ _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_8 , \
+ _gfortran_ieee_/**/TYPE/**/_/**/OP/**/_4 ; \
+ end interface ; \
+ public :: IEEE_/**/TYPE/**/_/**/OP
+
+#define IEEE_COMPARISON(TYPE,OP) \
+ COMP_FUNCTION(TYPE,OP) ; \
+ COMP_INTERFACE(TYPE,OP)
+
+ IEEE_COMPARISON(QUIET,EQ)
+ IEEE_COMPARISON(QUIET,GE)
+ IEEE_COMPARISON(QUIET,GT)
+ IEEE_COMPARISON(QUIET,LE)
+ IEEE_COMPARISON(QUIET,LT)
+ IEEE_COMPARISON(QUIET,NE)
+ IEEE_COMPARISON(SIGNALING,EQ)
+ IEEE_COMPARISON(SIGNALING,GE)
+ IEEE_COMPARISON(SIGNALING,GT)
+ IEEE_COMPARISON(SIGNALING,LE)
+ IEEE_COMPARISON(SIGNALING,LT)
+ IEEE_COMPARISON(SIGNALING,NE)
+
! IEEE_LOGB
interface
--
2.25.1
next reply other threads:[~2022-09-02 11:37 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-09-02 11:37 FX [this message]
2022-09-02 15:37 ` Bernhard Reutner-Fischer
2022-09-02 15:54 ` FX
2022-09-02 16:03 ` Bernhard Reutner-Fischer
2022-09-02 16:17 ` FX
2022-09-17 11:58 ` Mikael Morin
2023-06-06 19:29 FX Coudert
2023-06-08 12:26 ` Harald Anlauf
2023-06-10 15:21 ` FX Coudert
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=4E0DC1F3-FE18-4C6A-A767-E03A1BA6FCC6@gmail.com \
--to=fxcoudert@gmail.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).