Add last-resort implementation for POSIX::FLT_ROUNDS.

POSIX::FLT_ROUNDS now emulates (more) standard behavior that
reflects the current rounding mode set by fesetround(),
even when compiled with GCC whose FLT_ROUNDS is wrongly fixed to 1.

Also add tests for this.

2 files changed, 72 insertions, 1 deletions

diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index bd6d12e512..0f004cbbcf 100644
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -1017,6 +1017,11 @@ static NV my_log2(NV x)
 
 /* XXX nexttoward */
 
+/* GCC's FLT_ROUNDS is (wrongly) hardcoded to 1 (at least up to 11.x) */
+#if defined(PERL_IS_GCC) /* && __GNUC__ < XXX */
+#  define BROKEN_FLT_ROUNDS
+#endif
+
 static int my_fegetround()
 {
 #ifdef HAS_FEGETROUND
@@ -2516,8 +2521,26 @@ fegetround()
 #endif
             break;
         case 1:
-#ifdef FLT_ROUNDS
+#if defined(FLT_ROUNDS) && !defined(BROKEN_FLT_ROUNDS)
             RETVAL = FLT_ROUNDS;
+#elif defined(HAS_FEGETROUND) || defined(HAS_FPGETROUND) || defined(__osf__)
+            switch (my_fegetround()) {
+                /* C standard seems to say that each of the FE_* macros is
+                   defined if and only if the implementation supports it. */
+#  ifdef FE_TOWARDZERO
+            case FE_TOWARDZERO: RETVAL = 0;  break;
+#  endif
+#  ifdef FE_TONEAREST
+            case FE_TONEAREST:  RETVAL = 1;  break;
+#  endif
+#  ifdef FE_UPWARD
+            case FE_UPWARD:     RETVAL = 2;  break;
+#  endif
+#  ifdef FE_DOWNWARD
+            case FE_DOWNWARD:   RETVAL = 3;  break;
+#  endif
+            default:            RETVAL = -1; break;
+            }
 #else
             RETVAL = -1;
             not_here("FLT_ROUNDS");
diff --git a/ext/POSIX/t/fenv.t b/ext/POSIX/t/fenv.t
new file mode 100644
index 0000000000..11f62b3ca4
--- /dev/null
+++ b/ext/POSIX/t/fenv.t
@@ -0,0 +1,48 @@
+#! ./perl -w
+
+# These tests are in a separate .t file, because they may change
+# execution environment of the perl process.
+
+use strict;
+use warnings;
+
+use Test::More;
+use POSIX qw/:fenv_h :float_h/;
+
+my $defmode;
+plan skip_all => 'fegetround is unavailable'
+    unless eval { $defmode = fegetround(); 1 };
+
+ok(defined $defmode, 'fegetround');
+
+SKIP: {
+    skip 'default rounding mode is not FE_TONEAREST', 1
+        unless eval { $defmode == FE_TONEAREST() };
+    my $flt_rounds;
+    skip 'FLT_ROUNDS is unavailable', 1
+        unless eval { $flt_rounds = FLT_ROUNDS(); 1 };
+    cmp_ok($flt_rounds, '==', 1, 'FLT_ROUNDS');
+}
+
+cmp_ok(fesetround($defmode), '==', 0, 'fesetround');
+cmp_ok(fegetround(), '==', $defmode, 'fesetround/fegetround round-trip');
+
+my @rounding = qw/TOWARDZERO TONEAREST UPWARD DOWNWARD/;
+
+for (my $i = 0; $i < @rounding; $i++) {
+  SKIP: {
+      my $macro = "FE_$rounding[$i]";
+      my $femode = eval "$macro()";
+      skip "no support for FE_$rounding[$i]", 3
+          unless defined $femode;
+
+      cmp_ok(fesetround($femode), '==', 0, "fesetround($macro)");
+      cmp_ok(fegetround(), '==', $femode, "fegetround() under $macro");
+      cmp_ok(FLT_ROUNDS, '==', $i, "FLT_ROUNDS under $macro");
+    }
+}
+
+# Revert to default rounding mode
+fesetround($defmode);
+
+done_testing();