miniscm: add better support for immutable strings, and refactor to use real strings

3 files changed, 100 insertions, 49 deletions

diff --git a/miniscm/init.scm b/miniscm/init.scm
index 1803388..725c7d0 100644
--- a/miniscm/init.scm
+++ b/miniscm/init.scm
@@ -90,10 +90,10 @@
 
 ;;; Emulation of mutable strings.
 
-(define string-ref list-ref)
-(define string-set! list-set!)
-(define string list)
-(define (string->list x) x)
+(define mutable-string-ref list-ref)
+(define mutable-string-set! list-set!)
+(define mutable-string list)
+(define (mutable-string->list x) x)
 
 (define list<=>
   (lambda (x y <=>)
@@ -139,6 +139,18 @@
       ((f (car l)) #t)
       (else (any f (cdr l))))))
 
+(define string->list
+  (lambda (str)
+    (let ((len (string-length str)))
+      (letrec ((loop
+                (lambda (i lst)
+                  (if (= i len)
+                      (reverse lst)
+                      (loop (+ i 1)
+                            (cons (string-ref str i)
+                                  lst))))))
+        (loop 0)))))
+
 (macro
  cond-expand
  (lambda (body)
diff --git a/miniscm/miniscm.c b/miniscm/miniscm.c
index e2b062d..7500ad2 100644
--- a/miniscm/miniscm.c
+++ b/miniscm/miniscm.c
@@ -1216,6 +1216,7 @@ register pointer a, b;
 
 #define OP_CHAR2INT             111
 #define OP_STRINGREF            112
+#define OP_STRINGLEN            113
 
 static FILE *tmpfp;
 static int tok;
@@ -1977,6 +1978,13 @@ register short op;
 		}
 
 		s_return(mk_char_c(strvalue(x)[ivalue(y)]));
+
+	case OP_STRINGLEN:
+		if (!isstring(car(args))) {
+			Error_0("string-length -- argument must be string");
+		}
+
+		s_return(mk_number(strlen(strvalue(car(args)))));
 	}
 }
 
@@ -2481,7 +2489,8 @@ pointer	(*dispatch_table[])() = {
 	opexe_7,        /* OP_WRITEOUT */
 
 	opexe_2,        /* OP_CHAR2INT */
-	opexe_4         /* OP_STRINGREF */
+	opexe_4,        /* OP_STRINGREF */
+	opexe_4         /* OP_STRINGLEN */
 };
 
 
@@ -2642,6 +2651,7 @@ init_procs()
 	mk_proc(OP_CHAR2INT, "char->integer");
 
 	mk_proc(OP_STRINGREF, "string-ref");
+	mk_proc(OP_STRINGLEN, "string-length");
 }
 
 
diff --git a/set.scm b/set.scm
index a8683b1..52d10b6 100644
--- a/set.scm
+++ b/set.scm
@@ -410,14 +410,36 @@
 ;;; For strings
 ;;; ;;;;;;;;;;;
 
-(cond-expand
- ((not miniscm-unslisp)
-  (define (string<=> x y)
+(define integer<=>
+  (lambda (x y)
     (cond
-      ((string<? x y) '<)
-      ((string>? x y) '>)
-      (else '=))))
- (else #f))
+      ((< x y) '<)
+      ((= x y) '=)
+      (else '>))))
+
+(define char<=>
+  (lambda (x y)
+    (integer<=> (char->integer x)
+                (char->integer y))))
+
+(define string<=>
+  (lambda (x y)
+    (let ((x-len (string-length x))
+          (y-len (string-length y)))
+      (letrec ((loop
+                (lambda (i)
+                  (cond
+                    ((and (= i x-len) (= i y-len)) '=)
+                    ((= i x-len) '<)
+                    ((= i y-len) '>)
+                    (else
+                     (let ((dir (char<=>
+                                 (string-ref x i)
+                                 (string-ref y i))))
+                       (if (eq? dir '=)
+                           (loop (+ i 1))
+                           dir)))))))
+        (loop 0)))))
 
 (cond-expand
  ((and (not miniscm-unslisp) (not r7rs))
@@ -438,6 +460,13 @@
 (define %smap:split (map:split map:string<=>))
 (define smap:union (map:union %smap:split))
 
+(define smap:insert-many
+  (lambda (smap . pairs)
+    (fold (lambda (pair smap)
+            (smap:insert smap (car pair) (cdr pair)))
+          smap
+          pairs)))
+
 ;;; ;;;;;
 ;;; Tests
 ;;; ;;;;;
@@ -528,21 +557,21 @@
                (else #t)))))
    (cons "insert then delete"
          (lambda ()
-           (let ((insert-return (smap:insert '() (string #\a) 5)))
+           (let ((insert-return (smap:insert '() "a" 5)))
              (cond
                ((not (pair? insert-return)) "invalid insert return")
                ((not (null? (cdr insert-return))) "string found in empty tree")
                (else
                 (let ((tree (car insert-return)))
-                  (let ((found (smap:search tree (string #\a))))
+                  (let ((found (smap:search tree "a")))
                     (cond
                       ((null? found) "string not in tree")
-                      ((not (equal? (map:key tree) (string #\a)))
+                      ((not (equal? (map:key tree) "a"))
                        "returned key not equal to a")
                       ((not (equal? (map:val tree) 5))
                        "returned value not equal to 5")
                       (else
-                       (let ((delete-return (smap:delete tree (string #\a))))
+                       (let ((delete-return (smap:delete tree "a")))
                          (cond
                            ((not (pair? delete-return))
                             "invalid delete return")
@@ -553,19 +582,19 @@
    (cons "insert a few unique then delete"
          (lambda ()
            (let ((to-insert (list
-                             (list (string #\a #\b #\c) 1 #f)
-                             (list (string #\a #\b #\d) 2 #f)
-                             (list (string #\d #\e #\f) 3 #f)
-                             (list (string #\1 #\2 #\3 #\a #\C) 4 #f)
-                             (list (string #\q #\w #\e) 5 #f)
-                             (list (string #\1 #\2 #\3) 5 #f)
-                             (list (string #\l #\i #\s #\p) 6 #f)
-                             (list (string #\c) 7 #f)
-                             (list (string #\s #\c #\m) 8 #f)
-                             (list (string #\a #\l #\g #\o #\l) 9 #f)
-                             (list (string #\a #\s #\m) 10 #f)
-                             (list (string #\4) 11 #f)
-                             (list (string #\a #\s #\m #\e) 12 #f))))
+                             (list "abc" 1 #f)
+                             (list "abd" 2 #f)
+                             (list "def" 3 #f)
+                             (list "123aC" 4 #f)
+                             (list "qwe" 5 #f)
+                             (list "123" 5 #f)
+                             (list "lisp" 6 #f)
+                             (list "c" 7 #f)
+                             (list "scm" 8 #f)
+                             (list "algol" 9 #f)
+                             (list "asm" 10 #f)
+                             (list "4" 11 #f)
+                             (list "asme" 12 #f))))
              (display "insert all") (newline)
              (let ((tree (%set:insert-all '() to-insert)))
                (if (string? tree)
@@ -589,22 +618,22 @@
          (lambda ()
            (let ((tree (%set:insert-all '()
                                         (list
-                                         (list (string #\a #\b #\c #\d) 1 #f)
-                                         (list (string #\e #\f #\g #\h) 2 #f)
-                                         (list (string #\1 #\4 #\2 #\9 #\3) 3 #f)
-                                         (list (string #\a #\b #\c #\d #\e) 4 #f)))))
+                                         (list "abcd" 1 #f)
+                                         (list "efgh" 2 #f)
+                                         (list "14293" 3 #f)
+                                         (list "abcde" 4 #f)))))
              (if (string? tree)
                  tree
                  (let ((tree (smap:update tree
-                                          (string #\a #\b #\c #\d #\e)
+                                          "abcde"
                                           (lambda (key oldnode)
                                             10))))
                    (let ((res (%set:search-all tree
                                                (list
-                                                (list (string #\a #\b #\c #\d) 1 1)
-                                                (list (string #\e #\f #\g #\h) 2 2)
-                                                (list (string #\1 #\4 #\2 #\9 #\3) 3 3)
-                                                (list (string #\a #\b #\c #\d #\e) 10 10)))))
+                                                (list "abcd" 1 1)
+                                                (list "efgh" 2 2)
+                                                (list "14293" 3 3)
+                                                (list "abcde" 10 10)))))
                      (if (string? res)
                          res
                          #t)))))))
@@ -612,20 +641,20 @@
          (lambda ()
            (let ((tree1 (%set:insert-all '()
                                          (list
-                                          (list (string #\a) 1 #f)
-                                          (list (string #\b) 2 #f)
-                                          (list (string #\c) 3 #f))))
+                                          (list "a" 1 #f)
+                                          (list "b" 2 #f)
+                                          (list "c" 3 #f))))
                  (tree2 (%set:insert-all '()
                                          (list
-                                          (list (string #\c) 4 #f)
-                                          (list (string #\d) 5 #f)
-                                          (list (string #\e) 6 #f)))))
+                                          (list "c" 4 #f)
+                                          (list "d" 5 #f)
+                                          (list "e" 6 #f)))))
              (let ((tree (smap:union tree1 tree2))
                    (to-search (list
-                               (list (string #\a) 1 1)
-                               (list (string #\b) 2 2)
-                               (list (string #\c) 3 3)
-                               (list (string #\d) 5 5)
-                               (list (string #\e) 6 6))))
+                               (list "a" 1 1)
+                               (list "b" 2 2)
+                               (list "c" 3 3)
+                               (list "d" 5 5)
+                               (list "e" 6 6))))
                (not (string? (%set:search-all tree to-search)))))))))