1 | (use srfi-14) |
---|
2 | (use (only srfi-1 remove)) |
---|
3 | (define remv delete) |
---|
4 | |
---|
5 | (define (writeln . xs) |
---|
6 | (for-each display xs) |
---|
7 | (newline)) |
---|
8 | |
---|
9 | (define (fail token . more) |
---|
10 | (writeln "Error: test failed: " token) |
---|
11 | #f) |
---|
12 | |
---|
13 | (or (equal? #t (char-set? (char-set))) |
---|
14 | (fail 'char-set?:1)) |
---|
15 | (or (equal? #t (char-set? (string->char-set "abcde"))) |
---|
16 | (fail 'char-set?:2)) |
---|
17 | (or (equal? #f (char-set? 37)) |
---|
18 | (fail 'char-set?:3)) |
---|
19 | (or (equal? #f (char-set? "abcde")) |
---|
20 | (fail 'char-set?:4)) |
---|
21 | |
---|
22 | (or (equal? #t (char-set= (char-set) (char-set))) |
---|
23 | (fail 'char-set=:1)) |
---|
24 | (or (equal? #t (char-set= (char-set #\a #\b #\c) (char-set #\c #\b #\a))) |
---|
25 | (fail 'char-set=:2)) |
---|
26 | (or (equal? #f (char-set= (char-set #\a #\b #\c) (char-set #\c #\d #\a))) |
---|
27 | (fail 'char-set=:3)) |
---|
28 | (or (equal? #t (char-set=)) |
---|
29 | (fail 'char-set=:4)) |
---|
30 | (or (equal? #t (char-set= (char-set))) |
---|
31 | (fail 'char-set=:5)) |
---|
32 | |
---|
33 | (or (equal? #t (char-set<= (char-set) (char-set))) |
---|
34 | (fail 'char-set<=:1)) |
---|
35 | (or (equal? #t (char-set<= (char-set #\a #\b) (char-set #\a #\b #\c))) |
---|
36 | (fail 'char-set<=:2)) |
---|
37 | (or (equal? #f (char-set<= (char-set #\a #\b #\c) (char-set #\a #\b))) |
---|
38 | (fail 'char-set<=:3)) |
---|
39 | (or (equal? #t (char-set<=)) |
---|
40 | (fail 'char-set<=:4)) |
---|
41 | (or (equal? #t (char-set<= (char-set))) |
---|
42 | (fail 'char-set<=:5)) |
---|
43 | |
---|
44 | (or (let ((h (char-set-hash (char-set #\a #\b #\c) 3737))) |
---|
45 | (and (<= 0 h) (< h 3737))) |
---|
46 | (fail 'char-set-hash:1)) |
---|
47 | (or (equal? (char-set-hash (char-set #\a #\b #\c)) |
---|
48 | (char-set-hash (char-set #\b #\c #\a))) |
---|
49 | (fail 'char-set-hash:2)) |
---|
50 | |
---|
51 | (or (equal? '(#\G #\T #\a #\c #\e #\h) |
---|
52 | (let ((cs (char-set #\G #\a #\T #\e #\c #\h))) |
---|
53 | (let lp ((cur (char-set-cursor cs)) (ans '())) |
---|
54 | (if (end-of-char-set? cur) ans |
---|
55 | (lp (char-set-cursor-next cs cur) |
---|
56 | (cons (char-set-ref cs cur) ans)))))) |
---|
57 | (fail 'char-set-cursor:1)) |
---|
58 | |
---|
59 | (or (let ((ms (char-set-fold cons '() (char-set #\a #\b #\c #\T)))) |
---|
60 | (and (memv #\a ms) |
---|
61 | (memv #\b ms) |
---|
62 | (memv #\c ms) |
---|
63 | (memv #\T ms) |
---|
64 | (= (length ms) 4))) |
---|
65 | (fail 'char-set-fold:1)) |
---|
66 | |
---|
67 | (or (char-set= (char-set-unfold null? car cdr (string->list "abracadabra")) |
---|
68 | (string->char-set "abracadabra")) |
---|
69 | (fail 'char-set-unfold:1)) |
---|
70 | (or (char-set= (char-set-unfold null? car cdr (string->list "abracadabra") (char-set #\f)) |
---|
71 | (string->char-set "abracadabraf")) |
---|
72 | (fail 'char-set-unfold:2)) |
---|
73 | (or (char-set= (char-set-unfold! null? car cdr (string->list "abracadabra") (char-set #\f)) |
---|
74 | (string->char-set "abracadabraf")) |
---|
75 | (fail 'char-set-unfold!:1)) |
---|
76 | |
---|
77 | (or (let ((chars (string->list "fnord"))) |
---|
78 | (null? (begin |
---|
79 | (char-set-for-each (lambda (c) |
---|
80 | (if (not (memv c chars)) |
---|
81 | (fail 'char-set-for-each:0)) |
---|
82 | (set! chars (remv c chars))) |
---|
83 | (list->char-set chars)) |
---|
84 | chars))) |
---|
85 | (fail 'char-set-for-each:1)) |
---|
86 | |
---|
87 | (or (let ((chars (string->list "fnord"))) |
---|
88 | (let ((newchars (char-set-map (lambda (c) |
---|
89 | (if (not (memv c chars)) |
---|
90 | (fail 'char-set-map:0)) |
---|
91 | (set! chars (remv c chars)) |
---|
92 | c) |
---|
93 | (list->char-set chars)))) |
---|
94 | (char-set= (string->char-set "fnord") newchars))) |
---|
95 | (fail 'char-set-map:1)) |
---|
96 | |
---|
97 | ; ... |
---|
98 | |
---|
99 | ; Shivers's tests. |
---|
100 | |
---|
101 | (let-syntax ((test (syntax-rules () |
---|
102 | ((test form ...) |
---|
103 | (cond ((begin |
---|
104 | ;(writeln 'form) |
---|
105 | (not form)) |
---|
106 | (fail "Test failed" 'form)) ... |
---|
107 | (else 'OK)))))) |
---|
108 | (let ((vowel? (lambda (c) |
---|
109 | (member c '(#\a #\e #\i #\o #\u))))) |
---|
110 | (test |
---|
111 | (not (char-set? 5)) |
---|
112 | |
---|
113 | (char-set? (char-set #\a #\e #\i #\o #\u)) |
---|
114 | |
---|
115 | (char-set=) |
---|
116 | (char-set= (char-set)) |
---|
117 | |
---|
118 | (char-set= (char-set #\a #\e #\i #\o #\u) |
---|
119 | (string->char-set "ioeauaiii")) |
---|
120 | |
---|
121 | (not (char-set= (char-set #\e #\i #\o #\u) |
---|
122 | (string->char-set "ioeauaiii"))) |
---|
123 | |
---|
124 | (char-set<=) |
---|
125 | (char-set<= (char-set)) |
---|
126 | |
---|
127 | (char-set<= (char-set #\a #\e #\i #\o #\u) |
---|
128 | (string->char-set "ioeauaiii")) |
---|
129 | |
---|
130 | (char-set<= (char-set #\e #\i #\o #\u) |
---|
131 | (string->char-set "ioeauaiii")) |
---|
132 | |
---|
133 | (<= 0 (char-set-hash char-set:graphic 100) 99) |
---|
134 | |
---|
135 | (= 4 (char-set-fold (lambda (c i) (+ i 1)) 0 |
---|
136 | (char-set #\e #\i #\o #\u #\e #\e))) |
---|
137 | |
---|
138 | (char-set= (string->char-set "eiaou2468013579999") |
---|
139 | (char-set-unfold null? car cdr '(#\a #\e #\i #\o #\u #\u #\u) |
---|
140 | char-set:digit)) |
---|
141 | |
---|
142 | (char-set= (string->char-set "eiaou246801357999") |
---|
143 | (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u) |
---|
144 | (string->char-set "0123456789"))) |
---|
145 | |
---|
146 | (not (char-set= (string->char-set "eiaou246801357") |
---|
147 | (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u) |
---|
148 | (string->char-set "0123456789")))) |
---|
149 | |
---|
150 | (let ((cs (string->char-set "0123456789"))) |
---|
151 | (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c))) |
---|
152 | (string->char-set "02468000")) |
---|
153 | (char-set= cs (string->char-set "97531"))) |
---|
154 | |
---|
155 | (not (let ((cs (string->char-set "0123456789"))) |
---|
156 | (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c))) |
---|
157 | (string->char-set "02468")) |
---|
158 | (char-set= cs (string->char-set "7531")))) |
---|
159 | |
---|
160 | (char-set= (char-set-map char-upcase (string->char-set "aeiou")) |
---|
161 | (string->char-set "IOUAEEEE")) |
---|
162 | |
---|
163 | (not (char-set= (char-set-map char-upcase (string->char-set "aeiou")) |
---|
164 | (string->char-set "OUAEEEE"))) |
---|
165 | |
---|
166 | (char-set= (char-set-copy (string->char-set "aeiou")) |
---|
167 | (string->char-set "aeiou")) |
---|
168 | |
---|
169 | (char-set= (char-set #\x #\y) (string->char-set "xy")) |
---|
170 | (not (char-set= (char-set #\x #\y #\z) (string->char-set "xy"))) |
---|
171 | |
---|
172 | (char-set= (string->char-set "xy") (list->char-set '(#\x #\y))) |
---|
173 | (not (char-set= (string->char-set "axy") (list->char-set '(#\x #\y)))) |
---|
174 | |
---|
175 | (char-set= (string->char-set "xy12345") |
---|
176 | (list->char-set '(#\x #\y) (string->char-set "12345"))) |
---|
177 | (not (char-set= (string->char-set "y12345") |
---|
178 | (list->char-set '(#\x #\y) (string->char-set "12345")))) |
---|
179 | |
---|
180 | (char-set= (string->char-set "xy12345") |
---|
181 | (list->char-set! '(#\x #\y) (string->char-set "12345"))) |
---|
182 | (not (char-set= (string->char-set "y12345") |
---|
183 | (list->char-set! '(#\x #\y) (string->char-set "12345")))) |
---|
184 | |
---|
185 | (char-set= (string->char-set "aeiou12345") |
---|
186 | (char-set-filter vowel? char-set:ascii (string->char-set "12345"))) |
---|
187 | (not (char-set= (string->char-set "aeou12345") |
---|
188 | (char-set-filter vowel? char-set:ascii (string->char-set "12345")))) |
---|
189 | |
---|
190 | (char-set= (string->char-set "aeiou12345") |
---|
191 | (char-set-filter! vowel? char-set:ascii (string->char-set "12345"))) |
---|
192 | (not (char-set= (string->char-set "aeou12345") |
---|
193 | (char-set-filter! vowel? char-set:ascii (string->char-set "12345")))) |
---|
194 | |
---|
195 | |
---|
196 | (char-set= (string->char-set "abcdef12345") |
---|
197 | (ucs-range->char-set 97 103 #t (string->char-set "12345"))) |
---|
198 | (not (char-set= (string->char-set "abcef12345") |
---|
199 | (ucs-range->char-set 97 103 #t (string->char-set "12345")))) |
---|
200 | |
---|
201 | (char-set= (string->char-set "abcdef12345") |
---|
202 | (ucs-range->char-set! 97 103 #t (string->char-set "12345"))) |
---|
203 | (not (char-set= (string->char-set "abcef12345") |
---|
204 | (ucs-range->char-set! 97 103 #t (string->char-set "12345")))) |
---|
205 | |
---|
206 | |
---|
207 | (char-set= (->char-set #\x) |
---|
208 | (->char-set "x") |
---|
209 | (->char-set (char-set #\x))) |
---|
210 | |
---|
211 | (not (char-set= (->char-set #\x) |
---|
212 | (->char-set "y") |
---|
213 | (->char-set (char-set #\x)))) |
---|
214 | |
---|
215 | (= 10 (char-set-size (char-set-intersection char-set:ascii char-set:digit))) |
---|
216 | |
---|
217 | (= 5 (char-set-count vowel? char-set:ascii)) |
---|
218 | |
---|
219 | (equal? '(#\x) (char-set->list (char-set #\x))) |
---|
220 | (not (equal? '(#\X) (char-set->list (char-set #\x)))) |
---|
221 | |
---|
222 | (equal? "x" (char-set->string (char-set #\x))) |
---|
223 | (not (equal? "X" (char-set->string (char-set #\x)))) |
---|
224 | |
---|
225 | (char-set-contains? (->char-set "xyz") #\x) |
---|
226 | (not (char-set-contains? (->char-set "xyz") #\a)) |
---|
227 | |
---|
228 | (char-set-every char-lower-case? (->char-set "abcd")) |
---|
229 | (not (char-set-every char-lower-case? (->char-set "abcD"))) |
---|
230 | (char-set-any char-lower-case? (->char-set "abcd")) |
---|
231 | (not (char-set-any char-lower-case? (->char-set "ABCD"))) |
---|
232 | |
---|
233 | (char-set= (->char-set "ABCD") |
---|
234 | (let ((cs (->char-set "abcd"))) |
---|
235 | (let lp ((cur (char-set-cursor cs)) (ans '())) |
---|
236 | (if (end-of-char-set? cur) (list->char-set ans) |
---|
237 | (lp (char-set-cursor-next cs cur) |
---|
238 | (cons (char-upcase (char-set-ref cs cur)) ans)))))) |
---|
239 | |
---|
240 | |
---|
241 | (char-set= (char-set-adjoin (->char-set "123") #\x #\a) |
---|
242 | (->char-set "123xa")) |
---|
243 | (not (char-set= (char-set-adjoin (->char-set "123") #\x #\a) |
---|
244 | (->char-set "123x"))) |
---|
245 | (char-set= (char-set-adjoin! (->char-set "123") #\x #\a) |
---|
246 | (->char-set "123xa")) |
---|
247 | (not (char-set= (char-set-adjoin! (->char-set "123") #\x #\a) |
---|
248 | (->char-set "123x"))) |
---|
249 | |
---|
250 | (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2) |
---|
251 | (->char-set "13")) |
---|
252 | (not (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2) |
---|
253 | (->char-set "13a"))) |
---|
254 | (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2) |
---|
255 | (->char-set "13")) |
---|
256 | (not (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2) |
---|
257 | (->char-set "13a"))) |
---|
258 | |
---|
259 | (char-set= (char-set-intersection char-set:hex-digit (char-set-complement char-set:digit)) |
---|
260 | (->char-set "abcdefABCDEF")) |
---|
261 | (char-set= (char-set-intersection! (char-set-complement! (->char-set "0123456789")) |
---|
262 | char-set:hex-digit) |
---|
263 | (->char-set "abcdefABCDEF")) |
---|
264 | |
---|
265 | (char-set= (char-set-union char-set:hex-digit |
---|
266 | (->char-set "abcdefghijkl")) |
---|
267 | (->char-set "abcdefABCDEFghijkl0123456789")) |
---|
268 | (char-set= (char-set-union! (->char-set "abcdefghijkl") |
---|
269 | char-set:hex-digit) |
---|
270 | (->char-set "abcdefABCDEFghijkl0123456789")) |
---|
271 | |
---|
272 | (char-set= (char-set-difference (->char-set "abcdefghijklmn") |
---|
273 | char-set:hex-digit) |
---|
274 | (->char-set "ghijklmn")) |
---|
275 | (char-set= (char-set-difference! (->char-set "abcdefghijklmn") |
---|
276 | char-set:hex-digit) |
---|
277 | (->char-set "ghijklmn")) |
---|
278 | |
---|
279 | (char-set= (char-set-xor (->char-set "0123456789") |
---|
280 | char-set:hex-digit) |
---|
281 | (->char-set "abcdefABCDEF")) |
---|
282 | (char-set= (char-set-xor! (->char-set "0123456789") |
---|
283 | char-set:hex-digit) |
---|
284 | (->char-set "abcdefABCDEF")) |
---|
285 | |
---|
286 | (call-with-values (lambda () |
---|
287 | (char-set-diff+intersection char-set:hex-digit |
---|
288 | char-set:letter)) |
---|
289 | (lambda (d i) |
---|
290 | (and (char-set= d (->char-set "0123456789")) |
---|
291 | (char-set= i (->char-set "abcdefABCDEF"))))) |
---|
292 | |
---|
293 | (call-with-values (lambda () |
---|
294 | (char-set-diff+intersection! (char-set-copy char-set:hex-digit) |
---|
295 | (char-set-copy char-set:letter))) |
---|
296 | (lambda (d i) |
---|
297 | (and (char-set= d (->char-set "0123456789")) |
---|
298 | (char-set= i (->char-set "abcdefABCDEF")))))) |
---|
299 | |
---|
300 | )) |
---|