0.7.5.15:
[sbcl.git] / src / code / target-char.lisp
1 ;;;; character functions
2 ;;;;
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.
8 ;;;;
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
13
14 ;;;; This software is part of the SBCL system. See the README file for
15 ;;;; more information.
16 ;;;;
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.
22
23 (in-package "SB!IMPL")
24
25 ;;; We compile some trivial character operations via inline expansion.
26 #!-sb-fluid
27 (declaim (inline standard-char-p graphic-char-p alpha-char-p
28                  upper-case-p lower-case-p both-case-p alphanumericp
29                  char-int))
30 (declaim (maybe-inline digit-char-p digit-weight))
31
32 (deftype char-code ()
33   `(integer 0 (,char-code-limit)))
34
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)
39              (collect ((results))
40                (dolist (code char-names-list)
41                  (destructuring-bind (ccode names) code
42                    (dolist (name names)
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" "^@"))
49          (#x01 ("Soh" "^a"))
50          (#x02 ("Stx" "^b"))
51          (#x03 ("Etx" "^c"))
52          (#x04 ("Eot" "^d"))
53          (#x05 ("Enq" "^e"))
54          (#x06 ("Ack" "^f"))
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.
59          (#x0B ("Vt" "^k"))
60          (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np")) ; *** See Note above.
61          (#x0D ("Return" "^m" "Cr")) ; *** See Note above.
62          (#x0E ("So" "^n"))
63          (#x0F ("Si" "^o"))
64          (#x10 ("Dle" "^p"))
65          (#x11 ("Dc1" "^q"))
66          (#x12 ("Dc2" "^r"))
67          (#x13 ("Dc3" "^s"))
68          (#x14 ("Dc4" "^t"))
69          (#x15 ("Nak" "^u"))
70          (#x16 ("Syn" "^v"))
71          (#x17 ("Etb" "^w"))
72          (#x18 ("Can" "^x"))
73          (#x19 ("Em" "^y"))
74          (#x1A ("Sub" "^z"))
75          (#x1B ("Esc" "Escape" "^[" "Altmode" "Alt"))
76          (#x1C ("Fs" "^\\"))
77          (#x1D ("Gs" "^]"))
78          (#x1E ("Rs" "^^"))
79          (#x1F ("Us" "^_"))
80          (#x20 ("Space" "Sp")) ; *** See Note above.
81          (#x7f ("Rubout" "Delete" "Del"))))) ; *** See Note above.
82 \f
83 ;;;; accessor functions
84
85 (defun char-code (char)
86   #!+sb-doc
87   "Return the integer code of CHAR."
88   (etypecase char
89     (base-char (char-code (truly-the base-char char)))))
90
91 (defun char-int (char)
92   #!+sb-doc
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.)"
95   (char-code char))
96
97 (defun code-char (code)
98   #!+sb-doc
99   "Return the character with the code CODE."
100   (declare (type char-code code))
101   (code-char code))
102
103 (defun character (object)
104   #!+sb-doc
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
109                   :datum object
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)))
114     (typecase object
115       (character object)
116       (string (if (= 1 (length (the string object)))
117                   (char object 0)
118                   (do-error
119                    "String is not of length one: ~S" (list object))))
120       (symbol (if (= 1 (length (symbol-name object)))
121                   (schar (symbol-name object) 0)
122                   (do-error
123                    "Symbol name is not of length one: ~S" (list object))))
124       (t (do-error "~S cannot be coerced to a character." (list object))))))
125
126 (defun char-name (char)
127   #!+sb-doc
128   "Return the name (a STRING) for a CHARACTER object."
129   (car (rassoc char *char-name-alist*)))
130
131 (defun name-char (name)
132   #!+sb-doc
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)))
136 \f
137 ;;;; predicates
138
139 (defun standard-char-p (char)
140   #!+sb-doc
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
143    or <return>."
144   (declare (character char))
145   (and (typep char 'base-char)
146        (let ((n (char-code (the base-char char))))
147          (or (< 31 n 127)
148              (= n 10)))))
149
150 (defun %standard-char-p (thing)
151   #!+sb-doc
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)))
155
156 (defun graphic-char-p (char)
157   #!+sb-doc
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
160   returns ()."
161   (declare (character char))
162   (and (typep char 'base-char)
163        (< 31
164           (char-code (the base-char char))
165           127)))
166
167 (defun alpha-char-p (char)
168   #!+sb-doc
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))))
174
175 (defun upper-case-p (char)
176   #!+sb-doc
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))
180   (< 64
181      (char-code char)
182      91))
183
184 (defun lower-case-p (char)
185   #!+sb-doc
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))
189   (< 96
190      (char-code char)
191      123))
192
193 (defun both-case-p (char)
194   #!+sb-doc
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))))
201
202 (defun digit-char-p (char &optional (radix 10.))
203   #!+sb-doc
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
206   (decimal)."
207   (declare (character char) (type (integer 2 36) radix))
208   (let ((m (- (char-code char) 48)))
209     (declare (fixnum m))
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)
219           ;; Else, fail.
220           (t nil))))
221
222 (defun whitespace-char-p (x)
223   (and (characterp 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))))
228
229 (defun alphanumericp (char)
230   #!+sb-doc
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))))
236
237 (defun char= (character &rest more-characters)
238   #!+sb-doc
239   "Return T if all of the arguments are the same character."
240   (do ((clist more-characters (cdr clist)))
241       ((atom clist) T)
242     (unless (eq (car clist) character) (return nil))))
243
244 (defun char/= (character &rest more-characters)
245   #!+sb-doc
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)))
249        ((atom list) T)
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)))
253       (return nil))))
254
255 (defun char< (character &rest more-characters)
256   #!+sb-doc
257   "Return T if the arguments are in strictly increasing alphabetic order."
258   (do* ((c character (car list))
259         (list more-characters (cdr list)))
260        ((atom list) T)
261     (unless (< (char-int c)
262                (char-int (car list)))
263       (return nil))))
264
265 (defun char> (character &rest more-characters)
266   #!+sb-doc
267   "Return T if the arguments are in strictly decreasing alphabetic order."
268   (do* ((c character (car list))
269         (list more-characters (cdr list)))
270        ((atom list) T)
271     (unless (> (char-int c)
272                (char-int (car list)))
273       (return nil))))
274
275 (defun char<= (character &rest more-characters)
276   #!+sb-doc
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)))
280        ((atom list) T)
281     (unless (<= (char-int c)
282                 (char-int (car list)))
283       (return nil))))
284
285 (defun char>= (character &rest more-characters)
286   #!+sb-doc
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)))
290        ((atom list) T)
291     (unless (>= (char-int c)
292                 (char-int (car list)))
293       (return nil))))
294
295 ;;; Equal-Char-Code is used by the following functions as a version of char-int
296 ;;;  which loses font, bits, and case info.
297
298 (defmacro equal-char-code (character)
299   `(let ((ch (char-code ,character)))
300      (if (< 96 ch 123) (- ch 32) ch)))
301
302 (defun char-equal (character &rest more-characters)
303   #!+sb-doc
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)))
307       ((atom clist) T)
308     (unless (= (equal-char-code (car clist))
309                (equal-char-code character))
310       (return nil))))
311
312 (defun char-not-equal (character &rest more-characters)
313   #!+sb-doc
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)))
318        ((atom list) T)
319     (unless (do* ((l list (cdr l)))
320                  ((atom l) T)
321               (if (= (equal-char-code head)
322                      (equal-char-code (car l)))
323                   (return nil)))
324       (return nil))))
325
326 (defun char-lessp (character &rest more-characters)
327   #!+sb-doc
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)))
332        ((atom list) T)
333     (unless (< (equal-char-code c)
334                (equal-char-code (car list)))
335       (return nil))))
336
337 (defun char-greaterp (character &rest more-characters)
338   #!+sb-doc
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)))
343        ((atom list) T)
344     (unless (> (equal-char-code c)
345                (equal-char-code (car list)))
346       (return nil))))
347
348 (defun char-not-greaterp (character &rest more-characters)
349   #!+sb-doc
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)))
354        ((atom list) T)
355     (unless (<= (equal-char-code c)
356                 (equal-char-code (car list)))
357       (return nil))))
358
359 (defun char-not-lessp (character &rest more-characters)
360   #!+sb-doc
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)))
365        ((atom list) T)
366     (unless (>= (equal-char-code c)
367                 (equal-char-code (car list)))
368       (return nil))))
369 \f
370 ;;;; miscellaneous functions
371
372 (defun char-upcase (char)
373   #!+sb-doc
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))
378       char))
379
380 (defun char-downcase (char)
381   #!+sb-doc
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))
386       char))
387
388 (defun digit-char (weight &optional (radix 10))
389   #!+sb-doc
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
393   font attributes."
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)))))