source: trunk/source/tests/ansi-tests/char-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 9.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Oct  5 20:15:55 2002
4;;;; Contains: Auxiliary functions for character tests
5
6(in-package :cl-test)
7
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)
12          for e = (elt seq i)
13          always
14          (loop for j from (1+ i) below n
15                always (funcall fn e (elt seq j))))))
16
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))))
21
22(defun is-case-insensitive (fn)
23  (when (symbolp fn)
24    (assert (fboundp fn))
25    (setf fn (symbol-function fn)))
26  (assert (typep fn 'function))
27  (locally
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)
32         always
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)
37                             (funcall fn c2 d)
38                             (funcall fn c d2)
39                             (funcall fn c2 d2))))))
40
41(defun equiv (&rest args)
42  (declare (dynamic-extent args))
43  (cond
44   ((null args) t)
45   ((car args)
46    (loop for e in (cdr args) always e))
47   (t (loop for e in (cdr args) never e))))
48
49;;; From character.lsp
50(defun char-type-error-check (fn)
51  (when (symbolp fn)
52    (assert (fboundp fn))
53    (setf fn (symbol-function fn)))
54  (assert (typep fn 'function))
55  (locally
56   (declare (type function fn))
57   (loop for x in *universe*
58         always (or (characterp x)
59                    ;; FIXME -- catch the type error and check that datum
60                    ;; is eql to x (and that datum is not in the expected type)
61                    (eqt (catch-type-error (funcall fn x)) 'type-error)))))
62
63(defun standard-char.5.body ()
64  (loop for i from 0 below (min 65536 char-code-limit)
65        always (let ((c (code-char i)))
66                 (not (and (typep c 'standard-char)
67                           (not (standard-char-p c)))))))
68
69(defun extended-char.3.body ()
70  (loop for i from 0 below (min 65536 char-code-limit)
71        always (let ((c (code-char i)))
72                 (not (and (typep c 'base-char)
73                           (typep c 'extended-char)
74                           )))))
75
76(defun character.1.body ()
77  (loop for i from 0 below (min 65536 char-code-limit)
78        always (let ((c (code-char i)))
79                 (or (null c)
80                     (let ((s (string c)))
81                       (and
82                        (eqlt (character c) c)
83                        (eqlt (character s) c)
84                        (eqlt (character (make-symbol s)) c)))))))
85
86(defun character.2.body ()
87  (loop for x in *universe*
88        when (not (or (characterp x)
89                      (and (stringp x) (eqlt (length x) 1))
90                      (and (symbolp x) (eqlt (length (symbol-name x)) 1))
91                      (let ((c (catch-type-error (character x))))
92                        (or (eqlt c 'type-error)
93                            (let ((s (catch-type-error (string x))))
94                              (and (stringp s) (eqlt (my-aref s 0) c)))))))
95        do (return x)))
96
97(defun characterp.2.body ()
98  (loop for i from 0 below (min 65536 char-code-limit)
99        always (let ((c (code-char i)))
100                 (or (null c) (characterp c)))))
101
102(defun characterp.3.body ()
103  (loop for x in *universe*
104        always (let ((p (characterp x))
105                     (q (typep x 'character)))
106                 (if p (notnot q) (not q)))))
107
108(defun alphanumericp.4.body ()
109  (loop for x in *universe*
110        always (or (not (characterp x))
111                   (if (or (digit-char-p x) (alpha-char-p x))
112                       (alphanumericp x)
113                     ;; The hyperspec has an example that claims alphanumeric ==
114                     ;;  digit-char-p or alpha-char-p, but the text seems to suggest
115                     ;;  that there can be numeric characters for which digit-char-p
116                     ;;  returns NIL.  Therefore, I've weakened the next line
117                     ;; (not (alphanumericp x))
118                     t
119                     ))))
120
121(defun alphanumericp.5.body ()
122  (loop for i from 0 below (min 65536 char-code-limit)
123        for x = (code-char i)
124        always (or (not (characterp x))
125                   (if (or (digit-char-p x) (alpha-char-p x))
126                       (alphanumericp x)
127                     ;; The hyperspec has an example that claims alphanumeric ==
128                     ;;  digit-char-p or alpha-char-p, but the text seems to suggest
129                     ;;  that there can be numeric characters for which digit-char-p
130                     ;;  returns NIL.  Therefore, I've weakened the next line
131                     ;; (not (alphanumericp x))
132                     t               
133                     ))))
134
135(defun digit-char.1.body.old ()
136  (loop for r from 2 to 36 always
137       (loop for i from 0 to 36
138          always (let* ((c (digit-char i r))
139                        (result
140                         (if (>= i r) (null c)
141                             (eqlt c (char +extended-digit-chars+ i)))))
142                   (unless result
143                     (format t "~A ~A ~A~%" r i c))
144                   result))))
145
146(defun digit-char.1.body ()
147  (loop for r from 2 to 36 nconc
148       (loop for i from 0 to 36
149          for c = (digit-char i r)
150          unless (if (>= i r) (null c)
151                     (eqlt c (char +extended-digit-chars+ i)))
152          collect (list r i c))))
153
154(defun digit-char-p.1.body ()
155  (loop for x in *universe*
156        always (not (and (characterp x)
157                         (not (alphanumericp x))
158                         (digit-char-p x)))))
159
160(defun digit-char-p.2.body ()
161  (loop for i from 0 below (min 65536 char-code-limit)
162        for x = (code-char i)
163        always (or (not x)
164                   (not (and (not (alphanumericp x))
165                             (digit-char-p x))))))
166
167(defun digit-char-p.3.body ()
168  (loop for r from 2 to 35
169        always
170        (loop for i from r to 35
171              for c = (char +extended-digit-chars+ i)
172              never (or (digit-char-p c r)
173                        (digit-char-p (char-downcase c) r)))))
174
175(defun digit-char-p.4.body ()
176  (loop for r from 2 to 35
177        always
178        (loop for i from 0 below r
179              for c = (char +extended-digit-chars+ i)
180              always (and (eqlt (digit-char-p c r) i)
181                          (eqlt (digit-char-p (char-downcase c) r) i)))))
182
183(defun standard-char-p.2.body ()
184  (loop for x in *universe*
185        always (or (not (characterp x))
186                   (find x +standard-chars+)
187                   (not (standard-char-p x)))))
188
189(defun standard-char-p.2a.body ()
190  (loop for i from 0 below (min 65536 char-code-limit)
191        for x = (code-char i)
192        always (or (not (characterp x))
193                   (find x +standard-chars+)
194                   (not (standard-char-p x)))))
195
196(defun char-upcase.1.body ()
197  (loop for x in *universe*
198        always
199        (or (not (characterp x))
200            (let ((u (char-upcase x)))
201              (and
202               (or (lower-case-p x) (eqlt u x))
203               (eqlt u (char-upcase u)))))))
204
205(defun char-upcase.2.body ()
206  (loop for i from 0 below (min 65536 char-code-limit)
207        for x = (code-char i)
208        always
209        (or (not x)
210            (let ((u (char-upcase x)))
211              (and
212               (or (lower-case-p x) (eqlt u x))
213               (eqlt u (char-upcase u)))))))
214
215(defun char-downcase.1.body ()
216  (loop for x in *universe*
217        always
218        (or (not (characterp x))
219            (let ((u (char-downcase x)))
220              (and
221               (or (upper-case-p x) (eqlt u x))
222               (eqlt u (char-downcase u)))))))
223
224(defun char-downcase.2.body ()
225  (loop for i from 0 below (min 65536 char-code-limit)
226        for x = (code-char i)
227        always
228        (or (not x)
229            (let ((u (char-downcase x)))
230              (and
231               (or (upper-case-p x) (eqlt u x))
232               (eqlt u (char-downcase u)))))))
233
234(defun both-case-p.1.body ()
235  (loop for x in *universe*
236        always (or (not (characterp x))
237                   (if (both-case-p x)
238                       (and (graphic-char-p x)
239                            (or (upper-case-p x)
240                                (lower-case-p x)))
241                     (not (or (upper-case-p x)
242                              (lower-case-p x)))))))
243
244(defun both-case-p.2.body ()
245  (loop for i from 0 below (min 65536 char-code-limit)
246        for x = (code-char i)
247        always (or (not (characterp x))
248                   (if (both-case-p x)
249                       (and (graphic-char-p x)
250                            (or (upper-case-p x)
251                                (lower-case-p x)))
252                     (not (or (upper-case-p x)
253                              (lower-case-p x)))))))
254
255(defun char-code.2.body ()
256  (loop for i from 0 below (min 65536 char-code-limit)
257        for c = (code-char i)
258        always (or (not c)
259                   (eqlt (char-code c) i))))
260
261(defun char-int.2.fn ()
262  (declare (optimize (safety 3) (speed 1) (space 1)))
263  (let ((c->i (make-hash-table :test #'equal))
264        (i->c (make-hash-table :test #'eql)))
265    (flet ((%insert
266            (c)
267            (or (not (characterp c))
268                (let* ((i (char-int c))
269                       (j (gethash c c->i))
270                       (d (gethash i i->c)))
271                  (and
272                   (or (null j) (eqlt j i))
273                   (or (null d) (char= c d))
274                   (progn
275                     (setf (gethash c c->i) i)
276                     (setf (gethash i i->c) c)
277                     t))))))
278      (or
279       (loop for i from 0 below (min (ash 1 16) char-code-limit)
280             unless (%insert (code-char i))
281             collect i)
282       (loop for i = (random char-code-limit)
283             repeat 1000
284             unless (%insert (code-char i))
285             collect i)
286       (find-if-not #'%insert +standard-chars+)
287       (find-if-not #'%insert *universe*)))))
288
289(defun char-name.1.fn ()
290  (declare (optimize (safety 3) (speed 1) (space 1)))
291  (flet ((%check
292          (c)
293          (or (not (characterp c))
294              (let ((name (char-name c)))
295                (or (null name)
296                    (and (stringp name)
297                         (eqlt c (name-char name))))))))
298    (and
299     (loop for i from 0 below (min (ash 1 16) char-code-limit)
300           always (%check (code-char i)))
301     (every #'%check +standard-chars+)
302     (every #'%check *universe*)
303     t)))
304
305(defun name-char.1.body ()
306  (declare (optimize (safety 3)))
307  (loop for x in *universe*
308        for s = (catch-type-error (string x))
309        always
310        (or (eqlt s 'type-error)
311            (let ((c (name-char x)))
312              (or (not c)
313                  (characterp c)
314                  ;; FIXME The rest of this wasn't reachable
315                  #|
316                  (let ((name (char-name c)))
317                    (declare (type (or null string) name))
318                    (and name
319                         (string-equal name s)))
320                  |#
321                  )))))
Note: See TracBrowser for help on using the repository browser.