X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-char.lisp;h=68b02d0ddb60f1aba7db41bc6fa16228d433625e;hb=71d60093b1a9d80c4de6c5f51c6783eef86968d9;hp=2efd4c777e9be862297a2bc836eec086f86570b4;hpb=1c7cf626e647866aec33c4a6e7e8edb26554fe3b;p=sbcl.git diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index 2efd4c7..68b02d0 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -25,15 +25,15 @@ ;;; We compile some trivial character operations via inline expansion. #!-sb-fluid (declaim (inline standard-char-p graphic-char-p alpha-char-p - upper-case-p lower-case-p both-case-p alphanumericp - char-int)) + upper-case-p lower-case-p both-case-p alphanumericp + char-int)) (declaim (maybe-inline digit-char-p digit-weight)) (deftype char-code () `(integer 0 (,char-code-limit))) (defvar *character-database*) -(declaim (type (vector (unsigned-byte 8)) *character-database*)) +(declaim (type (simple-array (unsigned-byte 8) (*)) *character-database*)) (macrolet ((frob () (with-open-file (stream (merge-pathnames @@ -50,7 +50,7 @@ :element-type '(unsigned-byte 8)))) (read-sequence array stream) `(defun !character-database-cold-init () - (setq *character-database* ',array)))))) + (setq *character-database* ',array)))))) (frob)) #+sb-xc-host (!character-database-cold-init) @@ -58,83 +58,83 @@ ;;; 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 ccode))))) - `(defparameter *char-name-alist* + (collect ((results)) + (dolist (code char-names-list) + (destructuring-bind (ccode names) code + (dolist (name names) + (results (cons name ccode))))) + `(defparameter *char-name-alist* (mapcar (lambda (x) (cons (car x) (code-char (cdr x)))) ',(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")) ; *** 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")) - (#x80 ("C80")) - (#x81 ("C81")) - (#x82 ("Break-Permitted")) - (#x83 ("No-Break-Permitted")) - (#x84 ("C84")) - (#x85 ("Next-Line")) - (#x86 ("Start-Selected-Area")) - (#x87 ("End-Selected-Area")) - (#x88 ("Character-Tabulation-Set")) - (#x89 ("Character-Tabulation-With-Justification")) - (#x8A ("Line-Tabulation-Set")) - (#x8B ("Partial-Line-Forward")) - (#x8C ("Partial-Line-Backward")) - (#x8D ("Reverse-Linefeed")) - (#x8E ("Single-Shift-Two")) - (#x8F ("Single-Shift-Three")) - (#x90 ("Device-Control-String")) - (#x91 ("Private-Use-One")) - (#x92 ("Private-Use-Two")) - (#x93 ("Set-Transmit-State")) - (#x94 ("Cancel-Character")) - (#x95 ("Message-Waiting")) - (#x96 ("Start-Guarded-Area")) - (#x97 ("End-Guarded-Area")) - (#x98 ("Start-String")) - (#x99 ("C99")) - (#x9A ("Single-Character-Introducer")) - (#x9B ("Control-Sequence-Introducer")) - (#x9C ("String-Terminator")) - (#x9D ("Operating-System-Command")) - (#x9E ("Privacy-Message")) - (#x9F ("Application-Program-Command"))))) ; *** See Note above. + (#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")) ; *** 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")) + (#x80 ("C80")) + (#x81 ("C81")) + (#x82 ("Break-Permitted")) + (#x83 ("No-Break-Permitted")) + (#x84 ("C84")) + (#x85 ("Next-Line")) + (#x86 ("Start-Selected-Area")) + (#x87 ("End-Selected-Area")) + (#x88 ("Character-Tabulation-Set")) + (#x89 ("Character-Tabulation-With-Justification")) + (#x8A ("Line-Tabulation-Set")) + (#x8B ("Partial-Line-Forward")) + (#x8C ("Partial-Line-Backward")) + (#x8D ("Reverse-Linefeed")) + (#x8E ("Single-Shift-Two")) + (#x8F ("Single-Shift-Three")) + (#x90 ("Device-Control-String")) + (#x91 ("Private-Use-One")) + (#x92 ("Private-Use-Two")) + (#x93 ("Set-Transmit-State")) + (#x94 ("Cancel-Character")) + (#x95 ("Message-Waiting")) + (#x96 ("Start-Guarded-Area")) + (#x97 ("End-Guarded-Area")) + (#x98 ("Start-String")) + (#x99 ("C99")) + (#x9A ("Single-Character-Introducer")) + (#x9B ("Control-Sequence-Introducer")) + (#x9C ("String-Terminator")) + (#x9D ("Operating-System-Command")) + (#x9E ("Privacy-Message")) + (#x9F ("Application-Program-Command"))))) ; *** See Note above. ;;;; accessor functions @@ -142,8 +142,8 @@ ;; (+ 1488 (ash #x110000 -8)) => 5840 (defun ucd-index (char) (let* ((cp (char-code char)) - (cp-high (ash cp -8)) - (page (aref *character-database* (+ 1488 cp-high)))) + (cp-high (ash cp -8)) + (page (aref *character-database* (+ 1488 cp-high)))) (+ 5840 (ash page 10) (ash (ldb (byte 8 0) cp) 2)))) (defun ucd-value-0 (char) @@ -152,17 +152,17 @@ (defun ucd-value-1 (char) (let ((index (ucd-index char))) (dpb (aref *character-database* (+ index 3)) - (byte 8 16) - (dpb (aref *character-database* (+ index 2)) - (byte 8 8) - (aref *character-database* (1+ index)))))) + (byte 8 16) + (dpb (aref *character-database* (+ index 2)) + (byte 8 8) + (aref *character-database* (1+ index)))))) (defun ucd-general-category (char) (aref *character-database* (* 8 (ucd-value-0 char)))) (defun ucd-decimal-digit (char) (let ((decimal-digit (aref *character-database* - (+ 3 (* 8 (ucd-value-0 char)))))) + (+ 3 (* 8 (ucd-value-0 char)))))) (when (< decimal-digit 10) decimal-digit))) @@ -186,25 +186,25 @@ (defun character (object) #!+sb-doc - "Coerce OBJECT into a CHARACTER if possible. Legal inputs are + "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 - :datum object - ;;?? how to express "symbol with name of length 1"? - :expected-type '(or character (string 1)) - :format-control control - :format-arguments args))) + (error 'simple-type-error + :datum object + ;;?? how to express "symbol with name of length 1"? + :expected-type '(or character (string 1)) + :format-control control + :format-arguments args))) (typecase object (character object) (string (if (= 1 (length (the string object))) - (char object 0) - (do-error - "String is not of length one: ~S" (list object)))) + (char object 0) + (do-error + "String is not of length one: ~S" (list object)))) (symbol (if (= 1 (length (symbol-name object))) - (schar (symbol-name object) 0) - (do-error - "Symbol name is not of length one: ~S" (list object)))) + (schar (symbol-name object) 0) + (do-error + "Symbol name is not of length one: ~S" (list object)))) (t (do-error "~S cannot be coerced to a character." (list object)))))) (defun char-name (char) @@ -227,8 +227,8 @@ or ." (and (typep char 'base-char) (let ((n (char-code (the base-char char)))) - (or (< 31 n 127) - (= n 10))))) + (or (< 31 n 127) + (= n 10))))) (defun %standard-char-p (thing) #!+sb-doc @@ -243,7 +243,7 @@ returns NIL." (let ((n (char-code char))) (or (< 31 n 127) - (< 159 n)))) + (< 159 n)))) (defun alpha-char-p (char) #!+sb-doc @@ -277,18 +277,18 @@ (let ((m (- (char-code char) 48))) (declare (fixnum m)) (cond ((<= radix 10.) - ;; Special-case decimal and smaller radices. - (if (and (>= m 0) (< m radix)) m nil)) - ;; Digits 0 - 9 are used as is, since radix is larger. - ((and (>= m 0) (< m 10)) m) - ;; Check for upper case A - Z. - ((and (>= (setq m (- m 7)) 10) (< m radix)) m) - ;; Also check lower case a - z. - ((and (>= (setq m (- m 32)) 10) (< m radix)) m) - ;; Else, fail. - (t (let ((number (ucd-decimal-digit char))) - (when (and number (< number radix)) - number)))))) + ;; Special-case decimal and smaller radices. + (if (and (>= m 0) (< m radix)) m nil)) + ;; Digits 0 - 9 are used as is, since radix is larger. + ((and (>= m 0) (< m 10)) m) + ;; Check for upper case A - Z. + ((and (>= (setq m (- m 7)) 10) (< m radix)) m) + ;; Also check lower case a - z. + ((and (>= (setq m (- m 32)) 10) (< m radix)) m) + ;; Else, fail. + (t (let ((number (ucd-decimal-digit char))) + (when (and number (< number radix)) + number)))))) (defun alphanumericp (char) #!+sb-doc @@ -296,7 +296,7 @@ argument is either numeric or alphabetic." (let ((gc (ucd-general-category char))) (or (< gc 5) - (= gc 12)))) + (= gc 12)))) (defun char= (character &rest more-characters) #!+sb-doc @@ -309,7 +309,7 @@ #!+sb-doc "Return T if no two of the arguments are the same character." (do* ((head character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (declare (type character head)) (dolist (c list) @@ -320,40 +320,40 @@ #!+sb-doc "Return T if the arguments are in strictly increasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (< (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) (defun char> (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly decreasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (> (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) (defun char<= (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-decreasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (<= (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) (defun char>= (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-increasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (>= (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) ;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT @@ -363,8 +363,8 @@ (let ((ch (gensym))) `(let ((,ch ,character)) (if (= (ucd-value-0 ,ch) 0) - (ucd-value-1 ,ch) - (char-code ,ch))))) + (ucd-value-1 ,ch) + (char-code ,ch))))) (defun char-equal (character &rest more-characters) #!+sb-doc @@ -373,7 +373,7 @@ (do ((clist more-characters (cdr clist))) ((null clist) t) (unless (= (equal-char-code (car clist)) - (equal-char-code character)) + (equal-char-code character)) (return nil)))) (defun char-not-equal (character &rest more-characters) @@ -381,13 +381,13 @@ "Return T if no two of the arguments are the same character. Font, bits, and case are ignored." (do* ((head character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (do* ((l list (cdr l))) - ((null l) t) - (if (= (equal-char-code head) - (equal-char-code (car l))) - (return nil))) + ((null l) t) + (if (= (equal-char-code head) + (equal-char-code (car l))) + (return nil))) (return nil)))) (defun char-lessp (character &rest more-characters) @@ -395,10 +395,10 @@ "Return T if the arguments are in strictly increasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (< (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) (defun char-greaterp (character &rest more-characters) @@ -406,10 +406,10 @@ "Return T if the arguments are in strictly decreasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (> (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) (defun char-not-greaterp (character &rest more-characters) @@ -417,10 +417,10 @@ "Return T if the arguments are in strictly non-decreasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (<= (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) (defun char-not-lessp (character &rest more-characters) @@ -428,10 +428,10 @@ "Return T if the arguments are in strictly non-increasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (>= (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) ;;;; miscellaneous functions