src/code/char.lisp

   1 ;;;; character functions
   2 ;;;;
   3 ;;;; This file assumes the use of ASCII codes and the specific
   4 ;;;; character formats used in SBCL (and its ancestor, CMU CL). It is
   5 ;;;; optimized for performance rather than for portability and
   6 ;;;; elegance, and may have to be rewritten if the character
   7 ;;;; representation is changed.
   8 ;;;;
   9 ;;;; FIXME: should perhaps be renamed ascii.lisp since it's an
  10 ;;;; unportable ASCII-dependent implementation
  11
  12 ;;;; This software is part of the SBCL system. See the README file for
  13 ;;;; more information.
  14 ;;;;
  15 ;;;; This software is derived from the CMU CL system, which was
  16 ;;;; written at Carnegie Mellon University and released into the
  17 ;;;; public domain. The software is in the public domain and is
  18 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  19 ;;;; files for more information.
  20
  21 (in-package "SB!IMPL")
  22
  23 ;;; We compile some trivial character operations via inline expansion.
  24 #!-sb-fluid
  25 (declaim (inline standard-char-p graphic-char-p alpha-char-p
  26                  upper-case-p lower-case-p both-case-p alphanumericp
  27                  char-int))
  28 (declaim (maybe-inline digit-char-p digit-weight))
  29
  30 (defconstant char-code-limit 256
  31   #!+sb-doc
  32   "the upper exclusive bound on values produced by CHAR-CODE")
  33
  34 (deftype char-code ()
  35   `(integer 0 (,char-code-limit)))
  36
  37 (macrolet ((frob (char-names-list)
  38              (collect ((results))
  39                (dolist (code char-names-list)
  40                  (destructuring-bind (ccode names) code
  41                    (dolist (name names)
  42                      (results (cons name (code-char ccode))))))
  43                `(defparameter *char-name-alist* ',(results)
  44   #!+sb-doc
  45   "This is the alist of (character-name . character) for characters with
  46   long names. The first name in this list for a given character is used
  47   on typeout and is the preferred form for input."))))
  48   (frob ((#x00 ("Null" "^@" "Nul"))
  49          (#x01 ("^a" "Soh"))
  50          (#x02 ("^b" "Stx"))
  51          (#x03 ("^c" "Etx"))
  52          (#x04 ("^d" "Eot"))
  53          (#x05 ("^e" "Enq"))
  54          (#x06 ("^f" "Ack"))
  55          (#x07 ("Bell" "^g" "Bel"))
  56          (#x08 ("Backspace" "^h" "Bs"))
  57          (#x09 ("Tab" "^i" "Ht"))
  58          (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" ))
  59          (#x0B ("Vt" "^k"))
  60          (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np"))
  61          (#x0D ("Return" "^m" "Cr"))
  62          (#x0E ("^n" "So"))
  63          (#x0F ("^o" "Si"))
  64          (#x10 ("^p" "Dle"))
  65          (#x11 ("^q" "Dc1"))
  66          (#x12 ("^r" "Dc2"))
  67          (#x13 ("^s" "Dc3"))
  68          (#x14 ("^t" "Dc4"))
  69          (#x15 ("^u" "Nak"))
  70          (#x16 ("^v" "Syn"))
  71          (#x17 ("^w" "Etb"))
  72          (#x18 ("^x" "Can"))
  73          (#x19 ("^y" "Em"))
  74          (#x1A ("^z" "Sub"))
  75          (#x1B ("Escape" "^[" "Altmode" "Esc" "Alt"))
  76          (#x1C ("^\\" "Fs"))
  77          (#x1D ("^]" "Gs"))
  78          (#x1E ("^^" "Rs"))
  79          (#x1F ("^_" "Us"))
  80          (#x20 ("Space" "Sp"))
  81          (#x7f ("Rubout" "Delete" "Del")))))
  82 \f
  83 ;;;; accessor functions
  84
  85 (defun char-code (char)
  86   #!+sb-doc
  87   "Returns 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   "Returns the integer code of CHAR. This is the same as char-code, as
  94    CMU Common Lisp does not implement character bits or fonts."
  95   (char-code char))
  96
  97 (defun code-char (code)
  98   #!+sb-doc
  99   "Returns 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   "Coerces its argument into a character object if possible. Accepts
 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   "Given a character object, char-name returns the name for that
 129   object (a symbol)."
 130   (car (rassoc char *char-name-alist*)))
 131
 132 (defun name-char (name)
 133   #!+sb-doc
 134   "Given an argument acceptable to string, name-char returns a character
 135   object whose name is that symbol, if one exists. Otherwise, () is returned."
 136   (cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
 137 \f
 138 ;;;; predicates
 139
 140 (defun standard-char-p (char)
 141   #!+sb-doc
 142   "The argument must be a character object. Standard-char-p returns T if the
 143    argument is a standard character -- one of the 95 ASCII printing characters
 144    or <return>."
 145   (declare (character char))
 146   (and (typep char 'base-char)
 147        (let ((n (char-code (the base-char char))))
 148          (or (< 31 n 127)
 149              (= n 10)))))
 150
 151 (defun %standard-char-p (thing)
 152   #!+sb-doc
 153   "Return T if and only if THING is a standard-char. Differs from
 154   standard-char-p in that THING doesn't have to be a character."
 155   (and (characterp thing) (standard-char-p thing)))
 156
 157 (defun graphic-char-p (char)
 158   #!+sb-doc
 159   "The argument must be a character object. Graphic-char-p returns T if the
 160   argument is a printing character (space through ~ in ASCII), otherwise
 161   returns ()."
 162   (declare (character char))
 163   (and (typep char 'base-char)
 164        (< 31
 165           (char-code (the base-char char))
 166           127)))
 167
 168 (defun alpha-char-p (char)
 169   #!+sb-doc
 170   "The argument must be a character object. Alpha-char-p returns T if the
 171    argument is an alphabetic character, A-Z or a-z; otherwise ()."
 172   (declare (character char))
 173   (let ((m (char-code char)))
 174     (or (< 64 m 91) (< 96 m 123))))
 175
 176 (defun upper-case-p (char)
 177   #!+sb-doc
 178   "The argument must be a character object; upper-case-p returns T if the
 179    argument is an upper-case character, () otherwise."
 180   (declare (character char))
 181   (< 64
 182      (char-code char)
 183      91))
 184
 185 (defun lower-case-p (char)
 186   #!+sb-doc
 187   "The argument must be a character object; lower-case-p returns T if the
 188    argument is a lower-case character, () otherwise."
 189   (declare (character char))
 190   (< 96
 191      (char-code char)
 192      123))
 193
 194 (defun both-case-p (char)
 195   #!+sb-doc
 196   "The argument must be a character object. Both-case-p returns T if the
 197   argument is an alphabetic character and if the character exists in
 198   both upper and lower case. For ASCII, this is the same as Alpha-char-p."
 199   (declare (character char))
 200   (let ((m (char-code char)))
 201     (or (< 64 m 91) (< 96 m 123))))
 202
 203 (defun digit-char-p (char &optional (radix 10.))
 204   #!+sb-doc
 205   "If char is a digit in the specified radix, returns the fixnum for
 206   which that digit stands, else returns NIL. Radix defaults to 10
 207   (decimal)."
 208   (declare (character char) (type (integer 2 36) radix))
 209   (let ((m (- (char-code char) 48)))
 210     (declare (fixnum m))
 211     (cond ((<= radix 10.)
 212            ;; Special-case decimal and smaller radices.
 213            (if (and (>= m 0) (< m radix))  m  nil))
 214           ;; Digits 0 - 9 are used as is, since radix is larger.
 215           ((and (>= m 0) (< m 10)) m)
 216           ;; Check for upper case A - Z.
 217           ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
 218           ;; Also check lower case a - z.
 219           ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
 220           ;; Else, fail.
 221           (t nil))))
 222
 223 (defun alphanumericp (char)
 224   #!+sb-doc
 225   "Given a character-object argument, alphanumericp returns T if the
 226    argument is either numeric or alphabetic."
 227   (declare (character char))
 228   (let ((m (char-code char)))
 229     (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
 230
 231 (defun char= (character &rest more-characters)
 232   #!+sb-doc
 233   "Returns T if all of its arguments are the same character."
 234   (do ((clist more-characters (cdr clist)))
 235       ((atom clist) T)
 236     (unless (eq (car clist) character) (return nil))))
 237
 238 (defun char/= (character &rest more-characters)
 239   #!+sb-doc
 240   "Returns T if no two of its arguments are the same character."
 241   (do* ((head character (car list))
 242         (list more-characters (cdr list)))
 243        ((atom list) T)
 244     (unless (do* ((l list (cdr l)))               ;inner loop returns T
 245                  ((atom l) T)                        ; iff head /= rest.
 246               (if (eq head (car l)) (return nil)))
 247       (return nil))))
 248
 249 (defun char< (character &rest more-characters)
 250   #!+sb-doc
 251   "Returns T if its arguments are in strictly increasing alphabetic order."
 252   (do* ((c character (car list))
 253         (list more-characters (cdr list)))
 254        ((atom list) T)
 255     (unless (< (char-int c)
 256                (char-int (car list)))
 257       (return nil))))
 258
 259 (defun char> (character &rest more-characters)
 260   #!+sb-doc
 261   "Returns T if its arguments are in strictly decreasing alphabetic order."
 262   (do* ((c character (car list))
 263         (list more-characters (cdr list)))
 264        ((atom list) T)
 265     (unless (> (char-int c)
 266                (char-int (car list)))
 267       (return nil))))
 268
 269 (defun char<= (character &rest more-characters)
 270   #!+sb-doc
 271   "Returns T if its arguments are in strictly non-decreasing alphabetic order."
 272   (do* ((c character (car list))
 273         (list more-characters (cdr list)))
 274        ((atom list) T)
 275     (unless (<= (char-int c)
 276                 (char-int (car list)))
 277       (return nil))))
 278
 279 (defun char>= (character &rest more-characters)
 280   #!+sb-doc
 281   "Returns T if its arguments are in strictly non-increasing alphabetic order."
 282   (do* ((c character (car list))
 283         (list more-characters (cdr list)))
 284        ((atom list) T)
 285     (unless (>= (char-int c)
 286                 (char-int (car list)))
 287       (return nil))))
 288
 289 ;;; Equal-Char-Code is used by the following functions as a version of char-int
 290 ;;;  which loses font, bits, and case info.
 291
 292 (defmacro equal-char-code (character)
 293   `(let ((ch (char-code ,character)))
 294      (if (< 96 ch 123) (- ch 32) ch)))
 295
 296 (defun char-equal (character &rest more-characters)
 297   #!+sb-doc
 298   "Returns T if all of its arguments are the same character.
 299   Font, bits, and case are ignored."
 300   (do ((clist more-characters (cdr clist)))
 301       ((atom clist) T)
 302     (unless (= (equal-char-code (car clist))
 303                (equal-char-code character))
 304       (return nil))))
 305
 306 (defun char-not-equal (character &rest more-characters)
 307   #!+sb-doc
 308   "Returns T if no two of its arguments are the same character.
 309    Font, bits, and case are ignored."
 310   (do* ((head character (car list))
 311         (list more-characters (cdr list)))
 312        ((atom list) T)
 313     (unless (do* ((l list (cdr l)))
 314                  ((atom l) T)
 315               (if (= (equal-char-code head)
 316                      (equal-char-code (car l)))
 317                   (return nil)))
 318       (return nil))))
 319
 320 (defun char-lessp (character &rest more-characters)
 321   #!+sb-doc
 322   "Returns T if its arguments are in strictly increasing alphabetic order.
 323    Font, bits, and case are ignored."
 324   (do* ((c character (car list))
 325         (list more-characters (cdr list)))
 326        ((atom list) T)
 327     (unless (< (equal-char-code c)
 328                (equal-char-code (car list)))
 329       (return nil))))
 330
 331 (defun char-greaterp (character &rest more-characters)
 332   #!+sb-doc
 333   "Returns T if its arguments are in strictly decreasing alphabetic order.
 334    Font, bits, and case are ignored."
 335   (do* ((c character (car list))
 336         (list more-characters (cdr list)))
 337        ((atom list) T)
 338     (unless (> (equal-char-code c)
 339                (equal-char-code (car list)))
 340       (return nil))))
 341
 342 (defun char-not-greaterp (character &rest more-characters)
 343   #!+sb-doc
 344   "Returns T if its arguments are in strictly non-decreasing alphabetic order.
 345    Font, bits, and case are ignored."
 346   (do* ((c character (car list))
 347         (list more-characters (cdr list)))
 348        ((atom list) T)
 349     (unless (<= (equal-char-code c)
 350                 (equal-char-code (car list)))
 351       (return nil))))
 352
 353 (defun char-not-lessp (character &rest more-characters)
 354   #!+sb-doc
 355   "Returns T if its arguments are in strictly non-increasing alphabetic order.
 356    Font, bits, and case are ignored."
 357   (do* ((c character (car list))
 358         (list more-characters (cdr list)))
 359        ((atom list) T)
 360     (unless (>= (equal-char-code c)
 361                 (equal-char-code (car list)))
 362       (return nil))))
 363 \f
 364 ;;;; miscellaneous functions
 365
 366 (defun char-upcase (char)
 367   #!+sb-doc
 368   "Returns CHAR converted to upper-case if that is possible."
 369   (declare (character char))
 370   (if (lower-case-p char)
 371       (code-char (- (char-code char) 32))
 372       char))
 373
 374 (defun char-downcase (char)
 375   #!+sb-doc
 376   "Returns CHAR converted to lower-case if that is possible."
 377   (declare (character char))
 378   (if (upper-case-p char)
 379       (code-char (+ (char-code char) 32))
 380       char))
 381
 382 (defun digit-char (weight &optional (radix 10))
 383   #!+sb-doc
 384   "All arguments must be integers. Returns a character object that
 385   represents a digit of the given weight in the specified radix. Returns
 386   NIL if no such character exists. The character will have the specified
 387   font attributes."
 388   (declare (type (integer 2 36) radix) (type unsigned-byte weight))
 389   (and (typep weight 'fixnum)
 390        (>= weight 0) (< weight radix) (< weight 36)
 391        (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))