1;;;; srfi-14.test          -*- mode:scheme; coding: iso-8859-1 -*-
2;;;; --- Test suite for Guile's SRFI-14 functions.
3;;;; Martin Grabmueller, 2001-07-16
4;;;;
5;;;; Copyright (C) 2001, 2006, 2009, 2010, 2014 Free Software Foundation, Inc.
6;;;;
7;;;; This library is free software; you can redistribute it and/or
8;;;; modify it under the terms of the GNU Lesser General Public
9;;;; License as published by the Free Software Foundation; either
10;;;; version 3 of the License, or (at your option) any later version.
11;;;;
12;;;; This library is distributed in the hope that it will be useful,
13;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;;;; Lesser General Public License for more details.
16;;;;
17;;;; You should have received a copy of the GNU Lesser General Public
18;;;; License along with this library; if not, write to the Free Software
19;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20
21(define-module (test-suite test-srfi-14)
22  :use-module (srfi srfi-14)
23  :use-module (srfi srfi-1) ;; `every'
24  :use-module (test-suite lib))
25
26
27(define exception:invalid-char-set-cursor
28  (cons 'misc-error "^invalid character set cursor"))
29
30(define exception:non-char-return
31  (cons 'misc-error "returned non-char"))
32
33
34(with-test-prefix "char set contents"
35
36  (pass-if "empty set"
37    (list= eqv?
38           (char-set->list (char-set))
39           '()))
40
41  (pass-if "single char"
42    (list= eqv?
43           (char-set->list (char-set #\a))
44           (list #\a)))
45
46  (pass-if "contiguous chars"
47    (list= eqv?
48           (char-set->list (char-set #\a #\b #\c))
49           (list #\a #\b #\c)))
50
51  (pass-if "discontiguous chars"
52    (list= eqv?
53           (char-set->list (char-set #\a #\c #\e))
54           (list #\a #\c #\e))))
55
56(with-test-prefix "char set additition"
57
58  (pass-if "empty + x"
59    (let ((cs (char-set)))
60      (char-set-adjoin! cs #\x)
61      (list= eqv?
62             (char-set->list cs)
63             (list #\x))))
64
65  (pass-if "x + y"
66    (let ((cs (char-set #\x)))
67      (char-set-adjoin! cs #\y)
68      (list= eqv?
69             (char-set->list cs)
70             (list #\x #\y))))
71
72  (pass-if "x + w"
73    (let ((cs (char-set #\x)))
74      (char-set-adjoin! cs #\w)
75      (list= eqv?
76             (char-set->list cs)
77             (list #\w #\x))))
78
79  (pass-if "x + z"
80    (let ((cs (char-set #\x)))
81      (char-set-adjoin! cs #\z)
82      (list= eqv?
83             (char-set->list cs)
84             (list #\x #\z))))
85
86  (pass-if "x + v"
87    (let ((cs (char-set #\x)))
88      (char-set-adjoin! cs #\v)
89      (list= eqv?
90             (char-set->list cs)
91             (list #\v #\x))))
92
93  (pass-if "uv + w"
94    (let ((cs (char-set #\u #\v)))
95      (char-set-adjoin! cs #\w)
96      (list= eqv?
97             (char-set->list cs)
98             (list #\u #\v #\w))))
99
100  (pass-if "uv + t"
101    (let ((cs (char-set #\u #\v)))
102      (char-set-adjoin! cs #\t)
103      (list= eqv?
104             (char-set->list cs)
105             (list #\t #\u #\v))))
106
107  (pass-if "uv + x"
108    (let ((cs (char-set #\u #\v)))
109      (char-set-adjoin! cs #\x)
110      (list= eqv?
111             (char-set->list cs)
112             (list #\u #\v #\x))))
113
114  (pass-if "uv + s"
115    (let ((cs (char-set #\u #\v)))
116      (char-set-adjoin! cs #\s)
117      (list= eqv?
118             (char-set->list cs)
119             (list #\s #\u #\v))))
120
121  (pass-if "uvx + w"
122    (let ((cs (char-set #\u #\v #\x)))
123      (char-set-adjoin! cs #\w)
124      (list= eqv?
125             (char-set->list cs)
126             (list #\u #\v #\w #\x))))
127
128  (pass-if "uvx + y"
129    (let ((cs (char-set #\u #\v #\x)))
130      (char-set-adjoin! cs #\y)
131      (list= eqv?
132             (char-set->list cs)
133             (list #\u #\v #\x #\y))))
134
135  (pass-if "uvxy + w"
136    (let ((cs (char-set #\u #\v #\x #\y)))
137      (char-set-adjoin! cs #\w)
138      (list= eqv?
139             (char-set->list cs)
140             (list #\u #\v #\w #\x #\y)))))
141
142(with-test-prefix "char set union"
143  (pass-if "null U abc"
144    (char-set= (char-set-union (char-set) (->char-set "abc"))
145               (->char-set "abc")))
146
147  (pass-if "ab U ab"
148    (char-set= (char-set-union (->char-set "ab") (->char-set "ab"))
149               (->char-set "ab")))
150
151  (pass-if "ab U bc"
152    (char-set= (char-set-union (->char-set "ab") (->char-set "bc"))
153               (->char-set "abc")))
154
155  (pass-if "ab U cd"
156    (char-set= (char-set-union (->char-set "ab") (->char-set "cd"))
157               (->char-set "abcd")))
158
159  (pass-if "ab U de"
160    (char-set= (char-set-union (->char-set "ab") (->char-set "de"))
161               (->char-set "abde")))
162
163  (pass-if "abc U bcd"
164    (char-set= (char-set-union (->char-set "abc") (->char-set "bcd"))
165               (->char-set "abcd")))
166
167  (pass-if "abdf U abcdefg"
168    (char-set= (char-set-union (->char-set "abdf") (->char-set "abcdefg"))
169               (->char-set "abcdefg")))
170
171  (pass-if "abef U cd"
172    (char-set= (char-set-union (->char-set "abef") (->char-set "cd"))
173               (->char-set "abcdef")))
174
175  (pass-if "abgh U cd"
176    (char-set= (char-set-union (->char-set "abgh") (->char-set "cd"))
177               (->char-set "abcdgh")))
178
179  (pass-if "bc U ab"
180    (char-set= (char-set-union (->char-set "bc") (->char-set "ab"))
181               (->char-set "abc")))
182
183  (pass-if "cd U ab"
184    (char-set= (char-set-union (->char-set "cd") (->char-set "ab"))
185               (->char-set "abcd")))
186
187  (pass-if "de U ab"
188    (char-set= (char-set-union (->char-set "de") (->char-set "ab"))
189               (->char-set "abde")))
190
191  (pass-if "cd U abc"
192    (char-set= (char-set-union (->char-set "cd") (->char-set "abc"))
193               (->char-set "abcd")))
194
195  (pass-if "cd U abcd"
196    (char-set= (char-set-union (->char-set "cd") (->char-set "abcd"))
197               (->char-set "abcd")))
198
199  (pass-if "cde U abcdef"
200    (char-set= (char-set-union (->char-set "cde") (->char-set "abcdef"))
201               (->char-set "abcdef"))))
202
203(with-test-prefix "char set xor"
204  (pass-if "null - xy"
205    (char-set= (char-set-xor (char-set) (char-set #\x #\y))
206               (char-set #\x #\y)))
207
208  (pass-if "x - x"
209    (char-set= (char-set-xor (char-set #\x) (char-set #\x))
210               (char-set)))
211
212  (pass-if "xy - x"
213    (char-set= (char-set-xor (char-set #\x #\y) (char-set #\x))
214               (char-set #\y)))
215
216  (pass-if "xy - y"
217    (char-set= (char-set-xor (char-set #\x #\y) (char-set #\y))
218               (char-set #\x)))
219
220  (pass-if "wxy - w"
221    (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\w))
222               (char-set #\x #\y)))
223
224  (pass-if "wxy - x"
225    (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\x))
226               (char-set #\w #\y)))
227
228  (pass-if "wxy - y"
229    (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\y))
230               (char-set #\w #\x)))
231
232  (pass-if "uvxy - u"
233    (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\u))
234               (char-set #\v #\x #\y)))
235
236  (pass-if "uvxy - v"
237    (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\v))
238               (char-set #\u #\x #\y)))
239
240  (pass-if "uvxy - x"
241    (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\x))
242               (char-set #\u #\v #\y)))
243
244  (pass-if "uvxy - y"
245    (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\y))
246               (char-set #\u #\v #\x)))
247
248  (pass-if "uwy - u"
249    (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\u))
250               (char-set #\w #\y)))
251
252  (pass-if "uwy - w"
253    (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\w))
254               (char-set #\u #\y)))
255
256  (pass-if "uwy - y"
257    (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\y))
258               (char-set #\u #\w)))
259
260  (pass-if "uvwy - v"
261    (char-set= (char-set-xor (char-set #\u #\v #\w #\y) (char-set #\v))
262               (char-set #\u #\w #\y))))
263
264
265(with-test-prefix "char-set?"
266
267  (pass-if "success on empty set"
268    (char-set? (char-set)))
269
270  (pass-if "success on non-empty set"
271    (char-set? char-set:printing))
272
273  (pass-if "failure on empty set"
274    (not (char-set? #t))))
275
276
277(with-test-prefix "char-set="
278  (pass-if "success, no arg"
279    (char-set=))
280
281  (pass-if "success, one arg"
282    (char-set= char-set:lower-case))
283
284  (pass-if "success, two args"
285    (char-set= char-set:upper-case char-set:upper-case))
286
287  (pass-if "failure, first empty"
288    (not (char-set= (char-set) (char-set #\a))))
289
290  (pass-if "failure, second empty"
291    (not (char-set= (char-set #\a) (char-set))))
292
293  (pass-if "success, more args"
294    (char-set= char-set:blank char-set:blank char-set:blank))
295
296  (pass-if "failure, same length, different elements"
297    (not (char-set= (char-set #\a #\b #\d) (char-set #\a #\c #\d)))))
298
299(with-test-prefix "char-set<="
300  (pass-if "success, no arg"
301    (char-set<=))
302
303  (pass-if "success, one arg"
304    (char-set<= char-set:lower-case))
305
306  (pass-if "success, two args"
307    (char-set<= char-set:upper-case char-set:upper-case))
308
309  (pass-if "success, first empty"
310    (char-set<= (char-set) (char-set #\a)))
311
312  (pass-if "failure, second empty"
313    (not (char-set<= (char-set #\a) (char-set))))
314
315  (pass-if "success, more args, equal"
316    (char-set<= char-set:blank char-set:blank char-set:blank))
317
318  (pass-if "success, more args, not equal"
319    (char-set<= char-set:blank
320		(char-set-adjoin char-set:blank #\F)
321		(char-set-adjoin char-set:blank #\F #\o))))
322
323(with-test-prefix "char-set-hash"
324   (pass-if "empty set, bound"
325      (let ((h (char-set-hash char-set:empty 31)))
326	(and h (number? h) (exact? h) (>= h 0) (< h 31))))
327
328   (pass-if "empty set, no bound"
329      (let ((h (char-set-hash char-set:empty)))
330	(and h (number? h) (exact? h) (>= h 0))))
331
332   (pass-if "full set, bound"
333      (let ((h (char-set-hash char-set:full 31)))
334	(and h (number? h) (exact? h) (>= h 0) (< h 31))))
335
336   (pass-if "full set, no bound"
337      (let ((h (char-set-hash char-set:full)))
338	(and h (number? h) (exact? h) (>= h 0))))
339
340   (pass-if "other set, bound"
341      (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
342	(and h (number? h) (exact? h) (>= h 0) (< h 31))))
343
344   (pass-if "other set, no bound"
345      (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
346	(and h (number? h) (exact? h) (>= h 0)))))
347
348
349(with-test-prefix "char-set cursor"
350
351  (pass-if-exception "invalid character cursor"
352     exception:wrong-type-arg
353     (let* ((cs (char-set #\B #\r #\a #\z))
354	    (cc (char-set-cursor cs)))
355       (char-set-ref cs 1000)))
356
357  (pass-if "success"
358     (let* ((cs (char-set #\B #\r #\a #\z))
359	    (cc (char-set-cursor cs)))
360       (char? (char-set-ref cs cc))))
361
362  (pass-if "end of set fails"
363     (let* ((cs (char-set #\a))
364	    (cc (char-set-cursor cs)))
365       (not (end-of-char-set? cc))))
366
367  (pass-if "end of set succeeds, empty set"
368     (let* ((cs (char-set))
369	    (cc (char-set-cursor cs)))
370       (end-of-char-set? cc)))
371
372  (pass-if "end of set succeeds, non-empty set"
373     (let* ((cs (char-set #\a))
374	    (cc (char-set-cursor cs))
375	    (cc (char-set-cursor-next cs cc)))
376       (end-of-char-set? cc))))
377
378(with-test-prefix "char-set-fold"
379
380  (pass-if "count members"
381     (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
382
383  (pass-if "copy set"
384     (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
385				      (char-set) (char-set #\a #\b))) 2)))
386
387(define char-set:256
388  (string->char-set (apply string (map integer->char (iota 256)))))
389
390(with-test-prefix "char-set-unfold"
391
392  (pass-if "create char set"
393     (char-set= char-set:256
394		(char-set-unfold (lambda (s) (= s 256)) integer->char
395				 (lambda (s) (+ s 1)) 0)))
396  (pass-if "create char set (base set)"
397     (char-set= char-set:256
398		(char-set-unfold (lambda (s) (= s 256)) integer->char
399				 (lambda (s) (+ s 1)) 0 char-set:empty))))
400
401(with-test-prefix "char-set-unfold!"
402
403  (pass-if "create char set"
404     (char-set= char-set:256
405		(char-set-unfold! (lambda (s) (= s 256)) integer->char
406				 (lambda (s) (+ s 1)) 0
407				 (char-set-copy char-set:empty))))
408
409  (pass-if "create char set"
410     (char-set= char-set:256
411		(char-set-unfold! (lambda (s) (= s 32)) integer->char
412				 (lambda (s) (+ s 1)) 0
413				 (char-set-copy char-set:256)))))
414
415
416(with-test-prefix "char-set-for-each"
417
418  (pass-if "copy char set"
419     (= (char-set-size (let ((cs (char-set)))
420			 (char-set-for-each
421			  (lambda (c) (char-set-adjoin! cs c))
422			  (char-set #\a #\b))
423			 cs))
424	2)))
425
426(with-test-prefix "char-set-map"
427
428  (pass-if "upper case char set 1"
429     (char-set= (char-set-map char-upcase
430                              (string->char-set "abcdefghijklmnopqrstuvwxyz"))
431                (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
432
433  (pass-if "upper case char set 2"
434     (char-set= (char-set-map char-upcase
435                              (string->char-set "�����������������������������"))
436                (string->char-set "�����������������������������"))))
437
438(with-test-prefix "string->char-set"
439
440  (pass-if "some char set"
441     (let ((chars '(#\g #\u #\i #\l #\e)))
442       (char-set= (list->char-set chars)
443		  (string->char-set (apply string chars))))))
444
445(with-test-prefix "char-set->string"
446
447  (pass-if "some char set"
448     (let ((cs (char-set #\g #\u #\i #\l #\e)))
449       (string=? (char-set->string cs)
450                 "egilu"))))
451
452(with-test-prefix "list->char-set"
453
454  (pass-if "list->char-set"
455    (char-set= (list->char-set '(#\a #\b #\c))
456               (->char-set "abc")))
457
458  (pass-if "list->char-set!"
459    (let* ((cs (char-set #\a #\z)))
460      (list->char-set! '(#\m #\n) cs)
461      (char-set= cs
462                 (char-set #\a #\m #\n #\z)))))
463
464(with-test-prefix "string->char-set"
465
466  (pass-if "string->char-set"
467    (char-set= (string->char-set "foobar")
468               (string->char-set "barfoo")))
469
470  (pass-if "string->char-set cs"
471    (char-set= (string->char-set "foo" (string->char-set "bar"))
472               (string->char-set "barfoo")))
473
474  (pass-if "string->char-set!"
475    (let ((cs (string->char-set "bar")))
476      (string->char-set! "foo" cs)
477      (char-set= cs
478                 (string->char-set "barfoo")))))
479
480(with-test-prefix "char-set-filter"
481
482  (pass-if "filter w/o base"
483    (char-set=
484     (char-set-filter (lambda (c) (char=? c #\x))
485                      (->char-set "qrstuvwxyz"))
486     (->char-set #\x)))
487
488  (pass-if "filter w/ base"
489    (char-set=
490     (char-set-filter (lambda (c) (char=? c #\x))
491                      (->char-set "qrstuvwxyz")
492                      (->char-set "op"))
493
494     (->char-set "opx")))
495
496  (pass-if "filter!"
497    (let ((cs (->char-set "abc")))
498      (set! cs (char-set-filter! (lambda (c) (char=? c #\x))
499                                 (->char-set "qrstuvwxyz")
500                                 cs))
501      (char-set= (string->char-set "abcx")
502                 cs))))
503
504
505(with-test-prefix "char-set-intersection"
506
507  (pass-if "empty"
508    (char-set= (char-set-intersection (char-set) (char-set))
509               (char-set)))
510
511  (pass-if "identical, one element"
512    (char-set= (char-set-intersection (char-set #\a) (char-set #\a))
513               (char-set #\a)))
514
515  (pass-if "identical, two elements"
516    (char-set= (char-set-intersection (char-set #\a #\b) (char-set #\a #\b))
517               (char-set #\a #\b)))
518
519  (pass-if "identical, two elements"
520    (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\a #\c))
521               (char-set #\a #\c)))
522
523  (pass-if "one vs null"
524    (char-set= (char-set-intersection (char-set #\a) (char-set))
525               (char-set)))
526
527  (pass-if "null vs one"
528    (char-set= (char-set-intersection (char-set) (char-set #\a))
529               (char-set)))
530
531  (pass-if "no elements shared"
532    (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\b #\d))
533               (char-set)))
534
535  (pass-if "one elements shared"
536    (char-set= (char-set-intersection (char-set #\a #\c #\d) (char-set #\b #\d))
537               (char-set #\d))))
538
539(with-test-prefix "char-set-complement"
540
541  (pass-if "complement of null"
542           (char-set= (char-set-complement (char-set))
543                      (char-set-union (ucs-range->char-set 0 #xd800)
544                                      (ucs-range->char-set #xe000 #x110000))))
545
546  (pass-if "complement of null (2)"
547           (char-set= (char-set-complement (char-set))
548                      (ucs-range->char-set 0 #x110000)))
549
550  (pass-if "complement of #\\0"
551           (char-set= (char-set-complement (char-set #\nul))
552                      (ucs-range->char-set 1 #x110000)))
553
554  (pass-if "complement of U+10FFFF"
555           (char-set= (char-set-complement (char-set (integer->char #x10ffff)))
556                      (ucs-range->char-set 0 #x10ffff)))
557
558  (pass-if "complement of 'FOO'"
559           (char-set= (char-set-complement (->char-set "FOO"))
560                      (char-set-union (ucs-range->char-set 0 (char->integer #\F))
561                                      (ucs-range->char-set (char->integer #\G)
562                                                           (char->integer #\O))
563                                      (ucs-range->char-set (char->integer #\P)
564                                                            #x110000))))
565  (pass-if "complement of #\\a #\\b U+010300"
566           (char-set= (char-set-complement (char-set #\a #\b (integer->char #x010300)))
567                      (char-set-union (ucs-range->char-set 0 (char->integer #\a))
568                                      (ucs-range->char-set (char->integer #\c) #x010300)
569                                      (ucs-range->char-set #x010301 #x110000)))))
570
571(with-test-prefix "ucs-range->char-set"
572  (pass-if "char-set"
573    (char-set= (ucs-range->char-set 65 68)
574               (->char-set "ABC")))
575
576  (pass-if "char-set w/ base"
577    (char-set= (ucs-range->char-set 65 68 #f (->char-set "DEF"))
578               (->char-set "ABCDEF")))
579
580  (pass-if "char-set!"
581    (let ((cs (->char-set "DEF")))
582      (ucs-range->char-set! 65 68 #f cs)
583      (char-set= cs
584                 (->char-set "ABCDEF")))))
585
586(with-test-prefix "char-set-count"
587  (pass-if "null"
588    (= 0 (char-set-count (lambda (c) #t) (char-set))))
589
590  (pass-if "count"
591    (= 5 (char-set-count (lambda (c) #t)
592                         (->char-set "guile")))))
593
594(with-test-prefix "char-set-contains?"
595  (pass-if "#\\a not in null"
596    (not (char-set-contains? (char-set) #\a)))
597
598  (pass-if "#\\a is in 'abc'"
599    (char-set-contains? (->char-set "abc") #\a)))
600
601(with-test-prefix "any / every"
602  (pass-if "char-set-every #t"
603    (char-set-every (lambda (c) #t)
604                    (->char-set "abc")))
605
606  (pass-if "char-set-every #f"
607    (not (char-set-every (lambda (c) (char=? c #\c))
608                         (->char-set "abc"))))
609
610  (pass-if "char-set-any #t"
611    (char-set-any (lambda (c) (char=? c #\c))
612                  (->char-set "abc")))
613
614  (pass-if "char-set-any #f"
615    (not (char-set-any (lambda (c) #f)
616                       (->char-set "abc")))))
617
618(with-test-prefix "char-set-delete"
619  (pass-if "abc - a"
620    (char-set= (char-set-delete (->char-set "abc") #\a)
621               (char-set #\b #\c)))
622
623  (pass-if "abc - d"
624    (char-set= (char-set-delete (->char-set "abc") #\d)
625               (char-set #\a #\b #\c)))
626
627  (pass-if "delete! abc - a"
628    (let ((cs (char-set #\a #\b #\c)))
629      (char-set-delete! cs #\a)
630      (char-set= cs (char-set #\b #\c)))))
631
632(with-test-prefix "char-set-difference"
633  (pass-if "not different"
634    (char-set= (char-set-difference (->char-set "foobar") (->char-set "foobar"))
635               (char-set)))
636
637  (pass-if "completely different"
638    (char-set= (char-set-difference (->char-set "foo") (->char-set "bar"))
639               (->char-set "foo")))
640
641  (pass-if "partially different"
642    (char-set= (char-set-difference (->char-set "breakfast") (->char-set "breakroom"))
643               (->char-set "fst"))))
644
645(with-test-prefix "standard char sets (ASCII)"
646
647  (pass-if "char-set:lower-case"
648     (char-set<= (string->char-set "abcdefghijklmnopqrstuvwxyz")
649                 char-set:lower-case))
650
651  (pass-if "char-set:upper-case"
652     (char-set<= (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
653                 char-set:upper-case))
654
655  (pass-if "char-set:title-case"
656     (char-set<= (string->char-set "")
657                 char-set:title-case))
658
659  (pass-if "char-set:letter"
660     (char-set<= (char-set-union
661                  (string->char-set "abcdefghijklmnopqrstuvwxyz")
662                  (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
663                 char-set:letter))
664
665  (pass-if "char-set:digit"
666     (char-set<= (string->char-set "0123456789")
667                 char-set:digit))
668
669  (pass-if "char-set:hex-digit"
670     (char-set<= (string->char-set "0123456789abcdefABCDEF")
671                 char-set:hex-digit))
672
673  (pass-if "char-set:letter+digit"
674     (char-set<= (char-set-union
675                  (string->char-set "abcdefghijklmnopqrstuvwxyz")
676                  (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
677                  (string->char-set "0123456789"))
678                 char-set:letter+digit))
679
680  (pass-if "char-set:punctuation"
681     (char-set<= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
682                 char-set:punctuation))
683
684  (pass-if "char-set:symbol"
685     (char-set<= (string->char-set "$+<=>^`|~")
686                 char-set:symbol))
687
688  (pass-if "char-set:graphic"
689     (char-set<= (char-set-union
690                  (string->char-set "abcdefghijklmnopqrstuvwxyz")
691                  (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
692                  (string->char-set "0123456789")
693                  (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
694                  (string->char-set "$+<=>^`|~"))
695                 char-set:graphic))
696
697  (pass-if "char-set:whitespace"
698     (char-set<= (string->char-set
699                  (string
700                   (integer->char #x09)
701                   (integer->char #x0a)
702                   (integer->char #x0b)
703                   (integer->char #x0c)
704                   (integer->char #x0d)
705                   (integer->char #x20)))
706                 char-set:whitespace))
707
708  (pass-if "char-set:printing"
709     (char-set<= (char-set-union
710                  (string->char-set "abcdefghijklmnopqrstuvwxyz")
711                  (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
712                  (string->char-set "0123456789")
713                  (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
714                  (string->char-set "$+<=>^`|~")
715                  (string->char-set (string
716                                     (integer->char #x09)
717                                     (integer->char #x0a)
718                                     (integer->char #x0b)
719                                     (integer->char #x0c)
720                                     (integer->char #x0d)
721                                     (integer->char #x20))))
722                 char-set:printing))
723
724  (pass-if "char-set:ASCII"
725     (char-set= (ucs-range->char-set 0 128)
726                char-set:ascii))
727
728  (pass-if "char-set:iso-control"
729     (char-set<= (string->char-set
730                  (apply string
731                         (map integer->char (append
732                                             ;; U+0000 to U+001F
733                                             (iota #x20)
734                                             (list #x7f)))))
735                 char-set:iso-control)))
736
737
738;;;
739;;; Non-ASCII codepoints
740;;;
741;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
742;;; SRFI-14 for implementations supporting this charset is well-defined.
743;;;
744
745(define (every? pred lst)
746  (not (not (every pred lst))))
747
748(when (defined? 'setlocale)
749  (setlocale LC_ALL ""))
750
751(with-test-prefix "Latin-1 (8-bit charset)"
752
753  (pass-if "char-set:lower-case"
754    (char-set<= (string->char-set
755                 (string-append "abcdefghijklmnopqrstuvwxyz"
756                                "���������������������������������")
757                 char-set:lower-case)))
758
759  (pass-if "char-set:upper-case"
760    (char-set<= (string->char-set
761                 (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
762                                "������������������������������")
763                 char-set:lower-case)))
764
765  (pass-if "char-set:title-case"
766    (char-set<= (string->char-set "")
767                char-set:title-case))
768
769  (pass-if "char-set:letter"
770    (char-set<= (string->char-set
771                 (string-append
772                  ;; Lowercase
773                  "abcdefghijklmnopqrstuvwxyz"
774                  "���������������������������������"
775                  ;; Uppercase
776                  "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
777                  "������������������������������"
778                  ;; Uncased
779                  "��"))
780                char-set:letter))
781
782  (pass-if "char-set:digit"
783    (char-set<= (string->char-set "0123456789")
784                char-set:digit))
785
786  (pass-if "char-set:hex-digit"
787    (char-set<= (string->char-set "0123456789abcdefABCDEF")
788                char-set:hex-digit))
789
790  (pass-if "char-set:letter+digit"
791    (char-set<= (char-set-union
792                 char-set:letter
793                 char-set:digit)
794                char-set:letter+digit))
795
796  (pass-if "char-set:punctuation"
797    (char-set<= (string->char-set
798                 (string-append "!\"#%&'()*,-./:;?@[\\]_{}"
799                                "�������"))
800                char-set:punctuation))
801
802  (pass-if "char-set:symbol"
803    (char-set<= (string->char-set
804                 (string-append "$+<=>^`|~"
805                                "����������������"))
806                char-set:symbol))
807
808  ;; Note that SRFI-14 itself is inconsistent here.  Characters that
809  ;; are non-digit numbers (such as category No) are clearly 'graphic'
810  ;; but don't occur in the letter, digit, punct, or symbol charsets.
811  (pass-if "char-set:graphic"
812    (char-set<= (char-set-union
813                 char-set:letter
814                 char-set:digit
815                 char-set:punctuation
816                 char-set:symbol)
817                char-set:graphic))
818
819  (pass-if "char-set:whitespace"
820    (char-set<= (string->char-set
821                 (string
822                  (integer->char #x09)
823                  (integer->char #x0a)
824                  (integer->char #x0b)
825                  (integer->char #x0c)
826                  (integer->char #x0d)
827                  (integer->char #x20)
828                  (integer->char #xa0)))
829                char-set:whitespace))
830
831  (pass-if "char-set:printing"
832    (char-set<= (char-set-union char-set:graphic char-set:whitespace)
833                char-set:printing))
834
835  (pass-if "char-set:iso-control"
836    (char-set<= (string->char-set
837                 (apply string
838                        (map integer->char (append
839                                            ;; U+0000 to U+001F
840                                            (iota #x20)
841                                            (list #x7f)
842                                            ;; U+007F to U+009F
843                                            (map (lambda (x) (+ #x80 x))
844                                                 (iota #x20))))))
845                char-set:iso-control)))
846