klisp

commit 5df4b078b2cabb036c3f43792504d6ea0577c148
parent f5468caaf5f5aad02fb5b71204cab9880a6d7c98
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri,  6 May 2011 11:50:11 -0300

Added get-real-internal-primary & get-real-exact-primary to the ground environment.

Diffstat:
M
src/kgnumbers.c
 | 
33
+++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
5
++++-
M
src/kground.c
 | 
5
++++-

3 files changed, 41 insertions(+), 2 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -1146,6 +1146,39 @@ void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
     kapply_cc(K, res);
 }
 
+/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
+void kget_real_internal_primary(klisp_State *K, TValue *xparams, 
+				TValue ptree, TValue denv)
+{
+    bind_1tp(K, ptree, "real", krealp, tv_n);
+    /* TEMP: do it here directly */
+    if (ttisrwnpv(tv_n)) {
+	klispE_throw_simple_with_irritants(K, "no primary value", 1, tv_n);
+	return; 
+    } else {
+	kapply_cc(K, tv_n);
+    }
+}
+
+void kget_real_exact_primary(klisp_State *K, TValue *xparams, 
+			     TValue ptree, TValue denv)
+{
+    bind_1tp(K, ptree, "real", krealp, tv_n);
+    /* TEMP: do it here directly, for now all inexact objects have
+     [-inf, +inf] bounds, when bounded reals are implemented this
+    should take care to round the min towards -inf and the max towards
+    +inf when converting to exact */
+    TValue res;
+    if (ttisrwnpv(tv_n)) {
+	klispE_throw_simple_with_irritants(K, "no primary value", 1, tv_n);
+	return;
+    } else if (ttisexact(tv_n)) {
+	res = tv_n;
+    } else {
+	res = kinexact_to_exact(K, tv_n);
+    }
+    kapply_cc(K, res);
+}
 
 /* 12.8.1 rational? */
 /* uses ftypep */
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -125,7 +125,10 @@ void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
 			       TValue denv);
 
 /* 12.6.3 get-real-internal-primary, get-real-exact-primary */
-/* TODO */
+void kget_real_internal_primary(klisp_State *K, TValue *xparams, 
+				TValue ptree, TValue denv);
+void kget_real_exact_primary(klisp_State *K, TValue *xparams, 
+			     TValue ptree, TValue denv);
 
 /* 12.6.4 make-inexact */
 /* TODO */
diff --git a/src/kground.c b/src/kground.c
@@ -820,7 +820,10 @@ void kinit_ground_env(klisp_State *K)
 		    kget_real_exact_bounds, 0);
 
     /* 12.6.3 get-real-internal-primary, get-real-exact-primary */
-    /* TODO */
+    add_applicative(K, ground_env, "get-real-internal-primary", 
+		    kget_real_internal_primary, 0);
+    add_applicative(K, ground_env, "get-real-exact-primary", 
+		    kget_real_exact_primary, 0);
 
     /* 12.6.4 make-inexact */
     /* TODO */