/[gcl]/gcl/ansi-tests/character.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/character.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Sat Oct 5 20:32:50 2002 UTC revision 1.2 by pfdietz, Sat Oct 5 22:35:19 2002 UTC
# Line 5  Line 5 
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)
# Line 113  Line 118 
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
# Line 132  Line 133 
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))
# Line 234  Line 232 
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
# Line 259  Line 255 
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)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26