klisp

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

commit 96a9d8b8f3cce525645d9b3ca13b2ec1f5843566
parent a282ea6adf94a701c0d8dff48a60939bc70dba33
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 25 Nov 2011 15:42:33 -0300

Added string-upcase, string-downcase, string-titlecase and string-foldcase to the ground environment. Added test for all of these.

Diffstat:
MTODO | 3---
Msrc/kgstrings.c | 63++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---
Msrc/tests/characters.k | 1-
Msrc/tests/strings.k | 22+++++++++++++++++++++-
4 files changed, 81 insertions(+), 8 deletions(-)

diff --git a/TODO b/TODO @@ -33,9 +33,6 @@ ** vector-map (r7rs) ** bytevector-map (r7rs) ** string-map (r7rs) -** string-downcase (r7rs) -** string-foldcase (r7rs) -** string-upcase (r7rs) ** vector->string (r7rs) ** string->vector (r7rs) ** vector-fill (r7rs) diff --git a/src/kgstrings.c b/src/kgstrings.c @@ -176,6 +176,57 @@ void string(klisp_State *K) kapply_cc(K, new_str); } +/* 13.?? string-upcase, string-downcase, string-titlecase, string-foldcase */ +/* this will work for upcase, downcase and foldcase (in ASCII) */ +void kstring_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)); + /* + ** xparams[0]: conversion fn + */ + UNUSED(denv); + bind_1tp(K, ptree, "string", ttisstring, str); + char (*fn)(char) = pvalue(xparams[0]); + int32_t size = kstring_size(str); + TValue res = kstring_new_bs(K, kstring_buf(str), size); + char *buf = kstring_buf(res); + for(int32_t i = 0; i < size; ++i, buf++) { + *buf = fn(*buf); + } + kapply_cc(K, res); +} + +void kstring_title_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, "string", ttisstring, str); + int32_t size = kstring_size(str); + TValue res = kstring_new_bs(K, kstring_buf(str), size); + char *buf = kstring_buf(res); + bool first = true; + for(int32_t i = 0; i < size; ++i, buf++) { + char ch = *buf; + if (ch == ' ') + first = true; + else if (!first) + *buf = tolower(ch); + else if (isalpha(ch)) { + /* only count as first letter something that can be capitalized */ + *buf = toupper(ch); + first = false; + } + } + kapply_cc(K, res); +} + /* 13.2.2? string=?, string-ci=? */ /* use ftyped_bpredp */ @@ -500,6 +551,15 @@ void kinit_strings_ground_env(klisp_State *K) add_applicative(K, ground_env, "string-set!", string_setS, 0); /* 13.2.1? string */ add_applicative(K, ground_env, "string", string, 0); + /* 13.?? string-upcase, string-downcase, string-titlecase, + string-foldcase */ + add_applicative(K, ground_env, "string-upcase", kstring_change_case, 1, + p2tv(toupper)); + add_applicative(K, ground_env, "string-downcase", kstring_change_case, 1, + p2tv(tolower)); + add_applicative(K, ground_env, "string-titlecase", kstring_title_case, 0); + add_applicative(K, ground_env, "string-foldcase", kstring_change_case, 1, + p2tv(tolower)); /* 13.2.2? string=?, string-ci=? */ add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3, symbol, p2tv(kstringp), p2tv(kstring_eqp)); @@ -536,9 +596,6 @@ void kinit_strings_ground_env(klisp_State *K) add_applicative(K, ground_env, "string->immutable-string", string_to_immutable_string, 0); - /* TODO: add string-upcase and string-downcase like in r7rs-draft */ - /* foldcase too */ - /* 13.2.10? string-fill! */ add_applicative(K, ground_env, "string-fill!", string_fillS, 0); } diff --git a/src/tests/characters.k b/src/tests/characters.k @@ -74,7 +74,6 @@ ($check-predicate ($false-for-all? char-lower-case? #\0 #\A #\Z #\' #\@ #\{ #\[ #\~)) ;; XXX char-upcase char-downcase char-titlecase char-foldcase - ($check equal? (char-upcase #\a) #\A) ($check equal? (char-upcase #\z) #\Z) ($check equal? (char-upcase #\R) #\R) diff --git a/src/tests/strings.k b/src/tests/strings.k @@ -4,7 +4,9 @@ ;; ;; XXX immutability of string constants - +;; this works because this file is loaded and the strings +;; are immutable, but just reading the file wouldn't make them +;; immutable ($check-predicate (immutable-string? "")) ($check-predicate (immutable-string? "abcd")) @@ -84,6 +86,24 @@ ($check equal? (string #\a #\b #\c) "abc") ($check-not-predicate ($let ((x (string #\a)) (y (string #\a))) (eq? x y))) +;; XXX string-upcase string-downcase string-titlecase string-foldcase +($check equal? (string-upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz") + "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ") +($check equal? (string-titlecase "this is a regular sentence. this 1 2!") + "This Is A Regular Sentence. This 1 2!") +($check equal? (string-downcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz") + "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz") +($check equal? (string-foldcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz") + "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz") +($check-predicate (mutable-string? (string-upcase (string-copy "A0a")))) +($check-predicate (mutable-string? (string-upcase "A0a"))) +($check-predicate (mutable-string? (string-downcase (string-copy "A0a")))) +($check-predicate (mutable-string? (string-downcase "A0a"))) +($check-predicate (mutable-string? (string-titlecase (string-copy "A0a")))) +($check-predicate (mutable-string? (string-titlecase "A0a"))) +($check-predicate (mutable-string? (string-foldcase (string-copy "A0a")))) +($check-predicate (mutable-string? (string-foldcase "A0a"))) + ;; XXX string-length ($check equal? (string-length "") 0)