feature: support for floating-point rounding control.

* arith.c (flo_get_round_mode, flo_set_round_mode): New
functions.
(arith_init): Register global lexical variables flo-near,
flo-down, flo-up and flo-zero.
Register flo-get-round-mode and flo-set-round-mode intrinsic
functions.

* configure: Test for fesetround and fegetround variables,
and the associated constants, prpoducing a HAVE_ROUNDING_CTL_H
variable in config.h.

* txr.1: Documented new variables and functions.

3 files changed, 135 insertions, 0 deletions

diff --git a/arith.c b/arith.c
index 7731558d..7b02863a 100644
--- a/arith.c
+++ b/arith.c
@@ -36,12 +36,16 @@
 #include <ctype.h>
 #include <float.h>
 #include "config.h"
+#if HAVE_ROUNDING_CTL_H
+#include <fenv.h>
+#endif
 #include "lib.h"
 #include "signal.h"
 #include "unwind.h"
 #include "gc.h"
 #include "args.h"
 #include "eval.h"
+#include "itypes.h"
 #include "arith.h"
 
 #define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B))
@@ -3122,6 +3126,20 @@ val rpoly(val x, val seq)
   return acc;
 }
 
+#if HAVE_ROUNDING_CTL_H
+
+static val flo_get_round_mode(void)
+{
+  return num(fegetround());
+}
+
+static val flo_set_round_mode(val mode)
+{
+  return tnil(!fesetround(c_int(mode, lit("flo-set-round-mode"))));
+}
+
+#endif
+
 void arith_init(void)
 {
   mp_init(&NUM_MAX_MP);
@@ -3165,6 +3183,17 @@ void arith_init(void)
   reg_fun(intern(lit("digits"), user_package), func_n2o(digits, 1));
   reg_fun(intern(lit("poly"), user_package), func_n2(poly));
   reg_fun(intern(lit("rpoly"), user_package), func_n2(rpoly));
+
+#if HAVE_ROUNDING_CTL_H
+  reg_varl(intern(lit("flo-near"), user_package), num(FE_TONEAREST));
+  reg_varl(intern(lit("flo-down"), user_package), num(FE_DOWNWARD));
+  reg_varl(intern(lit("flo-up"), user_package), num(FE_UPWARD));
+  reg_varl(intern(lit("flo-zero"), user_package), num(FE_TOWARDZERO));
+  reg_fun(intern(lit("flo-get-round-mode"), user_package),
+          func_n0(flo_get_round_mode));
+  reg_fun(intern(lit("flo-set-round-mode"), user_package),
+          func_n1(flo_set_round_mode));
+#endif
 }
 
 void arith_free_all(void)
diff --git a/configure b/configure
index 809c4553..f50b757f 100755
--- a/configure
+++ b/configure
@@ -1392,6 +1392,32 @@ if ! [ $have_dbl_decimal_dig ] ; then
 fi
 
 #
+# Rounding mode control.
+#
+
+printf "Checking for fesetround and fegetround ... "
+
+cat > conftest.c <<!
+#include <fenv.h>
+
+int main(void)
+{
+  int mode = fegetround();
+  fesetround(FE_TONEAREST);
+  fesetround(FE_DOWNWARD);
+  fesetround(FE_UPWARD);
+  fesetround(FE_TOWARDZERO);
+  return 0;
+}
+!
+if conftest ; then
+  printf "yes\n"
+  printf "#define HAVE_ROUNDING_CTL_H 1\n" >> config.h
+else
+  printf "no\n"
+fi
+
+#
 # Valgrind
 #
 
diff --git a/txr.1 b/txr.1
index 3ce1e037..a7d26791 100644
--- a/txr.1
+++ b/txr.1
@@ -35991,6 +35991,86 @@ benefits from ordering the operations on multiple integer operands
 according to the magnitudes of those operands. The function provides an
 estimate of magnitude which trades accuracy for efficiency.
 
+.coNP Variables @, flo-near @, flo-down @ flo-up and @ flo-zero
+.desc
+These variables hold integer values suitable as arguments to the
+.code flo-set-round-mode
+function, which controls the rounding mode for the results of floating-point
+operations.  These variables are only defined on platforms which support
+rounding control.
+
+Their values have the following meanings:
+.RS
+.coIP flo-near
+Round to nearest: the result of an operation is rounded to the nearest
+representable value.
+.coIP flo-down
+Round down: the result of an operation is rounded to the nearest representable
+value that lies in the direction of negative infinity.
+.coIP flo-up
+Round up: the result of an operation is rounded to the nearest representable
+value that lies in the direction of positive infinity.
+.coIP flo-up
+Round to zero: the result of an operation is rounded to the nearest
+representable value that lies in the direction of zero.
+.RE
+.IP
+
+.coNP Functions @ flo-get-round-mode and @ flo-set-round-mode
+.synb
+.mets (flo-get-round-mode)
+.mets (flo-set-round-mode << mode )
+.syne
+.desc
+Sometimes floating-point operations produce a result which
+requires more bits of precision than the floating point representation
+can provide. A representable floating-point value must be substituted
+for the true result and yielded by the operation.
+
+On platforms which support rounding control, these functions are provided for
+selecting the decision procedure by which the floating-point representation
+is taken.
+
+The
+.code flo-get-round-mode
+returns the current rounding mode. The rounding mode is represented by
+an integer value which is either equal to one of the four variables
+.codn flo-near ,
+.codn flo-down ,
+.code flo-up
+and
+.codn flo-zero ,
+or else some other value specific to the host environment. Initially,
+the value is that of
+.codn flo-near .
+Otherwise, the value returned is that which was stored by the most
+recent successful call to
+.codn flo-set-round-mode .
+
+The
+.code flo-set-round-mode
+function changes the rounding mode. The argument to its
+.meta mode
+parameter may be the value of one of the above four variables,
+or else some other value supported by the host environment's
+.code fesetround
+C library function.
+
+The
+.code flo-set-round-mode
+function returns
+.code t
+if it is successful, otherwise the return value is
+.code nil
+and the rounding mode is not changed.
+
+If a value is is passed to
+.code flo-set-round-mode
+which is not the value of one of the above
+four rounding mode variables, and the function succeeds anyway, then the
+rounding behavior of floating-point operations depends on the host
+environment's interpretation of that value.
+
 .SS* Bit Operations
 In \*(TL, similarly to Common Lisp, bit operations on integers are based
 on a concept that might be called "infinite two's-complement".