1
;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions.
2
;;;; Martin Grabmueller, 2001-07-16
4
;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
6
;;;; This program is free software; you can redistribute it and/or modify
7
;;;; it under the terms of the GNU General Public License as published by
8
;;;; the Free Software Foundation; either version 2, or (at your option)
9
;;;; any later version.
11
;;;; This program is distributed in the hope that it will be useful,
12
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14
;;;; GNU General Public License for more details.
16
;;;; You should have received a copy of the GNU General Public License
17
;;;; along with this software; see the file COPYING. If not, write to
18
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19
;;;; Boston, MA 02110-1301 USA
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))
27
(define exception:invalid-char-set-cursor
28
(cons 'misc-error "^invalid character set cursor"))
30
(define exception:non-char-return
31
(cons 'misc-error "returned non-char"))
33
(with-test-prefix "char-set?"
35
(pass-if "success on empty set"
36
(char-set? (char-set)))
38
(pass-if "success on non-empty set"
39
(char-set? char-set:printing))
41
(pass-if "failure on empty set"
42
(not (char-set? #t))))
45
(with-test-prefix "char-set="
46
(pass-if "success, no arg"
49
(pass-if "success, one arg"
50
(char-set= char-set:lower-case))
52
(pass-if "success, two args"
53
(char-set= char-set:upper-case char-set:upper-case))
55
(pass-if "failure, first empty"
56
(not (char-set= (char-set) (char-set #\a))))
58
(pass-if "failure, second empty"
59
(not (char-set= (char-set #\a) (char-set))))
61
(pass-if "success, more args"
62
(char-set= char-set:blank char-set:blank char-set:blank)))
64
(with-test-prefix "char-set<="
65
(pass-if "success, no arg"
68
(pass-if "success, one arg"
69
(char-set<= char-set:lower-case))
71
(pass-if "success, two args"
72
(char-set<= char-set:upper-case char-set:upper-case))
74
(pass-if "success, first empty"
75
(char-set<= (char-set) (char-set #\a)))
77
(pass-if "failure, second empty"
78
(not (char-set<= (char-set #\a) (char-set))))
80
(pass-if "success, more args, equal"
81
(char-set<= char-set:blank char-set:blank char-set:blank))
83
(pass-if "success, more args, not equal"
84
(char-set<= char-set:blank
85
(char-set-adjoin char-set:blank #\F)
86
(char-set-adjoin char-set:blank #\F #\o))))
88
(with-test-prefix "char-set-hash"
89
(pass-if "empty set, bound"
90
(let ((h (char-set-hash char-set:empty 31)))
91
(and h (number? h) (exact? h) (>= h 0) (< h 31))))
93
(pass-if "empty set, no bound"
94
(let ((h (char-set-hash char-set:empty)))
95
(and h (number? h) (exact? h) (>= h 0))))
97
(pass-if "full set, bound"
98
(let ((h (char-set-hash char-set:full 31)))
99
(and h (number? h) (exact? h) (>= h 0) (< h 31))))
101
(pass-if "full set, no bound"
102
(let ((h (char-set-hash char-set:full)))
103
(and h (number? h) (exact? h) (>= h 0))))
105
(pass-if "other set, bound"
106
(let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
107
(and h (number? h) (exact? h) (>= h 0) (< h 31))))
109
(pass-if "other set, no bound"
110
(let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
111
(and h (number? h) (exact? h) (>= h 0)))))
114
(with-test-prefix "char-set cursor"
116
(pass-if-exception "invalid character cursor"
117
exception:invalid-char-set-cursor
118
(let* ((cs (char-set #\B #\r #\a #\z))
119
(cc (char-set-cursor cs)))
120
(char-set-ref cs 1000)))
123
(let* ((cs (char-set #\B #\r #\a #\z))
124
(cc (char-set-cursor cs)))
125
(char? (char-set-ref cs cc))))
127
(pass-if "end of set fails"
128
(let* ((cs (char-set #\a))
129
(cc (char-set-cursor cs)))
130
(not (end-of-char-set? cc))))
132
(pass-if "end of set succeeds, empty set"
133
(let* ((cs (char-set))
134
(cc (char-set-cursor cs)))
135
(end-of-char-set? cc)))
137
(pass-if "end of set succeeds, non-empty set"
138
(let* ((cs (char-set #\a))
139
(cc (char-set-cursor cs))
140
(cc (char-set-cursor-next cs cc)))
141
(end-of-char-set? cc))))
143
(with-test-prefix "char-set-fold"
145
(pass-if "count members"
146
(= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
149
(= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
150
(char-set) (char-set #\a #\b))) 2)))
152
(with-test-prefix "char-set-unfold"
154
(pass-if "create char set"
155
(char-set= char-set:full
156
(char-set-unfold (lambda (s) (= s 256)) integer->char
157
(lambda (s) (+ s 1)) 0)))
158
(pass-if "create char set (base set)"
159
(char-set= char-set:full
160
(char-set-unfold (lambda (s) (= s 256)) integer->char
161
(lambda (s) (+ s 1)) 0 char-set:empty))))
163
(with-test-prefix "char-set-unfold!"
165
(pass-if "create char set"
166
(char-set= char-set:full
167
(char-set-unfold! (lambda (s) (= s 256)) integer->char
168
(lambda (s) (+ s 1)) 0
169
(char-set-copy char-set:empty))))
171
(pass-if "create char set"
172
(char-set= char-set:full
173
(char-set-unfold! (lambda (s) (= s 32)) integer->char
174
(lambda (s) (+ s 1)) 0
175
(char-set-copy char-set:full)))))
178
(with-test-prefix "char-set-for-each"
180
(pass-if "copy char set"
181
(= (char-set-size (let ((cs (char-set)))
183
(lambda (c) (char-set-adjoin! cs c))
188
(with-test-prefix "char-set-map"
190
(pass-if "upper case char set"
191
(char-set= (char-set-map char-upcase char-set:lower-case)
192
char-set:upper-case)))
194
(with-test-prefix "string->char-set"
196
(pass-if "some char set"
197
(let ((chars '(#\g #\u #\i #\l #\e)))
198
(char-set= (list->char-set chars)
199
(string->char-set (apply string chars))))))
201
;; Make sure we get an ASCII charset and character classification.
202
(if (defined? 'setlocale) (setlocale LC_CTYPE "C"))
204
(with-test-prefix "standard char sets (ASCII)"
206
(pass-if "char-set:letter"
207
(char-set= (string->char-set
208
(string-append "abcdefghijklmnopqrstuvwxyz"
209
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
212
(pass-if "char-set:punctuation"
213
(char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
214
char-set:punctuation))
216
(pass-if "char-set:symbol"
217
(char-set= (string->char-set "$+<=>^`|~")
220
(pass-if "char-set:letter+digit"
221
(char-set= char-set:letter+digit
222
(char-set-union char-set:letter char-set:digit)))
224
(pass-if "char-set:graphic"
225
(char-set= char-set:graphic
226
(char-set-union char-set:letter char-set:digit
227
char-set:punctuation char-set:symbol)))
229
(pass-if "char-set:printing"
230
(char-set= char-set:printing
231
(char-set-union char-set:whitespace char-set:graphic))))
238
;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
239
;;; SRFI-14 for implementations supporting this charset is well-defined.
242
(define (every? pred lst)
243
(not (not (every pred lst))))
245
(define (find-latin1-locale)
246
;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure.
247
(if (defined? 'setlocale)
248
(let loop ((locales (map (lambda (lang)
249
(string-append lang ".iso88591"))
250
'("de_DE" "en_GB" "en_US" "es_ES"
254
(if (false-if-exception (setlocale LC_CTYPE (car locales)))
256
(loop (cdr locales)))))
260
(define %latin1 (find-latin1-locale))
262
(with-test-prefix "Latin-1 (8-bit charset)"
264
;; Note: the membership tests below are not exhaustive.
266
(pass-if "char-set:letter (membership)"
269
(let ((letters (char-set->list char-set:letter)))
270
(every? (lambda (8-bit-char)
271
(memq 8-bit-char letters))
272
(append '(#\a #\b #\c) ;; ASCII
273
(string->list "���������") ;; French
274
(string->list "���������"))))))
276
(pass-if "char-set:letter (size)"
279
(= (char-set-size char-set:letter) 117)))
281
(pass-if "char-set:lower-case (size)"
284
(= (char-set-size char-set:lower-case) (+ 26 33))))
286
(pass-if "char-set:upper-case (size)"
289
(= (char-set-size char-set:upper-case) (+ 26 30))))
291
(pass-if "char-set:punctuation (membership)"
294
(let ((punctuation (char-set->list char-set:punctuation)))
295
(every? (lambda (8-bit-char)
296
(memq 8-bit-char punctuation))
297
(append '(#\! #\. #\?) ;; ASCII
298
(string->list "��") ;; Castellano
299
(string->list "��")))))) ;; French
301
(pass-if "char-set:letter+digit"
302
(char-set= char-set:letter+digit
303
(char-set-union char-set:letter char-set:digit)))
305
(pass-if "char-set:graphic"
306
(char-set= char-set:graphic
307
(char-set-union char-set:letter char-set:digit
308
char-set:punctuation char-set:symbol)))
310
(pass-if "char-set:printing"
311
(char-set= char-set:printing
312
(char-set-union char-set:whitespace char-set:graphic))))
added
removed
test-suite/tests/srfi-14.test
