[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Thu Feb 1 04:03:27 UTC 2007
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
More information about the Elephant-cvs
mailing list