[cl-store-cvs] CVS cl-store

[sross]

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 at 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 at 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
 
-