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