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   (code-char code))
 101
 102 (defun character (object)
 103   #!+sb-doc
 104   "Coerce OBJECT into a CHARACTER if possible. Legal inputs are
 105   characters, strings and symbols of length 1."
 106   (flet ((do-error (control args)
 107            (error 'simple-type-error
 108                   :datum object
 109                   ;;?? how to express "symbol with name of length 1"?
 110                   :expected-type '(or character (string 1))
 111                   :format-control control
 112                   :format-arguments args)))
 113     (typecase object
 114       (character object)
 115       (string (if (= 1 (length (the string object)))
 116                   (char object 0)
 117                   (do-error
 118                    "String is not of length one: ~S" (list object))))
 119       (symbol (if (= 1 (length (symbol-name object)))
 120                   (schar (symbol-name object) 0)
 121                   (do-error
 122                    "Symbol name is not of length one: ~S" (list object))))
 123       (t (do-error "~S cannot be coerced to a character." (list object))))))
 124
 125 (defun char-name (char)
 126   #!+sb-doc
 127   "Return the name (a STRING) for a CHARACTER object."
 128   (car (rassoc char *char-name-alist*)))
 129
 130 (defun name-char (name)
 131   #!+sb-doc
 132   "Given an argument acceptable to STRING, NAME-CHAR returns a character
 133   whose name is that string, if one exists. Otherwise, NIL is returned."
 134   (cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
 135 \f
 136 ;;;; predicates
 137
 138 (defun standard-char-p (char)
 139   #!+sb-doc
 140   "The argument must be a character object. STANDARD-CHAR-P returns T if the
 141    argument is a standard character -- one of the 95 ASCII printing characters
 142    or <return>."
 143   (and (typep char 'base-char)
 144        (let ((n (char-code (the base-char char))))
 145          (or (< 31 n 127)
 146              (= n 10)))))
 147
 148 (defun %standard-char-p (thing)
 149   #!+sb-doc
 150   "Return T if and only if THING is a standard-char. Differs from
 151   STANDARD-CHAR-P in that THING doesn't have to be a character."
 152   (and (characterp thing) (standard-char-p thing)))
 153
 154 (defun graphic-char-p (char)
 155   #!+sb-doc
 156   "The argument must be a character object. GRAPHIC-CHAR-P returns T if the
 157   argument is a printing character (space through ~ in ASCII), otherwise
 158   returns NIL."
 159   (and (typep char 'base-char)
 160        (< 31
 161           (char-code (the base-char char))
 162           127)))
 163
 164 (defun alpha-char-p (char)
 165   #!+sb-doc
 166   "The argument must be a character object. ALPHA-CHAR-P returns T if the
 167    argument is an alphabetic character, A-Z or a-z; otherwise NIL."
 168   (let ((m (char-code char)))
 169     (or (< 64 m 91) (< 96 m 123))))
 170
 171 (defun upper-case-p (char)
 172   #!+sb-doc
 173   "The argument must be a character object; UPPER-CASE-P returns T if the
 174    argument is an upper-case character, NIL otherwise."
 175   (< 64
 176      (char-code char)
 177      91))
 178
 179 (defun lower-case-p (char)
 180   #!+sb-doc
 181   "The argument must be a character object; LOWER-CASE-P returns T if the
 182    argument is a lower-case character, NIL otherwise."
 183   (< 96
 184      (char-code char)
 185      123))
 186
 187 (defun both-case-p (char)
 188   #!+sb-doc
 189   "The argument must be a character object. BOTH-CASE-P returns T if the
 190   argument is an alphabetic character and if the character exists in
 191   both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
 192   (let ((m (char-code char)))
 193     (or (< 64 m 91) (< 96 m 123))))
 194
 195 (defun digit-char-p (char &optional (radix 10.))
 196   #!+sb-doc
 197   "If char is a digit in the specified radix, returns the fixnum for
 198   which that digit stands, else returns NIL."
 199   (let ((m (- (char-code char) 48)))
 200     (declare (fixnum m))
 201     (cond ((<= radix 10.)
 202            ;; Special-case decimal and smaller radices.
 203            (if (and (>= m 0) (< m radix))  m  nil))
 204           ;; Digits 0 - 9 are used as is, since radix is larger.
 205           ((and (>= m 0) (< m 10)) m)
 206           ;; Check for upper case A - Z.
 207           ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
 208           ;; Also check lower case a - z.
 209           ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
 210           ;; Else, fail.
 211           (t nil))))
 212
 213 (defun alphanumericp (char)
 214   #!+sb-doc
 215   "Given a character-object argument, ALPHANUMERICP returns T if the
 216    argument is either numeric or alphabetic."
 217   (let ((m (char-code char)))
 218     (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
 219
 220 (defun char= (character &rest more-characters)
 221   #!+sb-doc
 222   "Return T if all of the arguments are the same character."
 223   (dolist (c more-characters t)
 224     (declare (type character c))
 225     (unless (eq c character) (return nil))))
 226
 227 (defun char/= (character &rest more-characters)
 228   #!+sb-doc
 229   "Return T if no two of the arguments are the same character."
 230   (do* ((head character (car list))
 231         (list more-characters (cdr list)))
 232        ((null list) t)
 233     (declare (type character head))
 234     (dolist (c list)
 235       (declare (type character c))
 236       (when (eq head c) (return-from char/= nil)))))
 237
 238 (defun char< (character &rest more-characters)
 239   #!+sb-doc
 240   "Return T if the arguments are in strictly increasing alphabetic order."
 241   (do* ((c character (car list))
 242         (list more-characters (cdr list)))
 243        ((null list) t)
 244     (unless (< (char-int c)
 245                (char-int (car list)))
 246       (return nil))))
 247
 248 (defun char> (character &rest more-characters)
 249   #!+sb-doc
 250   "Return T if the arguments are in strictly decreasing alphabetic order."
 251   (do* ((c character (car list))
 252         (list more-characters (cdr list)))
 253        ((null list) t)
 254     (unless (> (char-int c)
 255                (char-int (car list)))
 256       (return nil))))
 257
 258 (defun char<= (character &rest more-characters)
 259   #!+sb-doc
 260   "Return T if the arguments are in strictly non-decreasing alphabetic order."
 261   (do* ((c character (car list))
 262         (list more-characters (cdr list)))
 263        ((null list) t)
 264     (unless (<= (char-int c)
 265                 (char-int (car list)))
 266       (return nil))))
 267
 268 (defun char>= (character &rest more-characters)
 269   #!+sb-doc
 270   "Return T if the arguments are in strictly non-increasing alphabetic order."
 271   (do* ((c character (car list))
 272         (list more-characters (cdr list)))
 273        ((null list) t)
 274     (unless (>= (char-int c)
 275                 (char-int (car list)))
 276       (return nil))))
 277
 278 ;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT
 279 ;;;  which loses font, bits, and case info.
 280
 281 (defmacro equal-char-code (character)
 282   `(let ((ch (char-code ,character)))
 283      (if (< 96 ch 123) (- ch 32) ch)))
 284
 285 (defun char-equal (character &rest more-characters)
 286   #!+sb-doc
 287   "Return T if all of the arguments are the same character.
 288   Font, bits, and case are ignored."
 289   (do ((clist more-characters (cdr clist)))
 290       ((null clist) t)
 291     (unless (= (equal-char-code (car clist))
 292                (equal-char-code character))
 293       (return nil))))
 294
 295 (defun char-not-equal (character &rest more-characters)
 296   #!+sb-doc
 297   "Return T if no two of the arguments are the same character.
 298    Font, bits, and case are ignored."
 299   (do* ((head character (car list))
 300         (list more-characters (cdr list)))
 301        ((null list) t)
 302     (unless (do* ((l list (cdr l)))
 303                  ((null l) t)
 304               (if (= (equal-char-code head)
 305                      (equal-char-code (car l)))
 306                   (return nil)))
 307       (return nil))))
 308
 309 (defun char-lessp (character &rest more-characters)
 310   #!+sb-doc
 311   "Return T if the arguments are in strictly increasing alphabetic order.
 312    Font, bits, and case are ignored."
 313   (do* ((c character (car list))
 314         (list more-characters (cdr list)))
 315        ((null list) t)
 316     (unless (< (equal-char-code c)
 317                (equal-char-code (car list)))
 318       (return nil))))
 319
 320 (defun char-greaterp (character &rest more-characters)
 321   #!+sb-doc
 322   "Return T if the arguments are in strictly decreasing alphabetic order.
 323    Font, bits, and case are ignored."
 324   (do* ((c character (car list))
 325         (list more-characters (cdr list)))
 326        ((null list) t)
 327     (unless (> (equal-char-code c)
 328                (equal-char-code (car list)))
 329       (return nil))))
 330
 331 (defun char-not-greaterp (character &rest more-characters)
 332   #!+sb-doc
 333   "Return T if the arguments are in strictly non-decreasing alphabetic order.
 334    Font, bits, and case are ignored."
 335   (do* ((c character (car list))
 336         (list more-characters (cdr list)))
 337        ((null list) t)
 338     (unless (<= (equal-char-code c)
 339                 (equal-char-code (car list)))
 340       (return nil))))
 341
 342 (defun char-not-lessp (character &rest more-characters)
 343   #!+sb-doc
 344   "Return T if the arguments are in strictly non-increasing alphabetic order.
 345    Font, bits, and case are ignored."
 346   (do* ((c character (car list))
 347         (list more-characters (cdr list)))
 348        ((null list) t)
 349     (unless (>= (equal-char-code c)
 350                 (equal-char-code (car list)))
 351       (return nil))))
 352 \f
 353 ;;;; miscellaneous functions
 354
 355 (defun char-upcase (char)
 356   #!+sb-doc
 357   "Return CHAR converted to upper-case if that is possible."
 358   (if (lower-case-p char)
 359       (code-char (- (char-code char) 32))
 360       char))
 361
 362 (defun char-downcase (char)
 363   #!+sb-doc
 364   "Return CHAR converted to lower-case if that is possible."
 365   (if (upper-case-p char)
 366       (code-char (+ (char-code char) 32))
 367       char))
 368
 369 (defun digit-char (weight &optional (radix 10))
 370   #!+sb-doc
 371   "All arguments must be integers. Returns a character object that
 372   represents a digit of the given weight in the specified radix. Returns
 373   NIL if no such character exists."
 374   (and (typep weight 'fixnum)
 375        (>= weight 0) (< weight radix) (< weight 36)
 376        (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))