diff --git a/code/char.lisp b/code/char.lisp index b1bfccabde0e765e1832964c0265821683a7dbe0..12adb4aec94f14904060e85027d9f992c84ec6c0 100644 --- a/code/char.lisp +++ b/code/char.lisp @@ -22,39 +22,26 @@ ;;; (in-package 'lisp) -(export '(char-code-limit char-font-limit char-bits-limit standard-char-p - graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p - both-case-p digit-char-p alphanumericp char= char/= char< char> - char<= char>= char-equal char-not-equal char-lessp char-greaterp - char-not-greaterp char-not-lessp character char-code char-bits - char-font code-char make-char char-upcase char-downcase - digit-char char-int int-char char-name name-char char-control-bit - char-meta-bit char-hyper-bit char-super-bit char-bit set-char-bit)) +(export '(char-code-limit standard-char-p graphic-char-p + alpha-char-p upper-case-p lower-case-p both-case-p digit-char-p + alphanumericp char= char/= char< char> char<= char>= char-equal + char-not-equal char-lessp char-greaterp char-not-greaterp + char-not-lessp character char-code code-char char-upcase + char-downcase digit-char char-int char-name name-char)) ;;; Compile some trivial character operations via inline expansion: ;;; -(proclaim '(inline standard-char-p - graphic-char-p string-char-p alpha-char-p upper-case-p - lower-case-p both-case-p alphanumericp char-bits +(proclaim '(inline standard-char-p graphic-char-p alpha-char-p + upper-case-p lower-case-p both-case-p alphanumericp char-int)) (defconstant char-code-limit 256 "The upper exclusive bound on values produced by CHAR-CODE.") -(defconstant char-font-limit 1 - "The upper exclusive bound on values produced by CHAR-FONT.") -(defconstant char-bits-limit 256 - "The upper exclusive bound on values produced by CHAR-BITS.") -(defconstant char-control-bit 1 - "This bit indicates a control character.") -(defconstant char-meta-bit 2 - "This bit indicates a meta character.") -(defconstant char-super-bit 4 - "This bit indicates a super character.") -(defconstant char-hyper-bit 8 - "This bit indicates a hyper character.") +(deftype char-code () + `(integer 0 (,char-code-limit))) (defparameter char-name-alist @@ -63,11 +50,11 @@ ("BACKSPACE" . ,(code-char 8)) ("BS" . ,(code-char 8)) ("TAB" . ,(code-char 9)) ("LINEFEED" . ,(code-char 10)) ("LF" . ,(code-char 10)) + ("NEWLINE" . ,(code-char 10)) ("NL" . ,(code-char 10)) ("VT" . ,(code-char 11)) ("PAGE" . ,(code-char 12)) ("FORM" . ,(code-char 12)) ("FORMFEED" . ,(code-char 12)) ("FF" . ,(code-char 12)) - ("RETURN" . ,(code-char 13)) ("NL" . ,(code-char 10)) - ("NEWLINE" . ,(code-char 10)) ("CR" . ,(code-char 13)) + ("RETURN" . ,(code-char 13)) ("CR" . ,(code-char 13)) ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27)) ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27)) ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32)) @@ -80,54 +67,21 @@ ;;;; Accessor functions: (defun char-code (char) - "Given a character object argument, char-code returns the code attribute - of that object as a non-negative integer." - (ldb %character-code-byte (char-int char))) + "Returns the integer code of CHAR." + (etypecase char + (base-character (char-code (truly-the base-character char))))) -(defun char-bits (char) - "Given a character object argument, char-code returns the bits attribute - of that object as a non-negative integer." - (ldb %character-control-byte (char-int char))) - -(defun char-font (char) - "Given a character object argument, char-code returns the font attribute - of that object as 0." - (declare (ignore char)) - 0) (defun char-int (char) - "The argument must be a character-object. Returns the font, bits, and - code fields as a single non-negative integer. Implementation dependent. - Used mostly for hashing." - (declare (character char)) - (%primitive make-fixnum char)) - - -(defun int-char (n) - "Performs the inverse of char-int. The argument must be a non-negative - integer of the appropriate size. It is turned into a character object." - (declare (type unsigned-byte n)) - (cond ((or (not (fixnump n)) - (not (<= 0 (the fixnum n) %character-int-mask))) - nil) - ((zerop (ldb %character-control-byte (the fixnum n))) - (%primitive make-immediate-type n %string-char-type)) - (t - (%primitive make-immediate-type n %bitsy-char-type)))) - - -(defun code-char (code &optional (bits 0) (font 0)) - "All three arguments, must be non-negative integers; the last two are - optional with default values of 0 (for the bits and font attributes). - Returns a character object with the specified code, bits, and font, - or returns NIL if this is not possible." - (cond ((not (and (< -1 code char-code-limit) (zerop font))) nil) - ((zerop bits) (code-char code)) - ((< -1 bits char-bits-limit) - (%primitive make-immediate-type - (dpb bits %character-control-byte code) - %bitsy-char-type)) - (t nil))) + "Returns the integer code of CHAR. This is the same as char-code, as + CMU Common Lisp does not implement character bits or fonts." + (char-code char)) + + +(defun code-char (code) + "Returns the character with the code CODE." + (declare (type char-code code)) + (code-char code)) (defun character (object) @@ -135,25 +89,17 @@ characters, strings and symbols of length 1, and integers." (typecase object (character object) - (integer (int-char object)) - (string (if (= 1 (the fixnum (length (the string object)))) + (char-code (code-char object)) + (string (if (= 1 (length (the string object))) (char object 0) (error "String is not of length one: ~S" object))) - (symbol (if (= 1 (the fixnum (length (symbol-name object)))) + (symbol (if (= 1 (length (symbol-name object))) (schar (symbol-name object) 0) (error "Symbol name is not of length one: ~S" object))) (t (error "~S cannot be coerced to a character.")))) -(defun make-char (char &optional (bits 0) (font 0)) - "Replaces the bits and font attributes of the specified character with - those supplied by the user as fixnums. Bits and font both default to 0." - (declare (character char)) - (and (< -1 bits char-bits-limit) - (zerop font) - (int-char (dpb bits %character-control-byte (char-code char))))) - (defun char-name (char) "Given a character object, char-name returns the name for that @@ -167,32 +113,6 @@ (cdr (assoc (string name) char-name-alist :test #'string-equal))) -(defun char-bit (char name) - "Returns T if the named bit is set in character object CHAR. Else, - returns NIL. Legal names are :CONTROL, :META, :HYPER, and :SUPER." - (logtest (case name - (:control char-control-bit) - (:meta char-meta-bit) - (:hyper char-hyper-bit) - (:super char-super-bit)) - (char-bits char))) - - -(defun set-char-bit (char name newvalue) - "Returns a character just like CHAR except that the named bit is - set or cleared, according to whether NEWVALUE is non-null or NIL. - Legal bit names are :CONTROL, :META, :HYPER, and :SUPER." - (let ((bit (case name - (:control char-control-bit) - (:meta char-meta-bit) - (:hyper char-hyper-bit) - (:super char-super-bit) - (t 0)))) - (code-char (char-code char) - (if newvalue - (logior bit (char-bits char)) - (logand (lognot bit) (char-bits char))) - (char-font char)))) ;;;; Predicates: @@ -202,8 +122,8 @@ argument is a standard character -- one of the 95 ASCII printing characters or <return>." (declare (character char)) - (and (typep char 'string-char) - (let ((n (char-code (the string-char char)))) + (and (typep char 'base-character) + (let ((n (char-code (the base-character char)))) (or (< 31 n 127) (= n 13) (= n 10))))) @@ -214,19 +134,12 @@ argument is a printing character (space through ~ in ASCII), otherwise returns ()." (declare (character char)) - (and (typep char 'string-char) + (and (typep char 'base-character) (< 31 - (char-code (the string-char char)) + (char-code (the base-character char)) 127))) -(defun string-char-p (char) - "The argument must be a character object. String-char-p returns T if the - argument can be stored in a string." - (declare (character char)) - (typep char 'string-char)) - - (defun alpha-char-p (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 ()." @@ -433,34 +346,23 @@ ;;;; Miscellaneous functions: (defun char-upcase (char) - "Returns a character with the same bits and font as the input character, - converted to upper-case if that is possible." + "Returns CHAR converted to upper-case if that is possible." (declare (character char)) - (cond ((typep char 'string-char) - (char-upcase (the string-char char))) - ((lower-case-p char) - (int-char (- (char-int char) 32))) - (t - char))) - + (if (lower-case-p char) + (code-char (- (char-code char) 32)) + char)) (defun char-downcase (char) - "Returns a character with the same bits and font as the input character, - converted to lower-case if that is possible." + "Returns CHAR converted to lower-case if that is possible." (declare (character char)) - (cond ((typep char 'string-char) - (char-downcase (the string-char char))) - ((upper-case-p char) - (int-char (+ (char-int char) 32))) - (t - char))) - + (if (upper-case-p char) + (code-char (+ (char-code char) 32)) + char)) -(defun digit-char (weight &optional (radix 10) (font 0)) +(defun digit-char (weight &optional (radix 10)) "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." (and (>= weight 0) (< weight radix) (< weight 36) - (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)) - 0 font))) + (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight))))) diff --git a/code/defmacro.lisp b/code/defmacro.lisp index aae4551ce1625c04690e3725a86dcb17a54680d5..b13f4250f03b1d1c7a08364409eecc0f4f491fe6 100644 --- a/code/defmacro.lisp +++ b/code/defmacro.lisp @@ -389,10 +389,10 @@ of the calling form containing keywords. LEGAL is the list of legal keywords. If the keyword :allow-other-keyws is present in KEYLIST, just return without complaining about anything." - (cond ((memq ':allow-other-keys keylist) nil) + (cond ((member ':allow-other-keys keylist :test #'eq) nil) (t (do ((kl keylist (cddr kl))) ((atom kl) nil) - (cond ((memq (car kl) legal)) + (cond ((member (car kl) legal :test #'eq)) (t (cerror "Ignore it." "~S illegal or unknown keyword." (car kl)))))))) diff --git a/code/hash.lisp b/code/hash.lisp index 7ecea07d1841032cab53f224f9f82d0678921c47..0457a326fb0fc3ccb9c0e7e24e8c8298fe235939 100644 --- a/code/hash.lisp +++ b/code/hash.lisp @@ -15,6 +15,12 @@ gethash remhash maphash clrhash hash-table-count sxhash)) +;;; Vector subtype codes. + +(defconstant valid-hashing 2) +(defconstant must-rehash 3) + + ;;; What a hash-table is: (defstruct (hash-table (:constructor make-hash-table-structure) @@ -132,7 +138,7 @@ (setf (hash-table-table structure) new-vector))) (if (not (eq (hash-table-kind structure) 'equal)) (%primitive set-vector-subtype new-vector - (+ 2 (%primitive newspace-bit))))))) + valid-hashing))))) (declare (fixnum i size)) (do ((bucket (aref hash-vector i) (cdr bucket))) ((null bucket)) @@ -178,8 +184,7 @@ (defmacro eq-rehash-if-needed () `(let ((subtype (%primitive get-vector-subtype vector))) (declare (fixnum subtype)) - (cond ((or (= subtype 4) - (/= subtype (+ 2 (%primitive newspace-bit)))) + (cond ((/= subtype valid-hashing) (rehash hash-table vector size) (setq vector (hash-table-table hash-table))) ((> (hash-table-number-entries hash-table) @@ -200,8 +205,7 @@ (size (length vector))) (declare (fixnum subtype size)) (cond ((and (not (eq (hash-table-kind hash-table) 'equal)) - (or (= subtype 4) - (/= subtype (the fixnum (+ 2 (the fixnum (%primitive newspace-bit))))))) + (/= subtype valid-hashing)) (rehash hash-table vector size) (setq vector (hash-table-table hash-table)) (setq size (length vector))) @@ -222,7 +226,7 @@ (cond ((eq test #'eq) (setq test 'eq)) ((eq test #'eql) (setq test 'eql)) ((eq test #'equal) (setq test 'equal))) - (if (not (memq test '(eq eql equal))) + (if (not (member test '(eq eql equal) :test #'eq)) (error "~S is an illegal :Test for hash tables." test)) (setq size (if (<= size 37) 37 (almost-primify size))) (cond ((null rehash-threshold) @@ -236,8 +240,8 @@ (if (eq test 'equal) (make-array size) (%primitive set-vector-subtype - (make-array size) - (the fixnum (+ 2 (the fixnum (%primitive newspace-bit)))))) + (make-array size) + valid-hashing)) :kind test))) ;;; Manipulating hash tables: @@ -362,7 +366,7 @@ (let ((n-x (gensym))) `(let ((,n-x ,x)) (declare (fixnum ,n-x)) - (abs (logxor (the fixnum (%primitive lsh ,n-x ,num)) ,n-x))))) + (abs (logxor (the fixnum (ash ,n-x ,num)) ,n-x))))) (defmacro sxhash-simple-string (sequence) `(%primitive sxhash-simple-string ,sequence)) @@ -373,8 +377,7 @@ (end (gensym))) `(with-array-data ((,data ,sequence) (,start) - (,end (%primitive header-ref ,sequence - %array-fill-pointer-slot))) + (,end)) (if (zerop ,start) (%primitive sxhash-simple-substring ,data ,end) (sxhash-simple-string (coerce (the string ,sequence) @@ -425,5 +428,6 @@ (internal-sxhash (denominator s-expr) 0)))) (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0) (internal-sxhash (imagpart s-expr) 0)))))) + #+nil (compiled-function (%primitive header-length s-expr)) (t (%primitive make-fixnum s-expr)))) diff --git a/code/string.lisp b/code/string.lisp index c9c96088043a94515aa091df771fca5a583e0472..838d975096b24ccfec11a947b6b03c33d0af1f7b 100644 --- a/code/string.lisp +++ b/code/string.lisp @@ -59,18 +59,19 @@ (data-end (gensym)) (offset (gensym))) `(progn - (if (symbolp ,string) (setq ,string (symbol-name ,string))) - (if (array-header-p ,string) - (with-array-data ((,data ,string :offset-var ,offset) - (,data-start ,start) - (,data-end (or ,end - (%primitive header-ref ,string - %array-fill-pointer-slot)))) - (psetq ,string ,data - ,cum-offset ,offset - ,start ,data-start - ,end ,data-end)) - (if (not ,end) (setq ,end (length (the simple-string ,string))))) + (if (symbolp ,string) + (setf ,string (symbol-name ,string))) + (if (array-header-p ,string) + (with-array-data ((,data ,string :offset-var ,offset) + (,data-start ,start) + (,data-end (or ,end + (length (the simple-string + ,string))))) + (psetq ,string ,data + ,cum-offset ,offset + ,start ,data-start + ,end ,data-end)) + (if (not ,end) (setq ,end (length (the simple-string ,string))))) ,@forms))) ) @@ -86,8 +87,7 @@ (if (array-header-p ,string) (with-array-data ((data ,string) (data-start start) - (data-end (%primitive header-ref ,string - %array-fill-pointer-slot))) + (data-end (length (the simple-string ,string)))) (psetq ,string data start data-start end data-end)) @@ -114,27 +114,28 @@ (with-array-data ((,data ,string1 :offset-var ,offset) (,data-start ,start1) (,data-end (or ,end1 - (%primitive header-ref ,string1 - %array-fill-pointer-slot)))) - (psetq ,string1 ,data - ,cum-offset-1 ,offset - ,start1 ,data-start - ,end1 ,data-end)) + (length (the simple-string + ,string1))))) + (psetq ,string1 ,data + ,cum-offset-1 ,offset + ,start1 ,data-start + ,end1 ,data-end)) (if (not ,end1) (setq ,end1 (length (the simple-string ,string1))))) (if (array-header-p ,string2) (with-array-data ((,data ,string2) (,data-start ,start2) (,data-end (or ,end2 - (%primitive header-ref ,string2 - %array-fill-pointer-slot)))) - (psetq ,string2 ,data - ,start2 ,data-start - ,end2 ,data-end)) + (length (the simple-string + ,string2))))) + (psetq ,string2 ,data + ,start2 ,data-start + ,end2 ,data-end)) (if (not ,end2) (setq ,end2 (length (the simple-string ,string2))))) ,@forms))) ) + (defun char (string index) "Given a string and a non-negative integer index less than the length of the string, returns the character object representing the character at diff --git a/code/symbol.lisp b/code/symbol.lisp index 50f0598a22d901c9f359196c4f6062545adc516f..59d0a026afe95793f129c0d0b694ff956d35039a 100644 --- a/code/symbol.lisp +++ b/code/symbol.lisp @@ -82,19 +82,17 @@ (defun %put (symbol indicator value) "The VALUE is added as a property of SYMBOL under the specified INDICATOR. Returns VALUE." - (%primitive put symbol indicator value) -#| (do ((pl (symbol-plist symbol) (cddr pl))) - ((atom pl) + (do ((pl (symbol-plist symbol) (cddr pl))) + ((endp pl) (setf (symbol-plist symbol) (list* indicator value (symbol-plist symbol))) value) - (cond ((atom (cdr pl)) + (cond ((endp (cdr pl)) (error "~S has an odd number of items in its property list." symbol)) ((eq (car pl) indicator) (rplaca (cdr pl) value) - (return value))))|# - ) + (return value))))) (defun remprop (symbol indicator) "Look on property list of SYMBOL for property with specified diff --git a/code/type-boot.lisp b/code/type-boot.lisp index c9d6019c79e869eb8fd361f8767fbc76d81e8101..622cf8a96bcb8c3c4f65311f7d67e8fe900c0174 100644 --- a/code/type-boot.lisp +++ b/code/type-boot.lisp @@ -24,7 +24,7 @@ ;;; (defun pathnamep (x) (and (structurep x) - (eq (%primitive header-ref x %g-vector-structure-name-slot) + (eq (%primitive structure-ref x 0) 'pathname))) ;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of @@ -32,7 +32,7 @@ ;;; (defun volatile-info-env-p (x) (and (structurep x) - (eq (%primitive header-ref x %g-vector-structure-name-slot) + (eq (%primitive structure-ref x 0) 'volatile-info-env)))