klisp

commit a282ea6adf94a701c0d8dff48a60939bc70dba33
parent 9bde851711b37bca2efd775d6d5d37015d152413
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 25 Nov 2011 15:14:16 -0300

Added char-foldcase (r7rs) and char-titlecase to the ground environment.

Diffstat:
M
TODO
 | 
7
++++++-
M
src/kgchars.c
 | 
38
++++++++++++++++----------------------
M
src/tests/characters.k
 | 
12
+++++++++++-

3 files changed, 33 insertions(+), 24 deletions(-)
diff --git a/TODO b/TODO
@@ -32,7 +32,6 @@
 * applicatives: 
 ** vector-map (r7rs)
 ** bytevector-map (r7rs)
-** char-foldcase (r7rs)
 ** string-map (r7rs)
 ** string-downcase (r7rs)
 ** string-foldcase (r7rs)
@@ -47,6 +46,9 @@
 ** number->string (r7rs)
 ** string->number (r7rs)
 ** define-record-type (r7rs)
+** char-digit?
+** digit->char
+** char->digit
 * reader
 ** symbol escapes (r7rs)
 ** string escapes (r7rs)
@@ -59,4 +61,7 @@
 ** add restart support to the repl/interpreter (r7rs)
 ** simple modules (something inspired in r7rs) (r7rs)
 ** add modules support to the interpreter (r7rs)
+** eager comprehensions (at least for check.k) see SRFIs 42 and 78
+   (srfi)
+
 
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -76,33 +76,21 @@ void kinteger_to_char(klisp_State *K)
     kapply_cc(K, ch2tv((char) i));
 }
 
-/* REFACTOR merge with downcase and future foldcase */
-/* 14.1.4? char-upcase, char-downcase */
-void kchar_upcase(klisp_State *K)
+/* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */
+void kchar_change_case(klisp_State *K)
 {
     TValue *xparams = K->next_xparams;
     TValue ptree = K->next_value;
     TValue denv = K->next_env;
     klisp_assert(ttisenvironment(K->next_env));
-    UNUSED(xparams);
-    UNUSED(denv);
-    bind_1tp(K, ptree, "character", ttischar, chtv);
-    char ch = chvalue(chtv);
-    ch = toupper(ch);
-    kapply_cc(K, ch2tv(ch));
-}
-
-void kchar_downcase(klisp_State *K)
-{
-    TValue *xparams = K->next_xparams;
-    TValue ptree = K->next_value;
-    TValue denv = K->next_env;
-    klisp_assert(ttisenvironment(K->next_env));
-    UNUSED(xparams);
+    /*
+    ** xparams[0]: conversion fn
+    */
     UNUSED(denv);
     bind_1tp(K, ptree, "character", ttischar, chtv);
     char ch = chvalue(chtv);
-    ch = tolower(ch);
+    char (*fn)(char) = pvalue(xparams[0]);
+    ch = fn(ch);
     kapply_cc(K, ch2tv(ch));
 }
 
@@ -175,9 +163,15 @@ void kinit_chars_ground_env(klisp_State *K)
     /* 14.1.4? char->integer, integer->char */
     add_applicative(K, ground_env, "char->integer", kchar_to_integer, 0);
     add_applicative(K, ground_env, "integer->char", kinteger_to_char, 0);
-    /* 14.1.4? char-upcase, char-downcase */
-    add_applicative(K, ground_env, "char-upcase", kchar_upcase, 0);
-    add_applicative(K, ground_env, "char-downcase", kchar_downcase, 0);
+    /* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */
+    add_applicative(K, ground_env, "char-upcase", kchar_change_case, 1,
+		    p2tv(toupper));
+    add_applicative(K, ground_env, "char-downcase", kchar_change_case, 1,
+		    p2tv(tolower));
+    add_applicative(K, ground_env, "char-titlecase", kchar_change_case, 1,
+		    p2tv(toupper));
+    add_applicative(K, ground_env, "char-foldcase", kchar_change_case, 1,
+		    p2tv(tolower));
     /* 14.2.1? char=? */
     add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3,
 		    symbol, p2tv(kcharp), p2tv(kchar_eqp));
diff --git a/src/tests/characters.k b/src/tests/characters.k
@@ -73,7 +73,7 @@
 ($check-predicate (char-lower-case? #\a #\b #\j #\y #\z))
 ($check-predicate ($false-for-all? char-lower-case? #\0 #\A #\Z #\' #\@ #\{ #\[ #\~))
 
-;; XXX char-upcase char-downcase
+;; XXX char-upcase char-downcase char-titlecase char-foldcase
 
 ($check equal? (char-upcase #\a) #\A)
 ($check equal? (char-upcase #\z) #\Z)
@@ -85,6 +85,16 @@
 ($check equal? (char-downcase #\r) #\r)
 ($check equal? (char-downcase #\9) #\9)
 
+($check equal? (char-titlecase #\a) #\A)
+($check equal? (char-titlecase #\z) #\Z)
+($check equal? (char-titlecase #\R) #\R)
+($check equal? (char-titlecase #\2) #\2)
+
+($check equal? (char-foldcase #\A) #\a)
+($check equal? (char-foldcase #\Z) #\z)
+($check equal? (char-foldcase #\r) #\r)
+($check equal? (char-foldcase #\9) #\9)
+
 ;; XXX char->integer integer->char
 
 ($check equal? (char->integer #\space) #x20)