Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv8038/src/elephant

Modified Files: serializer1.lisp serializer2.lisp Log Message: Small fix and a renaming to avoid warnings in SBCL

--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/05 00:40:31 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/05 03:18:22 1.6 @@ -18,7 +18,10 @@

(defpackage :elephant-serializer1 (:use :cl :elephant :elephant-memutil) - #+(or cmu sbcl) + #+cmu + (:import-from :bignum + %bignum-ref) + #+sbcl (:import-from :sb-bignum %bignum-ref) (:import-from :elephant --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 01:01:26 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 03:18:22 1.15 @@ -18,12 +18,14 @@

(defpackage :elephant-serializer2 (:use :cl :elephant :elephant-memutil :elephant-utils) - #+(or cmu sbcl) + #+cmu + (:import-from :bignum + %bignum-ref) + #+sbcl (:import-from :sb-bignum %bignum-ref) (:import-from :elephant *circularity-initial-hash-size* - #+(or cmu sbcl allegro) get-cached-instance controller-symbol-cache controller-symbol-id-cache @@ -37,11 +39,12 @@

(in-package :elephant-serializer2)

-(eval-when (compile) +(eval-when (:compile-toplevel) (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) (inline serialize deserialize slots-and-values - deserialize-bignum))) + deserialize-bignum + %bignum-ref)))

(uffi:def-type foreign-char :char)

@@ -156,11 +159,11 @@ "Serialize a lisp value into a buffer-stream." (declare (type buffer-stream bs) (ignorable sc)) - (let ((*lisp-obj-id* -1) - (*circularity-hash* (get-circularity-hash))) + (let ((lisp-obj-id -1) + (circularity-hash (get-circularity-hash))) (labels ((%next-object-id () - (incf *lisp-obj-id*)) + (incf lisp-obj-id)) (%serialize (frob) (etypecase frob (fixnum @@ -214,12 +217,12 @@ (buffer-write-double frob bs)) (standard-object (buffer-write-byte +object+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) (declare (dynamic-extent svs)) @@ -238,12 +241,12 @@ (buffer-write-uint (char-code frob) bs)) (cons (buffer-write-byte +cons+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (%serialize (car frob)) (%serialize (cdr frob)))))) (pathname @@ -252,12 +255,12 @@ (serialize-string pstring bs))) (hash-table (buffer-write-byte +hash-table+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (%serialize (hash-table-test frob)) (%serialize (hash-table-rehash-size frob)) (%serialize (hash-table-rehash-threshold frob)) @@ -269,11 +272,11 @@ (%serialize value)))))) ;; (structure-object ;; (buffer-write-byte +struct+ bs) - ;; (let ((idp (gethash frob *circularity-hash*))) + ;; (let ((idp (gethash frob circularity-hash))) ;; (if idp (buffer-write-int32 idp bs) ;; (progn - ;; (buffer-write-int32 (incf *lisp-obj-id*) bs) - ;; (setf (gethash frbo *circularity-hash*) *lisp-obj-id*) + ;; (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))) ;; (declare (dynamic-extent svs)) @@ -282,12 +285,12 @@ ;; do (%serialize item))))))) (array (buffer-write-byte +array+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (buffer-write-byte (logior (byte-from-array-type (array-element-type frob)) (if (array-has-fill-pointer-p frob) @@ -306,7 +309,7 @@ (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) - (release-circularity-hash *circularity-hash*) + (release-circularity-hash circularity-hash) bs)))

(defun serialize-bignum (frob bs) @@ -330,9 +333,7 @@ ;; and non-cons do #+(or cmu sbcl allegro) - (progn (setf (cdr byte-spec) (* 32 i)) - (%bignum-ref num i) bs) -;; (buffer-write-uint (ldb byte-spec num) bs)) + (buffer-write-uint (%bignum-ref num i) bs) #+(or lispworks openmcl) (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs) ))) @@ -344,14 +345,14 @@ (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." (declare (type (or null buffer-stream) buf-str)) - (let ((*circularity-vector* (get-circularity-vector))) + (let ((circularity-vector (get-circularity-vector))) (labels ((lookup-id (id) - (if (>= id (fill-pointer *circularity-vector*)) nil - (aref *circularity-vector* id))) + (if (>= id (fill-pointer circularity-vector)) nil + (aref circularity-vector id))) (add-object (object) - (vector-push-extend object *circularity-vector* 50) - (1- (fill-pointer *circularity-vector*))) + (vector-push-extend object circularity-vector 50) + (1- (fill-pointer circularity-vector))) (%deserialize (bs) (declare (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) @@ -484,7 +485,7 @@ (null (return-from deserialize nil)) (buffer-stream (let ((result (%deserialize buf-str))) - (release-circularity-vector *circularity-vector*) + (release-circularity-vector circularity-vector) result))))))

(defun deserialize-bignum (bs length positive)