[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README cl-store/backends.lisp cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp cl-store/xml-backend.lisp
Sean Ross
sross at common-lisp.net
Wed Nov 10 10:43:24 UTC 2004
Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv7159
Modified Files:
ChangeLog README backends.lisp circularities.lisp cl-store.asd
default-backend.lisp package.lisp plumbing.lisp tests.lisp
utils.lisp xml-backend.lisp
Log Message:
Changelog 2004-11-10
Date: Wed Nov 10 11:43:17 2004
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.13 cl-store/ChangeLog:1.14
--- cl-store/ChangeLog:1.13 Mon Nov 1 15:49:00 2004
+++ cl-store/ChangeLog Wed Nov 10 11:43:16 2004
@@ -1,3 +1,19 @@
+2004-11-10 Sean Ross <sross at common-lisp.net>
+ New Version: 0.3.6 New Magic Number (Breaks backwards compatibility)
+ * default-backend.lisp: Storing for functions and generic functions.
+ * tests.lisp: Tests for functions and GF's.
+ * plumbing.lisp, circularities.lisp, default-backend.lisp:
+ Optimized int-sym-or-charp.
+ * clisp/fix-clisp.lisp: Added generic-function-name.
+ * package.lisp: Import generic-function-name.
+ * default-backend.lisp: More optimizations for strings and ints.
+
+2004-11-03 Sean Ross <sross at common-lisp.net>
+ * tests.lisp: Added tests for unicode strings and symbols.
+ * default-backend.lisp: We definitely support unicode now.
+ Added small optimization to stop the size of files from
+ ballooning.
+
2004-11-01 Sean Ross <sross at common-lisp.net>
* default-backend.lisp: Changed storing of sizes of integers
and strings from store-32-bit to store-object. Changed all
Index: cl-store/README
diff -u cl-store/README:1.10 cl-store/README:1.11
--- cl-store/README:1.10 Mon Nov 1 15:30:18 2004
+++ cl-store/README Wed Nov 10 11:43:16 2004
@@ -1,7 +1,7 @@
README for Package CL-STORE.
Author: Sean Ross
Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.3.2
+Version: 0.3.6
0. About.
CL-STORE is an portable serialization package which
Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.3 cl-store/backends.lisp:1.4
--- cl-store/backends.lisp:1.3 Mon Nov 1 15:30:18 2004
+++ cl-store/backends.lisp Wed Nov 10 11:43:16 2004
@@ -7,7 +7,7 @@
;; in default-backend.lisp and xml-backend.lisp
(in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
(defun required-arg (name)
@@ -45,6 +45,7 @@
((,var ,type) ,stream (backend ,',class-name))
,(format nil "Definition for storing an object of type ~A with ~
backend ~A" type ',name)
+; (declare (optimize (speed 3) (safety 1) (debug 0)))
, at body))))
(defun get-restore-macro (name)
@@ -52,7 +53,9 @@
(let ((macro-name (symbolicate 'defrestore- name)))
`(defmacro ,macro-name ((type place) &body body)
(let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
- `(flet ((,fn-name (,place) , at body))
+ `(flet ((,fn-name (,place)
+; (declare (optimize (speed 3) (safety 1) (debug 0)))
+ , at body))
(let* ((backend (find-backend ',',name))
(restorers (restorer-funs backend)))
(when (gethash ',type restorers)
Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.10 cl-store/circularities.lisp:1.11
--- cl-store/circularities.lisp:1.10 Mon Nov 1 15:30:18 2004
+++ cl-store/circularities.lisp Wed Nov 10 11:43:16 2004
@@ -19,7 +19,7 @@
;; programs according to the Hyperspec(notes in EQ).
(in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defvar *postfix-setters* '(gethash)
"Setfable places which take the object to set after
@@ -27,9 +27,8 @@
(defun get-setf-place (place obj)
"Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*."
- (declare (type (or cons symbol) place))
(cond ((atom place) `(,place ,obj))
- ((member (car place) *postfix-setters*)
+ ((member (the symbol (car place)) *postfix-setters*)
`(, at place ,obj))
(t `(,(car place) ,obj ,@(cdr place)))))
@@ -48,52 +47,51 @@
(declare (ignore getting-key getting-value))
(error "setting-hash can only be used inside a resolving-object form."))
-
(defmacro resolving-object (create &body body)
"Execute body attempting to resolve circularities found in
form CREATE."
(with-gensyms (obj value key)
`(macrolet ((setting (place getting)
- (let ((setf-place (get-setf-place place ',obj)))
- `(let ((,',value ,getting))
- (if (referrer-p ,',value)
- (push (lambda ()
- (setf ,setf-place
- (referred-value ,',value
- *restored-values*)))
- *need-to-fix*)
- (setf ,setf-place ,',value)))))
- (setting-hash (getting-key getting-place)
- `(let ((,',key ,getting-key))
- (if (referrer-p ,',key)
- (let ((,',value ,getting-place))
- (push (lambda ()
- (setf (gethash
- (referred-value ,',key *restored-values*)
- ,',obj)
- (if (referrer-p ,',value)
+ (let ((setf-place (get-setf-place place ',obj)))
+ `(let ((,',value ,getting))
+ (if (referrer-p ,',value)
+ (push #'(lambda ()
+ (setf ,setf-place
(referred-value ,',value
- *restored-values*)
- ,',value)))
- *need-to-fix*))
- (setting (gethash ,',key) ,getting-place)))))
- (let ((,obj ,create))
- , at body
- ,obj))))
+ *restored-values*)))
+ *need-to-fix*)
+ (setf ,setf-place ,',value)))))
+ (setting-hash (getting-key getting-place)
+ `(let ((,',key ,getting-key))
+ (if (referrer-p ,',key)
+ (let ((,',value ,getting-place))
+ (push #'(lambda ()
+ (setf (gethash
+ (referred-value ,',key *restored-values*)
+ ,',obj)
+ (if (referrer-p ,',value)
+ (referred-value ,',value
+ *restored-values*)
+ ,',value)))
+ *need-to-fix*))
+ (setting (gethash ,',key) ,getting-place)))))
+ (let ((,obj ,create))
+ , at body
+ ,obj))))
(defstruct referrer
val)
(defun referred-value (referrer hash)
"Return the value REFERRER is meant to be by looking in HASH."
- (gethash (referrer-val referrer) ;(read-from-string (subseq (symbol-name referrer) 11))
+ (gethash (referrer-val referrer)
hash))
(defclass resolving-backend (backend)
()
(:documentation "A backend which does the setup for resolving circularities."))
-(declaim (type fixnum *stored-counter*))
+(declaim (type (or null fixnum) *stored-counter*))
(defvar *stored-counter*)
(defvar *stored-values*)
@@ -153,7 +151,7 @@
;; Restoration.
-(declaim (type fixnum *restore-counter*))
+(declaim (type (or null fixnum) *restore-counter*))
(defvar *restore-counter*)
(defvar *need-to-fix*)
(defvar *restored-values*)
@@ -170,12 +168,10 @@
(dolist (fn *need-to-fix*)
(funcall (the function fn))))))
-;; Change to backend-restore-object to allow support for
-;; multiple return values.
(defmethod backend-restore-object ((place t) (backend resolving-backend))
"Retrieve a object from PLACE, does housekeeping for circularity fixing."
- (let ((reader (find-function-for-type place backend)))
- (if (not (int-sym-or-char-p reader backend))
+ (multiple-value-bind (reader sym) (find-function-for-type place backend)
+ (if (not (int-sym-or-char-p sym backend))
(let ((spot (incf *restore-counter*))
(vals (mapcar #'new-val
(multiple-value-list (funcall (the function reader)
@@ -186,16 +182,13 @@
(funcall (the function reader) place))))
+
(defgeneric int-sym-or-char-p (fn backend)
(:argument-precedence-order backend fn)
(:method ((fn t) (backend t))
"Is function FN registered to restore an integer, character or symbol
in BACKEND."
- (let ((readers (restorer-funs backend)))
- (or (eq fn (lookup-reader 'integer readers))
- (eq fn (lookup-reader 'character readers))
- (eq fn (lookup-reader 'symbol readers))))))
-
+ (member fn '(integer character symbol))))
(defun new-val (val)
"Tries to get a referred value to reduce unnecessary cirularity fixing."
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.12 cl-store/cl-store.asd:1.13
--- cl-store/cl-store.asd:1.12 Mon Nov 1 15:30:18 2004
+++ cl-store/cl-store.asd Wed Nov 10 11:43:16 2004
@@ -40,7 +40,7 @@
:name "CL-STORE"
:author "Sean Ross <sdr at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
- :version "0.3.2"
+ :version "0.3.6"
:description "Serialization package"
:long-description "Portable CL Package to serialize data types"
:licence "MIT"
Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.10 cl-store/default-backend.lisp:1.11
--- cl-store/default-backend.lisp:1.10 Mon Nov 1 15:30:18 2004
+++ cl-store/default-backend.lisp Wed Nov 10 11:43:16 2004
@@ -5,13 +5,13 @@
(in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *cl-store-backend*
- (defbackend cl-store :magic-number 1347643724
+ (defbackend cl-store :magic-number 1349732684
:stream-type 'binary
- :old-magic-numbers (1912923 1886611788 1347635532)
+ :old-magic-numbers (1912923 1886611788 1347635532 1347643724)
:extends resolving-backend
:fields ((restorers :accessor restorers :initform (make-hash-table)))))
(defun register-code (code name &optional (errorp t))
@@ -24,6 +24,7 @@
;; Type code constants
(defconstant +referrer-code+ (register-code 1 'referrer nil))
(defconstant +values-code+ (register-code 2 'values-object nil))
+(defconstant +unicode-string-code+ (register-code 3 'unicode-string nil))
(defconstant +integer-code+ (register-code 4 'integer nil))
(defconstant +simple-string-code+ (register-code 5 'simple-string nil))
(defconstant +float-code+ (register-code 6 'float nil))
@@ -54,11 +55,11 @@
(defconstant +float-nan-code+ (register-code 25 'nan-float nil))
(defconstant +function-code+ (register-code 26 'function nil))
-
+(defconstant +gf-code+ (register-code 27 'generic-function nil))
;; setups for type code mapping
(defun output-type-code (code stream)
- (declare (type (mod 256) code))
+ (declare (type ub32 code))
(write-byte (ldb (byte 8 0) code) stream))
(defun read-type-code (stream)
@@ -77,43 +78,48 @@
;; referrer, Required for a resolving backend
(defmethod store-referrer (ref stream (backend cl-store-backend))
(output-type-code +referrer-code+ stream)
- (store-32-bit ref stream))
+ (dump-int ref stream))
(defrestore-cl-store (referrer stream)
- (make-referrer :val (read-32-bit stream nil)))
+ (make-referrer :val (undump-int stream)))
;; integers
;; The theory is that most numbers will fit in 32 bits
-;; so we try and cater for them
+;; so we we have a little optimization for it
;; We need this for circularity stuff.
(defmethod int-sym-or-char-p ((fn t) (backend cl-store-backend))
- (let ((readers (restorer-funs backend)))
- (or (eq fn (lookup-reader 'integer readers))
- (eq fn (lookup-reader 'character readers))
- (eq fn (lookup-reader '32-bit-integer readers))
- (eq fn (lookup-reader 'symbol readers)))))
+ (member fn '(integer character 32-bit-integer symbol)))
(defstore-cl-store (obj integer stream)
- (if (typep obj '(signed-byte 32))
+ (if (typep obj 'sb32)
(store-32-bit-integer obj stream)
(store-arbitrary-integer obj stream)))
+(defun dump-int (obj stream)
+ (declare (type ub32 obj))
+ (typecase obj
+ ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream))
+ (t (write-byte 2 stream) (store-32-bit obj stream))))
+
+(defun undump-int (stream)
+ (ecase (read-byte stream)
+ (1 (read-byte stream))
+ (2 (read-32-bit stream nil))))
-
-
-;; Should be 32-bit
(defun store-32-bit-integer (obj stream)
+ (declare (type sb32 obj))
(output-type-code +32-bit-integer-code+ stream)
(write-byte (if (minusp obj) 1 0) stream)
- (store-32-bit (abs obj) stream))
+ (dump-int (abs obj) stream))
(defrestore-cl-store (32-bit-integer stream)
- (funcall (if (zerop (read-byte stream)) #'+ #'-)
- (read-32-bit stream nil)))
+ (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-)
+ (undump-int stream)))
(defun store-arbitrary-integer (obj stream)
+ (declare (type integer obj) (stream stream))
(output-type-code +integer-code+ stream)
(loop for n = (abs obj) then (ash n -32)
for counter from 0
@@ -131,46 +137,14 @@
(defrestore-cl-store (integer buff)
(let ((count (restore-object buff))
(result 0))
+ (declare (type integer result count))
(loop repeat (abs count) do
- (setf result (+ (ash result 32) (read-32-bit buff nil))))
+ (setf result (the integer (+ (ash result 32)
+ (the ub32 (read-32-bit buff nil))))))
(if (minusp count)
(- result)
result)))
-
-;; Strings
-;; If the string to be stored is of type simple-standard-string
-;; we can write it down byte by byte. Otherwise we treat it as
-;; an array.
-(deftype simple-standard-string ()
- `(simple-array standard-char (*)))
-
-(defun output-simple-standard-string (obj stream)
- (store-object (length obj) stream)
- (loop for x across obj do
- (write-byte (char-code x) stream)))
-
-(defun restore-simple-standard-string (stream)
- (let* ((length (restore-object stream))
- (res (make-string length
- #+lispworks :element-type #+lispworks 'character)))
- (dotimes (x length)
- (setf (schar res x) (code-char (read-byte stream))))
- res))
-
-(defun store-simple-standard-string (string stream)
- (output-type-code +simple-string-code+ stream)
- (output-simple-standard-string string stream))
-
-
-(defstore-cl-store (obj string stream)
- (if (typep obj 'simple-standard-string)
- (store-simple-standard-string obj stream)
- (store-array obj stream)))
-
-(defrestore-cl-store (simple-string stream)
- (restore-simple-standard-string stream))
-
;; Floats
;; SBCL and CMUCL use a different mechanism for dealing
;; with floats which supports infinities.
@@ -201,7 +175,8 @@
(store-object (denominator obj) stream))
(defrestore-cl-store (ratio stream)
- (/ (restore-object stream) (restore-object stream)))
+ (/ (the integer (restore-object stream))
+ (the integer (restore-object stream))))
;; chars
(defstore-cl-store (obj character stream)
@@ -284,6 +259,7 @@
(size (restore-object stream))
(test (restore-object stream))
(count (restore-object stream)))
+ (declare (type integer count size))
(let ((hash (make-hash-table :test (symbol-function test)
:rehash-size rehash-size
:rehash-threshold rehash-threshold
@@ -298,6 +274,8 @@
(restore-object stream))))
hash)))
+
+;; Object and Conditions
(defun store-type-object (obj stream)
(let* ((all-slots (remove-if-not (lambda (x)
(slot-boundp obj (slot-definition-name x)))
@@ -307,6 +285,7 @@
(remove-if #'(lambda (x) (eql (slot-definition-allocation x)
:class))
all-slots))))
+ (declare (type list slots))
(store-object (type-of obj) stream)
(store-object (length slots) stream)
(dolist (slot slots)
@@ -328,6 +307,7 @@
(let* ((class (find-class (restore-object stream)))
(length (restore-object stream))
(new-instance (allocate-instance class)))
+ (declare (type integer length))
(loop repeat length do
(let ((slot-name (restore-object stream)))
;; slot-names are always symbols so we don't
@@ -387,9 +367,14 @@
(defrestore-cl-store (built-in-class stream)
(find-class (restore-object stream)))
-;; arrays and vectors
+
+
+;; Arrays and Vectors and Strings
(defstore-cl-store (obj array stream)
- (store-array obj stream))
+ (typecase obj
+ (simple-string (store-simple-string obj stream))
+ (simple-vector (store-simple-vector obj stream))
+ (t (store-array obj stream))))
(defun store-array (obj stream)
(output-type-code +array-code+ stream)
@@ -418,6 +403,7 @@
:element-type element-type
:adjustable adjustable
:fill-pointer fill-pointer)))
+ (declare (type cons dimensions) (type array-size size))
(when displaced-to
(adjust-array res dimensions :displaced-to displaced-to
:displaced-index-offset displaced-offset))
@@ -427,29 +413,65 @@
(setting (row-major-aref pos) (restore-object stream)))))
res))
-
-;; clisp and allegro doesn't have the class simple-vector
-#-(or clisp allegro)
-(defstore-cl-store (obj simple-vector stream)
+(defun store-simple-vector (obj stream)
+ (declare (type simple-vector obj))
(output-type-code +simple-vector-code+ stream)
(let ((size (length obj)))
(store-object size stream)
(loop for x across obj do
(store-object x stream))))
-#-(or clisp allegro)
(defrestore-cl-store (simple-vector stream)
(let* ((size (restore-object stream))
(res (make-array size)))
+ (declare (type array-size size))
(resolving-object res
- (loop repeat size
- for i from 0 do
+ (loop for i from 0 to (1- size) do
;; we need to copy the index so that
;; it's value is preserved for after the loop.
(let ((x i))
(setting (aref x) (restore-object stream)))))
res))
+;; Dumping (unsigned-byte 32) for each character seems
+;; like a bit much when most of them will be
+;; standard-chars. So we try to cater for them.
+(defvar *char-marker* (code-char 255)
+ "Largest character that can be represented in 8 bits")
+
+(defun store-simple-string (obj stream)
+ (declare (type simple-string obj))
+ ;; must be a better test than this.
+ (cond ((some #'(lambda (x) (char> x *char-marker*)) obj)
+ ;; contains wide characters
+ (output-type-code +unicode-string-code+ stream)
+ (dump-string #'dump-int obj stream))
+ (t (output-type-code +simple-string-code+ stream)
+ (dump-string #'write-byte obj stream))))
+
+(defun dump-string (dumper obj stream)
+ (declare (simple-string obj) (function dumper) (stream stream))
+ ;(store-object (length obj) stream)
+ (dump-int (length obj) stream)
+ (loop for x across obj do (funcall dumper (char-code x) stream)))
+
+(defrestore-cl-store (simple-string stream)
+ (undump-string #'read-byte stream))
+
+(defrestore-cl-store (unicode-string stream)
+ (undump-string #'undump-int stream))
+
+(defun undump-string (reader stream)
+ (declare (type function reader) (type stream stream))
+ (let* ((length (undump-int stream)) ;(restore-object stream))
+ (res (make-string length
+ #+lispworks :element-type #+lispworks 'character)))
+ (dotimes (x length)
+ (setf (schar res x) (code-char (funcall reader stream))))
+ res))
+
+
+
;; packages
(defstore-cl-store (obj package stream)
(output-type-code +package-code+ stream)
@@ -472,16 +494,35 @@
;; Function storing hack.
;; This just stores the function name if we can find it
-;; or signals a store-error.
+;; or signal a store-error.
(defstore-cl-store (obj function stream)
(output-type-code +function-code+ stream)
(multiple-value-bind (l cp name) (function-lambda-expression obj)
(declare (ignore l cp))
- (if (and name (symbolp name))
- (store-object name stream)
- (store-error "Unable to determine function name for ~A." obj))))
+ (cond ((and name (or (symbolp name) (consp name))) (store-object name stream))
+ ;; Try to deal with sbcl's naming convention
+ ;; of built in functions
+ #+sbcl
+ ((and name (stringp name) (search "top level local call " name))
+ (let ((new-name (subseq name 21)))
+ (when (not (string= new-name ""))
+ (handler-case (store-object (read-from-string new-name) stream)
+ (sb-ext:package-locked-error (c)
+ (declare (ignore c))
+ (store-error "Unable to determine function name for ~A." obj))))))
+ (t (store-error "Unable to determine function name for ~A." obj)))))
(defrestore-cl-store (function stream)
+ (fdefinition (restore-object stream)))
+
+;; Generic function, just dumps the gf-name
+(defstore-cl-store (obj generic-function stream)
+ (output-type-code +gf-code+ stream)
+ (aif (generic-function-name obj)
+ (store-object it stream)
+ (store-error "No generic function name for ~A." obj)))
+
+(defrestore-cl-store (generic-function stream)
(fdefinition (restore-object stream)))
(setf *default-backend* (find-backend 'cl-store))
Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.13 cl-store/package.lisp:1.14
--- cl-store/package.lisp:1.13 Mon Nov 1 15:30:18 2004
+++ cl-store/package.lisp Wed Nov 10 11:43:16 2004
@@ -12,7 +12,7 @@
#:cl-store-error #:store-error #:restore-error #:store
#:restore #:backend-store #:store-backend-code #:store-object
#:backend-store-object #:get-class-details #:get-array-values
- #:check-stream-element-type #:restore #:backend-restore
+ #:restore #:backend-restore
#:check-magic-number #:get-next-reader #:int-sym-or-char-p
#:restore-object #:backend-restore-object #:cl-store
#:defstore-cl-store #:defrestore-cl-store #:register-code
@@ -28,6 +28,7 @@
#:store-32-bit #:read-32-bit)
#+sbcl (:import-from #:sb-mop
+ #:generic-function-name
#:slot-definition-name
#:slot-value-using-class
#:slot-boundp-using-class
@@ -44,8 +45,9 @@
#:class-direct-superclasses
#:class-slots
#:ensure-class)
-
+
#+cmu (:import-from #:pcl
+ #:generic-function-name
#:slot-definition-name
#:slot-value-using-class
#:slot-boundp-using-class
@@ -70,6 +72,7 @@
#:class-of)
#+openmcl (:import-from #:openmcl-mop
+ #:generic-function-name
#:slot-definition-name
#:slot-value-using-class
#:slot-boundp-using-class
@@ -99,6 +102,7 @@
#+lispworks (:import-from #:clos
#:slot-definition-name
+ #:generic-function-name
#:slot-value-using-class
#:slot-boundp-using-class
#:slot-definition-allocation
@@ -117,6 +121,7 @@
#+allegro (:import-from #:mop
#:slot-definition-name
+ #:generic-function-name
#:slot-value-using-class
#:slot-boundp-using-class
#:slot-definition-allocation
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.5 cl-store/plumbing.lisp:1.6
--- cl-store/plumbing.lisp:1.5 Mon Nov 1 15:30:18 2004
+++ cl-store/plumbing.lisp Wed Nov 10 11:43:16 2004
@@ -5,7 +5,7 @@
;;
(in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
(defvar *nuke-existing-classes* nil
"Do we overwrite existing class definitions on restoration.")
@@ -24,6 +24,7 @@
;; store or restore will signal a store-error or a
;; restore-error respectively inside a handler-bind.
(defun cl-store-report (condition stream)
+ (declare (stream stream))
(aif (caused-by condition)
(format stream "~A" it)
(apply #'format stream (format-string condition)
@@ -92,15 +93,13 @@
(:documentation "Method wrapped by store, override this method for
custom behaviour (see circularities.lisp)."))
-(defun store-backend-code (stream backend)
- "Store magic-number of BACKEND, when present, into STREAM."
- (let ((code (magic-number backend)))
- (when code
- (ecase (stream-type backend)
- (character (store-string-code code stream))
- (integer (store-32-bit code stream))))))
-
-
+(defgeneric store-backend-code (stream backend)
+ (:argument-precedence-order backend stream)
+ (:method ((stream t) (backend t))
+ (let ((code (magic-number backend)))
+ (store-32-bit code stream)))
+ (:documentation
+ "Store magic-number of BACKEND, when present, into STREAM."))
(defun store-object (obj stream &optional (backend *current-backend*))
"Store OBJ into STREAM. Not meant to be overridden,
@@ -136,10 +135,6 @@
:caused-by c)))))
(backend-restore place backend)))))
-(declaim (inline check-stream-element-type))
-(defun check-stream-element-type (stream)
- (declare (ignore stream))
- nil)
(defgeneric backend-restore (place backend)
(:argument-precedence-order backend place)
@@ -180,20 +175,23 @@
(defun (setf restore) (new-val place)
(store new-val place))
-(defun check-magic-number (stream backend)
- "Check to see if STREAM actually contains a stored object for BACKEND."
- (let ((magic-number (magic-number backend)))
- (when magic-number
- (let ((val (ecase (stream-type backend)
- (integer (read-32-bit stream nil))
- (character (retrieve-string-code stream)))))
- (cond ((eql val magic-number) nil)
- ((member val (old-magic-numbers backend))
- (restore-error "Stream contains an object stored with a ~
+(defgeneric check-magic-number (stream backend)
+ (:argument-precedence-order backend stream)
+ (:method ((stream t) (backend t))
+ (let ((magic-number (magic-number backend)))
+ (declare (type ub32 magic-number))
+ (when magic-number
+ (let ((val (read-32-bit stream nil)))
+ (declare (type ub32 val))
+ (cond ((= val magic-number) nil)
+ ((member val (old-magic-numbers backend) :test #'=)
+ (restore-error "Stream contains an object stored with a ~
incompatible version of backend ~A." (name backend)))
- (t (restore-error "Stream does not contain a stored object~
+ (t (restore-error "Stream does not contain a stored object~
for backend ~A."
- (name backend))))))))
+ (name backend))))))))
+ (:documentation
+ "Check to see if STREAM actually contains a stored object for BACKEND."))
(defun lookup-reader (val readers)
(gethash val readers))
@@ -216,7 +214,7 @@
(:method (place backend)
(multiple-value-bind (val info) (get-next-reader place backend)
(let ((reader (lookup-reader val (restorer-funs backend))))
- (cond ((and val reader) reader)
+ (cond ((and val reader) (values reader val))
((not val)
(restore-error "~A is not registered with backend ~(~A~)."
(or info "Unknown Type") (name backend)))
Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.9 cl-store/tests.lisp:1.10
--- cl-store/tests.lisp:1.9 Mon Nov 1 15:30:18 2004
+++ cl-store/tests.lisp Wed Nov 10 11:43:16 2004
@@ -95,6 +95,12 @@
(make-array 10 :initial-element #\f :element-type 'character
:fill-pointer 3))
+#+(or (and sbcl sb-unicode) lispworks clisp acl)
+(progn
+ (deftestit unicode.1 (map 'string #'code-char (list #X20AC #X3BB)))
+ (deftestit unicode.2 (intern (map 'string #'code-char (list #X20AC #X3BB))
+ :cl-store-tests)))
+
;; vectors
(deftestit vector.1 #(1 2 3 4))
@@ -470,6 +476,19 @@
(let ((val (multiple-value-list (restore *test-file*))))
(eq (car val) (cadr val))))
t)
+
+
+(deftestit function.1 #'restores)
+(deftestit function.2 #'car)
+(deftestit function.3 #'cl-store::get-setf-place)
+#-(or clisp lispworks allegro openmcl)
+(deftestit function.4 #'(setf car))
+
+(deftestit gfunction.1 #'cl-store:restore)
+(deftestit gfunction.2 #'cl-store:store)
+#-(or clisp lispworks openmcl)
+(deftestit gfunction.3 #'(setf cl-store:restore))
+
(defun run-tests (backend)
Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.6 cl-store/utils.lisp:1.7
--- cl-store/utils.lisp:1.6 Mon Nov 1 15:30:18 2004
+++ cl-store/utils.lisp Wed Nov 10 11:43:16 2004
@@ -3,7 +3,7 @@
;; Miscellaneous utilities used throughout the package.
(in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defmacro aif (test then &optional else)
@@ -47,15 +47,29 @@
(0 1.0)
(1 1.0d0)))
+(deftype ub32 ()
+ `(unsigned-byte 32))
+
+(deftype sb32 ()
+ `(signed-byte 32))
+
+(deftype array-size ()
+ "The maximum size of an array"
+ `(integer 0 ,array-dimension-limit))
+
(defun store-32-bit (obj stream)
- "Write OBJ down STREAM as a 32 byte integer."
+ "Write OBJ down STREAM as a 32 bit integer."
+ (declare (ub32 obj))
(write-byte (ldb (byte 8 0) obj) stream)
(write-byte (ldb (byte 8 8) obj) stream)
(write-byte (ldb (byte 8 16) obj) stream)
(write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
+(defmacro make-ub32 (a b c d)
+ `(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d)))
+
(defun read-32-bit (buf &optional (signed t))
"Read a signed or unsigned byte off STREAM."
(let ((byte1 (read-byte buf))
@@ -63,7 +77,7 @@
(byte3 (read-byte buf))
(byte4 (read-byte buf)))
(declare (type (mod 256) byte1 byte2 byte3 byte4))
- (let ((ret (+ byte1 (* 256 (+ byte2 (* 256 (+ byte3 (* 256 byte4))))))))
+ (let ((ret (make-ub32 byte4 byte3 byte2 byte1)))
(if (and signed (> byte1 127))
(logior (ash -1 32) ret)
ret))))
@@ -71,7 +85,7 @@
(defun store-string-code (string stream)
"Write length of STRING then STRING into stream"
- (declare (type simple-string string))
+ (declare (simple-string string) (stream stream))
(format stream "~S" string))
(defun retrieve-string-code (stream)
Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.6 cl-store/xml-backend.lisp:1.7
--- cl-store/xml-backend.lisp:1.6 Mon Nov 1 15:30:18 2004
+++ cl-store/xml-backend.lisp Wed Nov 10 11:43:16 2004
@@ -3,7 +3,7 @@
(in-package :cl-store-xml)
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *xml-backend*
More information about the Cl-store-cvs
mailing list