X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-char.lisp;h=4be9e8376bc3485de4a4570d2f4c4fb111c358fc;hb=05525d3a5906d7a89fcb689c26177732493c40ce;hp=0437cc372fa07b7f5d25f080bfe7ad3c16c29050;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index 0437cc3..4be9e83 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -32,51 +32,53 @@ (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. ;;;; accessor functions @@ -88,19 +90,18 @@ (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 @@ -123,24 +124,22 @@ (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))) ;;;; 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 ." - (declare (character char)) (and (typep char 'base-char) (let ((n (char-code (the base-char char)))) (or (< 31 n 127) @@ -149,15 +148,14 @@ (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)) @@ -165,45 +163,39 @@ (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.) @@ -227,36 +219,35 @@ (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)))) @@ -266,7 +257,7 @@ "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)))) @@ -276,7 +267,7 @@ "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)))) @@ -286,12 +277,12 @@ "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) @@ -303,7 +294,7 @@ "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)))) @@ -314,9 +305,9 @@ 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))) @@ -328,7 +319,7 @@ 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)))) @@ -339,7 +330,7 @@ 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)))) @@ -350,7 +341,7 @@ 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)))) @@ -361,7 +352,7 @@ 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)))) @@ -371,7 +362,6 @@ (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)) @@ -379,7 +369,6 @@ (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)) @@ -388,9 +377,7 @@ #!+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)))))