5 |
|
|
6 |
(in-package :cl-test) |
(in-package :cl-test) |
7 |
|
|
8 |
|
(defun char-type-error-check (fn) |
9 |
|
(loop for x in *universe* |
10 |
|
always (or (characterp x) |
11 |
|
(eq (catch-type-error (funcall fn x)) 'type-error)))) |
12 |
|
|
13 |
(deftest character-class.1 |
(deftest character-class.1 |
14 |
(subtypep 'character t) |
(subtypep 'character t) |
15 |
t t) |
t t) |
118 |
t) |
t) |
119 |
|
|
120 |
(deftest alpha-char-p.3 |
(deftest alpha-char-p.3 |
121 |
(loop for x in *universe* |
(char-type-error-check #'alpha-char-p) |
|
always (if (characterp x) |
|
|
(or (find x +alpha-chars+) |
|
|
(not (alpha-char-p x))) |
|
|
(eql (catch-type-error (alpha-char-p x)) 'type-error))) |
|
122 |
t) |
t) |
123 |
|
|
124 |
(deftest alphanumericp.1 |
(deftest alphanumericp.1 |
133 |
t) |
t) |
134 |
|
|
135 |
(deftest alphanumericp.3 |
(deftest alphanumericp.3 |
136 |
(loop for x in *universe* |
(char-type-error-check #'alphanumericp) |
|
always (if (characterp x) |
|
|
(or (find x +alphanumeric-chars+) |
|
|
(not (alphanumericp x))) |
|
|
(eql (catch-type-error (alphanumericp x)) 'type-error))) |
|
137 |
t) |
t) |
138 |
|
|
139 |
|
|
140 |
(deftest alphanumericp.4 |
(deftest alphanumericp.4 |
141 |
(loop for x in *universe* |
(loop for x in *universe* |
142 |
always (or (not (characterp x)) |
always (or (not (characterp x)) |
232 |
nil) |
nil) |
233 |
|
|
234 |
(deftest graphic-char.3 |
(deftest graphic-char.3 |
235 |
(loop for x in *universe* |
(char-type-error-check #'graphic-char-p) |
|
never (and (not (characterp x)) |
|
|
(not (eq (catch-type-error (graphic-char-p x)) 'type-error)))) |
|
236 |
t) |
t) |
237 |
|
|
238 |
(deftest standard-char-p.1 |
(deftest standard-char-p.1 |
255 |
t) |
t) |
256 |
|
|
257 |
(deftest standard-char-p.3 |
(deftest standard-char-p.3 |
258 |
|
(char-type-error-check #'standard-char-p) |
259 |
|
t) |
260 |
|
|
261 |
|
(deftest char-upcase.1 |
262 |
(loop for x in *universe* |
(loop for x in *universe* |
263 |
always (or (characterp x) |
always |
264 |
(eq (catch-type-error (standard-char-p x)) 'type-error))) |
(or (not (characterp x)) |
265 |
|
(let ((u (char-upcase x))) |
266 |
|
(and |
267 |
|
(or (lower-case-p x) (eql u x)) |
268 |
|
(eql u (char-upcase u)))))) |
269 |
|
t) |
270 |
|
|
271 |
|
(deftest char-upcase.2 |
272 |
|
(loop for i from 0 below (min 65536 char-code-limit) |
273 |
|
for x = (code-char i) |
274 |
|
always |
275 |
|
(or (not x) |
276 |
|
(let ((u (char-upcase x))) |
277 |
|
(and |
278 |
|
(or (lower-case-p x) (eql u x)) |
279 |
|
(eql u (char-upcase u)))))) |
280 |
|
t) |
281 |
|
|
282 |
|
(deftest char-upcase.3 |
283 |
|
(map 'string #'char-upcase +alpha-chars+) |
284 |
|
"ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") |
285 |
|
|
286 |
|
(deftest char-upcase.4 |
287 |
|
(char-type-error-check #'char-upcase) |
288 |
|
t) |
289 |
|
|
290 |
|
(deftest char-downcase.1 |
291 |
|
(loop for x in *universe* |
292 |
|
always |
293 |
|
(or (not (characterp x)) |
294 |
|
(let ((u (char-downcase x))) |
295 |
|
(and |
296 |
|
(or (upper-case-p x) (eql u x)) |
297 |
|
(eql u (char-downcase u)))))) |
298 |
|
t) |
299 |
|
|
300 |
|
(deftest char-downcase.2 |
301 |
|
(loop for i from 0 below (min 65536 char-code-limit) |
302 |
|
for x = (code-char i) |
303 |
|
always |
304 |
|
(or (not x) |
305 |
|
(let ((u (char-downcase x))) |
306 |
|
(and |
307 |
|
(or (upper-case-p x) (eql u x)) |
308 |
|
(eql u (char-downcase u)))))) |
309 |
|
t) |
310 |
|
|
311 |
|
(deftest char-downcase.3 |
312 |
|
(map 'string #'char-downcase +alpha-chars+) |
313 |
|
"abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") |
314 |
|
|
315 |
|
(deftest char-downcase.4 |
316 |
|
(char-type-error-check #'char-downcase) |
317 |
|
t) |
318 |
|
|
319 |
|
(deftest upper-case-p.1 |
320 |
|
(find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52) |
321 |
|
nil) |
322 |
|
|
323 |
|
(deftest upper-case-p.2 |
324 |
|
(find-if #'upper-case-p +standard-chars+ :end 26) |
325 |
|
nil) |
326 |
|
|
327 |
|
(deftest upper-case-p.3 |
328 |
|
(find #'upper-case-p +standard-chars+ :start 52) |
329 |
|
nil) |
330 |
|
|
331 |
|
(deftest upper-case-p.4 |
332 |
|
(char-type-error-check #'upper-case-p) |
333 |
|
t) |
334 |
|
|
335 |
|
(deftest lower-case-p.1 |
336 |
|
(find-if-not #'lower-case-p +standard-chars+ :end 26) |
337 |
|
nil) |
338 |
|
|
339 |
|
(deftest lower-case-p.2 |
340 |
|
(find-if #'lower-case-p +standard-chars+ :start 26) |
341 |
|
nil) |
342 |
|
|
343 |
|
(deftest lower-case-p.3 |
344 |
|
(char-type-error-check #'lower-case-p) |
345 |
|
t) |
346 |
|
|
347 |
|
(deftest both-case-p.1 |
348 |
|
(loop for x in *universe* |
349 |
|
always (or (not (characterp x)) |
350 |
|
(if (both-case-p x) |
351 |
|
(and (graphic-char-p x) |
352 |
|
(or (upper-case-p x) |
353 |
|
(lower-case-p x))) |
354 |
|
(not (or (upper-case-p x) |
355 |
|
(lower-case-p x)))))) |
356 |
|
t) |
357 |
|
|
358 |
|
(deftest both-case-p.2 |
359 |
|
(loop for i from 0 below (min 65536 char-code-limit) |
360 |
|
for x = (code-char i) |
361 |
|
always (or (not (characterp x)) |
362 |
|
(if (both-case-p x) |
363 |
|
(and (graphic-char-p x) |
364 |
|
(or (upper-case-p x) |
365 |
|
(lower-case-p x))) |
366 |
|
(not (or (upper-case-p x) |
367 |
|
(lower-case-p x)))))) |
368 |
|
t) |
369 |
|
|
370 |
|
(deftest both-case-p.3 |
371 |
|
(char-type-error-check #'both-case-p) |
372 |
|
t) |
373 |
|
|
374 |
|
(deftest char-code.1 |
375 |
|
(char-type-error-check #'char-code) |
376 |
|
t) |
377 |
|
|
378 |
|
(deftest char-code.2 |
379 |
|
(loop for i from 0 below (min 65536 char-code-limit) |
380 |
|
for c = (code-char i) |
381 |
|
always (or (not c) |
382 |
|
(eql (char-code c) i))) |
383 |
|
t) |
384 |
|
|
385 |
|
(deftest code-char.1 |
386 |
|
(loop for x across +standard-chars+ |
387 |
|
always (eql (code-char (char-code x)) x)) |
388 |
|
t) |
389 |
|
|
390 |
|
(deftest char-int.1 |
391 |
|
(loop for x across +standard-chars+ |
392 |
|
always (eql (char-int x) (char-code x))) |
393 |
|
t) |
394 |
|
|
395 |
|
(deftest char-int.2 |
396 |
|
(let ((c->i (make-hash-table :test #'equal)) |
397 |
|
(i->c (make-hash-table :test #'eql))) |
398 |
|
(flet ((%insert |
399 |
|
(c) |
400 |
|
(or (not (characterp c)) |
401 |
|
(let* ((i (char-int c)) |
402 |
|
(j (gethash c c->i)) |
403 |
|
(d (gethash i i->c))) |
404 |
|
(and |
405 |
|
(or (null j) (eql j i)) |
406 |
|
(or (null d) (char= c d)) |
407 |
|
(progn |
408 |
|
(setf (gethash c c->i) i) |
409 |
|
(setf (gethash i i->c) c) |
410 |
|
t)))))) |
411 |
|
(and |
412 |
|
(loop for i from 0 below char-code-limit |
413 |
|
always (%insert (code-char i))) |
414 |
|
(every #'%insert +standard-chars+) |
415 |
|
(every #'%insert *universe*)))) |
416 |
|
t) |
417 |
|
|
418 |
|
(deftest char-name.1 |
419 |
|
(flet ((%check |
420 |
|
(c) |
421 |
|
(or (not (characterp c)) |
422 |
|
(let ((name (char-name c))) |
423 |
|
(or (null name) |
424 |
|
(and (stringp name) |
425 |
|
(eql c (name-char name)))))))) |
426 |
|
(and |
427 |
|
(loop for i from 0 below char-code-limit |
428 |
|
always (%check (code-char i))) |
429 |
|
(every #'%check +standard-chars+) |
430 |
|
(every #'%check *universe*))) |
431 |
|
t) |
432 |
|
|
433 |
|
(deftest char-name.2 |
434 |
|
(string= (char-name #\Space) "Space") |
435 |
|
t) |
436 |
|
|
437 |
|
(deftest char-name.3 |
438 |
|
(string= (char-name #\Newline) "Newline") |
439 |
|
t) |
440 |
|
|
441 |
|
(deftest char-name.4 |
442 |
|
(loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed") |
443 |
|
for c = (name-char s) |
444 |
|
unless (or (not c) (string= (char-name c) s)) |
445 |
|
collect (list s c (char-name c))) |
446 |
|
nil) |
447 |
|
|
448 |
|
(deftest char-name.5 |
449 |
|
(char-type-error-check #'char-name) |
450 |
|
t) |
451 |
|
|
452 |
|
(deftest name-char.1 |
453 |
|
(loop for x in *universe* |
454 |
|
for s = (catch-type-error (string x)) |
455 |
|
always |
456 |
|
(or (eql s 'type-error) |
457 |
|
(let ((c (name-char x))) |
458 |
|
(or (not c) |
459 |
|
(characterp c) |
460 |
|
(string-equal (char-name c) s))))) |
461 |
|
t) |
462 |
|
|
463 |
|
(deftest name-char.2 |
464 |
|
(loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" |
465 |
|
"SpaCE" "NewLine") |
466 |
|
always |
467 |
|
(let ((c1 (name-char (string-upcase s))) |
468 |
|
(c2 (name-char (string-downcase s))) |
469 |
|
(c3 (name-char (string-capitalize s))) |
470 |
|
(c4 (name-char s))) |
471 |
|
(and (eql c1 c2) (eql c2 c3) (eql c3 c4)))) |
472 |
t) |
t) |