[-- 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
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,
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
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,
> 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
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
[-- 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
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
[-- 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