klisp

commit 77b8aa5594386c25f2c3c0df60a081c79b04aee7
parent 9e0abd962529037edaedd2540776801fcdc9a40a
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sun, 20 Mar 2011 02:55:32 -0300

Added =?, <?, <=?, >? & >=? to the ground environment.

Diffstat:
M
src/kgnumbers.c
 | 
84
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
17
+++++++++++++++++
M
src/kground.c
 | 
15
++++++++++++++-
M
src/kobject.h
 | 
2
+-

4 files changed, 116 insertions(+), 2 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -23,6 +23,7 @@
 /* 15.5.1? number?, finite?, integer? */
 /* use ftypep & ftypep_predp */
 
+/* Helpers for typed predicates */
 bool knumberp(TValue obj) { return ttype(obj) <= K_LAST_NUMBER_TYPE; }
 /* obj is known to be a number */
 bool kfinitep(TValue obj) { return (!ttiseinf(obj) && !ttisiinf(obj)); }
@@ -30,4 +31,87 @@ bool kfinitep(TValue obj) { return (!ttiseinf(obj) && !ttisiinf(obj)); }
    inexact integers */
 bool kintegerp(TValue obj) { return ttisfixint(obj); }
 
+/* 12.5.2 =? */
+/* uses typed_bpredp */
+
+/* 12.5.3 <?, <=?, >?, >=? */
+/* use typed_bpredp */
+
+/* Helpers for typed binary predicates */
+/* XXX: this should probably be in a file knumber.h but there is no real need for 
+   that file yet */
+
+/* this will come handy when there are more numeric types,
+   it is intended to be used in switch */
+inline int32_t max_ttype(TValue obj1, TValue obj2)
+{
+    int32_t t1 = ttype(obj1);
+    int32_t t2 = ttype(obj2);
+
+    return (t1 > t2? t1 : t2);
+}
+
+/* TEMP: for now only fixints and exact infinities */
+bool knum_eqp(TValue n1, TValue n2) { return tv_equal(n1, n2); }
+bool knum_ltp(TValue n1, TValue n2) 
+{ 
+    switch(max_ttype(n1, n2)) {
+    case K_TFIXINT:
+	return ivalue(n1) < ivalue(n2);
+    case K_TEINF:
+	return !tv_equal(n1, n2) && (tv_equal(n1, KEMINF) ||
+				     tv_equal(n2, KEPINF));
+    default:
+	/* shouldn't happen */
+	assert(0);
+	return false;
+    }
+}
+
+bool knum_lep(TValue n1, TValue n2)
+{ 
+    switch(max_ttype(n1, n2)) {
+    case K_TFIXINT:
+	return ivalue(n1) <= ivalue(n2);
+    case K_TEINF:
+	return tv_equal(n1, n2) || tv_equal(n1, KEMINF) || 
+	    tv_equal(n2, KEPINF);
+    default:
+	/* shouldn't happen */
+	assert(0);
+	return false;
+    }
+}
+
+bool knum_gtp(TValue n1, TValue n2)
+{ 
+    switch(max_ttype(n1, n2)) {
+    case K_TFIXINT:
+	return ivalue(n1) > ivalue(n2);
+    case K_TEINF:
+	return !tv_equal(n1, n2) && (tv_equal(n1, KEPINF) ||
+				     tv_equal(n2, KEMINF));
+    default:
+	/* shouldn't happen */
+	assert(0);
+	return false;
+    }
+}
+
+bool knum_gep(TValue n1, TValue n2)
+{ 
+    switch(max_ttype(n1, n2)) {
+    case K_TFIXINT:
+	return ivalue(n1) >= ivalue(n2);
+    case K_TEINF:
+	return tv_equal(n1, n2) || tv_equal(n1, KEPINF) ||
+	    tv_equal(n2, KEMINF);
+    default:
+	/* shouldn't happen */
+	assert(0);
+	return false;
+    }
+}
+
+
 
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -28,4 +28,21 @@ bool knumberp(TValue obj);
 bool kfinitep(TValue obj);
 bool kintegerp(TValue obj);
 
+
+/* 12.5.2 =? */
+/* uses typed_bpredp */
+
+/* 12.5.3 <?, <=?, >?, >=? */
+/* use typed_bpredp */
+
+/* Helpers for typed binary predicates */
+/* XXX: this should probably be in a file knumber.h but there is no real need for 
+   that file yet */
+bool knum_eqp(TValue n1, TValue n2);
+bool knum_ltp(TValue n1, TValue n2);
+bool knum_lep(TValue n1, TValue n2);
+bool knum_gtp(TValue n1, TValue n2);
+bool knum_gep(TValue n1, TValue n2);
+
+
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -483,7 +483,7 @@ void kinit_ground_env(klisp_State *K)
     ** 12.5 Number features
     */
 
-    /* 12.5.1? number?, finite?, integer? */
+    /* 12.5.1 number?, finite?, integer? */
     add_applicative(K, ground_env, "number?", ftypep, 2, symbol, 
 		    p2tv(knumberp));
     add_applicative(K, ground_env, "finite?", ftyped_predp, 3, symbol, 
@@ -491,6 +491,19 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "integer?", ftypep, 2, symbol, 
 		    p2tv(kintegerp));
 
+    /* 12.5.2 =? */
+    add_applicative(K, ground_env, "=?", ftyped_bpredp, 3,
+		    symbol, p2tv(knumberp), p2tv(knum_eqp));
+    
+    /* 12.5.3 <?, <=?, >?, >=? */
+    add_applicative(K, ground_env, "<?", ftyped_bpredp, 3,
+		    symbol, p2tv(knumberp), p2tv(knum_ltp));
+    add_applicative(K, ground_env, "<=?", ftyped_bpredp, 3,
+		    symbol, p2tv(knumberp),  p2tv(knum_lep));
+    add_applicative(K, ground_env, ">?", ftyped_bpredp, 3,
+		    symbol, p2tv(knumberp), p2tv(knum_gtp));
+    add_applicative(K, ground_env, ">=?", ftyped_bpredp, 3,
+		    symbol, p2tv(knumberp), p2tv(knum_gep));
 
     /* ... TODO */
 
diff --git a/src/kobject.h b/src/kobject.h
@@ -127,7 +127,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
 #define K_TPORT         39
 
 /* this is used to test for numbers, as returned by ttype */
-#define K_LAST_NUMBER_TYPE K_TIINF
+#define K_LAST_NUMBER_TYPE K_TCOMPLEX
 
 #define K_MAKE_VTAG(t) (K_TAG_TAGGED | (t))