* [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
@ 2023-06-06 19:29 FX Coudert
2023-06-08 12:26 ` Harald Anlauf
0 siblings, 1 reply; 10+ messages in thread
From: FX Coudert @ 2023-06-06 19:29 UTC (permalink / raw)
To: fortran; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 509 bytes --]
Hi,
This is a repost of the patch at https://gcc.gnu.org/pipermail/gcc-patches/2022-September/600887.html
which never really got green light, but I stopped pushing because stage 1 was closing and I was out of time.
It depends on a middle-end patch adding a type-generic __builtin_iseqsig(), which I posted for review at: https://gcc.gnu.org/pipermail/gcc-patches/2023-June/620801.html
Bootstrapped and regtested on x86_64-pc-linux-gnu, OK to commit (once the middle-end patch is accepted)?
FX
[-- Attachment #2: 0002-Fortran-add-IEEE_QUIET_-and-IEEE_SIGNALING_-comparis.patch --]
[-- Type: application/octet-stream, Size: 33950 bytes --]
From 82742a558fbb4df6be5b0275e4d0d4ce54f51390 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 2/2] 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 | 90 ++++++
.../gfortran.dg/ieee/comparisons_1.f90 | 282 ++++++++++++++++++
.../gfortran.dg/ieee/comparisons_2.f90 | 282 ++++++++++++++++++
libgfortran/ieee/ieee_arithmetic.F90 | 69 +++++
5 files changed, 725 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 9684f1d4921..56722567662 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 a0e1110c5e0..39f9deacaca 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10263,6 +10263,92 @@ conv_intrinsic_ieee_fma (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. */
@@ -10301,6 +10387,10 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
conv_intrinsic_ieee_value (se, expr);
else if (startswith (name, "_gfortran_ieee_fma"))
conv_intrinsic_ieee_fma (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..aa082e368c1
--- /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.)) stop 1
+ if (.not. ieee_quiet_eq (0., -0.)) stop 2
+ if (.not. ieee_quiet_eq (1., 1.)) stop 3
+ if (.not. ieee_quiet_eq (rinf, rinf)) stop 4
+ if (.not. ieee_quiet_eq (-rinf, -rinf)) stop 5
+ if (ieee_quiet_eq (rnan, rnan)) stop 6
+ if (ieee_quiet_eq (0., 1.)) stop 7
+ if (ieee_quiet_eq (0., -1.)) stop 8
+ if (ieee_quiet_eq (0., rnan)) stop 9
+ if (ieee_quiet_eq (1., rnan)) stop 10
+ if (ieee_quiet_eq (0., rinf)) stop 11
+ if (ieee_quiet_eq (1., rinf)) stop 12
+ if (ieee_quiet_eq (rinf, rnan)) stop 13
+
+ if (.not. ieee_quiet_eq (0.d0, 0.d0)) stop 14
+ if (.not. ieee_quiet_eq (0.d0, -0.d0)) stop 15
+ if (.not. ieee_quiet_eq (1.d0, 1.d0)) stop 16
+ if (.not. ieee_quiet_eq (dinf, dinf)) stop 17
+ if (.not. ieee_quiet_eq (-dinf, -dinf)) stop 18
+ if (ieee_quiet_eq (dnan, dnan)) stop 19
+ if (ieee_quiet_eq (0.d0, 1.d0)) stop 20
+ if (ieee_quiet_eq (0.d0, -1.d0)) stop 21
+ if (ieee_quiet_eq (0.d0, dnan)) stop 22
+ if (ieee_quiet_eq (1.d0, dnan)) stop 23
+ if (ieee_quiet_eq (0.d0, dinf)) stop 24
+ if (ieee_quiet_eq (1.d0, dinf)) stop 25
+ if (ieee_quiet_eq (dinf, dnan)) stop 26
+
+ if (.not. ieee_quiet_eq (0._large, 0._large)) stop 27
+ if (.not. ieee_quiet_eq (0._large, -0._large)) stop 28
+ if (.not. ieee_quiet_eq (1._large, 1._large)) stop 29
+ if (.not. ieee_quiet_eq (linf, linf)) stop 30
+ if (.not. ieee_quiet_eq (-linf, -linf)) stop 31
+ if (ieee_quiet_eq (lnan, lnan)) stop 32
+ if (ieee_quiet_eq (0._large, 1._large)) stop 33
+ if (ieee_quiet_eq (0._large, -1._large)) stop 34
+ if (ieee_quiet_eq (0._large, lnan)) stop 35
+ if (ieee_quiet_eq (1._large, lnan)) stop 36
+ if (ieee_quiet_eq (0._large, linf)) stop 37
+ if (ieee_quiet_eq (1._large, linf)) stop 38
+ if (ieee_quiet_eq (linf, lnan)) stop 39
+
+
+ if (ieee_quiet_ne (0., 0.)) stop 40
+ if (ieee_quiet_ne (0., -0.)) stop 41
+ if (ieee_quiet_ne (1., 1.)) stop 42
+ if (ieee_quiet_ne (rinf, rinf)) stop 43
+ if (ieee_quiet_ne (-rinf, -rinf)) stop 44
+ if (.not. ieee_quiet_ne (rnan, rnan)) stop 45
+ if (.not. ieee_quiet_ne (0., 1.)) stop 46
+ if (.not. ieee_quiet_ne (0., -1.)) stop 47
+ if (.not. ieee_quiet_ne (0., rnan)) stop 48
+ if (.not. ieee_quiet_ne (1., rnan)) stop 49
+ if (.not. ieee_quiet_ne (0., rinf)) stop 50
+ if (.not. ieee_quiet_ne (1., rinf)) stop 51
+ if (.not. ieee_quiet_ne (rinf, rnan)) stop 52
+
+ if (ieee_quiet_ne (0.d0, 0.d0)) stop 53
+ if (ieee_quiet_ne (0.d0, -0.d0)) stop 54
+ if (ieee_quiet_ne (1.d0, 1.d0)) stop 55
+ if (ieee_quiet_ne (dinf, dinf)) stop 56
+ if (ieee_quiet_ne (-dinf, -dinf)) stop 57
+ if (.not. ieee_quiet_ne (dnan, dnan)) stop 58
+ if (.not. ieee_quiet_ne (0.d0, 1.d0)) stop 59
+ if (.not. ieee_quiet_ne (0.d0, -1.d0)) stop 60
+ if (.not. ieee_quiet_ne (0.d0, dnan)) stop 61
+ if (.not. ieee_quiet_ne (1.d0, dnan)) stop 62
+ if (.not. ieee_quiet_ne (0.d0, dinf)) stop 63
+ if (.not. ieee_quiet_ne (1.d0, dinf)) stop 64
+ if (.not. ieee_quiet_ne (dinf, dnan)) stop 65
+
+ if (ieee_quiet_ne (0._large, 0._large)) stop 66
+ if (ieee_quiet_ne (0._large, -0._large)) stop 67
+ if (ieee_quiet_ne (1._large, 1._large)) stop 68
+ if (ieee_quiet_ne (linf, linf)) stop 69
+ if (ieee_quiet_ne (-linf, -linf)) stop 70
+ if (.not. ieee_quiet_ne (lnan, lnan)) stop 71
+ if (.not. ieee_quiet_ne (0._large, 1._large)) stop 72
+ if (.not. ieee_quiet_ne (0._large, -1._large)) stop 73
+ if (.not. ieee_quiet_ne (0._large, lnan)) stop 74
+ if (.not. ieee_quiet_ne (1._large, lnan)) stop 75
+ if (.not. ieee_quiet_ne (0._large, linf)) stop 76
+ if (.not. ieee_quiet_ne (1._large, linf)) stop 77
+ if (.not. ieee_quiet_ne (linf, lnan)) stop 78
+
+
+ if (.not. ieee_quiet_le (0., 0.)) stop 79
+ if (.not. ieee_quiet_le (0., -0.)) stop 80
+ if (.not. ieee_quiet_le (1., 1.)) stop 81
+ if (.not. ieee_quiet_le (rinf, rinf)) stop 82
+ if (.not. ieee_quiet_le (-rinf, -rinf)) stop 83
+ if (ieee_quiet_le (rnan, rnan)) stop 84
+ if (.not. ieee_quiet_le (0., 1.)) stop 85
+ if (ieee_quiet_le (0., -1.)) stop 86
+ if (ieee_quiet_le (0., rnan)) stop 87
+ if (ieee_quiet_le (1., rnan)) stop 88
+ if (.not. ieee_quiet_le (0., rinf)) stop 89
+ if (.not. ieee_quiet_le (1., rinf)) stop 90
+ if (ieee_quiet_le (rinf, rnan)) stop 91
+
+ if (.not. ieee_quiet_le (0.d0, 0.d0)) stop 92
+ if (.not. ieee_quiet_le (0.d0, -0.d0)) stop 93
+ if (.not. ieee_quiet_le (1.d0, 1.d0)) stop 94
+ if (.not. ieee_quiet_le (dinf, dinf)) stop 95
+ if (.not. ieee_quiet_le (-dinf, -dinf)) stop 96
+ if (ieee_quiet_le (dnan, dnan)) stop 97
+ if (.not. ieee_quiet_le (0.d0, 1.d0)) stop 98
+ if (ieee_quiet_le (0.d0, -1.d0)) stop 99
+ if (ieee_quiet_le (0.d0, dnan)) stop 100
+ if (ieee_quiet_le (1.d0, dnan)) stop 101
+ if (.not. ieee_quiet_le (0.d0, dinf)) stop 102
+ if (.not. ieee_quiet_le (1.d0, dinf)) stop 103
+ if (ieee_quiet_le (dinf, dnan)) stop 104
+
+ if (.not. ieee_quiet_le (0._large, 0._large)) stop 105
+ if (.not. ieee_quiet_le (0._large, -0._large)) stop 106
+ if (.not. ieee_quiet_le (1._large, 1._large)) stop 107
+ if (.not. ieee_quiet_le (linf, linf)) stop 108
+ if (.not. ieee_quiet_le (-linf, -linf)) stop 109
+ if (ieee_quiet_le (lnan, lnan)) stop 110
+ if (.not. ieee_quiet_le (0._large, 1._large)) stop 111
+ if (ieee_quiet_le (0._large, -1._large)) stop 112
+ if (ieee_quiet_le (0._large, lnan)) stop 113
+ if (ieee_quiet_le (1._large, lnan)) stop 114
+ if (.not. ieee_quiet_le (0._large, linf)) stop 115
+ if (.not. ieee_quiet_le (1._large, linf)) stop 116
+ if (ieee_quiet_le (linf, lnan)) stop 117
+
+
+ if (.not. ieee_quiet_ge (0., 0.)) stop 118
+ if (.not. ieee_quiet_ge (0., -0.)) stop 119
+ if (.not. ieee_quiet_ge (1., 1.)) stop 120
+ if (.not. ieee_quiet_ge (rinf, rinf)) stop 121
+ if (.not. ieee_quiet_ge (-rinf, -rinf)) stop 122
+ if (ieee_quiet_ge (rnan, rnan)) stop 123
+ if (ieee_quiet_ge (0., 1.)) stop 124
+ if (.not. ieee_quiet_ge (0., -1.)) stop 125
+ if (ieee_quiet_ge (0., rnan)) stop 126
+ if (ieee_quiet_ge (1., rnan)) stop 127
+ if (ieee_quiet_ge (0., rinf)) stop 128
+ if (ieee_quiet_ge (1., rinf)) stop 129
+ if (ieee_quiet_ge (rinf, rnan)) stop 130
+
+ if (.not. ieee_quiet_ge (0.d0, 0.d0)) stop 131
+ if (.not. ieee_quiet_ge (0.d0, -0.d0)) stop 132
+ if (.not. ieee_quiet_ge (1.d0, 1.d0)) stop 133
+ if (.not. ieee_quiet_ge (dinf, dinf)) stop 134
+ if (.not. ieee_quiet_ge (-dinf, -dinf)) stop 135
+ if (ieee_quiet_ge (dnan, dnan)) stop 136
+ if (ieee_quiet_ge (0.d0, 1.d0)) stop 137
+ if (.not. ieee_quiet_ge (0.d0, -1.d0)) stop 138
+ if (ieee_quiet_ge (0.d0, dnan)) stop 139
+ if (ieee_quiet_ge (1.d0, dnan)) stop 140
+ if (ieee_quiet_ge (0.d0, dinf)) stop 141
+ if (ieee_quiet_ge (1.d0, dinf)) stop 142
+ if (ieee_quiet_ge (dinf, dnan)) stop 143
+
+ if (.not. ieee_quiet_ge (0._large, 0._large)) stop 144
+ if (.not. ieee_quiet_ge (0._large, -0._large)) stop 145
+ if (.not. ieee_quiet_ge (1._large, 1._large)) stop 146
+ if (.not. ieee_quiet_ge (linf, linf)) stop 147
+ if (.not. ieee_quiet_ge (-linf, -linf)) stop 148
+ if (ieee_quiet_ge (lnan, lnan)) stop 149
+ if (ieee_quiet_ge (0._large, 1._large)) stop 150
+ if (.not. ieee_quiet_ge (0._large, -1._large)) stop 151
+ if (ieee_quiet_ge (0._large, lnan)) stop 152
+ if (ieee_quiet_ge (1._large, lnan)) stop 153
+ if (ieee_quiet_ge (0._large, linf)) stop 154
+ if (ieee_quiet_ge (1._large, linf)) stop 155
+ if (ieee_quiet_ge (linf, lnan)) stop 156
+
+
+ if (ieee_quiet_lt (0., 0.)) stop 157
+ if (ieee_quiet_lt (0., -0.)) stop 158
+ if (ieee_quiet_lt (1., 1.)) stop 159
+ if (ieee_quiet_lt (rinf, rinf)) stop 160
+ if (ieee_quiet_lt (-rinf, -rinf)) stop 161
+ if (ieee_quiet_lt (rnan, rnan)) stop 162
+ if (.not. ieee_quiet_lt (0., 1.)) stop 163
+ if (ieee_quiet_lt (0., -1.)) stop 164
+ if (ieee_quiet_lt (0., rnan)) stop 165
+ if (ieee_quiet_lt (1., rnan)) stop 166
+ if (.not. ieee_quiet_lt (0., rinf)) stop 167
+ if (.not. ieee_quiet_lt (1., rinf)) stop 168
+ if (ieee_quiet_lt (rinf, rnan)) stop 169
+
+ if (ieee_quiet_lt (0.d0, 0.d0)) stop 170
+ if (ieee_quiet_lt (0.d0, -0.d0)) stop 171
+ if (ieee_quiet_lt (1.d0, 1.d0)) stop 172
+ if (ieee_quiet_lt (dinf, dinf)) stop 173
+ if (ieee_quiet_lt (-dinf, -dinf)) stop 174
+ if (ieee_quiet_lt (dnan, dnan)) stop 175
+ if (.not. ieee_quiet_lt (0.d0, 1.d0)) stop 176
+ if (ieee_quiet_lt (0.d0, -1.d0)) stop 177
+ if (ieee_quiet_lt (0.d0, dnan)) stop 178
+ if (ieee_quiet_lt (1.d0, dnan)) stop 179
+ if (.not. ieee_quiet_lt (0.d0, dinf)) stop 180
+ if (.not. ieee_quiet_lt (1.d0, dinf)) stop 181
+ if (ieee_quiet_lt (dinf, dnan)) stop 182
+
+ if (ieee_quiet_lt (0._large, 0._large)) stop 183
+ if (ieee_quiet_lt (0._large, -0._large)) stop 184
+ if (ieee_quiet_lt (1._large, 1._large)) stop 185
+ if (ieee_quiet_lt (linf, linf)) stop 186
+ if (ieee_quiet_lt (-linf, -linf)) stop 187
+ if (ieee_quiet_lt (lnan, lnan)) stop 188
+ if (.not. ieee_quiet_lt (0._large, 1._large)) stop 189
+ if (ieee_quiet_lt (0._large, -1._large)) stop 190
+ if (ieee_quiet_lt (0._large, lnan)) stop 191
+ if (ieee_quiet_lt (1._large, lnan)) stop 192
+ if (.not. ieee_quiet_lt (0._large, linf)) stop 193
+ if (.not. ieee_quiet_lt (1._large, linf)) stop 194
+ if (ieee_quiet_lt (linf, lnan)) stop 195
+
+
+ if (ieee_quiet_gt (0., 0.)) stop 196
+ if (ieee_quiet_gt (0., -0.)) stop 197
+ if (ieee_quiet_gt (1., 1.)) stop 198
+ if (ieee_quiet_gt (rinf, rinf)) stop 199
+ if (ieee_quiet_gt (-rinf, -rinf)) stop 200
+ if (ieee_quiet_gt (rnan, rnan)) stop 201
+ if (ieee_quiet_gt (0., 1.)) stop 202
+ if (.not. ieee_quiet_gt (0., -1.)) stop 203
+ if (ieee_quiet_gt (0., rnan)) stop 204
+ if (ieee_quiet_gt (1., rnan)) stop 205
+ if (ieee_quiet_gt (0., rinf)) stop 206
+ if (ieee_quiet_gt (1., rinf)) stop 207
+ if (ieee_quiet_gt (rinf, rnan)) stop 208
+
+ if (ieee_quiet_gt (0.d0, 0.d0)) stop 209
+ if (ieee_quiet_gt (0.d0, -0.d0)) stop 210
+ if (ieee_quiet_gt (1.d0, 1.d0)) stop 211
+ if (ieee_quiet_gt (dinf, dinf)) stop 212
+ if (ieee_quiet_gt (-dinf, -dinf)) stop 213
+ if (ieee_quiet_gt (dnan, dnan)) stop 214
+ if (ieee_quiet_gt (0.d0, 1.d0)) stop 215
+ if (.not. ieee_quiet_gt (0.d0, -1.d0)) stop 216
+ if (ieee_quiet_gt (0.d0, dnan)) stop 217
+ if (ieee_quiet_gt (1.d0, dnan)) stop 218
+ if (ieee_quiet_gt (0.d0, dinf)) stop 219
+ if (ieee_quiet_gt (1.d0, dinf)) stop 220
+ if (ieee_quiet_gt (dinf, dnan)) stop 221
+
+ if (ieee_quiet_gt (0._large, 0._large)) stop 222
+ if (ieee_quiet_gt (0._large, -0._large)) stop 223
+ if (ieee_quiet_gt (1._large, 1._large)) stop 224
+ if (ieee_quiet_gt (linf, linf)) stop 225
+ if (ieee_quiet_gt (-linf, -linf)) stop 226
+ if (ieee_quiet_gt (lnan, lnan)) stop 227
+ if (ieee_quiet_gt (0._large, 1._large)) stop 228
+ if (.not. ieee_quiet_gt (0._large, -1._large)) stop 229
+ if (ieee_quiet_gt (0._large, lnan)) stop 230
+ if (ieee_quiet_gt (1._large, lnan)) stop 231
+ if (ieee_quiet_gt (0._large, linf)) stop 232
+ if (ieee_quiet_gt (1._large, linf)) stop 233
+ if (ieee_quiet_gt (linf, lnan)) stop 234
+
+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..131b334f605
--- /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.)) stop 1
+ if (.not. ieee_signaling_eq (0., -0.)) stop 2
+ if (.not. ieee_signaling_eq (1., 1.)) stop 3
+ if (.not. ieee_signaling_eq (rinf, rinf)) stop 4
+ if (.not. ieee_signaling_eq (-rinf, -rinf)) stop 5
+ if (ieee_signaling_eq (rnan, rnan)) stop 6
+ if (ieee_signaling_eq (0., 1.)) stop 7
+ if (ieee_signaling_eq (0., -1.)) stop 8
+ if (ieee_signaling_eq (0., rnan)) stop 9
+ if (ieee_signaling_eq (1., rnan)) stop 10
+ if (ieee_signaling_eq (0., rinf)) stop 11
+ if (ieee_signaling_eq (1., rinf)) stop 12
+ if (ieee_signaling_eq (rinf, rnan)) stop 13
+
+ if (.not. ieee_signaling_eq (0.d0, 0.d0)) stop 14
+ if (.not. ieee_signaling_eq (0.d0, -0.d0)) stop 15
+ if (.not. ieee_signaling_eq (1.d0, 1.d0)) stop 16
+ if (.not. ieee_signaling_eq (dinf, dinf)) stop 17
+ if (.not. ieee_signaling_eq (-dinf, -dinf)) stop 18
+ if (ieee_signaling_eq (dnan, dnan)) stop 19
+ if (ieee_signaling_eq (0.d0, 1.d0)) stop 20
+ if (ieee_signaling_eq (0.d0, -1.d0)) stop 21
+ if (ieee_signaling_eq (0.d0, dnan)) stop 22
+ if (ieee_signaling_eq (1.d0, dnan)) stop 23
+ if (ieee_signaling_eq (0.d0, dinf)) stop 24
+ if (ieee_signaling_eq (1.d0, dinf)) stop 25
+ if (ieee_signaling_eq (dinf, dnan)) stop 26
+
+ if (.not. ieee_signaling_eq (0._large, 0._large)) stop 27
+ if (.not. ieee_signaling_eq (0._large, -0._large)) stop 28
+ if (.not. ieee_signaling_eq (1._large, 1._large)) stop 29
+ if (.not. ieee_signaling_eq (linf, linf)) stop 30
+ if (.not. ieee_signaling_eq (-linf, -linf)) stop 31
+ if (ieee_signaling_eq (lnan, lnan)) stop 32
+ if (ieee_signaling_eq (0._large, 1._large)) stop 33
+ if (ieee_signaling_eq (0._large, -1._large)) stop 34
+ if (ieee_signaling_eq (0._large, lnan)) stop 35
+ if (ieee_signaling_eq (1._large, lnan)) stop 36
+ if (ieee_signaling_eq (0._large, linf)) stop 37
+ if (ieee_signaling_eq (1._large, linf)) stop 38
+ if (ieee_signaling_eq (linf, lnan)) stop 39
+
+
+ if (ieee_signaling_ne (0., 0.)) stop 40
+ if (ieee_signaling_ne (0., -0.)) stop 41
+ if (ieee_signaling_ne (1., 1.)) stop 42
+ if (ieee_signaling_ne (rinf, rinf)) stop 43
+ if (ieee_signaling_ne (-rinf, -rinf)) stop 44
+ if (.not. ieee_signaling_ne (rnan, rnan)) stop 45
+ if (.not. ieee_signaling_ne (0., 1.)) stop 46
+ if (.not. ieee_signaling_ne (0., -1.)) stop 47
+ if (.not. ieee_signaling_ne (0., rnan)) stop 48
+ if (.not. ieee_signaling_ne (1., rnan)) stop 49
+ if (.not. ieee_signaling_ne (0., rinf)) stop 50
+ if (.not. ieee_signaling_ne (1., rinf)) stop 51
+ if (.not. ieee_signaling_ne (rinf, rnan)) stop 52
+
+ if (ieee_signaling_ne (0.d0, 0.d0)) stop 53
+ if (ieee_signaling_ne (0.d0, -0.d0)) stop 54
+ if (ieee_signaling_ne (1.d0, 1.d0)) stop 55
+ if (ieee_signaling_ne (dinf, dinf)) stop 56
+ if (ieee_signaling_ne (-dinf, -dinf)) stop 57
+ if (.not. ieee_signaling_ne (dnan, dnan)) stop 58
+ if (.not. ieee_signaling_ne (0.d0, 1.d0)) stop 59
+ if (.not. ieee_signaling_ne (0.d0, -1.d0)) stop 60
+ if (.not. ieee_signaling_ne (0.d0, dnan)) stop 61
+ if (.not. ieee_signaling_ne (1.d0, dnan)) stop 62
+ if (.not. ieee_signaling_ne (0.d0, dinf)) stop 63
+ if (.not. ieee_signaling_ne (1.d0, dinf)) stop 64
+ if (.not. ieee_signaling_ne (dinf, dnan)) stop 65
+
+ if (ieee_signaling_ne (0._large, 0._large)) stop 66
+ if (ieee_signaling_ne (0._large, -0._large)) stop 67
+ if (ieee_signaling_ne (1._large, 1._large)) stop 68
+ if (ieee_signaling_ne (linf, linf)) stop 69
+ if (ieee_signaling_ne (-linf, -linf)) stop 70
+ if (.not. ieee_signaling_ne (lnan, lnan)) stop 71
+ if (.not. ieee_signaling_ne (0._large, 1._large)) stop 72
+ if (.not. ieee_signaling_ne (0._large, -1._large)) stop 73
+ if (.not. ieee_signaling_ne (0._large, lnan)) stop 74
+ if (.not. ieee_signaling_ne (1._large, lnan)) stop 75
+ if (.not. ieee_signaling_ne (0._large, linf)) stop 76
+ if (.not. ieee_signaling_ne (1._large, linf)) stop 77
+ if (.not. ieee_signaling_ne (linf, lnan)) stop 78
+
+
+ if (.not. ieee_signaling_le (0., 0.)) stop 79
+ if (.not. ieee_signaling_le (0., -0.)) stop 80
+ if (.not. ieee_signaling_le (1., 1.)) stop 81
+ if (.not. ieee_signaling_le (rinf, rinf)) stop 82
+ if (.not. ieee_signaling_le (-rinf, -rinf)) stop 83
+ if (ieee_signaling_le (rnan, rnan)) stop 84
+ if (.not. ieee_signaling_le (0., 1.)) stop 85
+ if (ieee_signaling_le (0., -1.)) stop 86
+ if (ieee_signaling_le (0., rnan)) stop 87
+ if (ieee_signaling_le (1., rnan)) stop 88
+ if (.not. ieee_signaling_le (0., rinf)) stop 89
+ if (.not. ieee_signaling_le (1., rinf)) stop 90
+ if (ieee_signaling_le (rinf, rnan)) stop 91
+
+ if (.not. ieee_signaling_le (0.d0, 0.d0)) stop 92
+ if (.not. ieee_signaling_le (0.d0, -0.d0)) stop 93
+ if (.not. ieee_signaling_le (1.d0, 1.d0)) stop 94
+ if (.not. ieee_signaling_le (dinf, dinf)) stop 95
+ if (.not. ieee_signaling_le (-dinf, -dinf)) stop 96
+ if (ieee_signaling_le (dnan, dnan)) stop 97
+ if (.not. ieee_signaling_le (0.d0, 1.d0)) stop 98
+ if (ieee_signaling_le (0.d0, -1.d0)) stop 99
+ if (ieee_signaling_le (0.d0, dnan)) stop 100
+ if (ieee_signaling_le (1.d0, dnan)) stop 101
+ if (.not. ieee_signaling_le (0.d0, dinf)) stop 102
+ if (.not. ieee_signaling_le (1.d0, dinf)) stop 103
+ if (ieee_signaling_le (dinf, dnan)) stop 104
+
+ if (.not. ieee_signaling_le (0._large, 0._large)) stop 105
+ if (.not. ieee_signaling_le (0._large, -0._large)) stop 106
+ if (.not. ieee_signaling_le (1._large, 1._large)) stop 107
+ if (.not. ieee_signaling_le (linf, linf)) stop 108
+ if (.not. ieee_signaling_le (-linf, -linf)) stop 109
+ if (ieee_signaling_le (lnan, lnan)) stop 110
+ if (.not. ieee_signaling_le (0._large, 1._large)) stop 111
+ if (ieee_signaling_le (0._large, -1._large)) stop 112
+ if (ieee_signaling_le (0._large, lnan)) stop 113
+ if (ieee_signaling_le (1._large, lnan)) stop 114
+ if (.not. ieee_signaling_le (0._large, linf)) stop 115
+ if (.not. ieee_signaling_le (1._large, linf)) stop 116
+ if (ieee_signaling_le (linf, lnan)) stop 117
+
+
+ if (.not. ieee_signaling_ge (0., 0.)) stop 118
+ if (.not. ieee_signaling_ge (0., -0.)) stop 119
+ if (.not. ieee_signaling_ge (1., 1.)) stop 120
+ if (.not. ieee_signaling_ge (rinf, rinf)) stop 121
+ if (.not. ieee_signaling_ge (-rinf, -rinf)) stop 122
+ if (ieee_signaling_ge (rnan, rnan)) stop 123
+ if (ieee_signaling_ge (0., 1.)) stop 124
+ if (.not. ieee_signaling_ge (0., -1.)) stop 125
+ if (ieee_signaling_ge (0., rnan)) stop 126
+ if (ieee_signaling_ge (1., rnan)) stop 127
+ if (ieee_signaling_ge (0., rinf)) stop 128
+ if (ieee_signaling_ge (1., rinf)) stop 129
+ if (ieee_signaling_ge (rinf, rnan)) stop 130
+
+ if (.not. ieee_signaling_ge (0.d0, 0.d0)) stop 131
+ if (.not. ieee_signaling_ge (0.d0, -0.d0)) stop 132
+ if (.not. ieee_signaling_ge (1.d0, 1.d0)) stop 133
+ if (.not. ieee_signaling_ge (dinf, dinf)) stop 134
+ if (.not. ieee_signaling_ge (-dinf, -dinf)) stop 135
+ if (ieee_signaling_ge (dnan, dnan)) stop 136
+ if (ieee_signaling_ge (0.d0, 1.d0)) stop 137
+ if (.not. ieee_signaling_ge (0.d0, -1.d0)) stop 138
+ if (ieee_signaling_ge (0.d0, dnan)) stop 139
+ if (ieee_signaling_ge (1.d0, dnan)) stop 140
+ if (ieee_signaling_ge (0.d0, dinf)) stop 141
+ if (ieee_signaling_ge (1.d0, dinf)) stop 142
+ if (ieee_signaling_ge (dinf, dnan)) stop 143
+
+ if (.not. ieee_signaling_ge (0._large, 0._large)) stop 144
+ if (.not. ieee_signaling_ge (0._large, -0._large)) stop 145
+ if (.not. ieee_signaling_ge (1._large, 1._large)) stop 146
+ if (.not. ieee_signaling_ge (linf, linf)) stop 147
+ if (.not. ieee_signaling_ge (-linf, -linf)) stop 148
+ if (ieee_signaling_ge (lnan, lnan)) stop 149
+ if (ieee_signaling_ge (0._large, 1._large)) stop 150
+ if (.not. ieee_signaling_ge (0._large, -1._large)) stop 151
+ if (ieee_signaling_ge (0._large, lnan)) stop 152
+ if (ieee_signaling_ge (1._large, lnan)) stop 153
+ if (ieee_signaling_ge (0._large, linf)) stop 154
+ if (ieee_signaling_ge (1._large, linf)) stop 155
+ if (ieee_signaling_ge (linf, lnan)) stop 156
+
+
+ if (ieee_signaling_lt (0., 0.)) stop 157
+ if (ieee_signaling_lt (0., -0.)) stop 158
+ if (ieee_signaling_lt (1., 1.)) stop 159
+ if (ieee_signaling_lt (rinf, rinf)) stop 160
+ if (ieee_signaling_lt (-rinf, -rinf)) stop 161
+ if (ieee_signaling_lt (rnan, rnan)) stop 162
+ if (.not. ieee_signaling_lt (0., 1.)) stop 163
+ if (ieee_signaling_lt (0., -1.)) stop 164
+ if (ieee_signaling_lt (0., rnan)) stop 165
+ if (ieee_signaling_lt (1., rnan)) stop 166
+ if (.not. ieee_signaling_lt (0., rinf)) stop 167
+ if (.not. ieee_signaling_lt (1., rinf)) stop 168
+ if (ieee_signaling_lt (rinf, rnan)) stop 169
+
+ if (ieee_signaling_lt (0.d0, 0.d0)) stop 170
+ if (ieee_signaling_lt (0.d0, -0.d0)) stop 171
+ if (ieee_signaling_lt (1.d0, 1.d0)) stop 172
+ if (ieee_signaling_lt (dinf, dinf)) stop 173
+ if (ieee_signaling_lt (-dinf, -dinf)) stop 174
+ if (ieee_signaling_lt (dnan, dnan)) stop 175
+ if (.not. ieee_signaling_lt (0.d0, 1.d0)) stop 176
+ if (ieee_signaling_lt (0.d0, -1.d0)) stop 177
+ if (ieee_signaling_lt (0.d0, dnan)) stop 178
+ if (ieee_signaling_lt (1.d0, dnan)) stop 179
+ if (.not. ieee_signaling_lt (0.d0, dinf)) stop 180
+ if (.not. ieee_signaling_lt (1.d0, dinf)) stop 181
+ if (ieee_signaling_lt (dinf, dnan)) stop 182
+
+ if (ieee_signaling_lt (0._large, 0._large)) stop 183
+ if (ieee_signaling_lt (0._large, -0._large)) stop 184
+ if (ieee_signaling_lt (1._large, 1._large)) stop 185
+ if (ieee_signaling_lt (linf, linf)) stop 186
+ if (ieee_signaling_lt (-linf, -linf)) stop 187
+ if (ieee_signaling_lt (lnan, lnan)) stop 188
+ if (.not. ieee_signaling_lt (0._large, 1._large)) stop 189
+ if (ieee_signaling_lt (0._large, -1._large)) stop 190
+ if (ieee_signaling_lt (0._large, lnan)) stop 191
+ if (ieee_signaling_lt (1._large, lnan)) stop 192
+ if (.not. ieee_signaling_lt (0._large, linf)) stop 193
+ if (.not. ieee_signaling_lt (1._large, linf)) stop 194
+ if (ieee_signaling_lt (linf, lnan)) stop 195
+
+
+ if (ieee_signaling_gt (0., 0.)) stop 196
+ if (ieee_signaling_gt (0., -0.)) stop 197
+ if (ieee_signaling_gt (1., 1.)) stop 198
+ if (ieee_signaling_gt (rinf, rinf)) stop 199
+ if (ieee_signaling_gt (-rinf, -rinf)) stop 200
+ if (ieee_signaling_gt (rnan, rnan)) stop 201
+ if (ieee_signaling_gt (0., 1.)) stop 202
+ if (.not. ieee_signaling_gt (0., -1.)) stop 203
+ if (ieee_signaling_gt (0., rnan)) stop 204
+ if (ieee_signaling_gt (1., rnan)) stop 205
+ if (ieee_signaling_gt (0., rinf)) stop 206
+ if (ieee_signaling_gt (1., rinf)) stop 207
+ if (ieee_signaling_gt (rinf, rnan)) stop 208
+
+ if (ieee_signaling_gt (0.d0, 0.d0)) stop 209
+ if (ieee_signaling_gt (0.d0, -0.d0)) stop 210
+ if (ieee_signaling_gt (1.d0, 1.d0)) stop 211
+ if (ieee_signaling_gt (dinf, dinf)) stop 212
+ if (ieee_signaling_gt (-dinf, -dinf)) stop 213
+ if (ieee_signaling_gt (dnan, dnan)) stop 214
+ if (ieee_signaling_gt (0.d0, 1.d0)) stop 215
+ if (.not. ieee_signaling_gt (0.d0, -1.d0)) stop 216
+ if (ieee_signaling_gt (0.d0, dnan)) stop 217
+ if (ieee_signaling_gt (1.d0, dnan)) stop 218
+ if (ieee_signaling_gt (0.d0, dinf)) stop 219
+ if (ieee_signaling_gt (1.d0, dinf)) stop 220
+ if (ieee_signaling_gt (dinf, dnan)) stop 221
+
+ if (ieee_signaling_gt (0._large, 0._large)) stop 222
+ if (ieee_signaling_gt (0._large, -0._large)) stop 223
+ if (ieee_signaling_gt (1._large, 1._large)) stop 224
+ if (ieee_signaling_gt (linf, linf)) stop 225
+ if (ieee_signaling_gt (-linf, -linf)) stop 226
+ if (ieee_signaling_gt (lnan, lnan)) stop 227
+ if (ieee_signaling_gt (0._large, 1._large)) stop 228
+ if (.not. ieee_signaling_gt (0._large, -1._large)) stop 229
+ if (ieee_signaling_gt (0._large, lnan)) stop 230
+ if (ieee_signaling_gt (1._large, lnan)) stop 231
+ if (ieee_signaling_gt (0._large, linf)) stop 232
+ if (ieee_signaling_gt (1._large, linf)) stop 233
+ if (ieee_signaling_gt (linf, lnan)) stop 234
+
+end program foo
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index 9c0b9f31730..0f6d17cb243 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -378,6 +378,75 @@ UNORDERED_MACRO(4,4)
end interface
public :: IEEE_FMA
+ ! 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.34.1
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2023-06-06 19:29 [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons FX Coudert
@ 2023-06-08 12:26 ` Harald Anlauf
2023-06-08 12:26 ` Harald Anlauf
2023-06-10 15:21 ` FX Coudert
0 siblings, 2 replies; 10+ messages in thread
From: Harald Anlauf @ 2023-06-08 12:26 UTC (permalink / raw)
To: FX Coudert, fortran; +Cc: gcc-patches
Hi FX,
Am 06.06.23 um 21:29 schrieb FX Coudert via Gcc-patches:
> Hi,
>
> This is a repost of the patch at https://gcc.gnu.org/pipermail/gcc-patches/2022-September/600887.html
> which never really got green light, but I stopped pushing because stage 1 was closing and I was out of time.
I just looked at that thread. I guess if you answer Mikael's
questions at
https://gcc.gnu.org/pipermail/gcc-patches/2022-September/601744.html
the patch will be fine.
> It depends on a middle-end patch adding a type-generic __builtin_iseqsig(), which I posted for review at: https://gcc.gnu.org/pipermail/gcc-patches/2023-June/620801.html
>
> Bootstrapped and regtested on x86_64-pc-linux-gnu, OK to commit (once the middle-end patch is accepted)?
>
> FX
>
Thanks,
Harald
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2023-06-08 12:26 ` Harald Anlauf
@ 2023-06-08 12:26 ` Harald Anlauf
2023-06-10 15:21 ` FX Coudert
1 sibling, 0 replies; 10+ messages in thread
From: Harald Anlauf @ 2023-06-08 12:26 UTC (permalink / raw)
To: gcc-patches; +Cc: fortran
Hi FX,
Am 06.06.23 um 21:29 schrieb FX Coudert via Gcc-patches:
> Hi,
>
> This is a repost of the patch at https://gcc.gnu.org/pipermail/gcc-patches/2022-September/600887.html
> which never really got green light, but I stopped pushing because stage 1 was closing and I was out of time.
I just looked at that thread. I guess if you answer Mikael's
questions at
https://gcc.gnu.org/pipermail/gcc-patches/2022-September/601744.html
the patch will be fine.
> It depends on a middle-end patch adding a type-generic __builtin_iseqsig(), which I posted for review at: https://gcc.gnu.org/pipermail/gcc-patches/2023-June/620801.html
>
> Bootstrapped and regtested on x86_64-pc-linux-gnu, OK to commit (once the middle-end patch is accepted)?
>
> FX
>
Thanks,
Harald
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2023-06-08 12:26 ` Harald Anlauf
2023-06-08 12:26 ` Harald Anlauf
@ 2023-06-10 15:21 ` FX Coudert
1 sibling, 0 replies; 10+ messages in thread
From: FX Coudert @ 2023-06-10 15:21 UTC (permalink / raw)
To: Harald Anlauf; +Cc: Harald Anlauf via Fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 392 bytes --]
Hi Harald,
> I just looked at that thread. I guess if you answer Mikael's
> questions at
> https://gcc.gnu.org/pipermail/gcc-patches/2022-September/601744.html
> the patch will be fine.
Amended patch, adding the required testing of signalling vs. quiet behaviour.
I still need to get an OK on the middle-end part first, but I consider the Fortran part approved.
Thanks,
FX
[-- Attachment #2: 0001-Add-__builtin_iseqsig.patch --]
[-- Type: application/octet-stream, Size: 17359 bytes --]
From 46833574721f363cbbde032dcf8205340eeae468 Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Thu, 1 Sep 2022 22:49:49 +0200
Subject: [PATCH 1/2] Add __builtin_iseqsig()
iseqsig() is a C2x library function, for signaling floating-point
equality checks. Provide a GCC-builtin for it, which is folded to
a series of comparisons.
2022-09-01 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR middle-end/77928
gcc/
* doc/extend.texi: Document iseqsig builtin.
* builtins.cc (fold_builtin_iseqsig): New function.
(fold_builtin_2): Handle BUILT_IN_ISEQSIG.
(is_inexpensive_builtin): Handle BUILT_IN_ISEQSIG.
* builtins.def (BUILT_IN_ISEQSIG): New built-in.
gcc/c-family/
* c-common.cc (check_builtin_function_arguments):
Handle BUILT_IN_ISEQSIG.
gcc/testsuite/
* gcc.dg/torture/builtin-iseqsig-1.c: New test.
* gcc.dg/torture/builtin-iseqsig-2.c: New test.
* gcc.dg/torture/builtin-iseqsig-3.c: New test.
---
gcc/builtins.cc | 41 +++++++
gcc/builtins.def | 1 +
gcc/c-family/c-common.cc | 1 +
gcc/doc/extend.texi | 7 +-
.../gcc.dg/torture/builtin-iseqsig-1.c | 113 ++++++++++++++++++
.../gcc.dg/torture/builtin-iseqsig-2.c | 113 ++++++++++++++++++
.../gcc.dg/torture/builtin-iseqsig-3.c | 113 ++++++++++++++++++
7 files changed, 386 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gcc.dg/torture/builtin-iseqsig-1.c
create mode 100644 gcc/testsuite/gcc.dg/torture/builtin-iseqsig-2.c
create mode 100644 gcc/testsuite/gcc.dg/torture/builtin-iseqsig-3.c
diff --git a/gcc/builtins.cc b/gcc/builtins.cc
index 8400adaf5b4..9fd44cf7fcd 100644
--- a/gcc/builtins.cc
+++ b/gcc/builtins.cc
@@ -171,6 +171,7 @@ static tree fold_builtin_fabs (location_t, tree, tree);
static tree fold_builtin_abs (location_t, tree, tree);
static tree fold_builtin_unordered_cmp (location_t, tree, tree, tree, enum tree_code,
enum tree_code);
+static tree fold_builtin_iseqsig (location_t, tree, tree);
static tree fold_builtin_varargs (location_t, tree, tree*, int);
static tree fold_builtin_strpbrk (location_t, tree, tree, tree, tree);
@@ -9445,6 +9446,42 @@ fold_builtin_unordered_cmp (location_t loc, tree fndecl, tree arg0, tree arg1,
fold_build2_loc (loc, code, type, arg0, arg1));
}
+/* Fold a call to __builtin_iseqsig(). ARG0 and ARG1 are the arguments.
+ After choosing the wider floating-point type for the comparison,
+ the code is folded to:
+ SAVE_EXPR<ARG0> >= SAVE_EXPR<ARG1> && SAVE_EXPR<ARG0> <= SAVE_EXPR<ARG1> */
+
+static tree
+fold_builtin_iseqsig (location_t loc, tree arg0, tree arg1)
+{
+ tree type0, type1;
+ enum tree_code code0, code1;
+ tree cmp1, cmp2, cmp_type = NULL_TREE;
+
+ type0 = TREE_TYPE (arg0);
+ type1 = TREE_TYPE (arg1);
+
+ code0 = TREE_CODE (type0);
+ code1 = TREE_CODE (type1);
+
+ if (code0 == REAL_TYPE && code1 == REAL_TYPE)
+ /* Choose the wider of two real types. */
+ cmp_type = TYPE_PRECISION (type0) >= TYPE_PRECISION (type1)
+ ? type0 : type1;
+ else if (code0 == REAL_TYPE && code1 == INTEGER_TYPE)
+ cmp_type = type0;
+ else if (code0 == INTEGER_TYPE && code1 == REAL_TYPE)
+ cmp_type = type1;
+
+ arg0 = builtin_save_expr (fold_convert_loc (loc, cmp_type, arg0));
+ arg1 = builtin_save_expr (fold_convert_loc (loc, cmp_type, arg1));
+
+ cmp1 = fold_build2_loc (loc, GE_EXPR, integer_type_node, arg0, arg1);
+ cmp2 = fold_build2_loc (loc, LE_EXPR, integer_type_node, arg0, arg1);
+
+ return fold_build2_loc (loc, TRUTH_AND_EXPR, integer_type_node, cmp1, cmp2);
+}
+
/* Fold __builtin_{,s,u}{add,sub,mul}{,l,ll}_overflow, either into normal
arithmetics if it can never overflow, or into internal functions that
return both result of arithmetics and overflowed boolean flag in
@@ -9833,6 +9870,9 @@ fold_builtin_2 (location_t loc, tree expr, tree fndecl, tree arg0, tree arg1)
arg0, arg1, UNORDERED_EXPR,
NOP_EXPR);
+ case BUILT_IN_ISEQSIG:
+ return fold_builtin_iseqsig (loc, arg0, arg1);
+
/* We do the folding for va_start in the expander. */
case BUILT_IN_VA_START:
break;
@@ -11343,6 +11383,7 @@ is_inexpensive_builtin (tree decl)
case BUILT_IN_ISLESSEQUAL:
case BUILT_IN_ISLESSGREATER:
case BUILT_IN_ISUNORDERED:
+ case BUILT_IN_ISEQSIG:
case BUILT_IN_VA_ARG_PACK:
case BUILT_IN_VA_ARG_PACK_LEN:
case BUILT_IN_VA_COPY:
diff --git a/gcc/builtins.def b/gcc/builtins.def
index 4ad95a12f83..8cc282c1b87 100644
--- a/gcc/builtins.def
+++ b/gcc/builtins.def
@@ -1023,6 +1023,7 @@ DEF_GCC_BUILTIN (BUILT_IN_ISLESS, "isless", BT_FN_INT_VAR, ATTR_CONST_NOT
DEF_GCC_BUILTIN (BUILT_IN_ISLESSEQUAL, "islessequal", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC_LEAF)
DEF_GCC_BUILTIN (BUILT_IN_ISLESSGREATER, "islessgreater", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC_LEAF)
DEF_GCC_BUILTIN (BUILT_IN_ISUNORDERED, "isunordered", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC_LEAF)
+DEF_GCC_BUILTIN (BUILT_IN_ISEQSIG, "iseqsig", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC_LEAF)
DEF_GCC_BUILTIN (BUILT_IN_ISSIGNALING, "issignaling", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC_LEAF)
DEF_LIB_BUILTIN (BUILT_IN_LABS, "labs", BT_FN_LONG_LONG, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_C99_BUILTIN (BUILT_IN_LLABS, "llabs", BT_FN_LONGLONG_LONGLONG, ATTR_CONST_NOTHROW_LEAF_LIST)
diff --git a/gcc/c-family/c-common.cc b/gcc/c-family/c-common.cc
index 9c8eed5442a..9e1ce2a2bc9 100644
--- a/gcc/c-family/c-common.cc
+++ b/gcc/c-family/c-common.cc
@@ -6330,6 +6330,7 @@ check_builtin_function_arguments (location_t loc, vec<location_t> arg_loc,
case BUILT_IN_ISLESSEQUAL:
case BUILT_IN_ISLESSGREATER:
case BUILT_IN_ISUNORDERED:
+ case BUILT_IN_ISEQSIG:
if (builtin_function_validate_nargs (loc, fndecl, nargs, 2))
{
enum tree_code code0, code1;
diff --git a/gcc/doc/extend.texi b/gcc/doc/extend.texi
index cdbd4b34a35..360389df9dc 100644
--- a/gcc/doc/extend.texi
+++ b/gcc/doc/extend.texi
@@ -13017,6 +13017,7 @@ is called and the @var{flag} argument passed to it.
@node Other Builtins
@section Other Built-in Functions Provided by GCC
@cindex built-in functions
+@findex __builtin_iseqsig
@findex __builtin_isfinite
@findex __builtin_isnormal
@findex __builtin_isgreater
@@ -13568,9 +13569,9 @@ the same names as the standard macros ( @code{isgreater},
@code{islessgreater}, and @code{isunordered}) , with @code{__builtin_}
prefixed. We intend for a library implementor to be able to simply
@code{#define} each standard macro to its built-in equivalent.
-In the same fashion, GCC provides @code{fpclassify}, @code{isfinite},
-@code{isinf_sign}, @code{isnormal} and @code{signbit} built-ins used with
-@code{__builtin_} prefixed. The @code{isinf} and @code{isnan}
+In the same fashion, GCC provides @code{fpclassify}, @code{iseqsig},
+@code{isfinite}, @code{isinf_sign}, @code{isnormal} and @code{signbit} built-ins
+used with @code{__builtin_} prefixed. The @code{isinf} and @code{isnan}
built-in functions appear both with and without the @code{__builtin_} prefix.
With @code{-ffinite-math-only} option the @code{isinf} and @code{isnan}
built-in functions will always return 0.
diff --git a/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-1.c b/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-1.c
new file mode 100644
index 00000000000..c66431fff1c
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-1.c
@@ -0,0 +1,113 @@
+/* { dg-do run { xfail powerpc*-*-* } } */
+/* remove the xfail for powerpc when pr58684 is fixed */
+/* { dg-add-options ieee } */
+/* { dg-additional-options "-fsignaling-nans" } */
+/* { dg-require-effective-target fenv_exceptions } */
+
+#include <fenv.h>
+
+void
+ftrue (float x, float y)
+{
+ if (!__builtin_iseqsig (x, y))
+ __builtin_abort ();
+}
+
+void
+ffalse (float x, float y)
+{
+ if (__builtin_iseqsig (x, y))
+ __builtin_abort ();
+}
+
+int
+main ()
+{
+ volatile float f1, f2;
+
+ f1 = 0.f; f2 = 0.f;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.f; f2 = -0.f;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.f; f2 = 1.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = -0.f; f2 = 1.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.f; f2 = __builtin_inff();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = -0.f; f2 = __builtin_inff();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.f; f2 = __builtin_nanf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = -0.f; f2 = __builtin_nanf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = 1.f; f2 = 1.f;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.f; f2 = 0.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.f; f2 = -0.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.f; f2 = __builtin_inff();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.f; f2 = __builtin_nanf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_inff(); f2 = __builtin_inff();
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = __builtin_inff(); f2 = __builtin_nanf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nanf(""); f2 = __builtin_nanf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nansf(""); f2 = 1.f;
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = 1.f; f2 = __builtin_nansf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nansf(""); f2 = __builtin_nansf("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-2.c b/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-2.c
new file mode 100644
index 00000000000..03625b07e6f
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-2.c
@@ -0,0 +1,113 @@
+/* { dg-do run { xfail powerpc*-*-* } } */
+/* remove the xfail for powerpc when pr58684 is fixed */
+/* { dg-add-options ieee } */
+/* { dg-additional-options "-fsignaling-nans" } */
+/* { dg-require-effective-target fenv_exceptions_double } */
+
+#include <fenv.h>
+
+void
+ftrue (double x, double y)
+{
+ if (!__builtin_iseqsig (x, y))
+ __builtin_abort ();
+}
+
+void
+ffalse (double x, double y)
+{
+ if (__builtin_iseqsig (x, y))
+ __builtin_abort ();
+}
+
+int
+main ()
+{
+ volatile double f1, f2;
+
+ f1 = 0.; f2 = 0.;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.; f2 = -0.;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.; f2 = 1.;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = -0.; f2 = 1.;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.; f2 = __builtin_inf();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = -0.; f2 = __builtin_inf();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.; f2 = __builtin_nan("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = -0.; f2 = __builtin_nan("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = 1.; f2 = 1.;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.; f2 = 0.;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.; f2 = -0.;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.; f2 = __builtin_inf();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.; f2 = __builtin_nan("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_inf(); f2 = __builtin_inf();
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = __builtin_inf(); f2 = __builtin_nan("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nan(""); f2 = __builtin_nan("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nans(""); f2 = 1.;
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = 1.; f2 = __builtin_nans("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nans(""); f2 = __builtin_nans("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-3.c b/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-3.c
new file mode 100644
index 00000000000..ed24035264a
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/torture/builtin-iseqsig-3.c
@@ -0,0 +1,113 @@
+/* { dg-do run { xfail powerpc*-*-* } } */
+/* remove the xfail for powerpc when pr58684 is fixed */
+/* { dg-add-options ieee } */
+/* { dg-additional-options "-fsignaling-nans" } */
+/* { dg-require-effective-target fenv_exceptions_long_double } */
+
+#include <fenv.h>
+
+void
+ftrue (long double x, long double y)
+{
+ if (!__builtin_iseqsig (x, y))
+ __builtin_abort ();
+}
+
+void
+ffalse (long double x, long double y)
+{
+ if (__builtin_iseqsig (x, y))
+ __builtin_abort ();
+}
+
+int
+main ()
+{
+ volatile long double f1, f2;
+
+ f1 = 0.L; f2 = 0.f;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.L; f2 = -0.f;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.L; f2 = 1.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = -0.L; f2 = 1.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.L; f2 = __builtin_infl();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = -0.L; f2 = __builtin_infl();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 0.L; f2 = __builtin_nanl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = -0.L; f2 = __builtin_nanl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = 1.L; f2 = 1.f;
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.L; f2 = 0.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.L; f2 = -0.f;
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.L; f2 = __builtin_infl();
+ ffalse (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = 1.L; f2 = __builtin_nanl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_infl(); f2 = __builtin_infl();
+ ftrue (f1, f2);
+ if (fetestexcept (FE_INVALID)) __builtin_abort ();
+
+ f1 = __builtin_infl(); f2 = __builtin_nanl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nanl(""); f2 = __builtin_nanl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nansl(""); f2 = 1.L;
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = 1.L; f2 = __builtin_nansl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ f1 = __builtin_nansl(""); f2 = __builtin_nansl("");
+ ffalse (f1, f2);
+ if (!fetestexcept (FE_INVALID)) __builtin_abort ();
+ feclearexcept (FE_INVALID);
+
+ return 0;
+}
--
2.34.1
[-- Attachment #3: 0002-Fortran-add-IEEE_QUIET_-and-IEEE_SIGNALING_-comparis.patch --]
[-- Type: application/octet-stream, Size: 50517 bytes --]
From f6e11ea2402004df57f6997c63913252d67e8355 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 2/2] 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.
* gfortran.dg/ieee/comparisons_3.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 | 90 ++++
.../gfortran.dg/ieee/comparisons_1.f90 | 282 ++++++++++
.../gfortran.dg/ieee/comparisons_2.f90 | 282 ++++++++++
.../gfortran.dg/ieee/comparisons_3.F90 | 487 ++++++++++++++++++
libgfortran/ieee/ieee_arithmetic.F90 | 69 +++
6 files changed, 1212 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/ieee/comparisons_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/ieee/comparisons_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/ieee/comparisons_3.F90
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 9684f1d4921..56722567662 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 a0e1110c5e0..39f9deacaca 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10263,6 +10263,92 @@ conv_intrinsic_ieee_fma (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. */
@@ -10301,6 +10387,10 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
conv_intrinsic_ieee_value (se, expr);
else if (startswith (name, "_gfortran_ieee_fma"))
conv_intrinsic_ieee_fma (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..39a8abdef69
--- /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, volatile :: rnan, rinf
+ double precision, volatile :: dnan, dinf
+ real(kind=large), volatile :: 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.)) stop 1
+ if (.not. ieee_quiet_eq (0., -0.)) stop 2
+ if (.not. ieee_quiet_eq (1., 1.)) stop 3
+ if (.not. ieee_quiet_eq (rinf, rinf)) stop 4
+ if (.not. ieee_quiet_eq (-rinf, -rinf)) stop 5
+ if (ieee_quiet_eq (rnan, rnan)) stop 6
+ if (ieee_quiet_eq (0., 1.)) stop 7
+ if (ieee_quiet_eq (0., -1.)) stop 8
+ if (ieee_quiet_eq (0., rnan)) stop 9
+ if (ieee_quiet_eq (1., rnan)) stop 10
+ if (ieee_quiet_eq (0., rinf)) stop 11
+ if (ieee_quiet_eq (1., rinf)) stop 12
+ if (ieee_quiet_eq (rinf, rnan)) stop 13
+
+ if (.not. ieee_quiet_eq (0.d0, 0.d0)) stop 14
+ if (.not. ieee_quiet_eq (0.d0, -0.d0)) stop 15
+ if (.not. ieee_quiet_eq (1.d0, 1.d0)) stop 16
+ if (.not. ieee_quiet_eq (dinf, dinf)) stop 17
+ if (.not. ieee_quiet_eq (-dinf, -dinf)) stop 18
+ if (ieee_quiet_eq (dnan, dnan)) stop 19
+ if (ieee_quiet_eq (0.d0, 1.d0)) stop 20
+ if (ieee_quiet_eq (0.d0, -1.d0)) stop 21
+ if (ieee_quiet_eq (0.d0, dnan)) stop 22
+ if (ieee_quiet_eq (1.d0, dnan)) stop 23
+ if (ieee_quiet_eq (0.d0, dinf)) stop 24
+ if (ieee_quiet_eq (1.d0, dinf)) stop 25
+ if (ieee_quiet_eq (dinf, dnan)) stop 26
+
+ if (.not. ieee_quiet_eq (0._large, 0._large)) stop 27
+ if (.not. ieee_quiet_eq (0._large, -0._large)) stop 28
+ if (.not. ieee_quiet_eq (1._large, 1._large)) stop 29
+ if (.not. ieee_quiet_eq (linf, linf)) stop 30
+ if (.not. ieee_quiet_eq (-linf, -linf)) stop 31
+ if (ieee_quiet_eq (lnan, lnan)) stop 32
+ if (ieee_quiet_eq (0._large, 1._large)) stop 33
+ if (ieee_quiet_eq (0._large, -1._large)) stop 34
+ if (ieee_quiet_eq (0._large, lnan)) stop 35
+ if (ieee_quiet_eq (1._large, lnan)) stop 36
+ if (ieee_quiet_eq (0._large, linf)) stop 37
+ if (ieee_quiet_eq (1._large, linf)) stop 38
+ if (ieee_quiet_eq (linf, lnan)) stop 39
+
+
+ if (ieee_quiet_ne (0., 0.)) stop 40
+ if (ieee_quiet_ne (0., -0.)) stop 41
+ if (ieee_quiet_ne (1., 1.)) stop 42
+ if (ieee_quiet_ne (rinf, rinf)) stop 43
+ if (ieee_quiet_ne (-rinf, -rinf)) stop 44
+ if (.not. ieee_quiet_ne (rnan, rnan)) stop 45
+ if (.not. ieee_quiet_ne (0., 1.)) stop 46
+ if (.not. ieee_quiet_ne (0., -1.)) stop 47
+ if (.not. ieee_quiet_ne (0., rnan)) stop 48
+ if (.not. ieee_quiet_ne (1., rnan)) stop 49
+ if (.not. ieee_quiet_ne (0., rinf)) stop 50
+ if (.not. ieee_quiet_ne (1., rinf)) stop 51
+ if (.not. ieee_quiet_ne (rinf, rnan)) stop 52
+
+ if (ieee_quiet_ne (0.d0, 0.d0)) stop 53
+ if (ieee_quiet_ne (0.d0, -0.d0)) stop 54
+ if (ieee_quiet_ne (1.d0, 1.d0)) stop 55
+ if (ieee_quiet_ne (dinf, dinf)) stop 56
+ if (ieee_quiet_ne (-dinf, -dinf)) stop 57
+ if (.not. ieee_quiet_ne (dnan, dnan)) stop 58
+ if (.not. ieee_quiet_ne (0.d0, 1.d0)) stop 59
+ if (.not. ieee_quiet_ne (0.d0, -1.d0)) stop 60
+ if (.not. ieee_quiet_ne (0.d0, dnan)) stop 61
+ if (.not. ieee_quiet_ne (1.d0, dnan)) stop 62
+ if (.not. ieee_quiet_ne (0.d0, dinf)) stop 63
+ if (.not. ieee_quiet_ne (1.d0, dinf)) stop 64
+ if (.not. ieee_quiet_ne (dinf, dnan)) stop 65
+
+ if (ieee_quiet_ne (0._large, 0._large)) stop 66
+ if (ieee_quiet_ne (0._large, -0._large)) stop 67
+ if (ieee_quiet_ne (1._large, 1._large)) stop 68
+ if (ieee_quiet_ne (linf, linf)) stop 69
+ if (ieee_quiet_ne (-linf, -linf)) stop 70
+ if (.not. ieee_quiet_ne (lnan, lnan)) stop 71
+ if (.not. ieee_quiet_ne (0._large, 1._large)) stop 72
+ if (.not. ieee_quiet_ne (0._large, -1._large)) stop 73
+ if (.not. ieee_quiet_ne (0._large, lnan)) stop 74
+ if (.not. ieee_quiet_ne (1._large, lnan)) stop 75
+ if (.not. ieee_quiet_ne (0._large, linf)) stop 76
+ if (.not. ieee_quiet_ne (1._large, linf)) stop 77
+ if (.not. ieee_quiet_ne (linf, lnan)) stop 78
+
+
+ if (.not. ieee_quiet_le (0., 0.)) stop 79
+ if (.not. ieee_quiet_le (0., -0.)) stop 80
+ if (.not. ieee_quiet_le (1., 1.)) stop 81
+ if (.not. ieee_quiet_le (rinf, rinf)) stop 82
+ if (.not. ieee_quiet_le (-rinf, -rinf)) stop 83
+ if (ieee_quiet_le (rnan, rnan)) stop 84
+ if (.not. ieee_quiet_le (0., 1.)) stop 85
+ if (ieee_quiet_le (0., -1.)) stop 86
+ if (ieee_quiet_le (0., rnan)) stop 87
+ if (ieee_quiet_le (1., rnan)) stop 88
+ if (.not. ieee_quiet_le (0., rinf)) stop 89
+ if (.not. ieee_quiet_le (1., rinf)) stop 90
+ if (ieee_quiet_le (rinf, rnan)) stop 91
+
+ if (.not. ieee_quiet_le (0.d0, 0.d0)) stop 92
+ if (.not. ieee_quiet_le (0.d0, -0.d0)) stop 93
+ if (.not. ieee_quiet_le (1.d0, 1.d0)) stop 94
+ if (.not. ieee_quiet_le (dinf, dinf)) stop 95
+ if (.not. ieee_quiet_le (-dinf, -dinf)) stop 96
+ if (ieee_quiet_le (dnan, dnan)) stop 97
+ if (.not. ieee_quiet_le (0.d0, 1.d0)) stop 98
+ if (ieee_quiet_le (0.d0, -1.d0)) stop 99
+ if (ieee_quiet_le (0.d0, dnan)) stop 100
+ if (ieee_quiet_le (1.d0, dnan)) stop 101
+ if (.not. ieee_quiet_le (0.d0, dinf)) stop 102
+ if (.not. ieee_quiet_le (1.d0, dinf)) stop 103
+ if (ieee_quiet_le (dinf, dnan)) stop 104
+
+ if (.not. ieee_quiet_le (0._large, 0._large)) stop 105
+ if (.not. ieee_quiet_le (0._large, -0._large)) stop 106
+ if (.not. ieee_quiet_le (1._large, 1._large)) stop 107
+ if (.not. ieee_quiet_le (linf, linf)) stop 108
+ if (.not. ieee_quiet_le (-linf, -linf)) stop 109
+ if (ieee_quiet_le (lnan, lnan)) stop 110
+ if (.not. ieee_quiet_le (0._large, 1._large)) stop 111
+ if (ieee_quiet_le (0._large, -1._large)) stop 112
+ if (ieee_quiet_le (0._large, lnan)) stop 113
+ if (ieee_quiet_le (1._large, lnan)) stop 114
+ if (.not. ieee_quiet_le (0._large, linf)) stop 115
+ if (.not. ieee_quiet_le (1._large, linf)) stop 116
+ if (ieee_quiet_le (linf, lnan)) stop 117
+
+
+ if (.not. ieee_quiet_ge (0., 0.)) stop 118
+ if (.not. ieee_quiet_ge (0., -0.)) stop 119
+ if (.not. ieee_quiet_ge (1., 1.)) stop 120
+ if (.not. ieee_quiet_ge (rinf, rinf)) stop 121
+ if (.not. ieee_quiet_ge (-rinf, -rinf)) stop 122
+ if (ieee_quiet_ge (rnan, rnan)) stop 123
+ if (ieee_quiet_ge (0., 1.)) stop 124
+ if (.not. ieee_quiet_ge (0., -1.)) stop 125
+ if (ieee_quiet_ge (0., rnan)) stop 126
+ if (ieee_quiet_ge (1., rnan)) stop 127
+ if (ieee_quiet_ge (0., rinf)) stop 128
+ if (ieee_quiet_ge (1., rinf)) stop 129
+ if (ieee_quiet_ge (rinf, rnan)) stop 130
+
+ if (.not. ieee_quiet_ge (0.d0, 0.d0)) stop 131
+ if (.not. ieee_quiet_ge (0.d0, -0.d0)) stop 132
+ if (.not. ieee_quiet_ge (1.d0, 1.d0)) stop 133
+ if (.not. ieee_quiet_ge (dinf, dinf)) stop 134
+ if (.not. ieee_quiet_ge (-dinf, -dinf)) stop 135
+ if (ieee_quiet_ge (dnan, dnan)) stop 136
+ if (ieee_quiet_ge (0.d0, 1.d0)) stop 137
+ if (.not. ieee_quiet_ge (0.d0, -1.d0)) stop 138
+ if (ieee_quiet_ge (0.d0, dnan)) stop 139
+ if (ieee_quiet_ge (1.d0, dnan)) stop 140
+ if (ieee_quiet_ge (0.d0, dinf)) stop 141
+ if (ieee_quiet_ge (1.d0, dinf)) stop 142
+ if (ieee_quiet_ge (dinf, dnan)) stop 143
+
+ if (.not. ieee_quiet_ge (0._large, 0._large)) stop 144
+ if (.not. ieee_quiet_ge (0._large, -0._large)) stop 145
+ if (.not. ieee_quiet_ge (1._large, 1._large)) stop 146
+ if (.not. ieee_quiet_ge (linf, linf)) stop 147
+ if (.not. ieee_quiet_ge (-linf, -linf)) stop 148
+ if (ieee_quiet_ge (lnan, lnan)) stop 149
+ if (ieee_quiet_ge (0._large, 1._large)) stop 150
+ if (.not. ieee_quiet_ge (0._large, -1._large)) stop 151
+ if (ieee_quiet_ge (0._large, lnan)) stop 152
+ if (ieee_quiet_ge (1._large, lnan)) stop 153
+ if (ieee_quiet_ge (0._large, linf)) stop 154
+ if (ieee_quiet_ge (1._large, linf)) stop 155
+ if (ieee_quiet_ge (linf, lnan)) stop 156
+
+
+ if (ieee_quiet_lt (0., 0.)) stop 157
+ if (ieee_quiet_lt (0., -0.)) stop 158
+ if (ieee_quiet_lt (1., 1.)) stop 159
+ if (ieee_quiet_lt (rinf, rinf)) stop 160
+ if (ieee_quiet_lt (-rinf, -rinf)) stop 161
+ if (ieee_quiet_lt (rnan, rnan)) stop 162
+ if (.not. ieee_quiet_lt (0., 1.)) stop 163
+ if (ieee_quiet_lt (0., -1.)) stop 164
+ if (ieee_quiet_lt (0., rnan)) stop 165
+ if (ieee_quiet_lt (1., rnan)) stop 166
+ if (.not. ieee_quiet_lt (0., rinf)) stop 167
+ if (.not. ieee_quiet_lt (1., rinf)) stop 168
+ if (ieee_quiet_lt (rinf, rnan)) stop 169
+
+ if (ieee_quiet_lt (0.d0, 0.d0)) stop 170
+ if (ieee_quiet_lt (0.d0, -0.d0)) stop 171
+ if (ieee_quiet_lt (1.d0, 1.d0)) stop 172
+ if (ieee_quiet_lt (dinf, dinf)) stop 173
+ if (ieee_quiet_lt (-dinf, -dinf)) stop 174
+ if (ieee_quiet_lt (dnan, dnan)) stop 175
+ if (.not. ieee_quiet_lt (0.d0, 1.d0)) stop 176
+ if (ieee_quiet_lt (0.d0, -1.d0)) stop 177
+ if (ieee_quiet_lt (0.d0, dnan)) stop 178
+ if (ieee_quiet_lt (1.d0, dnan)) stop 179
+ if (.not. ieee_quiet_lt (0.d0, dinf)) stop 180
+ if (.not. ieee_quiet_lt (1.d0, dinf)) stop 181
+ if (ieee_quiet_lt (dinf, dnan)) stop 182
+
+ if (ieee_quiet_lt (0._large, 0._large)) stop 183
+ if (ieee_quiet_lt (0._large, -0._large)) stop 184
+ if (ieee_quiet_lt (1._large, 1._large)) stop 185
+ if (ieee_quiet_lt (linf, linf)) stop 186
+ if (ieee_quiet_lt (-linf, -linf)) stop 187
+ if (ieee_quiet_lt (lnan, lnan)) stop 188
+ if (.not. ieee_quiet_lt (0._large, 1._large)) stop 189
+ if (ieee_quiet_lt (0._large, -1._large)) stop 190
+ if (ieee_quiet_lt (0._large, lnan)) stop 191
+ if (ieee_quiet_lt (1._large, lnan)) stop 192
+ if (.not. ieee_quiet_lt (0._large, linf)) stop 193
+ if (.not. ieee_quiet_lt (1._large, linf)) stop 194
+ if (ieee_quiet_lt (linf, lnan)) stop 195
+
+
+ if (ieee_quiet_gt (0., 0.)) stop 196
+ if (ieee_quiet_gt (0., -0.)) stop 197
+ if (ieee_quiet_gt (1., 1.)) stop 198
+ if (ieee_quiet_gt (rinf, rinf)) stop 199
+ if (ieee_quiet_gt (-rinf, -rinf)) stop 200
+ if (ieee_quiet_gt (rnan, rnan)) stop 201
+ if (ieee_quiet_gt (0., 1.)) stop 202
+ if (.not. ieee_quiet_gt (0., -1.)) stop 203
+ if (ieee_quiet_gt (0., rnan)) stop 204
+ if (ieee_quiet_gt (1., rnan)) stop 205
+ if (ieee_quiet_gt (0., rinf)) stop 206
+ if (ieee_quiet_gt (1., rinf)) stop 207
+ if (ieee_quiet_gt (rinf, rnan)) stop 208
+
+ if (ieee_quiet_gt (0.d0, 0.d0)) stop 209
+ if (ieee_quiet_gt (0.d0, -0.d0)) stop 210
+ if (ieee_quiet_gt (1.d0, 1.d0)) stop 211
+ if (ieee_quiet_gt (dinf, dinf)) stop 212
+ if (ieee_quiet_gt (-dinf, -dinf)) stop 213
+ if (ieee_quiet_gt (dnan, dnan)) stop 214
+ if (ieee_quiet_gt (0.d0, 1.d0)) stop 215
+ if (.not. ieee_quiet_gt (0.d0, -1.d0)) stop 216
+ if (ieee_quiet_gt (0.d0, dnan)) stop 217
+ if (ieee_quiet_gt (1.d0, dnan)) stop 218
+ if (ieee_quiet_gt (0.d0, dinf)) stop 219
+ if (ieee_quiet_gt (1.d0, dinf)) stop 220
+ if (ieee_quiet_gt (dinf, dnan)) stop 221
+
+ if (ieee_quiet_gt (0._large, 0._large)) stop 222
+ if (ieee_quiet_gt (0._large, -0._large)) stop 223
+ if (ieee_quiet_gt (1._large, 1._large)) stop 224
+ if (ieee_quiet_gt (linf, linf)) stop 225
+ if (ieee_quiet_gt (-linf, -linf)) stop 226
+ if (ieee_quiet_gt (lnan, lnan)) stop 227
+ if (ieee_quiet_gt (0._large, 1._large)) stop 228
+ if (.not. ieee_quiet_gt (0._large, -1._large)) stop 229
+ if (ieee_quiet_gt (0._large, lnan)) stop 230
+ if (ieee_quiet_gt (1._large, lnan)) stop 231
+ if (ieee_quiet_gt (0._large, linf)) stop 232
+ if (ieee_quiet_gt (1._large, linf)) stop 233
+ if (ieee_quiet_gt (linf, lnan)) stop 234
+
+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..35aa1fcba1b
--- /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, volatile :: rnan, rinf
+ double precision, volatile :: dnan, dinf
+ real(kind=large), volatile :: 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.)) stop 1
+ if (.not. ieee_signaling_eq (0., -0.)) stop 2
+ if (.not. ieee_signaling_eq (1., 1.)) stop 3
+ if (.not. ieee_signaling_eq (rinf, rinf)) stop 4
+ if (.not. ieee_signaling_eq (-rinf, -rinf)) stop 5
+ if (ieee_signaling_eq (rnan, rnan)) stop 6
+ if (ieee_signaling_eq (0., 1.)) stop 7
+ if (ieee_signaling_eq (0., -1.)) stop 8
+ if (ieee_signaling_eq (0., rnan)) stop 9
+ if (ieee_signaling_eq (1., rnan)) stop 10
+ if (ieee_signaling_eq (0., rinf)) stop 11
+ if (ieee_signaling_eq (1., rinf)) stop 12
+ if (ieee_signaling_eq (rinf, rnan)) stop 13
+
+ if (.not. ieee_signaling_eq (0.d0, 0.d0)) stop 14
+ if (.not. ieee_signaling_eq (0.d0, -0.d0)) stop 15
+ if (.not. ieee_signaling_eq (1.d0, 1.d0)) stop 16
+ if (.not. ieee_signaling_eq (dinf, dinf)) stop 17
+ if (.not. ieee_signaling_eq (-dinf, -dinf)) stop 18
+ if (ieee_signaling_eq (dnan, dnan)) stop 19
+ if (ieee_signaling_eq (0.d0, 1.d0)) stop 20
+ if (ieee_signaling_eq (0.d0, -1.d0)) stop 21
+ if (ieee_signaling_eq (0.d0, dnan)) stop 22
+ if (ieee_signaling_eq (1.d0, dnan)) stop 23
+ if (ieee_signaling_eq (0.d0, dinf)) stop 24
+ if (ieee_signaling_eq (1.d0, dinf)) stop 25
+ if (ieee_signaling_eq (dinf, dnan)) stop 26
+
+ if (.not. ieee_signaling_eq (0._large, 0._large)) stop 27
+ if (.not. ieee_signaling_eq (0._large, -0._large)) stop 28
+ if (.not. ieee_signaling_eq (1._large, 1._large)) stop 29
+ if (.not. ieee_signaling_eq (linf, linf)) stop 30
+ if (.not. ieee_signaling_eq (-linf, -linf)) stop 31
+ if (ieee_signaling_eq (lnan, lnan)) stop 32
+ if (ieee_signaling_eq (0._large, 1._large)) stop 33
+ if (ieee_signaling_eq (0._large, -1._large)) stop 34
+ if (ieee_signaling_eq (0._large, lnan)) stop 35
+ if (ieee_signaling_eq (1._large, lnan)) stop 36
+ if (ieee_signaling_eq (0._large, linf)) stop 37
+ if (ieee_signaling_eq (1._large, linf)) stop 38
+ if (ieee_signaling_eq (linf, lnan)) stop 39
+
+
+ if (ieee_signaling_ne (0., 0.)) stop 40
+ if (ieee_signaling_ne (0., -0.)) stop 41
+ if (ieee_signaling_ne (1., 1.)) stop 42
+ if (ieee_signaling_ne (rinf, rinf)) stop 43
+ if (ieee_signaling_ne (-rinf, -rinf)) stop 44
+ if (.not. ieee_signaling_ne (rnan, rnan)) stop 45
+ if (.not. ieee_signaling_ne (0., 1.)) stop 46
+ if (.not. ieee_signaling_ne (0., -1.)) stop 47
+ if (.not. ieee_signaling_ne (0., rnan)) stop 48
+ if (.not. ieee_signaling_ne (1., rnan)) stop 49
+ if (.not. ieee_signaling_ne (0., rinf)) stop 50
+ if (.not. ieee_signaling_ne (1., rinf)) stop 51
+ if (.not. ieee_signaling_ne (rinf, rnan)) stop 52
+
+ if (ieee_signaling_ne (0.d0, 0.d0)) stop 53
+ if (ieee_signaling_ne (0.d0, -0.d0)) stop 54
+ if (ieee_signaling_ne (1.d0, 1.d0)) stop 55
+ if (ieee_signaling_ne (dinf, dinf)) stop 56
+ if (ieee_signaling_ne (-dinf, -dinf)) stop 57
+ if (.not. ieee_signaling_ne (dnan, dnan)) stop 58
+ if (.not. ieee_signaling_ne (0.d0, 1.d0)) stop 59
+ if (.not. ieee_signaling_ne (0.d0, -1.d0)) stop 60
+ if (.not. ieee_signaling_ne (0.d0, dnan)) stop 61
+ if (.not. ieee_signaling_ne (1.d0, dnan)) stop 62
+ if (.not. ieee_signaling_ne (0.d0, dinf)) stop 63
+ if (.not. ieee_signaling_ne (1.d0, dinf)) stop 64
+ if (.not. ieee_signaling_ne (dinf, dnan)) stop 65
+
+ if (ieee_signaling_ne (0._large, 0._large)) stop 66
+ if (ieee_signaling_ne (0._large, -0._large)) stop 67
+ if (ieee_signaling_ne (1._large, 1._large)) stop 68
+ if (ieee_signaling_ne (linf, linf)) stop 69
+ if (ieee_signaling_ne (-linf, -linf)) stop 70
+ if (.not. ieee_signaling_ne (lnan, lnan)) stop 71
+ if (.not. ieee_signaling_ne (0._large, 1._large)) stop 72
+ if (.not. ieee_signaling_ne (0._large, -1._large)) stop 73
+ if (.not. ieee_signaling_ne (0._large, lnan)) stop 74
+ if (.not. ieee_signaling_ne (1._large, lnan)) stop 75
+ if (.not. ieee_signaling_ne (0._large, linf)) stop 76
+ if (.not. ieee_signaling_ne (1._large, linf)) stop 77
+ if (.not. ieee_signaling_ne (linf, lnan)) stop 78
+
+
+ if (.not. ieee_signaling_le (0., 0.)) stop 79
+ if (.not. ieee_signaling_le (0., -0.)) stop 80
+ if (.not. ieee_signaling_le (1., 1.)) stop 81
+ if (.not. ieee_signaling_le (rinf, rinf)) stop 82
+ if (.not. ieee_signaling_le (-rinf, -rinf)) stop 83
+ if (ieee_signaling_le (rnan, rnan)) stop 84
+ if (.not. ieee_signaling_le (0., 1.)) stop 85
+ if (ieee_signaling_le (0., -1.)) stop 86
+ if (ieee_signaling_le (0., rnan)) stop 87
+ if (ieee_signaling_le (1., rnan)) stop 88
+ if (.not. ieee_signaling_le (0., rinf)) stop 89
+ if (.not. ieee_signaling_le (1., rinf)) stop 90
+ if (ieee_signaling_le (rinf, rnan)) stop 91
+
+ if (.not. ieee_signaling_le (0.d0, 0.d0)) stop 92
+ if (.not. ieee_signaling_le (0.d0, -0.d0)) stop 93
+ if (.not. ieee_signaling_le (1.d0, 1.d0)) stop 94
+ if (.not. ieee_signaling_le (dinf, dinf)) stop 95
+ if (.not. ieee_signaling_le (-dinf, -dinf)) stop 96
+ if (ieee_signaling_le (dnan, dnan)) stop 97
+ if (.not. ieee_signaling_le (0.d0, 1.d0)) stop 98
+ if (ieee_signaling_le (0.d0, -1.d0)) stop 99
+ if (ieee_signaling_le (0.d0, dnan)) stop 100
+ if (ieee_signaling_le (1.d0, dnan)) stop 101
+ if (.not. ieee_signaling_le (0.d0, dinf)) stop 102
+ if (.not. ieee_signaling_le (1.d0, dinf)) stop 103
+ if (ieee_signaling_le (dinf, dnan)) stop 104
+
+ if (.not. ieee_signaling_le (0._large, 0._large)) stop 105
+ if (.not. ieee_signaling_le (0._large, -0._large)) stop 106
+ if (.not. ieee_signaling_le (1._large, 1._large)) stop 107
+ if (.not. ieee_signaling_le (linf, linf)) stop 108
+ if (.not. ieee_signaling_le (-linf, -linf)) stop 109
+ if (ieee_signaling_le (lnan, lnan)) stop 110
+ if (.not. ieee_signaling_le (0._large, 1._large)) stop 111
+ if (ieee_signaling_le (0._large, -1._large)) stop 112
+ if (ieee_signaling_le (0._large, lnan)) stop 113
+ if (ieee_signaling_le (1._large, lnan)) stop 114
+ if (.not. ieee_signaling_le (0._large, linf)) stop 115
+ if (.not. ieee_signaling_le (1._large, linf)) stop 116
+ if (ieee_signaling_le (linf, lnan)) stop 117
+
+
+ if (.not. ieee_signaling_ge (0., 0.)) stop 118
+ if (.not. ieee_signaling_ge (0., -0.)) stop 119
+ if (.not. ieee_signaling_ge (1., 1.)) stop 120
+ if (.not. ieee_signaling_ge (rinf, rinf)) stop 121
+ if (.not. ieee_signaling_ge (-rinf, -rinf)) stop 122
+ if (ieee_signaling_ge (rnan, rnan)) stop 123
+ if (ieee_signaling_ge (0., 1.)) stop 124
+ if (.not. ieee_signaling_ge (0., -1.)) stop 125
+ if (ieee_signaling_ge (0., rnan)) stop 126
+ if (ieee_signaling_ge (1., rnan)) stop 127
+ if (ieee_signaling_ge (0., rinf)) stop 128
+ if (ieee_signaling_ge (1., rinf)) stop 129
+ if (ieee_signaling_ge (rinf, rnan)) stop 130
+
+ if (.not. ieee_signaling_ge (0.d0, 0.d0)) stop 131
+ if (.not. ieee_signaling_ge (0.d0, -0.d0)) stop 132
+ if (.not. ieee_signaling_ge (1.d0, 1.d0)) stop 133
+ if (.not. ieee_signaling_ge (dinf, dinf)) stop 134
+ if (.not. ieee_signaling_ge (-dinf, -dinf)) stop 135
+ if (ieee_signaling_ge (dnan, dnan)) stop 136
+ if (ieee_signaling_ge (0.d0, 1.d0)) stop 137
+ if (.not. ieee_signaling_ge (0.d0, -1.d0)) stop 138
+ if (ieee_signaling_ge (0.d0, dnan)) stop 139
+ if (ieee_signaling_ge (1.d0, dnan)) stop 140
+ if (ieee_signaling_ge (0.d0, dinf)) stop 141
+ if (ieee_signaling_ge (1.d0, dinf)) stop 142
+ if (ieee_signaling_ge (dinf, dnan)) stop 143
+
+ if (.not. ieee_signaling_ge (0._large, 0._large)) stop 144
+ if (.not. ieee_signaling_ge (0._large, -0._large)) stop 145
+ if (.not. ieee_signaling_ge (1._large, 1._large)) stop 146
+ if (.not. ieee_signaling_ge (linf, linf)) stop 147
+ if (.not. ieee_signaling_ge (-linf, -linf)) stop 148
+ if (ieee_signaling_ge (lnan, lnan)) stop 149
+ if (ieee_signaling_ge (0._large, 1._large)) stop 150
+ if (.not. ieee_signaling_ge (0._large, -1._large)) stop 151
+ if (ieee_signaling_ge (0._large, lnan)) stop 152
+ if (ieee_signaling_ge (1._large, lnan)) stop 153
+ if (ieee_signaling_ge (0._large, linf)) stop 154
+ if (ieee_signaling_ge (1._large, linf)) stop 155
+ if (ieee_signaling_ge (linf, lnan)) stop 156
+
+
+ if (ieee_signaling_lt (0., 0.)) stop 157
+ if (ieee_signaling_lt (0., -0.)) stop 158
+ if (ieee_signaling_lt (1., 1.)) stop 159
+ if (ieee_signaling_lt (rinf, rinf)) stop 160
+ if (ieee_signaling_lt (-rinf, -rinf)) stop 161
+ if (ieee_signaling_lt (rnan, rnan)) stop 162
+ if (.not. ieee_signaling_lt (0., 1.)) stop 163
+ if (ieee_signaling_lt (0., -1.)) stop 164
+ if (ieee_signaling_lt (0., rnan)) stop 165
+ if (ieee_signaling_lt (1., rnan)) stop 166
+ if (.not. ieee_signaling_lt (0., rinf)) stop 167
+ if (.not. ieee_signaling_lt (1., rinf)) stop 168
+ if (ieee_signaling_lt (rinf, rnan)) stop 169
+
+ if (ieee_signaling_lt (0.d0, 0.d0)) stop 170
+ if (ieee_signaling_lt (0.d0, -0.d0)) stop 171
+ if (ieee_signaling_lt (1.d0, 1.d0)) stop 172
+ if (ieee_signaling_lt (dinf, dinf)) stop 173
+ if (ieee_signaling_lt (-dinf, -dinf)) stop 174
+ if (ieee_signaling_lt (dnan, dnan)) stop 175
+ if (.not. ieee_signaling_lt (0.d0, 1.d0)) stop 176
+ if (ieee_signaling_lt (0.d0, -1.d0)) stop 177
+ if (ieee_signaling_lt (0.d0, dnan)) stop 178
+ if (ieee_signaling_lt (1.d0, dnan)) stop 179
+ if (.not. ieee_signaling_lt (0.d0, dinf)) stop 180
+ if (.not. ieee_signaling_lt (1.d0, dinf)) stop 181
+ if (ieee_signaling_lt (dinf, dnan)) stop 182
+
+ if (ieee_signaling_lt (0._large, 0._large)) stop 183
+ if (ieee_signaling_lt (0._large, -0._large)) stop 184
+ if (ieee_signaling_lt (1._large, 1._large)) stop 185
+ if (ieee_signaling_lt (linf, linf)) stop 186
+ if (ieee_signaling_lt (-linf, -linf)) stop 187
+ if (ieee_signaling_lt (lnan, lnan)) stop 188
+ if (.not. ieee_signaling_lt (0._large, 1._large)) stop 189
+ if (ieee_signaling_lt (0._large, -1._large)) stop 190
+ if (ieee_signaling_lt (0._large, lnan)) stop 191
+ if (ieee_signaling_lt (1._large, lnan)) stop 192
+ if (.not. ieee_signaling_lt (0._large, linf)) stop 193
+ if (.not. ieee_signaling_lt (1._large, linf)) stop 194
+ if (ieee_signaling_lt (linf, lnan)) stop 195
+
+
+ if (ieee_signaling_gt (0., 0.)) stop 196
+ if (ieee_signaling_gt (0., -0.)) stop 197
+ if (ieee_signaling_gt (1., 1.)) stop 198
+ if (ieee_signaling_gt (rinf, rinf)) stop 199
+ if (ieee_signaling_gt (-rinf, -rinf)) stop 200
+ if (ieee_signaling_gt (rnan, rnan)) stop 201
+ if (ieee_signaling_gt (0., 1.)) stop 202
+ if (.not. ieee_signaling_gt (0., -1.)) stop 203
+ if (ieee_signaling_gt (0., rnan)) stop 204
+ if (ieee_signaling_gt (1., rnan)) stop 205
+ if (ieee_signaling_gt (0., rinf)) stop 206
+ if (ieee_signaling_gt (1., rinf)) stop 207
+ if (ieee_signaling_gt (rinf, rnan)) stop 208
+
+ if (ieee_signaling_gt (0.d0, 0.d0)) stop 209
+ if (ieee_signaling_gt (0.d0, -0.d0)) stop 210
+ if (ieee_signaling_gt (1.d0, 1.d0)) stop 211
+ if (ieee_signaling_gt (dinf, dinf)) stop 212
+ if (ieee_signaling_gt (-dinf, -dinf)) stop 213
+ if (ieee_signaling_gt (dnan, dnan)) stop 214
+ if (ieee_signaling_gt (0.d0, 1.d0)) stop 215
+ if (.not. ieee_signaling_gt (0.d0, -1.d0)) stop 216
+ if (ieee_signaling_gt (0.d0, dnan)) stop 217
+ if (ieee_signaling_gt (1.d0, dnan)) stop 218
+ if (ieee_signaling_gt (0.d0, dinf)) stop 219
+ if (ieee_signaling_gt (1.d0, dinf)) stop 220
+ if (ieee_signaling_gt (dinf, dnan)) stop 221
+
+ if (ieee_signaling_gt (0._large, 0._large)) stop 222
+ if (ieee_signaling_gt (0._large, -0._large)) stop 223
+ if (ieee_signaling_gt (1._large, 1._large)) stop 224
+ if (ieee_signaling_gt (linf, linf)) stop 225
+ if (ieee_signaling_gt (-linf, -linf)) stop 226
+ if (ieee_signaling_gt (lnan, lnan)) stop 227
+ if (ieee_signaling_gt (0._large, 1._large)) stop 228
+ if (.not. ieee_signaling_gt (0._large, -1._large)) stop 229
+ if (ieee_signaling_gt (0._large, lnan)) stop 230
+ if (ieee_signaling_gt (1._large, lnan)) stop 231
+ if (ieee_signaling_gt (0._large, linf)) stop 232
+ if (ieee_signaling_gt (1._large, linf)) stop 233
+ if (ieee_signaling_gt (linf, lnan)) stop 234
+
+end program foo
diff --git a/gcc/testsuite/gfortran.dg/ieee/comparisons_3.F90 b/gcc/testsuite/gfortran.dg/ieee/comparisons_3.F90
new file mode 100644
index 00000000000..c15678fec35
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/comparisons_3.F90
@@ -0,0 +1,487 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none" }
+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, volatile :: rnan, rinf
+ double precision, volatile :: dnan, dinf
+ real(kind=large), volatile :: lnan, linf
+
+ logical :: flag
+
+ 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)
+
+#define CHECK_INVALID(expected) \
+ call ieee_get_flag(ieee_invalid, flag) ; \
+ if (flag .neqv. expected) then ; \
+ write (*,*) "Check failed at ", __LINE__ ; \
+ stop 1; \
+ end if ; \
+ call ieee_set_flag(ieee_invalid, .false.)
+
+ !! REAL
+
+ ! Signaling versions
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_eq (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_eq (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_eq (0., rnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_eq (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_eq (rnan, rnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ne (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ne (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ne (0., rnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_ne (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ne (rnan, rnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_le (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_le (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_le (0., rnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_le (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_le (rnan, rnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0., rnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_lt (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (rnan, rnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ge (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ge (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ge (0., rnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_ge (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ge (rnan, rnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0., rnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_gt (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (rnan, rnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ ! Quiet versions
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_eq (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_eq (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (0., rnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (rnan, rnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ne (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ne (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (0., rnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (rnan, rnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_le (0., rnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_le (rnan, rnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0., rnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_lt (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (rnan, rnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ge (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ge (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (0., rnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (rnan, rnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0., 0.)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0., -0.)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0., rnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0., rinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (rnan, rnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ !! DOUBLE PRECISION
+
+ ! Signaling versions
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_eq (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_eq (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_eq (0.d0, dnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_eq (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_eq (dnan, dnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ne (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ne (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ne (0.d0, dnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_ne (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ne (dnan, dnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_le (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_le (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_le (0.d0, dnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_le (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_le (dnan, dnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0.d0, dnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_lt (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (dnan, dnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ge (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ge (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ge (0.d0, dnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_ge (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ge (dnan, dnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0.d0, dnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_gt (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (dnan, dnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ ! Quiet versions
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_eq (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_eq (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (0.d0, dnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (dnan, dnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ne (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ne (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (0.d0, dnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (dnan, dnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_le (0.d0, dnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_le (dnan, dnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0.d0, dnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_lt (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (dnan, dnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ge (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ge (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (0.d0, dnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (dnan, dnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0.d0, 0.d0)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0.d0, -0.d0)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0.d0, dnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0.d0, dinf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (dnan, dnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ !! LARGE KIND
+
+ ! Signaling versions
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_eq (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_eq (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_eq (0._large, lnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_eq (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_eq (lnan, lnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ne (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ne (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ne (0._large, lnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_ne (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ne (lnan, lnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_le (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_le (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_le (0._large, lnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_le (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_le (lnan, lnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (0._large, lnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (.not. ieee_signaling_lt (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_lt (lnan, lnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ge (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_signaling_ge (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ge (0._large, lnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_ge (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_ge (lnan, lnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (0._large, lnan)) stop 13
+ CHECK_INVALID(.true.)
+ if (ieee_signaling_gt (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_signaling_gt (lnan, lnan)) stop 15
+ CHECK_INVALID(.true.)
+
+ ! Quiet versions
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_eq (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_eq (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (0._large, lnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_eq (lnan, lnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ne (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ne (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (0._large, lnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ne (lnan, lnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_le (0._large, lnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_le (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_le (lnan, lnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (0._large, lnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_lt (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_lt (lnan, lnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ge (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (.not. ieee_quiet_ge (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (0._large, lnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_ge (lnan, lnan)) stop 15
+ CHECK_INVALID(.false.)
+
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0._large, 0._large)) stop 11
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0._large, -0._large)) stop 12
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0._large, lnan)) stop 13
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (0._large, linf)) stop 14
+ CHECK_INVALID(.false.)
+ if (ieee_quiet_gt (lnan, lnan)) stop 15
+ CHECK_INVALID(.false.)
+
+
+end program foo
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index 9c0b9f31730..0f6d17cb243 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -378,6 +378,75 @@ UNORDERED_MACRO(4,4)
end interface
public :: IEEE_FMA
+ ! 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.34.1
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2022-09-02 11:37 FX
2022-09-02 15:37 ` Bernhard Reutner-Fischer
@ 2022-09-17 11:58 ` Mikael Morin
1 sibling, 0 replies; 10+ messages in thread
From: Mikael Morin @ 2022-09-17 11:58 UTC (permalink / raw)
To: FX, Fortran; +Cc: gcc-patches
Le 02/09/2022 à 13:37, FX via Fortran a écrit :
> 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
>
Hello,
the implementation looks good, but the tests lack checks regarding
exception status. This is an important part, I think, and basically
what makes a difference between the quiet and signaling variants.
As the functions are elemental, a few checks with array values would be
nice too.
OK with these additional checks.
Mikael
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2022-09-02 16:03 ` Bernhard Reutner-Fischer
@ 2022-09-02 16:17 ` FX
0 siblings, 0 replies; 10+ messages in thread
From: FX @ 2022-09-02 16:17 UTC (permalink / raw)
To: Bernhard Reutner-Fischer; +Cc: FX via Fortran, gcc-patches
> IIRC there was discussion about abort on the ML some years ago where folks decided to switch to stop N.
> I don't think I participated in that discussion, maybe somebody remembers the reasoning or is able to find the thread.
Found it: https://gcc.gnu.org/legacy-ml/fortran/2018-02/msg00105.html
Will replace those abort calls, then.
FX
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2022-09-02 15:54 ` FX
@ 2022-09-02 16:03 ` Bernhard Reutner-Fischer
2022-09-02 16:17 ` FX
0 siblings, 1 reply; 10+ messages in thread
From: Bernhard Reutner-Fischer @ 2022-09-02 16:03 UTC (permalink / raw)
To: FX; +Cc: FX via Fortran, gcc-patches
On 2 September 2022 17:54:00 CEST, FX <fxcoudert@gmail.com> wrote:
>Hi Bernhard,
>
>> Please do not call the non-standard abort, but use stop N.
>
>Is there a specific reason? It’s a well-documented GNU extension, and it’s useful because it can easily display a backtrace and give line info for the failure, unlike STOP.
>I’ll replace if there is consensus, but apart from aesthetics I don’t see why.
IIRC there was discussion about abort on the ML some years ago where folks decided to switch to stop N.
I don't think I participated in that discussion, maybe somebody remembers the reasoning or is able to find the thread.
thanks,
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2022-09-02 15:37 ` Bernhard Reutner-Fischer
@ 2022-09-02 15:54 ` FX
2022-09-02 16:03 ` Bernhard Reutner-Fischer
0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-09-02 15:54 UTC (permalink / raw)
To: Bernhard Reutner-Fischer; +Cc: FX via Fortran, gcc-patches
Hi Bernhard,
> Please do not call the non-standard abort, but use stop N.
Is there a specific reason? It’s a well-documented GNU extension, and it’s useful because it can easily display a backtrace and give line info for the failure, unlike STOP.
I’ll replace if there is consensus, but apart from aesthetics I don’t see why.
FX
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
2022-09-02 11:37 FX
@ 2022-09-02 15:37 ` Bernhard Reutner-Fischer
2022-09-02 15:54 ` FX
2022-09-17 11:58 ` Mikael Morin
1 sibling, 1 reply; 10+ messages in thread
From: Bernhard Reutner-Fischer @ 2022-09-02 15:37 UTC (permalink / raw)
To: FX, FX via Fortran, Fortran; +Cc: gcc-patches
On 2 September 2022 13:37:41 CEST, FX via Fortran <fortran@gcc.gnu.org> wrote:
>Hi,
Please do not call the non-standard abort, but use stop N.
IIRC I once had a trivial script.. https://www.mail-archive.com/search?l=gcc-patches@gcc.gnu.org&q=subject:%22%5C%5BPATCH%2C+OpenACC%5C%5D+Fortran+deviceptr%22&o=newest&f=1
---8<---
Like (modulo typos, untested):
$ cat abort_to_stop.awk ; echo EOF
# awk -f ./abort_to_stop.awk < foo.f90 > x && mv x foo.f90
BEGIN { IGNORECASE = 1; i = 1 } { while (sub(/call\s\s*abort/, "stop " i)) {let i++;}; print $0; }
EOF
HTH and thanks,
^ permalink raw reply [flat|nested] 10+ messages in thread
* [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons
@ 2022-09-02 11:37 FX
2022-09-02 15:37 ` Bernhard Reutner-Fischer
2022-09-17 11:58 ` Mikael Morin
0 siblings, 2 replies; 10+ messages in thread
From: FX @ 2022-09-02 11:37 UTC (permalink / raw)
To: Fortran; +Cc: gcc-patches
[-- 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
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2023-06-10 15:21 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-06 19:29 [PATCH] Fortran: add IEEE_QUIET_* and IEEE_SIGNALING_* comparisons FX Coudert
2023-06-08 12:26 ` Harald Anlauf
2023-06-08 12:26 ` Harald Anlauf
2023-06-10 15:21 ` FX Coudert
-- strict thread matches above, loose matches on Subject: below --
2022-09-02 11:37 FX
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
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).