diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-07-26 20:46:07 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-07-26 20:46:07 -0700 |
| commit | 16abe7b771f09846e0769302bc5cc9c9ad28ce27 (patch) | |
| tree | 2d89406e060b7db66186554d11d90dd8670f924d /arith.c | |
| parent | adf06aa46d7a4151ce4145d01ec1b9dcdb085338 (diff) | |
| download | txr-16abe7b771f09846e0769302bc5cc9c9ad28ce27.tar.gz txr-16abe7b771f09846e0769302bc5cc9c9ad28ce27.tar.bz2 txr-16abe7b771f09846e0769302bc5cc9c9ad28ce27.zip | |
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.
Diffstat (limited to 'arith.c')
| -rw-r--r-- | arith.c | 29 |
1 files changed, 29 insertions, 0 deletions
@@ -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) |