1 ;;;; character functions
3 ;;;; This implementation assumes the use of ASCII codes and the
4 ;;;; specific character formats used in SBCL (and its ancestor, CMU
5 ;;;; CL). It is optimized for performance rather than for portability
6 ;;;; and elegance, and may have to be rewritten if the character
7 ;;;; representation is changed.
9 ;;;; KLUDGE: As of sbcl-0.6.11.25, at least, the ASCII-dependence is
10 ;;;; not confined to this file. E.g. there are DEFTRANSFORMs in
11 ;;;; srctran.lisp for CHAR-UPCASE, CHAR-EQUAL, and CHAR-DOWNCASE, and
12 ;;;; they assume ASCII. -- WHN 2001-03-25
14 ;;;; This software is part of the SBCL system. See the README file for
15 ;;;; more information.
17 ;;;; This software is derived from the CMU CL system, which was
18 ;;;; written at Carnegie Mellon University and released into the
19 ;;;; public domain. The software is in the public domain and is
20 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
21 ;;;; files for more information.
23 (in-package "SB!IMPL")
25 ;;; We compile some trivial character operations via inline expansion.
27 (declaim (inline standard-char-p graphic-char-p alpha-char-p
28 upper-case-p lower-case-p both-case-p alphanumericp
30 (declaim (maybe-inline digit-char-p digit-weight
))
33 `(integer 0 (,char-code-limit
)))
35 ;;; This is the alist of (character-name . character) for characters
36 ;;; with long names. The first name in this list for a given character
37 ;;; is used on typeout and is the preferred form for input.
38 (macrolet ((frob (char-names-list)
40 (dolist (code char-names-list
)
41 (destructuring-bind (ccode names
) code
43 (results (cons name
(code-char ccode
))))))
44 `(defparameter *char-name-alist
* ',(results)))))
45 ;; Note: The *** markers here indicate character names which are
46 ;; required by the ANSI specification of #'CHAR-NAME. For the others,
47 ;; we prefer the ASCII standard name.
48 (frob ((#x00
("Nul" "Null" "^@"))
55 (#x07
("Bel" "Bell" "^g"))
56 (#x08
("Backspace" "^h" "Bs")) ; *** See Note above.
57 (#x09
("Tab" "^i" "Ht")) ; *** See Note above.
58 (#x0A
("Newline" "Linefeed" "^j" "Lf" "Nl" )) ; *** See Note above.
60 (#x0C
("Page" "^l" "Form" "Formfeed" "Ff" "Np")) ; *** See Note above.
61 (#x0D
("Return" "^m" "Cr")) ; *** See Note above.
75 (#x1B
("Esc" "Escape" "^[" "Altmode" "Alt"))
80 (#x20
("Space" "Sp")) ; *** See Note above.
81 (#x7f
("Rubout" "Delete" "Del"))))) ; *** See Note above.
83 ;;;; accessor functions
85 (defun char-code (char)
87 "Return the integer code of CHAR."
89 (base-char (char-code (truly-the base-char char
)))))
91 (defun char-int (char)
93 "Return the integer code of CHAR. (In SBCL this is the same as CHAR-CODE, as
94 there are no character bits or fonts.)"
97 (defun code-char (code)
99 "Return the character with the code CODE."
100 (declare (type char-code code
))
103 (defun character (object)
105 "Coerce OBJECT into a CHARACTER if possible. Legal inputs are
106 characters, strings and symbols of length 1."
107 (flet ((do-error (control args
)
108 (error 'simple-type-error
110 ;;?? how to express "symbol with name of length 1"?
111 :expected-type
'(or character
(string 1))
112 :format-control control
113 :format-arguments args
)))
116 (string (if (= 1 (length (the string object
)))
119 "String is not of length one: ~S" (list object
))))
120 (symbol (if (= 1 (length (symbol-name object
)))
121 (schar (symbol-name object
) 0)
123 "Symbol name is not of length one: ~S" (list object
))))
124 (t (do-error "~S cannot be coerced to a character." (list object
))))))
126 (defun char-name (char)
128 "Return the name (a STRING) for a CHARACTER object."
129 (car (rassoc char
*char-name-alist
*)))
131 (defun name-char (name)
133 "Given an argument acceptable to STRING, NAME-CHAR returns a character
134 whose name is that string, if one exists. Otherwise, NIL is returned."
135 (cdr (assoc (string name
) *char-name-alist
* :test
#'string-equal
)))
139 (defun standard-char-p (char)
141 "The argument must be a character object. Standard-char-p returns T if the
142 argument is a standard character -- one of the 95 ASCII printing characters
144 (declare (character char
))
145 (and (typep char
'base-char
)
146 (let ((n (char-code (the base-char char
))))
150 (defun %standard-char-p
(thing)
152 "Return T if and only if THING is a standard-char. Differs from
153 standard-char-p in that THING doesn't have to be a character."
154 (and (characterp thing
) (standard-char-p thing
)))
156 (defun graphic-char-p (char)
158 "The argument must be a character object. Graphic-char-p returns T if the
159 argument is a printing character (space through ~ in ASCII), otherwise
161 (declare (character char
))
162 (and (typep char
'base-char
)
164 (char-code (the base-char char
))
167 (defun alpha-char-p (char)
169 "The argument must be a character object. Alpha-char-p returns T if the
170 argument is an alphabetic character, A-Z or a-z; otherwise ()."
171 (declare (character char
))
172 (let ((m (char-code char
)))
173 (or (< 64 m
91) (< 96 m
123))))
175 (defun upper-case-p (char)
177 "The argument must be a character object; upper-case-p returns T if the
178 argument is an upper-case character, () otherwise."
179 (declare (character char
))
184 (defun lower-case-p (char)
186 "The argument must be a character object; lower-case-p returns T if the
187 argument is a lower-case character, () otherwise."
188 (declare (character char
))
193 (defun both-case-p (char)
195 "The argument must be a character object. Both-case-p returns T if the
196 argument is an alphabetic character and if the character exists in
197 both upper and lower case. For ASCII, this is the same as Alpha-char-p."
198 (declare (character char
))
199 (let ((m (char-code char
)))
200 (or (< 64 m
91) (< 96 m
123))))
202 (defun digit-char-p (char &optional
(radix 10.
))
204 "If char is a digit in the specified radix, returns the fixnum for
205 which that digit stands, else returns NIL. Radix defaults to 10
207 (declare (character char
) (type (integer 2 36) radix
))
208 (let ((m (- (char-code char
) 48)))
210 (cond ((<= radix
10.
)
211 ;; Special-case decimal and smaller radices.
212 (if (and (>= m
0) (< m radix
)) m nil
))
213 ;; Digits 0 - 9 are used as is, since radix is larger.
214 ((and (>= m
0) (< m
10)) m
)
215 ;; Check for upper case A - Z.
216 ((and (>= (setq m
(- m
7)) 10) (< m radix
)) m
)
217 ;; Also check lower case a - z.
218 ((and (>= (setq m
(- m
32)) 10) (< m radix
)) m
)
222 (defun whitespace-char-p (x)
224 (or (char= x
#\space
)
225 (char= x
(code-char tab-char-code
))
226 (char= x
(code-char return-char-code
))
227 (char= x
#\linefeed
))))
229 (defun alphanumericp (char)
231 "Given a character-object argument, alphanumericp returns T if the
232 argument is either numeric or alphabetic."
233 (declare (character char
))
234 (let ((m (char-code char
)))
235 (or (< 47 m
58) (< 64 m
91) (< 96 m
123))))
237 (defun char= (character &rest more-characters
)
239 "Return T if all of the arguments are the same character."
240 (do ((clist more-characters
(cdr clist
)))
242 (unless (eq (car clist
) character
) (return nil
))))
244 (defun char/= (character &rest more-characters
)
246 "Return T if no two of the arguments are the same character."
247 (do* ((head character
(car list
))
248 (list more-characters
(cdr list
)))
250 (unless (do* ((l list
(cdr l
))) ;inner loop returns T
251 ((atom l
) T
) ; iff head /= rest.
252 (if (eq head
(car l
)) (return nil
)))
255 (defun char< (character &rest more-characters
)
257 "Return T if the arguments are in strictly increasing alphabetic order."
258 (do* ((c character
(car list
))
259 (list more-characters
(cdr list
)))
261 (unless (< (char-int c
)
262 (char-int (car list
)))
265 (defun char> (character &rest more-characters
)
267 "Return T if the arguments are in strictly decreasing alphabetic order."
268 (do* ((c character
(car list
))
269 (list more-characters
(cdr list
)))
271 (unless (> (char-int c
)
272 (char-int (car list
)))
275 (defun char<= (character &rest more-characters
)
277 "Return T if the arguments are in strictly non-decreasing alphabetic order."
278 (do* ((c character
(car list
))
279 (list more-characters
(cdr list
)))
281 (unless (<= (char-int c
)
282 (char-int (car list
)))
285 (defun char>= (character &rest more-characters
)
287 "Return T if the arguments are in strictly non-increasing alphabetic order."
288 (do* ((c character
(car list
))
289 (list more-characters
(cdr list
)))
291 (unless (>= (char-int c
)
292 (char-int (car list
)))
295 ;;; Equal-Char-Code is used by the following functions as a version of char-int
296 ;;; which loses font, bits, and case info.
298 (defmacro equal-char-code
(character)
299 `(let ((ch (char-code ,character
)))
300 (if (< 96 ch
123) (- ch
32) ch
)))
302 (defun char-equal (character &rest more-characters
)
304 "Return T if all of the arguments are the same character.
305 Font, bits, and case are ignored."
306 (do ((clist more-characters
(cdr clist
)))
308 (unless (= (equal-char-code (car clist
))
309 (equal-char-code character
))
312 (defun char-not-equal (character &rest more-characters
)
314 "Return T if no two of the arguments are the same character.
315 Font, bits, and case are ignored."
316 (do* ((head character
(car list
))
317 (list more-characters
(cdr list
)))
319 (unless (do* ((l list
(cdr l
)))
321 (if (= (equal-char-code head
)
322 (equal-char-code (car l
)))
326 (defun char-lessp (character &rest more-characters
)
328 "Return T if the arguments are in strictly increasing alphabetic order.
329 Font, bits, and case are ignored."
330 (do* ((c character
(car list
))
331 (list more-characters
(cdr list
)))
333 (unless (< (equal-char-code c
)
334 (equal-char-code (car list
)))
337 (defun char-greaterp (character &rest more-characters
)
339 "Return T if the arguments are in strictly decreasing alphabetic order.
340 Font, bits, and case are ignored."
341 (do* ((c character
(car list
))
342 (list more-characters
(cdr list
)))
344 (unless (> (equal-char-code c
)
345 (equal-char-code (car list
)))
348 (defun char-not-greaterp (character &rest more-characters
)
350 "Return T if the arguments are in strictly non-decreasing alphabetic order.
351 Font, bits, and case are ignored."
352 (do* ((c character
(car list
))
353 (list more-characters
(cdr list
)))
355 (unless (<= (equal-char-code c
)
356 (equal-char-code (car list
)))
359 (defun char-not-lessp (character &rest more-characters
)
361 "Return T if the arguments are in strictly non-increasing alphabetic order.
362 Font, bits, and case are ignored."
363 (do* ((c character
(car list
))
364 (list more-characters
(cdr list
)))
366 (unless (>= (equal-char-code c
)
367 (equal-char-code (car list
)))
370 ;;;; miscellaneous functions
372 (defun char-upcase (char)
374 "Return CHAR converted to upper-case if that is possible."
375 (declare (character char
))
376 (if (lower-case-p char
)
377 (code-char (- (char-code char
) 32))
380 (defun char-downcase (char)
382 "Return CHAR converted to lower-case if that is possible."
383 (declare (character char
))
384 (if (upper-case-p char
)
385 (code-char (+ (char-code char
) 32))
388 (defun digit-char (weight &optional
(radix 10))
390 "All arguments must be integers. Returns a character object that
391 represents a digit of the given weight in the specified radix. Returns
392 NIL if no such character exists. The character will have the specified
394 (declare (type (integer 2 36) radix
) (type unsigned-byte weight
))
395 (and (typep weight
'fixnum
)
396 (>= weight
0) (< weight radix
) (< weight
36)
397 (code-char (if (< weight
10) (+ 48 weight
) (+ 55 weight
)))))