mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-03 03:06:39 +02:00
adding (srfi 14)
This commit is contained in:
Alex Shinn
parent
ba0d15ec14
commit
0f84fac70d
6 changed files with 344 additions and 16 deletions
|
|
@ -2,9 +2,11 @@
|
|||
(define (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)
|
||||
(make-iset start (- end 1)))
|
||||
(define (ucs-range->char-set start end . o)
|
||||
(let ((res (make-iset start (- end 1))))
|
||||
(if (and (pair? o) (pair? (cdr o)))
|
||||
(iset-union res (cadr o))
|
||||
res)))
|
||||
|
||||
(define char-set-copy iset-copy)
|
||||
|
||||
|
|
@ -16,8 +18,8 @@
|
|||
(define (char-set-for-each proc cset)
|
||||
(iset-for-each (lambda (i) (proc (integer->char i))) cset))
|
||||
|
||||
(define (list->char-set ls)
|
||||
(list->iset (map char->integer ls)))
|
||||
(define (list->char-set ls . o)
|
||||
(apply list->iset (map char->integer ls) o))
|
||||
(define (char-set->list cset)
|
||||
(map integer->char (iset->list cset)))
|
||||
|
||||
|
|
@ -26,10 +28,10 @@
|
|||
(define (char-set->string cset)
|
||||
(list->string (char-set->list cset)))
|
||||
|
||||
(define (char-set-adjoin! cset ch)
|
||||
(iset-adjoin! cset (char->integer ch)))
|
||||
(define (char-set-adjoin cset ch)
|
||||
(iset-adjoin cset (char->integer ch)))
|
||||
(define (char-set-adjoin! cset . o)
|
||||
(apply iset-adjoin! cset (map char->integer o)))
|
||||
(define (char-set-adjoin cset . o)
|
||||
(apply iset-adjoin cset (map char->integer o)))
|
||||
|
||||
(define char-set-union iset-union)
|
||||
(define char-set-union! iset-union!)
|
||||
|
|
|
|||
|
|
@ -84,10 +84,10 @@
|
|||
(error "cursor reference past end of iset")
|
||||
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.
|
||||
|
||||
(define (end-of-iset? iset cur)
|
||||
(define (end-of-iset? cur)
|
||||
(let ((node (iset-cursor-node cur)))
|
||||
(and (if (iset-bits node)
|
||||
(zero? (iset-cursor-pos cur))
|
||||
|
|
@ -101,8 +101,8 @@
|
|||
(define (iset2= is1 is2)
|
||||
(let lp ((cur1 (iset-cursor is1))
|
||||
(cur2 (iset-cursor is2)))
|
||||
(cond ((end-of-iset? is1 cur1) (end-of-iset? is2 cur2))
|
||||
((end-of-iset? is2 cur2) #f)
|
||||
(cond ((end-of-iset? cur1) (end-of-iset? cur2))
|
||||
((end-of-iset? cur2) #f)
|
||||
((= (iset-ref is1 cur1) (iset-ref is2 cur2))
|
||||
(lp (iset-cursor-next is1 cur1) (iset-cursor-next is2 cur2)))
|
||||
(else
|
||||
|
|
@ -111,8 +111,8 @@
|
|||
(define (iset2<= is1 is2)
|
||||
(let lp ((cur1 (iset-cursor is1))
|
||||
(cur2 (iset-cursor is2)))
|
||||
(cond ((end-of-iset? is1 cur1))
|
||||
((end-of-iset? is2 cur2) #f)
|
||||
(cond ((end-of-iset? cur1))
|
||||
((end-of-iset? cur2) #f)
|
||||
(else
|
||||
(let ((i1 (iset-ref is1 cur1))
|
||||
(i2 (iset-ref is1 cur2)))
|
||||
|
|
|
|||
103
lib/srfi/14.sld
Normal file
103
lib/srfi/14.sld
Normal 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
221
lib/srfi/14/test.sld
Normal 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))))
|
||||
|
|
@ -3,6 +3,7 @@
|
|||
(chibi test)
|
||||
(rename (srfi 1 test) (run-tests run-srfi-1-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 18 test) (run-tests run-srfi-18-tests))
|
||||
(rename (srfi 26 test) (run-tests run-srfi-26-tests))
|
||||
|
|
@ -54,6 +55,7 @@
|
|||
|
||||
(run-srfi-1-tests)
|
||||
(run-srfi-2-tests)
|
||||
(run-srfi-14-tests)
|
||||
(run-srfi-16-tests)
|
||||
(run-srfi-18-tests)
|
||||
(run-srfi-26-tests)
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@
|
|||
(do ((cur (iset-cursor value)
|
||||
(iset-cursor-next value cur))
|
||||
(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"))
|
||||
(display " computing intersection\n" (current-error-port))
|
||||
(let* ((iset1 (if ascii?
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue