Commit 10ba407e authored by sds's avatar sds

use `collect' instead of `always' to display problematic objects in the error

parent 3d8aea7c
...@@ -61,27 +61,26 @@ ...@@ -61,27 +61,26 @@
(eqt (catch-type-error (funcall fn x)) 'type-error))))) (eqt (catch-type-error (funcall fn x)) 'type-error)))))
(defun standard-char.5.body () (defun standard-char.5.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
always (let ((c (code-char i))) unless (not (and (typep c 'standard-char)
(not (and (typep c 'standard-char) (not (standard-char-p c))))
(not (standard-char-p c))))))) collect c))
(defun extended-char.3.body () (defun extended-char.3.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
always (let ((c (code-char i))) unless (not (and (typep c 'base-char)
(not (and (typep c 'base-char) (typep c 'extended-char)))
(typep c 'extended-char) collect c))
)))))
(defun character.1.body () (defun character.1.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
always (let ((c (code-char i))) unless (or (null c)
(or (null c) (let ((s (string c)))
(let ((s (string c))) (and
(and (eqlt (character c) c)
(eqlt (character c) c) (eqlt (character s) c)
(eqlt (character s) c) (eqlt (character (make-symbol s)) c))))
(eqlt (character (make-symbol s)) c))))))) collect c))
(defun character.2.body () (defun character.2.body ()
(loop for x in *universe* (loop for x in *universe*
...@@ -95,19 +94,20 @@ ...@@ -95,19 +94,20 @@
do (return x))) do (return x)))
(defun characterp.2.body () (defun characterp.2.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
always (let ((c (code-char i))) unless (or (null c) (characterp c))
(or (null c) (characterp c))))) collect c))
(defun characterp.3.body () (defun characterp.3.body ()
(loop for x in *universe* (loop for x in *universe*
always (let ((p (characterp x)) unless (let ((p (characterp x))
(q (typep x 'character))) (q (typep x 'character)))
(if p (notnot q) (not q))))) (if p (notnot q) (not q)))
collect x))
(defun alphanumericp.4.body () (defun alphanumericp.4.body ()
(loop for x in *universe* (loop for x in *universe*
always (or (not (characterp x)) unless (or (not (characterp x))
(if (or (digit-char-p x) (alpha-char-p x)) (if (or (digit-char-p x) (alpha-char-p x))
(alphanumericp x) (alphanumericp x)
;; The hyperspec has an example that claims alphanumeric == ;; The hyperspec has an example that claims alphanumeric ==
...@@ -115,13 +115,13 @@ ...@@ -115,13 +115,13 @@
;; that there can be numeric characters for which digit-char-p ;; that there can be numeric characters for which digit-char-p
;; returns NIL. Therefore, I've weakened the next line ;; returns NIL. Therefore, I've weakened the next line
;; (not (alphanumericp x)) ;; (not (alphanumericp x))
t t))
)))) collect x))
(defun alphanumericp.5.body () (defun alphanumericp.5.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for x = (code-char i) for x = (code-char i)
always (or (not (characterp x)) unless (or (not (characterp x))
(if (or (digit-char-p x) (alpha-char-p x)) (if (or (digit-char-p x) (alpha-char-p x))
(alphanumericp x) (alphanumericp x)
;; The hyperspec has an example that claims alphanumeric == ;; The hyperspec has an example that claims alphanumeric ==
...@@ -129,8 +129,8 @@ ...@@ -129,8 +129,8 @@
;; that there can be numeric characters for which digit-char-p ;; that there can be numeric characters for which digit-char-p
;; returns NIL. Therefore, I've weakened the next line ;; returns NIL. Therefore, I've weakened the next line
;; (not (alphanumericp x)) ;; (not (alphanumericp x))
t t))
)))) collect x))
(defun digit-char.1.body.old () (defun digit-char.1.body.old ()
(loop for r from 2 to 36 always (loop for r from 2 to 36 always
...@@ -153,110 +153,121 @@ ...@@ -153,110 +153,121 @@
(defun digit-char-p.1.body () (defun digit-char-p.1.body ()
(loop for x in *universe* (loop for x in *universe*
always (not (and (characterp x) unless (not (and (characterp x)
(not (alphanumericp x)) (not (alphanumericp x))
(digit-char-p x))))) (digit-char-p x)))
collect x))
(defun digit-char-p.2.body () (defun digit-char-p.2.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for x = (code-char i) for x = (code-char i)
always (or (not x) unless (or (not x)
(not (and (not (alphanumericp x)) (not (and (not (alphanumericp x))
(digit-char-p x)))))) (digit-char-p x))))
collect x))
(defun digit-char-p.3.body () (defun digit-char-p.3.body ()
(loop for r from 2 to 35 (loop for r from 2 to 35
always for bad =
(loop for i from r to 35 (loop for i from r to 35
for c = (char +extended-digit-chars+ i) for c = (char +extended-digit-chars+ i)
never (or (digit-char-p c r) when (or (digit-char-p c r)
(digit-char-p (char-downcase c) r))))) (digit-char-p (char-downcase c) r))
collect i)
when bad collect (cons r bad)))
(defun digit-char-p.4.body () (defun digit-char-p.4.body ()
(loop for r from 2 to 35 (loop for r from 2 to 35
always for bad =
(loop for i from 0 below r (loop for i from 0 below r
for c = (char +extended-digit-chars+ i) for c = (char +extended-digit-chars+ i)
always (and (eqlt (digit-char-p c r) i) unless (and (eqlt (digit-char-p c r) i)
(eqlt (digit-char-p (char-downcase c) r) i))))) (eqlt (digit-char-p (char-downcase c) r) i))
collect i)
when bad collect (cons r bad)))
(defun standard-char-p.2.body () (defun standard-char-p.2.body ()
(loop for x in *universe* (loop for x in *universe*
always (or (not (characterp x)) unless (or (not (characterp x))
(find x +standard-chars+) (find x +standard-chars+)
(not (standard-char-p x))))) (not (standard-char-p x)))
collect x))
(defun standard-char-p.2a.body () (defun standard-char-p.2a.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for x = (code-char i) for x = (code-char i)
always (or (not (characterp x)) unless (or (not (characterp x))
(find x +standard-chars+) (find x +standard-chars+)
(not (standard-char-p x))))) (not (standard-char-p x)))
collect x))
(defun char-upcase.1.body () (defun char-upcase.1.body ()
(loop for x in *universe* (loop for x in *universe*
always unless (or (not (characterp x))
(or (not (characterp x)) (let ((u (char-upcase x)))
(let ((u (char-upcase x))) (and
(and (or (lower-case-p x) (eqlt u x))
(or (lower-case-p x) (eqlt u x)) (eqlt u (char-upcase u)))))
(eqlt u (char-upcase u))))))) collect x))
(defun char-upcase.2.body () (defun char-upcase.2.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for x = (code-char i) for x = (code-char i)
always unless (or (not x)
(or (not x) (let ((u (char-upcase x)))
(let ((u (char-upcase x))) (and
(and (or (lower-case-p x) (eqlt u x))
(or (lower-case-p x) (eqlt u x)) (eqlt u (char-upcase u)))))
(eqlt u (char-upcase u))))))) collect x))
(defun char-downcase.1.body () (defun char-downcase.1.body ()
(loop for x in *universe* (loop for x in *universe*
always unless (or (not (characterp x))
(or (not (characterp x)) (let ((u (char-downcase x)))
(let ((u (char-downcase x))) (and
(and (or (upper-case-p x) (eqlt u x))
(or (upper-case-p x) (eqlt u x)) (eqlt u (char-downcase u)))))
(eqlt u (char-downcase u))))))) collect x))
(defun char-downcase.2.body () (defun char-downcase.2.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for x = (code-char i) for x = (code-char i)
always unless (or (not x)
(or (not x) (let ((u (char-downcase x)))
(let ((u (char-downcase x))) (and
(and (or (upper-case-p x) (eqlt u x))
(or (upper-case-p x) (eqlt u x)) (eqlt u (char-downcase u)))))
(eqlt u (char-downcase u))))))) collect x))
(defun both-case-p.1.body () (defun both-case-p.1.body ()
(loop for x in *universe* (loop for x in *universe*
always (or (not (characterp x)) unless (or (not (characterp x))
(if (both-case-p x) (if (both-case-p x)
(and (graphic-char-p x) (and (graphic-char-p x)
(or (upper-case-p x) (or (upper-case-p x)
(lower-case-p x))) (lower-case-p x)))
(not (or (upper-case-p x) (not (or (upper-case-p x)
(lower-case-p x))))))) (lower-case-p x)))))
collect x))
(defun both-case-p.2.body () (defun both-case-p.2.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for x = (code-char i) for x = (code-char i)
always (or (not (characterp x)) unless (or (not (characterp x))
(if (both-case-p x) (if (both-case-p x)
(and (graphic-char-p x) (and (graphic-char-p x)
(or (upper-case-p x) (or (upper-case-p x)
(lower-case-p x))) (lower-case-p x)))
(not (or (upper-case-p x) (not (or (upper-case-p x)
(lower-case-p x))))))) (lower-case-p x)))))
collect x))
(defun char-code.2.body () (defun char-code.2.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
for c = (code-char i) for c = (code-char i)
always (or (not c) unless (or (not c)
(eqlt (char-code c) i)))) (eqlt (char-code c) i))
collect c))
(defun char-int.2.fn () (defun char-int.2.fn ()
(declare (optimize (safety 3) (speed 1) (space 1))) (declare (optimize (safety 3) (speed 1) (space 1)))
...@@ -306,7 +317,7 @@ ...@@ -306,7 +317,7 @@
(declare (optimize (safety 3))) (declare (optimize (safety 3)))
(loop for x in *universe* (loop for x in *universe*
for s = (catch-type-error (string x)) for s = (catch-type-error (string x))
always unless
(or (eqlt s 'type-error) (or (eqlt s 'type-error)
(let ((c (name-char x))) (let ((c (name-char x)))
(or (not c) (or (not c)
...@@ -318,4 +329,5 @@ ...@@ -318,4 +329,5 @@
(and name (and name
(string-equal name s))) (string-equal name s)))
|# |#
))))) )))
collect x))
...@@ -9,18 +9,19 @@ ...@@ -9,18 +9,19 @@
(deftest name-char.1 (deftest name-char.1
(name-char.1.body) (name-char.1.body)
t) ())
(deftest name-char.2 (deftest name-char.2
(loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed"
"SpaCE" "NewLine") "SpaCE" "NewLine")
always unless
(let ((c1 (name-char (string-upcase s))) (let ((c1 (name-char (string-upcase s)))
(c2 (name-char (string-downcase s))) (c2 (name-char (string-downcase s)))
(c3 (name-char (string-capitalize s))) (c3 (name-char (string-capitalize s)))
(c4 (name-char s))) (c4 (name-char s)))
(and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))
t) collect s)
())
(deftest name-char.order.1 (deftest name-char.order.1
(let ((i 0)) (let ((i 0))
......
...@@ -140,7 +140,9 @@ ...@@ -140,7 +140,9 @@
(deftest string-is-not-vector-of-character.1 (deftest string-is-not-vector-of-character.1
:notes (:nil-vectors-are-strings) :notes (:nil-vectors-are-strings)
(subtypep* 'string '(vector character)) (or (subtypep* 'string '(vector character))
(subtypep* 'string '(vector base-char))
(subtypep* 'string '(vector extended-char)))
nil t) nil t)
(deftest vector-of-character-is-string.2 (deftest vector-of-character-is-string.2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment