peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

This commit is contained in:
Peter McGoron 2024-09-08 10:10:12 -04:00
parent f26ab0db3f
commit 85e38a2b19
3 changed files with 100 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
miniscm/init.scm
View File

@ -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)

12
miniscm/miniscm.c
View File

@ -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");
}

117
set.scm
View File

@ -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)))))))))