Ticket #874: srfi-14-test.scm

File srfi-14-test.scm, 10.1 KB (added by mario, 6 years ago)

srfi-14-test.scm

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