klisp

commit 9b7e91e97554f09bfa016cc1bc39343b413ed4b3
parent 6a422ae614b1c784cbe8a6e3408d6c1a571c5f57
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Mon, 25 Apr 2011 18:03:33 -0300

Added floor, ceiling, truncate & round.

Diffstat:
M
src/kgnumbers.c
 | 
35
++++++++++++++++++++++++++++++++++-
M
src/kgnumbers.h
 | 
3
++-
M
src/kground.c
 | 
9
++++++++-
M
src/krational.c
 | 
43
+++++++++++++++++++++++++++++++++++++++++++
M
src/krational.h
 | 
8
+++-----

5 files changed, 90 insertions(+), 8 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -426,6 +426,24 @@ TValue knum_denominator(klisp_State *K, TValue n)
     }
 }
 
+/* GC: assumes n is rooted */
+TValue knum_real_to_integer(klisp_State *K, TValue n, kround_mode mode)
+{
+    switch(ttype(n)) {
+    case K_TFIXINT:
+    case K_TBIGINT:
+	return n; /* integers are easy */
+    case K_TBIGRAT:
+	return kbigrat_to_integer(K, n, mode);
+    case K_TEINF: 
+	klispE_throw(K, "round: infinite value");
+	return KINERT;
+    default:
+	klispE_throw(K, "denominator: unsopported type");
+	return KINERT;
+    }
+}
+
 /* 12.5.4 + */
 void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 {
@@ -1103,7 +1121,22 @@ void kdenominator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 }
 
 /* 12.8.4 floor, ceiling, truncate, round */
-/* TODO */
+void kreal_to_integer(klisp_State *K, TValue *xparams, TValue ptree, 
+		      TValue denv)
+{
+    /*
+    ** xparams[0]: symbol name
+    ** xparams[1]: bool: true min, false max
+    */
+    UNUSED(denv);
+    char *name = ksymbol_buf(xparams[0]);
+    kround_mode mode = (kround_mode) ivalue(xparams[1]);
+    
+    bind_1tp(K, name, ptree, "real", krealp, n);
+
+    TValue res = knum_real_to_integer(K, n, mode);
+    kapply_cc(K, res);
+}
 
 /* 12.8.5 rationalize, simplest-rational */
 /* TODO */
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -122,7 +122,8 @@ void knumerator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 void kdenominator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 12.8.4 floor, ceiling, truncate, round */
-/* TODO */
+void kreal_to_integer(klisp_State *K, TValue *xparams, TValue ptree, 
+		      TValue denv);
 
 /* 12.8.5 rationalize, simplest-rational */
 /* TODO */
diff --git a/src/kground.c b/src/kground.c
@@ -747,7 +747,14 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "denominator", kdenominator, 0);
 
     /* 12.8.4 floor, ceiling, truncate, round */
-    /* TODO */
+    add_applicative(K, ground_env, "floor", kreal_to_integer, 2,
+		    symbol, i2tv((int32_t) K_FLOOR));
+    add_applicative(K, ground_env, "ceiling", kreal_to_integer, 2,
+		    symbol, i2tv((int32_t) K_CEILING));
+    add_applicative(K, ground_env, "truncate", kreal_to_integer, 2,
+		    symbol, i2tv((int32_t) K_TRUNCATE));
+    add_applicative(K, ground_env, "round", kreal_to_integer, 2,
+		    symbol, i2tv((int32_t) K_ROUND_EVEN));
 
     /* 12.8.5 rationalize, simplest-rational */
     /* TODO */
diff --git a/src/krational.c b/src/krational.c
@@ -257,3 +257,46 @@ TValue kbigrat_denominator(klisp_State *K, TValue tv_bigrat)
 	return kbigint_try_fixint(K, copy);
     }
 }
+
+TValue kbigrat_to_integer(klisp_State *K, TValue tv_bigrat, kround_mode mode)
+{
+    /* do an usigned divide first */
+    TValue tv_quot = kbigint_make_simple(K);
+    krooted_tvs_push(K, tv_quot);
+    TValue tv_rest = kbigint_make_simple(K);
+    krooted_tvs_push(K, tv_rest);
+    Bigint *quot = tv2bigint(tv_quot);
+    Bigint *rest = tv2bigint(tv_rest);
+    Bigrat *n = tv2bigrat(tv_bigrat);
+
+    UNUSED(mp_int_abs(K, MP_NUMER_P(n), quot));
+    UNUSED(mp_int_div(K, quot, MP_DENOM_P(n), quot, rest));
+
+    if (mp_rat_compare_zero(n) < 0)
+	UNUSED(mp_int_neg(K, quot, quot));
+
+    switch(mode) {
+    case K_TRUNCATE: 
+	/* nothing needs to be done */
+	break;
+    case K_CEILING:
+	if (mp_rat_compare_zero(n) > 0 && mp_int_compare_zero(rest) != 0)
+	    UNUSED(mp_int_add_value(K, quot, 1, quot));
+	break;
+    case K_FLOOR:
+	if (mp_rat_compare_zero(n) < 0 && mp_int_compare_zero(rest) != 0)
+	    UNUSED(mp_int_sub_value(K, quot, 1, quot));
+	break;
+    case K_ROUND_EVEN:
+	UNUSED(mp_int_mul_pow2(K, rest, 1, rest));
+	if (mp_int_compare(rest, MP_DENOM_P(n)) == 0 &&
+	     mp_int_is_odd(quot))
+	    UNUSED(mp_int_add_value(K, quot, mp_rat_compare_zero(n) < 0? 
+				    -1 : 1, quot));
+	break;
+    }
+
+    krooted_tvs_pop(K);
+    krooted_tvs_pop(K);
+    return kbigint_try_fixint(K, tv_quot);
+}
diff --git a/src/krational.h b/src/krational.h
@@ -167,12 +167,10 @@ TValue kbigrat_numerator(klisp_State *K, TValue tv_bigrat);
 TValue kbigrat_denominator(klisp_State *K, TValue tv_bigrat);
 
 /* TODO implement these */
-#if 0
-TValue kbigrat_floor(klisp_State *K, TValue n1, TValue n2);
-TValue kbigrat_ceiling(klisp_State *K, TValue n1, TValue n2);
-TValue kbigrat_truncate(klisp_State *K, TValue n1, TValue n2);
-TValue kbigrat_round(klisp_State *K, TValue n1, TValue n2);
+typedef enum { K_FLOOR, K_CEILING, K_TRUNCATE, K_ROUND_EVEN } kround_mode;
+TValue kbigrat_to_integer(klisp_State *K, TValue tv_bigrat, kround_mode mode);
 
+#if 0
 TValue kbigrat_simplest_rational(klisp_State *K, TValue n1, TValue n2);
 TValue kbigrat_rationalize(klisp_State *K, TValue n1, TValue n2);
 #endif