(deftype char-code ()
`(integer 0 (,char-code-limit)))
+;;; This is the alist of (character-name . character) for characters
+;;; with long names. The first name in this list for a given character
+;;; is used on typeout and is the preferred form for input.
(macrolet ((frob (char-names-list)
(collect ((results))
(dolist (code char-names-list)
(destructuring-bind (ccode names) code
(dolist (name names)
(results (cons name (code-char ccode))))))
- `(defparameter *char-name-alist* ',(results)
- #!+sb-doc
- "This is the alist of (character-name . character) for characters with
- long names. The first name in this list for a given character is used
- on typeout and is the preferred form for input."))))
- (frob ((#x00 ("Null" "^@" "Nul"))
- (#x01 ("^a" "Soh"))
- (#x02 ("^b" "Stx"))
- (#x03 ("^c" "Etx"))
- (#x04 ("^d" "Eot"))
- (#x05 ("^e" "Enq"))
- (#x06 ("^f" "Ack"))
- (#x07 ("Bell" "^g" "Bel"))
- (#x08 ("Backspace" "^h" "Bs"))
- (#x09 ("Tab" "^i" "Ht"))
- (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" ))
+ `(defparameter *char-name-alist* ',(results)))))
+ ;; Note: The *** markers here indicate character names which are
+ ;; required by the ANSI specification of #'CHAR-NAME. For the others,
+ ;; we prefer the ASCII standard name.
+ (frob ((#x00 ("Nul" "Null" "^@"))
+ (#x01 ("Soh" "^a"))
+ (#x02 ("Stx" "^b"))
+ (#x03 ("Etx" "^c"))
+ (#x04 ("Eot" "^d"))
+ (#x05 ("Enq" "^e"))
+ (#x06 ("Ack" "^f"))
+ (#x07 ("Bel" "Bell" "^g"))
+ (#x08 ("Backspace" "^h" "Bs")) ; *** See Note above.
+ (#x09 ("Tab" "^i" "Ht")) ; *** See Note above.
+ (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" )) ; *** See Note above.
(#x0B ("Vt" "^k"))
- (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np"))
- (#x0D ("Return" "^m" "Cr"))
- (#x0E ("^n" "So"))
- (#x0F ("^o" "Si"))
- (#x10 ("^p" "Dle"))
- (#x11 ("^q" "Dc1"))
- (#x12 ("^r" "Dc2"))
- (#x13 ("^s" "Dc3"))
- (#x14 ("^t" "Dc4"))
- (#x15 ("^u" "Nak"))
- (#x16 ("^v" "Syn"))
- (#x17 ("^w" "Etb"))
- (#x18 ("^x" "Can"))
- (#x19 ("^y" "Em"))
- (#x1A ("^z" "Sub"))
- (#x1B ("Escape" "^[" "Altmode" "Esc" "Alt"))
- (#x1C ("^\\" "Fs"))
- (#x1D ("^]" "Gs"))
- (#x1E ("^^" "Rs"))
- (#x1F ("^_" "Us"))
- (#x20 ("Space" "Sp"))
- (#x7f ("Rubout" "Delete" "Del")))))
+ (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np")) ; *** See Note above.
+ (#x0D ("Return" "^m" "Cr")) ; *** See Note above.
+ (#x0E ("So" "^n"))
+ (#x0F ("Si" "^o"))
+ (#x10 ("Dle" "^p"))
+ (#x11 ("Dc1" "^q"))
+ (#x12 ("Dc2" "^r"))
+ (#x13 ("Dc3" "^s"))
+ (#x14 ("Dc4" "^t"))
+ (#x15 ("Nak" "^u"))
+ (#x16 ("Syn" "^v"))
+ (#x17 ("Etb" "^w"))
+ (#x18 ("Can" "^x"))
+ (#x19 ("Em" "^y"))
+ (#x1A ("Sub" "^z"))
+ (#x1B ("Esc" "Escape" "^[" "Altmode" "Alt"))
+ (#x1C ("Fs" "^\\"))
+ (#x1D ("Gs" "^]"))
+ (#x1E ("Rs" "^^"))
+ (#x1F ("Us" "^_"))
+ (#x20 ("Space" "Sp")) ; *** See Note above.
+ (#x7f ("Rubout" "Delete" "Del"))))) ; *** See Note above.
\f
;;;; accessor functions
(defun char-int (char)
#!+sb-doc
- "Return the integer code of CHAR. This is the same as char-code, as
- CMU Common Lisp does not implement character bits or fonts."
+ "Return the integer code of CHAR. (In SBCL this is the same as CHAR-CODE, as
+ there are no character bits or fonts.)"
(char-code char))
(defun code-char (code)
#!+sb-doc
"Return the character with the code CODE."
- (declare (type char-code code))
(code-char code))
(defun character (object)
#!+sb-doc
- "Coerces its argument into a character object if possible. Accepts
+ "Coerce OBJECT into a CHARACTER if possible. Legal inputs are
characters, strings and symbols of length 1."
(flet ((do-error (control args)
(error 'simple-type-error
(defun char-name (char)
#!+sb-doc
- "Given a character object, char-name returns the name for that
- object (a symbol)."
+ "Return the name (a STRING) for a CHARACTER object."
(car (rassoc char *char-name-alist*)))
(defun name-char (name)
#!+sb-doc
- "Given an argument acceptable to string, name-char returns a character
- object whose name is that symbol, if one exists. Otherwise, () is returned."
+ "Given an argument acceptable to STRING, NAME-CHAR returns a character
+ whose name is that string, if one exists. Otherwise, NIL is returned."
(cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
\f
;;;; predicates
(defun standard-char-p (char)
#!+sb-doc
- "The argument must be a character object. Standard-char-p returns T if the
+ "The argument must be a character object. STANDARD-CHAR-P returns T if the
argument is a standard character -- one of the 95 ASCII printing characters
or <return>."
- (declare (character char))
(and (typep char 'base-char)
(let ((n (char-code (the base-char char))))
(or (< 31 n 127)
(defun %standard-char-p (thing)
#!+sb-doc
"Return T if and only if THING is a standard-char. Differs from
- standard-char-p in that THING doesn't have to be a character."
+ STANDARD-CHAR-P in that THING doesn't have to be a character."
(and (characterp thing) (standard-char-p thing)))
(defun graphic-char-p (char)
#!+sb-doc
- "The argument must be a character object. Graphic-char-p returns T if the
+ "The argument must be a character object. GRAPHIC-CHAR-P returns T if the
argument is a printing character (space through ~ in ASCII), otherwise
- returns ()."
- (declare (character char))
+ returns NIL."
(and (typep char 'base-char)
(< 31
(char-code (the base-char char))
(defun alpha-char-p (char)
#!+sb-doc
- "The argument must be a character object. Alpha-char-p returns T if the
- argument is an alphabetic character, A-Z or a-z; otherwise ()."
- (declare (character char))
+ "The argument must be a character object. ALPHA-CHAR-P returns T if the
+ argument is an alphabetic character, A-Z or a-z; otherwise NIL."
(let ((m (char-code char)))
(or (< 64 m 91) (< 96 m 123))))
(defun upper-case-p (char)
#!+sb-doc
- "The argument must be a character object; upper-case-p returns T if the
- argument is an upper-case character, () otherwise."
- (declare (character char))
+ "The argument must be a character object; UPPER-CASE-P returns T if the
+ argument is an upper-case character, NIL otherwise."
(< 64
(char-code char)
91))
(defun lower-case-p (char)
#!+sb-doc
- "The argument must be a character object; lower-case-p returns T if the
- argument is a lower-case character, () otherwise."
- (declare (character char))
+ "The argument must be a character object; LOWER-CASE-P returns T if the
+ argument is a lower-case character, NIL otherwise."
(< 96
(char-code char)
123))
(defun both-case-p (char)
#!+sb-doc
- "The argument must be a character object. Both-case-p returns T if the
+ "The argument must be a character object. BOTH-CASE-P returns T if the
argument is an alphabetic character and if the character exists in
- both upper and lower case. For ASCII, this is the same as Alpha-char-p."
- (declare (character char))
+ both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
(let ((m (char-code char)))
(or (< 64 m 91) (< 96 m 123))))
(defun digit-char-p (char &optional (radix 10.))
#!+sb-doc
"If char is a digit in the specified radix, returns the fixnum for
- which that digit stands, else returns NIL. Radix defaults to 10
- (decimal)."
- (declare (character char) (type (integer 2 36) radix))
+ which that digit stands, else returns NIL."
(let ((m (- (char-code char) 48)))
(declare (fixnum m))
(cond ((<= radix 10.)
;; Else, fail.
(t nil))))
-(defun whitespace-char-p (x)
- (and (characterp x)
- (or (char= x #\space)
- (char= x (code-char tab-char-code))
- (char= x (code-char return-char-code))
- (char= x #\linefeed))))
-
(defun alphanumericp (char)
#!+sb-doc
- "Given a character-object argument, alphanumericp returns T if the
+ "Given a character-object argument, ALPHANUMERICP returns T if the
argument is either numeric or alphabetic."
- (declare (character char))
(let ((m (char-code char)))
(or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
(defun char= (character &rest more-characters)
#!+sb-doc
"Return T if all of the arguments are the same character."
- (do ((clist more-characters (cdr clist)))
- ((atom clist) T)
- (unless (eq (car clist) character) (return nil))))
+ (dolist (c more-characters t)
+ (declare (type character c))
+ (unless (eq c character) (return nil))))
(defun char/= (character &rest more-characters)
#!+sb-doc
"Return T if no two of the arguments are the same character."
(do* ((head character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
- (unless (do* ((l list (cdr l))) ;inner loop returns T
- ((atom l) T) ; iff head /= rest.
- (if (eq head (car l)) (return nil)))
- (return nil))))
+ ((null list) t)
+ (declare (type character head))
+ (dolist (c list)
+ (declare (type character c))
+ (when (eq head c) (return-from char/= nil)))))
(defun char< (character &rest more-characters)
#!+sb-doc
"Return T if the arguments are in strictly increasing alphabetic order."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (< (char-int c)
(char-int (car list)))
(return nil))))
"Return T if the arguments are in strictly decreasing alphabetic order."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (> (char-int c)
(char-int (car list)))
(return nil))))
"Return T if the arguments are in strictly non-decreasing alphabetic order."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (<= (char-int c)
(char-int (car list)))
(return nil))))
"Return T if the arguments are in strictly non-increasing alphabetic order."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (>= (char-int c)
(char-int (car list)))
(return nil))))
-;;; Equal-Char-Code is used by the following functions as a version of char-int
+;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT
;;; which loses font, bits, and case info.
(defmacro equal-char-code (character)
"Return T if all of the arguments are the same character.
Font, bits, and case are ignored."
(do ((clist more-characters (cdr clist)))
- ((atom clist) T)
+ ((null clist) t)
(unless (= (equal-char-code (car clist))
(equal-char-code character))
(return nil))))
Font, bits, and case are ignored."
(do* ((head character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (do* ((l list (cdr l)))
- ((atom l) T)
+ ((null l) t)
(if (= (equal-char-code head)
(equal-char-code (car l)))
(return nil)))
Font, bits, and case are ignored."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (< (equal-char-code c)
(equal-char-code (car list)))
(return nil))))
Font, bits, and case are ignored."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (> (equal-char-code c)
(equal-char-code (car list)))
(return nil))))
Font, bits, and case are ignored."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (<= (equal-char-code c)
(equal-char-code (car list)))
(return nil))))
Font, bits, and case are ignored."
(do* ((c character (car list))
(list more-characters (cdr list)))
- ((atom list) T)
+ ((null list) t)
(unless (>= (equal-char-code c)
(equal-char-code (car list)))
(return nil))))
(defun char-upcase (char)
#!+sb-doc
"Return CHAR converted to upper-case if that is possible."
- (declare (character char))
(if (lower-case-p char)
(code-char (- (char-code char) 32))
char))
(defun char-downcase (char)
#!+sb-doc
"Return CHAR converted to lower-case if that is possible."
- (declare (character char))
(if (upper-case-p char)
(code-char (+ (char-code char) 32))
char))
#!+sb-doc
"All arguments must be integers. Returns a character object that
represents a digit of the given weight in the specified radix. Returns
- NIL if no such character exists. The character will have the specified
- font attributes."
- (declare (type (integer 2 36) radix) (type unsigned-byte weight))
+ NIL if no such character exists."
(and (typep weight 'fixnum)
(>= weight 0) (< weight radix) (< weight 36)
(code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))
projects / sbcl.git / blobdiff