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