klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
MTODO | 7++++++-
Msrc/kgchars.c | 38++++++++++++++++----------------------
Msrc/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)