2
;;;; Author: Paul Dietz
3
;;;; Created: Sat Oct 5 20:15:55 2002
4
;;;; Contains: Auxiliary functions for character tests
8
(defun is-ordered-by (seq fn)
9
(declare (type function fn))
10
(let ((n (length seq)))
11
(loop for i from 0 below (1- n)
14
(loop for j from (1+ i) below n
15
always (funcall fn e (elt seq j))))))
17
(defun is-antisymmetrically-ordered-by (seq fn)
18
(declare (type function fn))
19
(and (is-ordered-by seq fn)
20
(is-ordered-by (reverse seq) (complement fn))))
22
(defun is-case-insensitive (fn)
25
(setf fn (symbol-function fn)))
26
(assert (typep fn 'function))
28
(declare (type function fn))
29
(loop for c across +code-chars+
30
for c1 = (char-upcase c)
31
for c2 = (if (eql c c1) (char-downcase c) c1)
33
(loop for d across +code-chars+
34
for d1 = (char-upcase d)
35
for d2 = (if (eql d d1) (char-downcase d) d1)
36
always (equiv (funcall fn c d)
39
(funcall fn c2 d2))))))
41
(defun equiv (&rest args)
42
(declare (dynamic-extent args))
46
(loop for e in (cdr args) always e))
47
(t (loop for e in (cdr args) never e))))
49
;;; From character.lsp
50
(defun char-type-error-check (fn)
53
(setf fn (symbol-function fn)))
54
(assert (typep fn 'function))
56
(declare (type function fn))
57
(loop for x in *universe*
58
always (or (characterp x)
59
(eqt (catch-type-error (funcall fn x)) 'type-error)))))
61
(defun standard-char.5.body ()
62
(loop for i from 0 below (min 65536 char-code-limit)
63
always (let ((c (code-char i)))
64
(not (and (typep c 'standard-char)
65
(not (standard-char-p c)))))))
67
(defun extended-char.3.body ()
68
(loop for i from 0 below (min 65536 char-code-limit)
69
always (let ((c (code-char i)))
70
(not (and (typep c 'base-char)
71
(typep c 'extended-char)
74
(defun character.1.body ()
75
(loop for i from 0 below (min 65536 char-code-limit)
76
always (let ((c (code-char i)))
80
(eqlt (character c) c)
81
(eqlt (character s) c)
82
(eqlt (character (make-symbol s)) c)))))))
84
(defun character.2.body ()
85
(loop for x in *universe*
86
when (not (or (characterp x)
87
(and (stringp x) (eqlt (length x) 1))
88
(and (symbolp x) (eqlt (length (symbol-name x)) 1))
89
(let ((c (catch-type-error (character x))))
90
(or (eqlt c 'type-error)
91
(let ((s (catch-type-error (string x))))
92
(and (stringp s) (eqlt (my-aref s 0) c)))))))
95
(defun characterp.2.body ()
96
(loop for i from 0 below (min 65536 char-code-limit)
97
always (let ((c (code-char i)))
98
(or (null c) (characterp c)))))
100
(defun characterp.3.body ()
101
(loop for x in *universe*
102
always (let ((p (characterp x))
103
(q (typep x 'character)))
104
(if p (notnot q) (not q)))))
106
(defun alphanumericp.4.body ()
107
(loop for x in *universe*
108
always (or (not (characterp x))
109
(if (or (digit-char-p x) (alpha-char-p x))
111
;; The hyperspec has an example that claims alphanumeric ==
112
;; digit-char-p or alpha-char-p, but the text seems to suggest
113
;; that there can be numeric characters for which digit-char-p
114
;; returns NIL. Therefore, I've weakened the next line
115
;; (not (alphanumericp x))
119
(defun alphanumericp.5.body ()
120
(loop for i from 0 below (min 65536 char-code-limit)
121
for x = (code-char i)
122
always (or (not (characterp x))
123
(if (or (digit-char-p x) (alpha-char-p x))
125
;; The hyperspec has an example that claims alphanumeric ==
126
;; digit-char-p or alpha-char-p, but the text seems to suggest
127
;; that there can be numeric characters for which digit-char-p
128
;; returns NIL. Therefore, I've weakened the next line
129
;; (not (alphanumericp x))
133
(defun digit-char.1.body ()
137
(loop for i from 0 to 36
138
always (let ((c (digit-char i r)))
139
(if (>= i r) (null c)
140
(eqlt c (char +extended-digit-chars+ i)))))))
142
(defun digit-char-p.1.body ()
143
(loop for x in *universe*
144
always (not (and (characterp x)
145
(not (alphanumericp x))
148
(defun digit-char-p.2.body ()
149
(loop for i from 0 below (min 65536 char-code-limit)
150
for x = (code-char i)
152
(not (and (not (alphanumericp x))
153
(digit-char-p x))))))
155
(defun digit-char-p.3.body ()
156
(loop for r from 2 to 35
158
(loop for i from r to 35
159
for c = (char +extended-digit-chars+ i)
160
never (or (digit-char-p c r)
161
(digit-char-p (char-downcase c) r)))))
163
(defun digit-char-p.4.body ()
164
(loop for r from 2 to 35
166
(loop for i from 0 below r
167
for c = (char +extended-digit-chars+ i)
168
always (and (eqlt (digit-char-p c r) i)
169
(eqlt (digit-char-p (char-downcase c) r) i)))))
171
(defun standard-char-p.2.body ()
172
(loop for x in *universe*
173
always (or (not (characterp x))
174
(find x +standard-chars+)
175
(not (standard-char-p x)))))
177
(defun standard-char-p.2a.body ()
178
(loop for i from 0 below (min 65536 char-code-limit)
179
for x = (code-char i)
180
always (or (not (characterp x))
181
(find x +standard-chars+)
182
(not (standard-char-p x)))))
184
(defun char-upcase.1.body ()
185
(loop for x in *universe*
187
(or (not (characterp x))
188
(let ((u (char-upcase x)))
190
(or (lower-case-p x) (eqlt u x))
191
(eqlt u (char-upcase u)))))))
193
(defun char-upcase.2.body ()
194
(loop for i from 0 below (min 65536 char-code-limit)
195
for x = (code-char i)
198
(let ((u (char-upcase x)))
200
(or (lower-case-p x) (eqlt u x))
201
(eqlt u (char-upcase u)))))))
203
(defun char-downcase.1.body ()
204
(loop for x in *universe*
206
(or (not (characterp x))
207
(let ((u (char-downcase x)))
209
(or (upper-case-p x) (eqlt u x))
210
(eqlt u (char-downcase u)))))))
212
(defun char-downcase.2.body ()
213
(loop for i from 0 below (min 65536 char-code-limit)
214
for x = (code-char i)
217
(let ((u (char-downcase x)))
219
(or (upper-case-p x) (eqlt u x))
220
(eqlt u (char-downcase u)))))))
222
(defun both-case-p.1.body ()
223
(loop for x in *universe*
224
always (or (not (characterp x))
226
(and (graphic-char-p x)
229
(not (or (upper-case-p x)
230
(lower-case-p x)))))))
232
(defun both-case-p.2.body ()
233
(loop for i from 0 below (min 65536 char-code-limit)
234
for x = (code-char i)
235
always (or (not (characterp x))
237
(and (graphic-char-p x)
240
(not (or (upper-case-p x)
241
(lower-case-p x)))))))
243
(defun char-code.2.body ()
244
(loop for i from 0 below (min 65536 char-code-limit)
245
for c = (code-char i)
247
(eqlt (char-code c) i))))
249
(defun char-int.2.fn ()
250
(declare (optimize (safety 3) (speed 1) (space 1)))
251
(let ((c->i (make-hash-table :test #'equal))
252
(i->c (make-hash-table :test #'eql)))
255
(or (not (characterp c))
256
(let* ((i (char-int c))
258
(d (gethash i i->c)))
260
(or (null j) (eqlt j i))
261
(or (null d) (char= c d))
263
(setf (gethash c c->i) i)
264
(setf (gethash i i->c) c)
267
(loop for i from 0 below char-code-limit
268
always (%insert (code-char i)))
269
(every #'%insert +standard-chars+)
270
(every #'%insert *universe*)
273
(defun char-name.1.fn ()
274
(declare (optimize (safety 3) (speed 1) (space 1)))
277
(or (not (characterp c))
278
(let ((name (char-name c)))
281
(eqlt c (name-char name))))))))
283
(loop for i from 0 below char-code-limit
284
always (%check (code-char i)))
285
(every #'%check +standard-chars+)
286
(every #'%check *universe*)
289
(defun name-char.1.body ()
290
(declare (optimize (safety 3)))
291
(loop for x in *universe*
292
for s = (catch-type-error (string x))
294
(or (eqlt s 'type-error)
295
(let ((c (name-char x)))
298
(let ((name (char-name c)))
299
(declare (type (or null string) name))
301
(string-equal name s))))))))
added
removed
ansi-tests/char-aux.lsp
