Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-03 03:06:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

adding (srfi 14)

Browse source
This commit is contained in:
Alex Shinn 2017-08-26 20:34:56 +09:00
parent ba0d15ec14
commit 0f84fac70d
6 changed files with 344 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
lib/chibi/char-set/extras.scm
View file

@ -2,9 +2,11 @@
(define (char-set . args) (define (char-set . args)
(list->char-set args)) (list->char-set args))
;; This is a mistake in the SRFI-14 design - end should be inclusive. (define (ucs-range->char-set start end . o)
(define (ucs-range->char-set start end) (let ((res (make-iset start (- end 1))))
(make-iset start (- end 1))) (if (and (pair? o) (pair? (cdr o)))
(iset-union res (cadr o))
res)))
(define char-set-copy iset-copy) (define char-set-copy iset-copy)
@ -16,8 +18,8 @@
(define (char-set-for-each proc cset) (define (char-set-for-each proc cset)
(iset-for-each (lambda (i) (proc (integer->char i))) cset)) (iset-for-each (lambda (i) (proc (integer->char i))) cset))
(define (list->char-set ls) (define (list->char-set ls . o)
(list->iset (map char->integer ls))) (apply list->iset (map char->integer ls) o))
(define (char-set->list cset) (define (char-set->list cset)
(map integer->char (iset->list cset))) (map integer->char (iset->list cset)))
@ -26,10 +28,10 @@
(define (char-set->string cset) (define (char-set->string cset)
(list->string (char-set->list cset))) (list->string (char-set->list cset)))
(define (char-set-adjoin! cset ch) (define (char-set-adjoin! cset . o)
(iset-adjoin! cset (char->integer ch))) (apply iset-adjoin! cset (map char->integer o)))
(define (char-set-adjoin cset ch) (define (char-set-adjoin cset . o)
(iset-adjoin cset (char->integer ch))) (apply iset-adjoin cset (map char->integer o)))
(define char-set-union iset-union) (define char-set-union iset-union)
(define char-set-union! iset-union!) (define char-set-union! iset-union!)

12
lib/chibi/iset/iterators.scm
View file

@ -84,10 +84,10 @@
(error "cursor reference past end of iset") (error "cursor reference past end of iset")
pos))))) pos)))))
;;> Returns true iff \var{cur} is at the end of \var{iset}, such that ;;> Returns true iff \var{cur} is at the end of iset, such that
;;> \scheme{iset-ref} is no longer valid. ;;> \scheme{iset-ref} is no longer valid.
(define (end-of-iset? iset cur) (define (end-of-iset? cur)
(let ((node (iset-cursor-node cur))) (let ((node (iset-cursor-node cur)))
(and (if (iset-bits node) (and (if (iset-bits node)
(zero? (iset-cursor-pos cur)) (zero? (iset-cursor-pos cur))
@ -101,8 +101,8 @@
(define (iset2= is1 is2) (define (iset2= is1 is2)
(let lp ((cur1 (iset-cursor is1)) (let lp ((cur1 (iset-cursor is1))
(cur2 (iset-cursor is2))) (cur2 (iset-cursor is2)))
(cond ((end-of-iset? is1 cur1) (end-of-iset? is2 cur2)) (cond ((end-of-iset? cur1) (end-of-iset? cur2))
((end-of-iset? is2 cur2) #f) ((end-of-iset? cur2) #f)
((= (iset-ref is1 cur1) (iset-ref is2 cur2)) ((= (iset-ref is1 cur1) (iset-ref is2 cur2))
(lp (iset-cursor-next is1 cur1) (iset-cursor-next is2 cur2))) (lp (iset-cursor-next is1 cur1) (iset-cursor-next is2 cur2)))
(else (else
@ -111,8 +111,8 @@
(define (iset2<= is1 is2) (define (iset2<= is1 is2)
(let lp ((cur1 (iset-cursor is1)) (let lp ((cur1 (iset-cursor is1))
(cur2 (iset-cursor is2))) (cur2 (iset-cursor is2)))
(cond ((end-of-iset? is1 cur1)) (cond ((end-of-iset? cur1))
((end-of-iset? is2 cur2) #f) ((end-of-iset? cur2) #f)
(else (else
(let ((i1 (iset-ref is1 cur1)) (let ((i1 (iset-ref is1 cur1))
(i2 (iset-ref is1 cur2))) (i2 (iset-ref is1 cur2)))

103
lib/srfi/14.sld Normal file
View file

@ -0,0 +1,103 @@
(define-library (srfi 14)
(export
char-set? char-set= char-set<=
char-set-hash
char-set-cursor char-set-ref char-set-cursor-next end-of-char-set?
char-set-fold char-set-unfold char-set-unfold!
char-set-for-each char-set-map
char-set-copy char-set
list->char-set string->char-set
list->char-set! string->char-set!
char-set-filter ucs-range->char-set ->char-set
char-set-filter! ucs-range->char-set!
char-set->list char-set->string
char-set-size char-set-count char-set-contains?
char-set-every char-set-any
char-set-adjoin char-set-delete
char-set-adjoin! char-set-delete!
char-set-complement char-set-union char-set-intersection
char-set-complement! char-set-union! char-set-intersection!
char-set-difference char-set-xor char-set-diff+intersection
char-set-difference! char-set-xor! char-set-diff+intersection!
char-set:lower-case char-set:upper-case char-set:title-case
char-set:letter char-set:digit char-set:letter+digit
char-set:graphic char-set:printing char-set:whitespace
char-set:iso-control char-set:punctuation char-set:symbol
char-set:hex-digit char-set:blank char-set:ascii
char-set:empty char-set:full)
(import (scheme base)
(chibi char-set)
(chibi char-set full)
(chibi iset)
(only (srfi 125) hash))
(begin
(define char-set= iset=)
(define char-set<= iset<=)
(define char-set-hash hash)
(define char-set-cursor iset-cursor)
(define char-set-cursor-next iset-cursor-next)
(define (char-set-ref cs cur) (integer->char (iset-ref cs cur)))
(define end-of-char-set? end-of-iset?)
(define (char-set-fold kons knil cs)
(iset-fold (lambda (i x) (kons (integer->char i) x)) knil cs))
(define (char-set-unfold! p f g seed cs)
(let lp ((seed seed) (cs cs))
(if (p seed)
cs
(lp (g seed) (char-set-adjoin! cs (f seed))))))
(define (char-set-unfold p f g seed . o)
(let ((cs (if (pair? o) (char-set-copy (car o)) (char-set))))
(char-set-unfold! p f g seed cs)))
(define (char-set-map proc cs)
(iset-map (lambda (i) (char->integer (proc (integer->char i)))) cs))
(define list->char-set! list->char-set)
(define string->char-set! string->char-set)
(define ucs-range->char-set! ucs-range->char-set)
(define (->char-set x)
(cond ((char? x) (char-set x))
((pair? x) (list->char-set x))
((string? x) (string->char-set x))
(else x)))
(define (char-set-delete cs . o)
(apply iset-delete cs (map char->integer o)))
(define (char-set-delete! cs . o)
(apply iset-delete! cs (map char->integer o)))
(define char-set-complement! char-set-complement)
(define (char-set-filter pred cs . o)
(char-set-fold
(lambda (ch res) (if (pred ch) (char-set-adjoin! res ch) res))
(if (pair? o) (char-set-copy (car o)) (char-set))
cs))
(define char-set-filter! char-set-filter)
(define (char-set-count pred cs)
(char-set-fold (lambda (ch i) (if (pred ch) (+ i 1) i)) 0 cs))
(define (char-set-any pred cs)
(let lp ((cur (char-set-cursor cs)))
(if (end-of-char-set? cur)
#f
(or (pred (char-set-ref cs cur))
(lp (char-set-cursor-next cs cur))))))
(define (char-set-every pred cs)
(not (char-set-any (lambda (ch) (not (pred ch))) cs)))
(define (char-set-xor2 cs1 cs2)
(char-set-union (char-set-difference cs1 cs2)
(char-set-difference cs2 cs1)))
(define (char-set-xor . o)
(cond
((null? o) (char-set))
((null? (cdr o)) (char-set-copy (car o)))
(else (apply char-set-xor (char-set-xor2 (car o) (cadr o)) (cddr o)))))
(define char-set-xor! char-set-xor)
(define (char-set-diff+intersection . o)
(values (apply char-set-difference o)
(apply char-set-intersection o)))
(define char-set-diff+intersection! char-set-diff+intersection)))

221
lib/srfi/14/test.sld Normal file
View file

@ -0,0 +1,221 @@
(define-library (srfi 14 test)
(import (scheme base) (scheme char) (srfi 14) (chibi test))
(export run-tests)
(begin
(define-syntax test-cs
(syntax-rules ()
((test-cs . o)
(test-equal char-set= . o))))
(define (vowel? c) (member c '(#\a #\e #\i #\o #\u)))
(define (run-tests)
(test-begin "srfi-14: char-sets")
(test-not (char-set? 5))
(test-assert (char-set? (char-set #\a #\e #\i #\o #\u)))
(test-assert (char-set=))
(test-assert (char-set= (char-set)))
(test-cs (char-set #\a #\e #\i #\o #\u)
(string->char-set "ioeauaiii"))
(test-not (char-set= (char-set #\e #\i #\o #\u)
(string->char-set "ioeauaiii")))
(test-assert (char-set<=))
(test-assert (char-set<= (char-set)))
(test-assert (char-set<= (char-set #\a #\e #\i #\o #\u)
(string->char-set "ioeauaiii")))
(test-assert (char-set<= (char-set #\e #\i #\o #\u)
(string->char-set "ioeauaiii")))
(test-assert (<= 0 (char-set-hash char-set:graphic 100) 99))
(test 4 (char-set-fold (lambda (c i) (+ i 1)) 0
(char-set #\e #\i #\o #\u #\e #\e)))
(test-cs (string->char-set "eiaou2468013579999")
(char-set-unfold null? car cdr
'(#\a #\e #\i #\o #\u #\u #\u)
(char-set-intersection char-set:ascii
char-set:digit)))
(test-cs (string->char-set "eiaou246801357999")
(char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
(string->char-set "0123456789")))
(test-not (char-set= (string->char-set "eiaou246801357")
(char-set-unfold! null? car cdr
'(#\a #\e #\i #\o #\u)
(string->char-set "0123456789"))))
(let ((cs (string->char-set "0123456789")))
(char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
(string->char-set "02468000"))
(test-cs cs (string->char-set "97531")))
(test-not (let ((cs (string->char-set "0123456789")))
(char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
(string->char-set "02468"))
(char-set= cs (string->char-set "7531"))))
(test-cs (string->char-set "IOUAEEEE")
(char-set-map char-upcase (string->char-set "aeiou")))
(test-not (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
(string->char-set "OUAEEEE")))
(test-cs (string->char-set "aeiou")
(char-set-copy (string->char-set "aeiou")))
(test-cs (string->char-set "xy") (char-set #\x #\y))
(test-not (char-set= (char-set #\x #\y #\z) (string->char-set "xy")))
(test-cs (string->char-set "xy") (list->char-set '(#\x #\y)))
(test-not (char-set= (string->char-set "axy")
(list->char-set '(#\x #\y))))
(test-cs (string->char-set "xy12345")
(list->char-set '(#\x #\y) (string->char-set "12345")))
(test-not (char-set= (string->char-set "y12345")
(list->char-set '(#\x #\y)
(string->char-set "12345"))))
(test-cs (string->char-set "xy12345")
(list->char-set! '(#\x #\y) (string->char-set "12345")))
(test-not (char-set= (string->char-set "y12345")
(list->char-set! '(#\x #\y)
(string->char-set "12345"))))
(test-cs (string->char-set "aeiou12345")
(char-set-filter vowel?
char-set:ascii
(string->char-set "12345")))
(test-not (char-set= (string->char-set "aeou12345")
(char-set-filter vowel?
char-set:ascii
(string->char-set "12345"))))
(test-cs (string->char-set "aeiou12345")
(char-set-filter! vowel?
char-set:ascii
(string->char-set "12345")))
(test-not (char-set= (string->char-set "aeou12345")
(char-set-filter! vowel?
char-set:ascii
(string->char-set "12345"))))
(test-cs (string->char-set "abcdef12345")
(ucs-range->char-set 97 103 #t (string->char-set "12345")))
(test-not (char-set=
(string->char-set "abcef12345")
(ucs-range->char-set 97 103 #t (string->char-set "12345"))))
(test-cs (string->char-set "abcdef12345")
(ucs-range->char-set! 97 103 #t (string->char-set "12345")))
(test-not (char-set=
(string->char-set "abcef12345")
(ucs-range->char-set! 97 103 #t (string->char-set "12345"))))
(test-assert (char-set= (->char-set #\x)
(->char-set "x")
(->char-set (char-set #\x))))
(test-not (char-set= (->char-set #\x)
(->char-set "y")
(->char-set (char-set #\x))))
(test 10 (char-set-size
(char-set-intersection char-set:ascii char-set:digit)))
(test 5 (char-set-count vowel? char-set:ascii))
(test '(#\x) (char-set->list (char-set #\x)))
(test-not (equal? '(#\X) (char-set->list (char-set #\x))))
(test "x" (char-set->string (char-set #\x)))
(test-not (equal? "X" (char-set->string (char-set #\x))))
(test-assert (char-set-contains? (->char-set "xyz") #\x))
(test-not (char-set-contains? (->char-set "xyz") #\a))
(test-assert (char-set-every char-lower-case? (->char-set "abcd")))
(test-not (char-set-every char-lower-case? (->char-set "abcD")))
(test-assert (char-set-any char-lower-case? (->char-set "abcd")))
(test-not (char-set-any char-lower-case? (->char-set "ABCD")))
(test-cs (->char-set "ABCD")
(let ((cs (->char-set "abcd")))
(let lp ((cur (char-set-cursor cs)) (ans '()))
(if (end-of-char-set? cur) (list->char-set ans)
(lp (char-set-cursor-next cs cur)
(cons (char-upcase (char-set-ref cs cur)) ans))))))
(test-cs (->char-set "123xa")
(char-set-adjoin (->char-set "123") #\x #\a))
(test-not (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
(->char-set "123x")))
(test-cs (->char-set "123xa")
(char-set-adjoin! (->char-set "123") #\x #\a))
(test-not (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
(->char-set "123x")))
(test-cs (->char-set "13")
(char-set-delete (->char-set "123") #\2 #\a #\2))
(test-not (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
(->char-set "13a")))
(test-cs (->char-set "13")
(char-set-delete! (->char-set "123") #\2 #\a #\2))
(test-not (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
(->char-set "13a")))
(test-cs (->char-set "abcdefABCDEF")
(char-set-intersection char-set:hex-digit
(char-set-complement char-set:digit)))
(test-cs (->char-set "abcdefABCDEF")
(char-set-intersection!
(char-set-complement! (->char-set "0123456789"))
char-set:hex-digit))
(test-cs (->char-set "abcdefABCDEFghijkl0123456789")
(char-set-union char-set:hex-digit
(->char-set "abcdefghijkl")))
(test-cs (->char-set "abcdefABCDEFghijkl0123456789")
(char-set-union! (->char-set "abcdefghijkl")
char-set:hex-digit))
(test-cs (->char-set "ghijklmn")
(char-set-difference (->char-set "abcdefghijklmn")
char-set:hex-digit))
(test-cs (->char-set "ghijklmn")
(char-set-difference! (->char-set "abcdefghijklmn")
char-set:hex-digit))
(test-cs (->char-set "abcdefABCDEF")
(char-set-xor (->char-set "0123456789")
char-set:hex-digit))
(test-cs (->char-set "abcdefABCDEF")
(char-set-xor! (->char-set "0123456789")
char-set:hex-digit))
(call-with-values
(lambda ()
(char-set-diff+intersection char-set:hex-digit
char-set:letter))
(lambda (d i)
(test-cs d (->char-set "0123456789"))
(test-cs i (->char-set "abcdefABCDEF"))))
(call-with-values
(lambda ()
(char-set-diff+intersection! (char-set-copy char-set:hex-digit)
(char-set-copy char-set:letter)))
(lambda (d i)
(test-cs d (->char-set "0123456789"))
(test-cs i (->char-set "abcdefABCDEF"))))
(test-end))))

2
tests/lib-tests.scm
View file

@ -3,6 +3,7 @@
(chibi test) (chibi test)
(rename (srfi 1 test) (run-tests run-srfi-1-tests)) (rename (srfi 1 test) (run-tests run-srfi-1-tests))
(rename (srfi 2 test) (run-tests run-srfi-2-tests)) (rename (srfi 2 test) (run-tests run-srfi-2-tests))
(rename (srfi 14 test) (run-tests run-srfi-14-tests))
(rename (srfi 16 test) (run-tests run-srfi-16-tests)) (rename (srfi 16 test) (run-tests run-srfi-16-tests))
(rename (srfi 18 test) (run-tests run-srfi-18-tests)) (rename (srfi 18 test) (run-tests run-srfi-18-tests))
(rename (srfi 26 test) (run-tests run-srfi-26-tests)) (rename (srfi 26 test) (run-tests run-srfi-26-tests))
@ -54,6 +55,7 @@
(run-srfi-1-tests) (run-srfi-1-tests)
(run-srfi-2-tests) (run-srfi-2-tests)
(run-srfi-14-tests)
(run-srfi-16-tests) (run-srfi-16-tests)
(run-srfi-18-tests) (run-srfi-18-tests)
(run-srfi-26-tests) (run-srfi-26-tests)

2
tools/optimize-char-sets.scm
View file

@ -48,7 +48,7 @@
(do ((cur (iset-cursor value) (do ((cur (iset-cursor value)
(iset-cursor-next value cur)) (iset-cursor-next value cur))
(res '() (cons (iset-ref value cur) res))) (res '() (cons (iset-ref value cur) res)))
((end-of-iset? value cur) (reverse res))))) ((end-of-iset? cur) (reverse res)))))
(error "error in iset cursors")) (error "error in iset cursors"))
(display " computing intersection\n" (current-error-port)) (display " computing intersection\n" (current-error-port))
(let* ((iset1 (if ascii? (let* ((iset1 (if ascii?