klisp

commit 28bb5650b30f2e830473715f3e1fc714beac9929
parent d39ed8fe1e0e487000b793bfe324988d1c1747ae
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 18 Mar 2011 17:19:20 -0300

Added all char comparison predicates (both case significant and case insignificant).
Char section is complete

Diffstat:
M
src/kgchars.c
 | 
31
+++++++++++++++++++++++++++----
M
src/kgchars.h
 | 
23
+++++++++++++++++++----
M
src/kground.c
 | 
24
++++++++++++++++++++----

3 files changed, 66 insertions(+), 12 deletions(-)
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -92,13 +92,36 @@ void kchar_downcase(klisp_State *K, TValue *xparams, TValue ptree,
 }
 
 /* 14.2.1? char=? */
-/* TODO */
+/* uses ftyped_bpredp */
 
 /* 14.2.2? char<?, char<=?, char>?, char>=? */
-/* TODO */
+/* use ftyped_bpredp */
 
 /* 14.2.3? char-ci=? */
-/* TODO */
+/* uses ftyped_bpredp */
 
 /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
-/* TODO */
+/* use ftyped_bpredp */
+
+/* Helpers for binary typed predicates */
+bool kchar_eqp(TValue ch1, TValue ch2) { return chvalue(ch1) == chvalue(ch2); }
+bool kchar_ltp(TValue ch1, TValue ch2) { return chvalue(ch1) <  chvalue(ch2); }
+bool kchar_lep(TValue ch1, TValue ch2) { return chvalue(ch1) <= chvalue(ch2); }
+bool kchar_gtp(TValue ch1, TValue ch2) { return chvalue(ch1) >  chvalue(ch2); }
+bool kchar_gep(TValue ch1, TValue ch2) { return chvalue(ch1) >= chvalue(ch2); }
+
+bool kchar_ci_eqp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) == tolower(chvalue(ch2)); }
+
+bool kchar_ci_ltp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) <  tolower(chvalue(ch2)); }
+
+bool kchar_ci_lep(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) <= tolower(chvalue(ch2)); }
+
+bool kchar_ci_gtp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) > tolower(chvalue(ch2)); }
+
+bool kchar_ci_gep(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) >= tolower(chvalue(ch2)); }
+
diff --git a/src/kgchars.h b/src/kgchars.h
@@ -50,15 +50,30 @@ void kchar_downcase(klisp_State *K, TValue *xparams, TValue ptree,
 		    TValue denv);
 
 /* 14.2.1? char=? */
-/* TODO */
+/* uses ftyped_bpredp */
 
 /* 14.2.2? char<?, char<=?, char>?, char>=? */
-/* TODO */
+/* use ftyped_bpredp */
 
 /* 14.2.3? char-ci=? */
-/* TODO */
+/* uses ftyped_bpredp */
 
 /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
-/* TODO */
+/* use ftyped_bpredp */
+
+/* Helpers for typed binary predicates */
+/* XXX: this should probably be in a file kchar.h but there is no real need for 
+   that file yet */
+bool kchar_eqp(TValue ch1, TValue ch2);
+bool kchar_ltp(TValue ch1, TValue ch2);
+bool kchar_lep(TValue ch1, TValue ch2);
+bool kchar_gtp(TValue ch1, TValue ch2);
+bool kchar_gep(TValue ch1, TValue ch2);
+
+bool kchar_ci_eqp(TValue ch1, TValue ch2);
+bool kchar_ci_ltp(TValue ch1, TValue ch2);
+bool kchar_ci_lep(TValue ch1, TValue ch2);
+bool kchar_ci_gtp(TValue ch1, TValue ch2);
+bool kchar_ci_gep(TValue ch1, TValue ch2);
 
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -523,16 +523,32 @@ void kinit_ground_env(klisp_State *K)
     */
 
     /* 14.2.1? char=? */
-    /* TODO */
+    add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_eqp));
 
     /* 14.2.2? char<?, char<=?, char>?, char>=? */
-    /* TODO */
+    add_applicative(K, ground_env, "char<?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_ltp));
+    add_applicative(K, ground_env, "char<=?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp),  p2tv(kchar_lep));
+    add_applicative(K, ground_env, "char>?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_gtp));
+    add_applicative(K, ground_env, "char>=?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_gep));
 
     /* 14.2.3? char-ci=? */
-    /* TODO */
+    add_applicative(K, ground_env, "char-ci=?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_ci_eqp));
 
     /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
-    /* TODO */
+    add_applicative(K, ground_env, "char-ci<?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_ci_ltp));
+    add_applicative(K, ground_env, "char-ci<=?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp),  p2tv(kchar_ci_lep));
+    add_applicative(K, ground_env, "char-ci>?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
+    add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3,
+		    symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
 
     /*
     **