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