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 whitespace-char-p (x)
 214   (and (characterp x)
 215        (or (char= x #\space)
 216            (char= x (code-char tab-char-code))
 217            (char= x (code-char return-char-code))
 218            (char= x #\linefeed))))
 219
 220 (defun alphanumericp (char)
 221   #!+sb-doc
 222   "Given a character-object argument, ALPHANUMERICP returns T if the
 223    argument is either numeric or alphabetic."
 224   (let ((m (char-code char)))
 225     (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
 226
 227 (defun char= (character &rest more-characters)
 228   #!+sb-doc
 229   "Return T if all of the arguments are the same character."
 230   (dolist (c more-characters t)
 231     (declare (type character c))
 232     (unless (eq c character) (return nil))))
 233
 234 (defun char/= (character &rest more-characters)
 235   #!+sb-doc
 236   "Return T if no two of the arguments are the same character."
 237   (do* ((head character (car list))
 238         (list more-characters (cdr list)))
 239        ((null list) t)
 240     (declare (type character head))
 241     (dolist (c list)
 242       (declare (type character c))
 243       (when (eq head c) (return-from char/= nil)))))
 244
 245 (defun char< (character &rest more-characters)
 246   #!+sb-doc
 247   "Return T if the arguments are in strictly increasing alphabetic order."
 248   (do* ((c character (car list))
 249         (list more-characters (cdr list)))
 250        ((null list) t)
 251     (unless (< (char-int c)
 252                (char-int (car list)))
 253       (return nil))))
 254
 255 (defun char> (character &rest more-characters)
 256   #!+sb-doc
 257   "Return T if the arguments are in strictly decreasing alphabetic order."
 258   (do* ((c character (car list))
 259         (list more-characters (cdr list)))
 260        ((null 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 non-decreasing alphabetic order."
 268   (do* ((c character (car list))
 269         (list more-characters (cdr list)))
 270        ((null 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-increasing alphabetic order."
 278   (do* ((c character (car list))
 279         (list more-characters (cdr list)))
 280        ((null list) t)
 281     (unless (>= (char-int c)
 282                 (char-int (car list)))
 283       (return nil))))
 284
 285 ;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT
 286 ;;;  which loses font, bits, and case info.
 287
 288 (defmacro equal-char-code (character)
 289   `(let ((ch (char-code ,character)))
 290      (if (< 96 ch 123) (- ch 32) ch)))
 291
 292 (defun char-equal (character &rest more-characters)
 293   #!+sb-doc
 294   "Return T if all of the arguments are the same character.
 295   Font, bits, and case are ignored."
 296   (do ((clist more-characters (cdr clist)))
 297       ((null clist) t)
 298     (unless (= (equal-char-code (car clist))
 299                (equal-char-code character))
 300       (return nil))))
 301
 302 (defun char-not-equal (character &rest more-characters)
 303   #!+sb-doc
 304   "Return T if no two of the arguments are the same character.
 305    Font, bits, and case are ignored."
 306   (do* ((head character (car list))
 307         (list more-characters (cdr list)))
 308        ((null list) t)
 309     (unless (do* ((l list (cdr l)))
 310                  ((null l) t)
 311               (if (= (equal-char-code head)
 312                      (equal-char-code (car l)))
 313                   (return nil)))
 314       (return nil))))
 315
 316 (defun char-lessp (character &rest more-characters)
 317   #!+sb-doc
 318   "Return T if the arguments are in strictly increasing alphabetic order.
 319    Font, bits, and case are ignored."
 320   (do* ((c character (car list))
 321         (list more-characters (cdr list)))
 322        ((null list) t)
 323     (unless (< (equal-char-code c)
 324                (equal-char-code (car list)))
 325       (return nil))))
 326
 327 (defun char-greaterp (character &rest more-characters)
 328   #!+sb-doc
 329   "Return T if the arguments are in strictly decreasing alphabetic order.
 330    Font, bits, and case are ignored."
 331   (do* ((c character (car list))
 332         (list more-characters (cdr list)))
 333        ((null list) t)
 334     (unless (> (equal-char-code c)
 335                (equal-char-code (car list)))
 336       (return nil))))
 337
 338 (defun char-not-greaterp (character &rest more-characters)
 339   #!+sb-doc
 340   "Return T if the arguments are in strictly non-decreasing alphabetic order.
 341    Font, bits, and case are ignored."
 342   (do* ((c character (car list))
 343         (list more-characters (cdr list)))
 344        ((null list) t)
 345     (unless (<= (equal-char-code c)
 346                 (equal-char-code (car list)))
 347       (return nil))))
 348
 349 (defun char-not-lessp (character &rest more-characters)
 350   #!+sb-doc
 351   "Return T if the arguments are in strictly non-increasing alphabetic order.
 352    Font, bits, and case are ignored."
 353   (do* ((c character (car list))
 354         (list more-characters (cdr list)))
 355        ((null list) t)
 356     (unless (>= (equal-char-code c)
 357                 (equal-char-code (car list)))
 358       (return nil))))
 359 \f
 360 ;;;; miscellaneous functions
 361
 362 (defun char-upcase (char)
 363   #!+sb-doc
 364   "Return CHAR converted to upper-case if that is possible."
 365   (if (lower-case-p char)
 366       (code-char (- (char-code char) 32))
 367       char))
 368
 369 (defun char-downcase (char)
 370   #!+sb-doc
 371   "Return CHAR converted to lower-case if that is possible."
 372   (if (upper-case-p char)
 373       (code-char (+ (char-code char) 32))
 374       char))
 375
 376 (defun digit-char (weight &optional (radix 10))
 377   #!+sb-doc
 378   "All arguments must be integers. Returns a character object that
 379   represents a digit of the given weight in the specified radix. Returns
 380   NIL if no such character exists."
 381   (and (typep weight 'fixnum)
 382        (>= weight 0) (< weight radix) (< weight 36)
 383        (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))