0.9.5.58:
[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 (defvar *character-database*)
36 (declaim (type (simple-array (unsigned-byte 8) (*)) *character-database*))
37
38 (macrolet ((frob ()
39              (with-open-file (stream (merge-pathnames
40                                       (make-pathname
41                                        :directory
42                                        '(:relative :up :up "output")
43                                        :name "ucd"
44                                        :type "dat")
45                                       sb!xc:*compile-file-truename*)
46                                      :direction :input
47                                      :element-type '(unsigned-byte 8))
48                (let* ((length (file-length stream))
49                       (array (make-array length
50                                          :element-type '(unsigned-byte 8))))
51                  (read-sequence array stream)
52                  `(defun !character-database-cold-init ()
53                     (setq *character-database* ',array))))))
54   (frob))
55 #+sb-xc-host (!character-database-cold-init)
56
57 ;;; This is the alist of (character-name . character) for characters
58 ;;; with long names. The first name in this list for a given character
59 ;;; is used on typeout and is the preferred form for input.
60 (macrolet ((frob (char-names-list)
61              (collect ((results))
62                (dolist (code char-names-list)
63                  (destructuring-bind (ccode names) code
64                    (dolist (name names)
65                      (results (cons name ccode)))))
66                `(defparameter *char-name-alist*
67                  (mapcar (lambda (x) (cons (car x) (code-char (cdr x))))
68                          ',(results))))))
69   ;; Note: The *** markers here indicate character names which are
70   ;; required by the ANSI specification of #'CHAR-NAME. For the others,
71   ;; we prefer the ASCII standard name.
72   (frob ((#x00 ("Nul" "Null" "^@"))
73          (#x01 ("Soh" "^a"))
74          (#x02 ("Stx" "^b"))
75          (#x03 ("Etx" "^c"))
76          (#x04 ("Eot" "^d"))
77          (#x05 ("Enq" "^e"))
78          (#x06 ("Ack" "^f"))
79          (#x07 ("Bel" "Bell" "^g"))
80          (#x08 ("Backspace" "^h" "Bs")) ; *** See Note above.
81          (#x09 ("Tab" "^i" "Ht")) ; *** See Note above.
82          (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" )) ; *** See Note above.
83          (#x0B ("Vt" "^k"))
84          (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np")) ; *** See Note above.
85          (#x0D ("Return" "^m" "Cr")) ; *** See Note above.
86          (#x0E ("So" "^n"))
87          (#x0F ("Si" "^o"))
88          (#x10 ("Dle" "^p"))
89          (#x11 ("Dc1" "^q"))
90          (#x12 ("Dc2" "^r"))
91          (#x13 ("Dc3" "^s"))
92          (#x14 ("Dc4" "^t"))
93          (#x15 ("Nak" "^u"))
94          (#x16 ("Syn" "^v"))
95          (#x17 ("Etb" "^w"))
96          (#x18 ("Can" "^x"))
97          (#x19 ("Em" "^y"))
98          (#x1A ("Sub" "^z"))
99          (#x1B ("Esc" "Escape" "^[" "Altmode" "Alt"))
100          (#x1C ("Fs" "^\\"))
101          (#x1D ("Gs" "^]"))
102          (#x1E ("Rs" "^^"))
103          (#x1F ("Us" "^_"))
104          (#x20 ("Space" "Sp")) ; *** See Note above.
105          (#x7f ("Rubout" "Delete" "Del"))
106          (#x80 ("C80"))
107          (#x81 ("C81"))
108          (#x82 ("Break-Permitted"))
109          (#x83 ("No-Break-Permitted"))
110          (#x84 ("C84"))
111          (#x85 ("Next-Line"))
112          (#x86 ("Start-Selected-Area"))
113          (#x87 ("End-Selected-Area"))
114          (#x88 ("Character-Tabulation-Set"))
115          (#x89 ("Character-Tabulation-With-Justification"))
116          (#x8A ("Line-Tabulation-Set"))
117          (#x8B ("Partial-Line-Forward"))
118          (#x8C ("Partial-Line-Backward"))
119          (#x8D ("Reverse-Linefeed"))
120          (#x8E ("Single-Shift-Two"))
121          (#x8F ("Single-Shift-Three"))
122          (#x90 ("Device-Control-String"))
123          (#x91 ("Private-Use-One"))
124          (#x92 ("Private-Use-Two"))
125          (#x93 ("Set-Transmit-State"))
126          (#x94 ("Cancel-Character"))
127          (#x95 ("Message-Waiting"))
128          (#x96 ("Start-Guarded-Area"))
129          (#x97 ("End-Guarded-Area"))
130          (#x98 ("Start-String"))
131          (#x99 ("C99"))
132          (#x9A ("Single-Character-Introducer"))
133          (#x9B ("Control-Sequence-Introducer"))
134          (#x9C ("String-Terminator"))
135          (#x9D ("Operating-System-Command"))
136          (#x9E ("Privacy-Message"))
137          (#x9F ("Application-Program-Command"))))) ; *** See Note above.
138 \f
139 ;;;; accessor functions
140
141 ;; (* 8 186) => 1488
142 ;; (+ 1488 (ash #x110000 -8)) => 5840
143 (defun ucd-index (char)
144   (let* ((cp (char-code char))
145          (cp-high (ash cp -8))
146          (page (aref *character-database* (+ 1488 cp-high))))
147     (+ 5840 (ash page 10) (ash (ldb (byte 8 0) cp) 2))))
148
149 (defun ucd-value-0 (char)
150   (aref *character-database* (ucd-index char)))
151
152 (defun ucd-value-1 (char)
153   (let ((index (ucd-index char)))
154     (dpb (aref *character-database* (+ index 3))
155          (byte 8 16)
156          (dpb (aref *character-database* (+ index 2))
157               (byte 8 8)
158               (aref *character-database* (1+ index))))))
159
160 (defun ucd-general-category (char)
161   (aref *character-database* (* 8 (ucd-value-0 char))))
162
163 (defun ucd-decimal-digit (char)
164   (let ((decimal-digit (aref *character-database*
165                              (+ 3 (* 8 (ucd-value-0 char))))))
166     (when (< decimal-digit 10)
167       decimal-digit)))
168
169 (defun char-code (char)
170   #!+sb-doc
171   "Return the integer code of CHAR."
172   ;; FIXME: do we actually need this?
173   (etypecase char
174     (character (char-code (truly-the character char)))))
175
176 (defun char-int (char)
177   #!+sb-doc
178   "Return the integer code of CHAR. (In SBCL this is the same as CHAR-CODE, as
179    there are no character bits or fonts.)"
180   (char-code char))
181
182 (defun code-char (code)
183   #!+sb-doc
184   "Return the character with the code CODE."
185   (code-char code))
186
187 (defun character (object)
188   #!+sb-doc
189   "Coerce OBJECT into a CHARACTER if possible. Legal inputs are
190   characters, strings and symbols of length 1."
191   (flet ((do-error (control args)
192            (error 'simple-type-error
193                   :datum object
194                   ;;?? how to express "symbol with name of length 1"?
195                   :expected-type '(or character (string 1))
196                   :format-control control
197                   :format-arguments args)))
198     (typecase object
199       (character object)
200       (string (if (= 1 (length (the string object)))
201                   (char object 0)
202                   (do-error
203                    "String is not of length one: ~S" (list object))))
204       (symbol (if (= 1 (length (symbol-name object)))
205                   (schar (symbol-name object) 0)
206                   (do-error
207                    "Symbol name is not of length one: ~S" (list object))))
208       (t (do-error "~S cannot be coerced to a character." (list object))))))
209
210 (defun char-name (char)
211   #!+sb-doc
212   "Return the name (a STRING) for a CHARACTER object."
213   (car (rassoc char *char-name-alist*)))
214
215 (defun name-char (name)
216   #!+sb-doc
217   "Given an argument acceptable to STRING, NAME-CHAR returns a character
218   whose name is that string, if one exists. Otherwise, NIL is returned."
219   (cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
220 \f
221 ;;;; predicates
222
223 (defun standard-char-p (char)
224   #!+sb-doc
225   "The argument must be a character object. STANDARD-CHAR-P returns T if the
226    argument is a standard character -- one of the 95 ASCII printing characters
227    or <return>."
228   (and (typep char 'base-char)
229        (let ((n (char-code (the base-char char))))
230          (or (< 31 n 127)
231              (= n 10)))))
232
233 (defun %standard-char-p (thing)
234   #!+sb-doc
235   "Return T if and only if THING is a standard-char. Differs from
236   STANDARD-CHAR-P in that THING doesn't have to be a character."
237   (and (characterp thing) (standard-char-p thing)))
238
239 (defun graphic-char-p (char)
240   #!+sb-doc
241   "The argument must be a character object. GRAPHIC-CHAR-P returns T if the
242   argument is a printing character (space through ~ in ASCII), otherwise
243   returns NIL."
244   (let ((n (char-code char)))
245     (or (< 31 n 127)
246         (< 159 n))))
247
248 (defun alpha-char-p (char)
249   #!+sb-doc
250   "The argument must be a character object. ALPHA-CHAR-P returns T if the
251    argument is an alphabetic character, A-Z or a-z; otherwise NIL."
252   (< (ucd-general-category char) 5))
253
254 (defun upper-case-p (char)
255   #!+sb-doc
256   "The argument must be a character object; UPPER-CASE-P returns T if the
257    argument is an upper-case character, NIL otherwise."
258   (= (ucd-value-0 char) 0))
259
260 (defun lower-case-p (char)
261   #!+sb-doc
262   "The argument must be a character object; LOWER-CASE-P returns T if the
263    argument is a lower-case character, NIL otherwise."
264   (= (ucd-value-0 char) 1))
265
266 (defun both-case-p (char)
267   #!+sb-doc
268   "The argument must be a character object. BOTH-CASE-P returns T if the
269   argument is an alphabetic character and if the character exists in
270   both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
271   (< (ucd-value-0 char) 2))
272
273 (defun digit-char-p (char &optional (radix 10.))
274   #!+sb-doc
275   "If char is a digit in the specified radix, returns the fixnum for
276   which that digit stands, else returns NIL."
277   (let ((m (- (char-code char) 48)))
278     (declare (fixnum m))
279     (cond ((<= radix 10.)
280            ;; Special-case decimal and smaller radices.
281            (if (and (>= m 0) (< m radix))  m  nil))
282           ;; Digits 0 - 9 are used as is, since radix is larger.
283           ((and (>= m 0) (< m 10)) m)
284           ;; Check for upper case A - Z.
285           ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
286           ;; Also check lower case a - z.
287           ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
288           ;; Else, fail.
289           (t (let ((number (ucd-decimal-digit char)))
290                (when (and number (< number radix))
291                  number))))))
292
293 (defun alphanumericp (char)
294   #!+sb-doc
295   "Given a character-object argument, ALPHANUMERICP returns T if the
296    argument is either numeric or alphabetic."
297   (let ((gc (ucd-general-category char)))
298     (or (< gc 5)
299         (= gc 12))))
300
301 (defun char= (character &rest more-characters)
302   #!+sb-doc
303   "Return T if all of the arguments are the same character."
304   (dolist (c more-characters t)
305     (declare (type character c))
306     (unless (eq c character) (return nil))))
307
308 (defun char/= (character &rest more-characters)
309   #!+sb-doc
310   "Return T if no two of the arguments are the same character."
311   (do* ((head character (car list))
312         (list more-characters (cdr list)))
313        ((null list) t)
314     (declare (type character head))
315     (dolist (c list)
316       (declare (type character c))
317       (when (eq head c) (return-from char/= nil)))))
318
319 (defun char< (character &rest more-characters)
320   #!+sb-doc
321   "Return T if the arguments are in strictly increasing alphabetic order."
322   (do* ((c character (car list))
323         (list more-characters (cdr list)))
324        ((null list) t)
325     (unless (< (char-int c)
326                (char-int (car list)))
327       (return nil))))
328
329 (defun char> (character &rest more-characters)
330   #!+sb-doc
331   "Return T if the arguments are in strictly decreasing alphabetic order."
332   (do* ((c character (car list))
333         (list more-characters (cdr list)))
334        ((null list) t)
335     (unless (> (char-int c)
336                (char-int (car list)))
337       (return nil))))
338
339 (defun char<= (character &rest more-characters)
340   #!+sb-doc
341   "Return T if the arguments are in strictly non-decreasing alphabetic order."
342   (do* ((c character (car list))
343         (list more-characters (cdr list)))
344        ((null list) t)
345     (unless (<= (char-int c)
346                 (char-int (car list)))
347       (return nil))))
348
349 (defun char>= (character &rest more-characters)
350   #!+sb-doc
351   "Return T if the arguments are in strictly non-increasing alphabetic order."
352   (do* ((c character (car list))
353         (list more-characters (cdr list)))
354        ((null list) t)
355     (unless (>= (char-int c)
356                 (char-int (car list)))
357       (return nil))))
358
359 ;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT
360 ;;;  which loses font, bits, and case info.
361
362 (defmacro equal-char-code (character)
363   (let ((ch (gensym)))
364     `(let ((,ch ,character))
365       (if (= (ucd-value-0 ,ch) 0)
366           (ucd-value-1 ,ch)
367           (char-code ,ch)))))
368
369 (defun char-equal (character &rest more-characters)
370   #!+sb-doc
371   "Return T if all of the arguments are the same character.
372   Font, bits, and case are ignored."
373   (do ((clist more-characters (cdr clist)))
374       ((null clist) t)
375     (unless (= (equal-char-code (car clist))
376                (equal-char-code character))
377       (return nil))))
378
379 (defun char-not-equal (character &rest more-characters)
380   #!+sb-doc
381   "Return T if no two of the arguments are the same character.
382    Font, bits, and case are ignored."
383   (do* ((head character (car list))
384         (list more-characters (cdr list)))
385        ((null list) t)
386     (unless (do* ((l list (cdr l)))
387                  ((null l) t)
388               (if (= (equal-char-code head)
389                      (equal-char-code (car l)))
390                   (return nil)))
391       (return nil))))
392
393 (defun char-lessp (character &rest more-characters)
394   #!+sb-doc
395   "Return T if the arguments are in strictly increasing alphabetic order.
396    Font, bits, and case are ignored."
397   (do* ((c character (car list))
398         (list more-characters (cdr list)))
399        ((null list) t)
400     (unless (< (equal-char-code c)
401                (equal-char-code (car list)))
402       (return nil))))
403
404 (defun char-greaterp (character &rest more-characters)
405   #!+sb-doc
406   "Return T if the arguments are in strictly decreasing alphabetic order.
407    Font, bits, and case are ignored."
408   (do* ((c character (car list))
409         (list more-characters (cdr list)))
410        ((null list) t)
411     (unless (> (equal-char-code c)
412                (equal-char-code (car list)))
413       (return nil))))
414
415 (defun char-not-greaterp (character &rest more-characters)
416   #!+sb-doc
417   "Return T if the arguments are in strictly non-decreasing alphabetic order.
418    Font, bits, and case are ignored."
419   (do* ((c character (car list))
420         (list more-characters (cdr list)))
421        ((null list) t)
422     (unless (<= (equal-char-code c)
423                 (equal-char-code (car list)))
424       (return nil))))
425
426 (defun char-not-lessp (character &rest more-characters)
427   #!+sb-doc
428   "Return T if the arguments are in strictly non-increasing alphabetic order.
429    Font, bits, and case are ignored."
430   (do* ((c character (car list))
431         (list more-characters (cdr list)))
432        ((null list) t)
433     (unless (>= (equal-char-code c)
434                 (equal-char-code (car list)))
435       (return nil))))
436 \f
437 ;;;; miscellaneous functions
438
439 (defun char-upcase (char)
440   #!+sb-doc
441   "Return CHAR converted to upper-case if that is possible.  Don't convert
442    lowercase eszet (U+DF)."
443   (if (= (ucd-value-0 char) 1)
444       (code-char (ucd-value-1 char))
445       char))
446
447 (defun char-downcase (char)
448   #!+sb-doc
449   "Return CHAR converted to lower-case if that is possible."
450   (if (= (ucd-value-0 char) 0)
451       (code-char (ucd-value-1 char))
452       char))
453
454 (defun digit-char (weight &optional (radix 10))
455   #!+sb-doc
456   "All arguments must be integers. Returns a character object that
457   represents a digit of the given weight in the specified radix. Returns
458   NIL if no such character exists."
459   (and (typep weight 'fixnum)
460        (>= weight 0) (< weight radix) (< weight 36)
461        (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))