klisp

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:
M
TODO
 | 
3
---
M
src/kgstrings.c
 | 
63
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---
M
src/tests/characters.k
 | 
1
-
M
src/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)