/[gcl]/gcl/ansi-tests/char-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/char-aux.lsp

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

revision 1.5 by pfdietz, Thu Feb 20 13:12:14 2003 UTC revision 1.6 by pfdietz, Tue Jul 1 02:08:54 2003 UTC
# Line 6  Line 6 
6  (in-package :cl-test)  (in-package :cl-test)
7    
8  (defun is-ordered-by (seq fn)  (defun is-ordered-by (seq fn)
9      (declare (type function fn))
10    (let ((n (length seq)))    (let ((n (length seq)))
11      (loop for i from 0 below (1- n)      (loop for i from 0 below (1- n)
12            for e = (elt seq i)            for e = (elt seq i)
# Line 14  Line 15 
15                  always (funcall fn e (elt seq j))))))                  always (funcall fn e (elt seq j))))))
16    
17  (defun is-antisymmetrically-ordered-by (seq fn)  (defun is-antisymmetrically-ordered-by (seq fn)
18      (declare (type function fn))
19    (and (is-ordered-by seq fn)    (and (is-ordered-by seq fn)
20         (is-ordered-by (reverse seq) (complement fn))))         (is-ordered-by (reverse seq) (complement fn))))
21    
22  (defun is-case-insensitive (fn)  (defun is-case-insensitive (fn)
23    (loop for c across +code-chars+    (when (symbolp fn)
24          for c1 = (char-upcase c)      (assert (fboundp fn))
25          for c2 = (if (eql c c1) (char-downcase c) c1)      (setf fn (symbol-function fn)))
26          always    (assert (typep fn 'function))
27          (loop for d across +code-chars+    (locally
28                for d1 = (char-upcase d)     (declare (type function fn))
29                for d2 = (if (eql d d1) (char-downcase d) d1)     (loop for c across +code-chars+
30                always (equiv (funcall fn c d)           for c1 = (char-upcase c)
31                              (funcall fn c2 d)           for c2 = (if (eql c c1) (char-downcase c) c1)
32                              (funcall fn c d2)           always
33                              (funcall fn c2 d2)))))           (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)  (defun equiv (&rest args)
42    (declare (dynamic-extent args))    (declare (dynamic-extent args))
# Line 40  Line 48 
48    
49  ;;; From character.lsp  ;;; From character.lsp
50  (defun char-type-error-check (fn)  (defun char-type-error-check (fn)
51    (loop for x in *universe*    (when (symbolp fn)
52          always (or (characterp x)      (assert (fboundp fn))
53                     (eqt (catch-type-error (funcall fn x)) 'type-error))))      (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                        (eqt (catch-type-error (funcall fn x)) 'type-error)))))
60    
61  (defun standard-char.5.body ()  (defun standard-char.5.body ()
62    (loop for i from 0 below (min 65536 char-code-limit)    (loop for i from 0 below (min 65536 char-code-limit)

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

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