1 ;;;; various CHARACTER tests without side effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 ;;; ANSI's specification of #'CHAR-NAME imposes these constraints.
16 ;;; (Obviously, the numeric values in this test implicitly assume
17 ;;; we're using an ASCII-based character set.)
18 (dolist (i '(("Newline" 10)
19 ;; (ANSI also imposes a constraint on the "semi-standard
20 ;; character" "Linefeed", but in ASCII as interpreted by
21 ;; Unix it's shadowed by "Newline" and so doesn't exist
22 ;; as a separate character.)
29 (destructuring-bind (name code
) i
30 (let ((named-char (name-char name
))
31 (coded-char (code-char code
)))
32 (assert (eql named-char coded-char
))
33 (assert (characterp named-char
))
34 (let ((coded-char-name (char-name coded-char
)))
35 (assert (string= name coded-char-name
))))))
37 ;;; Trivial tests for some unicode names
39 (dolist (d '(("LATIN_CAPITAL_LETTER_A" 65)
40 ("LATIN_SMALL_LETTER_A" 97)
41 ("LATIN_SMALL_LETTER_CLOSED_OPEN_E" 666)
42 ("DIGRAM_FOR_GREATER_YIN" 9871)))
43 (destructuring-bind (name code
) d
44 (assert (eql (code-char code
) (name-char (string-downcase name
))))
45 (assert (equal name
(char-name (code-char code
))))))
47 ;;; bug 230: CHAR= didn't check types of &REST arguments
48 (with-test (:name
:type-errors
)
49 (dolist (form '((code-char char-code-limit
)
61 (char-equal #\a #\a "b")
66 (assert-error (apply (car form
) (mapcar 'eval
(cdr form
))) type-error
)))
68 ;; All of the inequality predicates when called out-of-line
69 ;; were lazy in their type-checking, and would allow junk
70 ;; if short-circuit evaluation allowed early loop termination.
71 (with-test (:name
:char-inequality-
&rest-arguments
)
72 (dolist (f '(char= char
< char
<= char
> char
>=
73 char-equal char-lessp char-not-greaterp
74 char-greaterp char-not-lessp
))
76 (assert-error (funcall f
'feep
) type-error
)
78 (assert-error (funcall f
#\a 'feep
) type-error
)
79 (assert-error (funcall f
'feep
#\a) type-error
)
81 (assert-error (funcall f
#\a #\a 'feep
) type-error
)
82 (assert-error (funcall f
#\a #\b 'feep
) type-error
)
83 (assert-error (funcall f
#\b #\a 'feep
) type-error
)
85 (assert-error (funcall f
#\a #\a #\a 'feep
) type-error
)
86 (assert-error (funcall f
#\a #\a #\a 'feep
) type-error
)))
89 (let* ((char (code-char i
))
90 (graphicp (graphic-char-p char
))
91 (name (char-name char
)))
95 (assert (null (name-char 'foo
)))
97 ;;; Between 1.0.4.53 and 1.0.4.69 character untagging was broken on
98 ;;; x86-64 if the result of the VOP was allocated on the stack, failing
99 ;;; an aver in the compiler.
100 (with-test (:name
:character-untagging
)
102 '(lambda (c0 c1 c2 c3 c4 c5 c6 c7
103 c8 c9 ca cb cc cd ce cf
)
104 (declare (type character c0 c1 c2 c3 c4 c5 c6 c7
105 c8 c9 ca cb cc cd ce cf
))
106 (char< c0 c1 c2 c3 c4 c5 c6 c7
107 c8 c9 ca cb cc cd ce cf
))))
109 ;;; Characters could be coerced to subtypes of CHARACTER to which they
110 ;;; don't belong. Also, character designators that are not characters
111 ;;; could be coerced to proper subtypes of CHARACTER.
112 (with-test (:name
:bug-841312
)
113 ;; First let's make sure that the conditions hold that make the test
114 ;; valid: #\Nak is a BASE-CHAR, which at the same time ensures that
115 ;; STANDARD-CHAR is a proper subtype of BASE-CHAR, and under
116 ;; #+SB-UNICODE the character with code 955 exists and is not a
118 (assert (typep #\Nak
'base-char
))
120 (assert (let ((c (code-char 955)))
121 (and c
(not (typep c
'base-char
)))))
122 ;; Test the formerly buggy coercions:
123 (macrolet ((assert-coerce-type-error (object type
)
124 `(assert-error (coerce ,object
',type
)
126 (assert-coerce-type-error #\Nak standard-char
)
127 (assert-coerce-type-error #\a extended-char
)
129 (assert-coerce-type-error (code-char 955) base-char
)
130 (assert-coerce-type-error 'a standard-char
)
131 (assert-coerce-type-error "a" standard-char
))
132 ;; The following coercions still need to be possible:
133 (macrolet ((assert-coercion (object type
)
134 `(assert (typep (coerce ,object
',type
) ',type
))))
135 (assert-coercion #\a standard-char
)
136 (assert-coercion #\Nak base-char
)
138 (assert-coercion (code-char 955) character
)
139 (assert-coercion 'a character
)
140 (assert-coercion "a" character
)))
142 (with-test (:name
:bug-994487
)
143 (let ((f (compile nil
`(lambda (char)
144 (code-char (1+ (char-code char
)))))))
145 (assert (equal `(function (t) (values (sb-kernel:character-set
146 ((1 .
,(1- char-code-limit
))))
148 (sb-impl::%fun-ftype f
)))))
150 (with-test (:name
(:case-insensitive-char-comparisons
:eacute
))
151 (assert (char-equal (code-char 201) (code-char 233))))
153 (with-test (:name
(:case-insensitive-char-comparisons
:exhaustive
))
154 (dotimes (i char-code-limit
)
155 (let* ((char (code-char i
))
156 (down (char-downcase char
))
157 (up (char-upcase char
)))
158 (assert (char-equal char char
))
159 (when (char/= char down
)
160 (assert (char-equal char down
)))
161 (when (char/= char up
)
162 (assert (char-equal char up
))))))
164 (macrolet ((frob (predicate yes
)
165 `(with-test (:name
(,predicate standard-char
))
167 (let ((char (code-char i
)))
168 (when (typep char
'standard-char
)
170 (assert (,predicate char
))
171 (assert (not (,predicate char
))))))))))
172 (frob lower-case-p
"abcdefghijklmnopqrstuvwxyz")
173 (frob upper-case-p
"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
174 (frob digit-char-p
"0123456789")
175 (frob both-case-p
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
176 (frob alphanumericp
"0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
178 (with-test (:name
:name-char-short-string
)
182 (with-test (:name
:char-case-latin-1-base-strings
)
183 (let ((string (map-into (make-array 10 :element-type
'character
:adjustable t
)
185 '(192 193 194 195 196 197 198 199 200 201))))
187 (map 'list
#'char-code
(nstring-downcase string
))
188 '(224 225 226 227 228 229 230 231 232 233)))
190 (map 'list
#'char-code
(string-upcase string
))
191 '(192 193 194 195 196 197 198 199 200 201)))))
193 (with-test (:name
:char-equal-transform
)
194 (let ((fun (checked-compile
196 (declare (base-char x y
)
199 (loop for a below sb-int
:base-char-code-limit
200 for char-a
= (code-char a
)
202 (loop for b below sb-int
:base-char-code-limit
203 for char-b
= (code-char b
)
204 for equal
= (char= (char-downcase char-a
)
205 (char-downcase char-b
))
206 do
(assert (eql (funcall fun char-a char-b
)
208 (with-test (:name
:code-char-type-unions
)
211 (declare ((or (eql 5) (eql 10)) b
))
212 (typep (code-char b
) 'base-char
))
215 (with-test (:name
:char
<-out-of-range
)
218 (when (char> c
(code-char (1- char-code-limit
)))
223 (when (char< c
(code-char 0))
228 (with-test (:name
:equalp-to-eql
)
229 (checked-compile-and-assert
232 (declare (character a
))
233 (equalp a
(the (or null character
) b
)))