Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12752/src

Modified Files: serializer.lisp Log Message: +base-char+ => +char+ handle uninterned symbols / symbols in another package optimizations / fixes for bignums fill-pointers circularity fixes (big typo!) automatic numeric array definition types

Date: Sat Sep 4 10:20:37 2004 Author: blee

Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.6 elephant/src/serializer.lisp:1.7 --- elephant/src/serializer.lisp:1.6 Sun Aug 29 22:40:49 2004 +++ elephant/src/serializer.lisp Sat Sep 4 10:20:37 2004 @@ -58,7 +58,7 @@ (defconstant +persistent+ (char-code #\P)) (defconstant +single-float+ (char-code #\F)) (defconstant +double-float+ (char-code #\D)) -(defconstant +base-char+ (char-code #\c)) +(defconstant +char+ (char-code #\c)) (defconstant +pathname+ (char-code #\p)) (defconstant +positive-bignum+ (char-code #\B)) (defconstant +negative-bignum+ (char-code #\b)) @@ -66,6 +66,7 @@ (defconstant +cons+ (char-code #\C)) (defconstant +hash-table+ (char-code #\H)) (defconstant +object+ (char-code #\O)) + (defconstant +array+ (char-code #\A))

(defconstant +fill-pointer-p+ #x40) @@ -90,7 +91,11 @@ (declare (type string s) (dynamic-extent s)) (buffer-write-byte +symbol+ bs) (buffer-write-int (byte-length s) bs) - (buffer-write-string s bs))) + (buffer-write-string s bs) + (let ((package (symbol-package frob))) + (if package + (%serialize (package-name package)) + (%serialize nil))))) (string (buffer-write-byte +string+ bs) (buffer-write-int (byte-length frob) bs) @@ -107,9 +112,9 @@ (buffer-write-byte +double-float+ bs) (buffer-write-double frob bs)) (character - (buffer-write-byte +base-char+ bs) + (buffer-write-byte +char+ bs) ;; might be wide! - (buffer-write-int (char-code frob) bs)) + (buffer-write-uint (char-code frob) bs)) (pathname (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) @@ -125,14 +130,15 @@ (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) - (loop for i fixnum from 0 to word-size - for byte-spec = (int-byte-spec i) + (loop for i fixnum from 0 below word-size ;; this ldb is consing on CMUCL! ;; there is an OpenMCL function which should work ;; and non-cons - for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num) - do - (buffer-write-uint the-uint bs)))) + do + #+(or cmu sbcl) + (buffer-write-uint (%bignum-ref num i) bs) + #+(or allegro lispworks openmcl) + (buffer-write-uint (ldb (int-byte-spec i) num) bs)))) (rational (buffer-write-byte +rational+ bs) (%serialize (numerator frob)) @@ -194,6 +200,8 @@ (loop for i fixnum from 0 below rank do (buffer-write-int (array-dimension frob i) bs))) + (when (array-has-fill-pointer-p frob) + (buffer-write-int (fill-pointer frob) bs)) (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) @@ -233,7 +241,11 @@ (buffer-read-fixnum bs)) ((= tag +nil+) nil) ((= tag +symbol+) - (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + (let ((name (buffer-read-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) ((= tag +string+) (buffer-read-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) @@ -244,8 +256,8 @@ (buffer-read-float bs)) ((= tag +double-float+) (buffer-read-double bs)) - ((= tag +base-char+) - (code-char (buffer-read-byte bs))) + ((= tag +char+) + (code-char (buffer-read-uint bs))) ((= tag +pathname+) (parse-namestring (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) @@ -273,6 +285,7 @@ :rehash-size (%deserialize bs) :rehash-threshold (%deserialize bs)))) + (setf (gethash id *circularity-hash*) h) (loop for i fixnum from 0 below (%deserialize bs) do (setf (gethash (%deserialize bs) h) @@ -283,6 +296,7 @@ (maybe-o (gethash id *circularity-hash*))) (if maybe-o maybe-o (let ((o (make-instance (%deserialize bs)))) + (setf (gethash id *circularity-hash*) o) (loop for i fixnum from 0 below (%deserialize bs) do (setf (slot-value o (%deserialize bs)) @@ -303,6 +317,9 @@ flags)) :adjustable (/= 0 (logand +adjustable-p+ flags))))) + (when (array-has-fill-pointer-p a) + (setf (fill-pointer a) (buffer-read-int bs))) + (setf (gethash id *circularity-hash*) a) (loop for i fixnum from 0 below (array-total-size a) do (setf (row-major-aref a i) (%deserialize bs))) @@ -315,7 +332,7 @@ (type buffer-stream bs) (type fixnum length) (type boolean positive)) - (loop for i from 0 upto (/ length 4) + (loop for i from 0 below (/ length 4) for byte-spec = (int-byte-spec i) with num integer = 0 do @@ -330,22 +347,27 @@ (defvar byte-to-array-type (make-hash-table :test 'equalp))

(setf (gethash 'T array-type-to-byte) #x00) -(setf (gethash 'bit array-type-to-byte) #x01) -(setf (gethash '(unsigned-byte 2) array-type-to-byte) #x02) -(setf (gethash '(unsigned-byte 4) array-type-to-byte) #x03) -(setf (gethash '(unsigned-byte 8) array-type-to-byte) #x04) -(setf (gethash '(unsigned-byte 16) array-type-to-byte) #x05) -(setf (gethash '(unsigned-byte 32) array-type-to-byte) #x06) -(setf (gethash '(unsigned-byte 64) array-type-to-byte) #x07) -(setf (gethash '(signed-byte 8) array-type-to-byte) #x08) -(setf (gethash '(signed-byte 16) array-type-to-byte) #x09) -(setf (gethash '(signed-byte 32) array-type-to-byte) #x0A) -(setf (gethash '(signed-byte 64) array-type-to-byte) #x0B) -(setf (gethash 'character array-type-to-byte) #x0C) -(setf (gethash 'single-float array-type-to-byte) #x0D) -(setf (gethash 'double-float array-type-to-byte) #x0E) -(setf (gethash '(complex single-float) array-type-to-byte) #x0F) -(setf (gethash '(complex double-float) array-type-to-byte) #x10) +(setf (gethash 'base-char array-type-to-byte) #x01) +(setf (gethash 'character array-type-to-byte) #x02) +(setf (gethash 'single-float array-type-to-byte) #x03) +(setf (gethash 'double-float array-type-to-byte) #x04) +(setf (gethash '(complex single-float) array-type-to-byte) #x05) +(setf (gethash '(complex double-float) array-type-to-byte) #x06) +(setf (gethash 'fixnum array-type-to-byte) #x07) +(setf (gethash 'bit array-type-to-byte) #x08) +(let ((counter 8)) + (loop for i from 2 to 65 + for spec = (list 'unsigned-byte i) + for uspec = (upgraded-array-element-type spec) + unless (gethash uspec array-type-to-byte) + do + (setf (gethash uspec array-type-to-byte) (incf counter))) + (loop for i from 2 to 65 + for spec = (list 'signed-byte i) + for uspec = (upgraded-array-element-type spec) + unless (gethash uspec array-type-to-byte) + do + (setf (gethash uspec array-type-to-byte) (incf counter))))

(loop for key being the hash-key of array-type-to-byte using (hash-value value)