From 85e38a2b19ad3f36132aa733b11a0901736a99a5 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Sun, 8 Sep 2024 10:10:12 -0400 Subject: [PATCH] miniscm: add better support for immutable strings, and refactor to use real strings --- miniscm/init.scm | 20 ++++++-- miniscm/miniscm.c | 12 ++++- set.scm | 117 +++++++++++++++++++++++++++++----------------- 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) '>) - (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)))))))))