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. ;;; Emulation of mutable strings.
(define string-ref list-ref) (define mutable-string-ref list-ref)
(define string-set! list-set!) (define mutable-string-set! list-set!)
(define string list) (define mutable-string list)
(define (string->list x) x) (define (mutable-string->list x) x)
(define list<=> (define list<=>
(lambda (x y <=>) (lambda (x y <=>)
@ -139,6 +139,18 @@
((f (car l)) #t) ((f (car l)) #t)
(else (any f (cdr l)))))) (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 (macro
cond-expand cond-expand
(lambda (body) (lambda (body)

12
miniscm/miniscm.c
View File

@ -1216,6 +1216,7 @@ register pointer a, b;
#define OP_CHAR2INT 111 #define OP_CHAR2INT 111
#define OP_STRINGREF 112 #define OP_STRINGREF 112
#define OP_STRINGLEN 113
static FILE *tmpfp; static FILE *tmpfp;
static int tok; static int tok;
@ -1977,6 +1978,13 @@ register short op;
} }
s_return(mk_char_c(strvalue(x)[ivalue(y)])); 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_7, /* OP_WRITEOUT */
opexe_2, /* OP_CHAR2INT */ 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_CHAR2INT, "char->integer");
mk_proc(OP_STRINGREF, "string-ref"); mk_proc(OP_STRINGREF, "string-ref");
mk_proc(OP_STRINGLEN, "string-length");
} }

117
set.scm
View File

@ -410,14 +410,36 @@
;;; For strings ;;; For strings
;;; ;;;;;;;;;;; ;;; ;;;;;;;;;;;
(cond-expand (define integer<=>
((not miniscm-unslisp) (lambda (x y)
(define (string<=> x y)
(cond (cond
((string<? x y) '<) ((< x y) '<)
((string>? x y) '>) ((= x y) '=)
(else '=)))) (else '>))))
(else #f))
(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 (cond-expand
((and (not miniscm-unslisp) (not r7rs)) ((and (not miniscm-unslisp) (not r7rs))
@ -438,6 +460,13 @@
(define %smap:split (map:split map:string<=>)) (define %smap:split (map:split map:string<=>))
(define smap:union (map:union %smap:split)) (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 ;;; Tests
;;; ;;;;; ;;; ;;;;;
@ -528,21 +557,21 @@
(else #t))))) (else #t)))))
(cons "insert then delete" (cons "insert then delete"
(lambda () (lambda ()
(let ((insert-return (smap:insert '() (string #\a) 5))) (let ((insert-return (smap:insert '() "a" 5)))
(cond (cond
((not (pair? insert-return)) "invalid insert return") ((not (pair? insert-return)) "invalid insert return")
((not (null? (cdr insert-return))) "string found in empty tree") ((not (null? (cdr insert-return))) "string found in empty tree")
(else (else
(let ((tree (car insert-return))) (let ((tree (car insert-return)))
(let ((found (smap:search tree (string #\a)))) (let ((found (smap:search tree "a")))
(cond (cond
((null? found) "string not in tree") ((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") "returned key not equal to a")
((not (equal? (map:val tree) 5)) ((not (equal? (map:val tree) 5))
"returned value not equal to 5") "returned value not equal to 5")
(else (else
(let ((delete-return (smap:delete tree (string #\a)))) (let ((delete-return (smap:delete tree "a")))
(cond (cond
((not (pair? delete-return)) ((not (pair? delete-return))
"invalid delete return") "invalid delete return")
@ -553,19 +582,19 @@
(cons "insert a few unique then delete" (cons "insert a few unique then delete"
(lambda () (lambda ()
(let ((to-insert (list (let ((to-insert (list
(list (string #\a #\b #\c) 1 #f) (list "abc" 1 #f)
(list (string #\a #\b #\d) 2 #f) (list "abd" 2 #f)
(list (string #\d #\e #\f) 3 #f) (list "def" 3 #f)
(list (string #\1 #\2 #\3 #\a #\C) 4 #f) (list "123aC" 4 #f)
(list (string #\q #\w #\e) 5 #f) (list "qwe" 5 #f)
(list (string #\1 #\2 #\3) 5 #f) (list "123" 5 #f)
(list (string #\l #\i #\s #\p) 6 #f) (list "lisp" 6 #f)
(list (string #\c) 7 #f) (list "c" 7 #f)
(list (string #\s #\c #\m) 8 #f) (list "scm" 8 #f)
(list (string #\a #\l #\g #\o #\l) 9 #f) (list "algol" 9 #f)
(list (string #\a #\s #\m) 10 #f) (list "asm" 10 #f)
(list (string #\4) 11 #f) (list "4" 11 #f)
(list (string #\a #\s #\m #\e) 12 #f)))) (list "asme" 12 #f))))
(display "insert all") (newline) (display "insert all") (newline)
(let ((tree (%set:insert-all '() to-insert))) (let ((tree (%set:insert-all '() to-insert)))
(if (string? tree) (if (string? tree)
@ -589,22 +618,22 @@
(lambda () (lambda ()
(let ((tree (%set:insert-all '() (let ((tree (%set:insert-all '()
(list (list
(list (string #\a #\b #\c #\d) 1 #f) (list "abcd" 1 #f)
(list (string #\e #\f #\g #\h) 2 #f) (list "efgh" 2 #f)
(list (string #\1 #\4 #\2 #\9 #\3) 3 #f) (list "14293" 3 #f)
(list (string #\a #\b #\c #\d #\e) 4 #f))))) (list "abcde" 4 #f)))))
(if (string? tree) (if (string? tree)
tree tree
(let ((tree (smap:update tree (let ((tree (smap:update tree
(string #\a #\b #\c #\d #\e) "abcde"
(lambda (key oldnode) (lambda (key oldnode)
10)))) 10))))
(let ((res (%set:search-all tree (let ((res (%set:search-all tree
(list (list
(list (string #\a #\b #\c #\d) 1 1) (list "abcd" 1 1)
(list (string #\e #\f #\g #\h) 2 2) (list "efgh" 2 2)
(list (string #\1 #\4 #\2 #\9 #\3) 3 3) (list "14293" 3 3)
(list (string #\a #\b #\c #\d #\e) 10 10))))) (list "abcde" 10 10)))))
(if (string? res) (if (string? res)
res res
#t))))))) #t)))))))
@ -612,20 +641,20 @@
(lambda () (lambda ()
(let ((tree1 (%set:insert-all '() (let ((tree1 (%set:insert-all '()
(list (list
(list (string #\a) 1 #f) (list "a" 1 #f)
(list (string #\b) 2 #f) (list "b" 2 #f)
(list (string #\c) 3 #f)))) (list "c" 3 #f))))
(tree2 (%set:insert-all '() (tree2 (%set:insert-all '()
(list (list
(list (string #\c) 4 #f) (list "c" 4 #f)
(list (string #\d) 5 #f) (list "d" 5 #f)
(list (string #\e) 6 #f))))) (list "e" 6 #f)))))
(let ((tree (smap:union tree1 tree2)) (let ((tree (smap:union tree1 tree2))
(to-search (list (to-search (list
(list (string #\a) 1 1) (list "a" 1 1)
(list (string #\b) 2 2) (list "b" 2 2)
(list (string #\c) 3 3) (list "c" 3 3)
(list (string #\d) 5 5) (list "d" 5 5)
(list (string #\e) 6 6)))) (list "e" 6 6))))
(not (string? (%set:search-all tree to-search))))))))) (not (string? (%set:search-all tree to-search)))))))))