Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv1882/src/elephant
Modified Files: serializer1.lisp serializer2.lisp Log Message: Added 64-bit support, verified for 32-bit lisp via Allegro/Mac OS X. Thanks to Henrik Hjelte
--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/21 21:20:04 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/01 04:03:27 1.3 @@ -93,7 +93,8 @@ (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (type buffer-stream bs) + (ignore sc)) (setq *lisp-obj-id* 0) (clear-circularity-hash) (labels --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/31 20:05:38 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/01 04:03:27 1.8 @@ -144,6 +144,9 @@ ;; SERIALIZER ;;
+(defconstant +2^32+ 4294967296) +(defconstant +2^64+ 18446744073709551616) + (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare (type buffer-stream bs) @@ -155,9 +158,16 @@ (incf *lisp-obj-id*)) (%serialize (frob) (etypecase frob - ((integer #.most-negative-fixnum #.most-positive-fixnum) - (buffer-write-byte +fixnum32+ bs) - (buffer-write-int frob bs)) + (fixnum ;; (integer #.most-negative-fixnum #.most-positive-fixnum) + ;; Should be compiled away... + (if (< #.most-positive-fixnum +2^32+) + (progn + (buffer-write-byte +fixnum32+ bs) + (buffer-write-int32 frob bs)) + (progn + (assert (< #.most-positive-fixnum +2^64+)) + (buffer-write-byte +fixnum64+ bs) + (buffer-write-int64 frob bs)))) (null (buffer-write-byte +nil+ bs)) (symbol @@ -174,7 +184,7 @@ (serialize-string frob bs)) (persistent (buffer-write-byte +persistent+ bs) - (buffer-write-int (oid frob) bs) + (buffer-write-int32 (oid frob) bs) ;; This circumlocution is necessitated by ;; an apparent bug in SBCL 9.9 --- type-of sometimes ;; does NOT return the "proper name" of the class as the @@ -196,10 +206,10 @@ (standard-object (buffer-write-byte +object+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) @@ -220,10 +230,10 @@ (cons (buffer-write-byte +cons+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (%serialize (car frob)) (%serialize (cdr frob)))))) @@ -234,10 +244,10 @@ (hash-table (buffer-write-byte +hash-table+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (%serialize (hash-table-test frob)) (%serialize (hash-table-rehash-size frob)) @@ -251,9 +261,9 @@ ;; (structure-object ;; (buffer-write-byte +struct+ bs) ;; (let ((idp (gethash frob *circularity-hash*))) - ;; (if idp (buffer-write-int idp bs) + ;; (if idp (buffer-write-int32 idp bs) ;; (progn - ;; (buffer-write-int (incf *lisp-obj-id*) bs) + ;; (buffer-write-int32 (incf *lisp-obj-id*) bs) ;; (setf (gethash frbo *circularity-hash*) *lisp-obj-id*) ;; (%serialize (type-of frob)) ;; (let ((svs (slots-and-values frob))) @@ -264,10 +274,10 @@ (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (buffer-write-byte (logior (byte-from-array-type (array-element-type frob)) @@ -277,12 +287,11 @@ +adjustable-p+ 0)) bs) (let ((rank (array-rank frob))) - (buffer-write-int rank bs) + (buffer-write-int32 rank bs) (loop for i fixnum from 0 below rank - do (buffer-write-int (array-dimension frob i) - bs))) + do (%serialize (array-dimension frob i)))) (when (array-has-fill-pointer-p frob) - (buffer-write-int (fill-pointer frob) bs)) + (%serialize (fill-pointer frob))) (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) @@ -334,8 +343,10 @@ (declare (type foreign-char tag) (dynamic-extent tag)) (cond - ((= tag +fixnum32+) - (buffer-read-fixnum bs)) + ((= tag +fixnum32+) + (buffer-read-fixnum32 bs)) + ((= tag +fixnum64+) + (buffer-read-fixnum64 bs)) ((= tag +nil+) nil) ((= tag +utf8-string+) (deserialize-string :utf8 bs)) @@ -352,7 +363,7 @@ (make-symbol name)))) ((= tag +persistent+) (get-cached-instance sc - (buffer-read-fixnum bs) + (buffer-read-fixnum32 bs) (%deserialize bs))) ((= tag +single-float+) (buffer-read-float bs)) @@ -428,14 +439,14 @@ (%deserialize bs))) o))))))) ((= tag +array+) - (let* ((id (buffer-read-fixnum bs)) + (let* ((id (buffer-read-fixnum32 bs)) (maybe-array (lookup-id id))) (if maybe-array maybe-array (let* ((flags (buffer-read-byte bs)) (a (make-array (loop for i fixnum from 0 below - (buffer-read-int bs) - collect (buffer-read-int bs)) + (buffer-read-int32 bs) + collect (%deserialize bs)) :element-type (array-type-from-byte (logand #x3f flags)) :fill-pointer (/= 0 (logand +fill-pointer-p+ @@ -443,7 +454,7 @@ :adjustable (/= 0 (logand +adjustable-p+ flags))))) (when (array-has-fill-pointer-p a) - (setf (fill-pointer a) (buffer-read-int bs))) + (setf (fill-pointer a) (%deserialize bs))) (add-object a) (loop for i fixnum from 0 below (array-total-size a) do