klisp

commit f02a11015371ea0dd91da1df3cadc23396767375
parent e85e28e4b95eb621096b8d43f650f048363c8049
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 19 May 2011 03:35:59 -0300

Added support for inexact reals to all the rounding applicatives.

Diffstat:
M
src/kgnumbers.c
 | 
7
+++++++
M
src/kreal.c
 | 
29
+++++++++++++++++++++++++++++
M
src/kreal.h
 | 
3
+++

3 files changed, 39 insertions(+), 0 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -744,9 +744,16 @@ TValue knum_real_to_integer(klisp_State *K, TValue n, kround_mode mode)
 	return n; /* integers are easy */
     case K_TBIGRAT:
 	return kbigrat_to_integer(K, n, mode);
+    case K_TDOUBLE:
+	return kdouble_to_integer(K, n, mode);
     case K_TEINF: 
 	klispE_throw_simple(K, "infinite value");
 	return KINERT;
+    case K_TIINF: 
+	klispE_throw_simple(K, "infinite value");
+	return KINERT;
+    case K_TUNDEFINED:
+	/* undefined in not a real, shouldn't get here, fall through */
     default:
 	klispE_throw_simple(K, "unsupported type");
 	return KINERT;
diff --git a/src/kreal.c b/src/kreal.c
@@ -10,6 +10,7 @@
 #include <inttypes.h>
 #include <ctype.h> 
 #include <math.h>
+#include <fenv.h> /* for setting round direction */
 
 #include "kreal.h"
 #include "krational.h"
@@ -712,3 +713,31 @@ double kdouble_div0_mod0(double n, double d, double *res_mod)
     *res_mod = mod;
     return div;
 }
+
+TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode)
+{
+    double d = dvalue(tv_double);
+    switch(mode) {
+    case K_TRUNCATE: 
+	d = trunc(d);
+	break;
+    case K_CEILING:
+	d = ceil(d);
+	break;
+    case K_FLOOR:
+	d = floor(d);
+	break;
+    case K_ROUND_EVEN: {
+	int res = fesetround(FE_TONEAREST); /* REFACTOR: should be done once only... */
+	klisp_assert(res == 0);
+	d = nearbyint(d);
+    }
+    }
+    /* ASK John: we currently return inexact if given inexact is this ok?
+       or should it return an exact integer? */
+    return ktag_double(d);
+#if 0    
+    tv_double = ktag_double(d); /* won't alloc mem so no need to root */
+    return kinexact_to_exact(K, tv_double); 
+#endif
+}
diff --git a/src/kreal.h b/src/kreal.h
@@ -14,6 +14,7 @@
 #include "kobject.h"
 #include "kstate.h"
 #include "kinteger.h"
+#include "krational.h"
 #include "imrat.h"
 
 /* REFACTOR rename. These can take any real, but
@@ -25,6 +26,8 @@ TValue kinexact_to_exact(klisp_State *K, TValue n);
 double kdouble_div_mod(double n, double d, double *res_mod);
 double kdouble_div0_mod0(double n, double d, double *res_mod);
 
+TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode);
+
 /*
 ** read/write interface 
 */