Update of /project/cl-store/cvsroot/cl-store In directory clnet:/tmp/cvs-serv25979
Modified Files: ChangeLog backends.lisp default-backend.lisp package.lisp tests.lisp Log Message: Changelog 2007-01-26 : Bug fix and alias-backend
--- /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/23 15:37:17 1.47 +++ /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/26 15:02:24 1.48 @@ -1,3 +1,11 @@ +2007-01-26 Sean Ross sross@common-lisp.net + * default-backend.lisp : Checked in a fix for non sb32 integers, certain + large number numbers where incorrectly serialize. + Reported by Cyrus Harmon. + * plumbing.lisp: Added a new function alias-backend and alias the backend + 'cl-store:cl-store as :cl-store + + 2007-01-23 Sean Ross sross@common-lisp.net * circularities.lisp: Renamed with-grouped-serialization to with-serialization-unit and added two keyword args to allow removal of *grouped-restore-hash* and --- /project/cl-store/cvsroot/cl-store/backends.lisp 2006/12/14 18:15:41 1.14 +++ /project/cl-store/cvsroot/cl-store/backends.lisp 2007/01/26 15:02:24 1.15 @@ -111,6 +111,12 @@ (push (cons name instance) *registered-backends*)) instance))
+(defun alias-backend (old alias) + (let ((backend (find-backend old t))) + (pushnew (cons alias backend) *registered-backends* + :test #'equalp) + t)) + (defun get-class-form (name fields extends) `(defclass ,name ,extends ,fields --- /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/01/23 15:37:17 1.38 +++ /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/01/26 15:02:24 1.39 @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +7;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information.
;; The cl-store backend. @@ -117,9 +117,9 @@
(defun dump-int (obj stream) (declare (optimize speed (safety 0) (debug 0))) - (typecase obj + (etypecase obj ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream)) - (t (write-byte 2 stream) (store-32-bit obj stream)))) + ((unsigned-byte 32) (write-byte 2 stream) (store-32-bit obj stream))))
(defun undump-int (stream) (declare (optimize speed (safety 0) (debug 0))) @@ -138,34 +138,45 @@ (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-) (undump-int stream)))
+ +(defun num->bits (num ) + (loop for val = (abs num) then (ash val -8 ) + for count from 0 + until (zerop val) + collect (logand val #XFF) into bits + finally (return (values bits count)))) + (defun store-arbitrary-integer (obj stream) (declare (type integer obj) (stream stream) (optimize speed)) (output-type-code +integer-code+ stream) - (loop for n = (abs obj) then (ash n -32) - for counter from 0 - with collect = nil - until (zerop n) - do (push n collect) - finally (progn - (store-object (if (minusp obj) - (- counter) - counter) - stream) - (dolist (num collect) - (dump-int num stream))))) + (multiple-value-bind (bits count) (num->bits obj) + (store-object (if (minusp obj) (- count) count) + stream) + (dolist (x bits) (store-32-bit x stream)))) +
(defrestore-cl-store (integer buff) (declare (optimize speed)) - (let ((count (restore-object buff)) - (result 0)) - (declare (type integer result count)) - (loop repeat (abs count) do - (setf result (the integer (+ (ash result 32) - (the ub32 (undump-int buff)))))) - (if (minusp count) - (- result) - result))) + (let ((count (restore-object buff))) + (loop repeat (abs count) + with sum = 0 + for pos from 0 by 8 + for bit = (read-32-bit buff nil) + finally (return (if (minusp count) (- sum) sum)) + :do + (incf sum (* bit (expt 2 pos)))))) + + + +(defun bits->num (bits) + (loop with sum = 0 + for pos from 0 by 8 + for bit in bits + finally (return sum) + :do (incf sum (* bit (expt 2 pos))))) + +
;; Floats (*special-floats* are setup in the custom.lisp files)
@@ -191,6 +202,7 @@ ;; function (defun create-float-values (value &rest codes) "Returns a alist of special float to float code mappings." + (declare (ignore value codes)) nil)
(defun setup-special-floats () --- /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/23 15:37:17 1.26 +++ /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/26 15:02:24 1.27 @@ -29,7 +29,9 @@
;; Hooks into lower level circularity tracking ;; to reduce consing. - #:with-serialization-unit #:create-serialize-hash) + #:with-serialization-unit #:create-serialize-hash + + #:alias-backend)
#+sbcl (:import-from #:sb-mop #:generic-function-name --- /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/23 15:37:17 1.31 +++ /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/26 15:02:25 1.32 @@ -28,6 +28,7 @@ (deftestit integer.4 -2322993) (deftestit integer.5 most-positive-fixnum) (deftestit integer.6 most-negative-fixnum) +(deftestit integer.7 #x100000000)
;; ratios (deftestit ratio.1 1/2) @@ -44,8 +45,8 @@ (deftestit complex.5 #C(-111 -1123)) (deftestit complex.6 #C(-11.2 -34.5))
-;; short floats
+;; short floats
;; single-float (deftestit single-float.1 3244.32) @@ -664,4 +665,3 @@
;; EOF
-