[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
Sean Ross
sross at common-lisp.net
Wed Nov 24 13:27:10 UTC 2004
Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv15959
Modified Files:
ChangeLog README backends.lisp circularities.lisp cl-store.asd
default-backend.lisp package.lisp plumbing.lisp tests.lisp
utils.lisp
Log Message:
Changelog 2004-11-24 (0.4 Release)
Date: Wed Nov 24 14:27:04 2004
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.14 cl-store/ChangeLog:1.15
--- cl-store/ChangeLog:1.14 Wed Nov 10 11:43:16 2004
+++ cl-store/ChangeLog Wed Nov 24 14:27:03 2004
@@ -1,9 +1,26 @@
+2004-11-24 Sean Ross <sross at common-lisp.net>
+ * default-backend.lisp: New Magic Number (Breaks backwards compatibility)
+ * cl-store.asd New Version 0.4
+ * default-backend.lisp: Changed symbol storing to be smarter
+ with symbols with no home package.
+ * sbcl/custom.lisp: Support for structure definitions from defstruct.
+ * tests.lisp: Tests for structure definitions.
+ * circularities.lisp: Optimization for referrers and values-object's.
+ Added *store-hash-size* and *restore-hash-size* which can be bound
+ to reduce the calls to rehash which conses like crazy.
+ Added *check-for-circs* which can be bound to nil to stop
+ checking for circularities which reduces consing drastically but objects
+ will not be eq and will hang on circular objects (see README).
+ * default-backend.lisp: New Magic Number ,again.
+ Cater for SB! package names for built-in function names
+ in SBCL.
+
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.
+ Optimized int-sym-or-char-p.
* clisp/fix-clisp.lisp: Added generic-function-name.
* package.lisp: Import generic-function-name.
* default-backend.lisp: More optimizations for strings and ints.
Index: cl-store/README
diff -u cl-store/README:1.11 cl-store/README:1.12
--- cl-store/README:1.11 Wed Nov 10 11:43:16 2004
+++ cl-store/README Wed Nov 24 14:27:03 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.6
+Version: 0.4
0. About.
CL-STORE is an portable serialization package which
@@ -11,12 +11,12 @@
1. Usage
The main entry points are
- - [Function] cl-store:store (obj place &optional (backend *default-backend*)) i
+ - [Method] cl-store:store (obj place &optional (backend *default-backend*)) i
=> obj
Where place is a path designator or stream and
backend is one of the registered backends.
- - [Function] cl-store:restore (place &optional (backend *default-backend*))
+ - [Method] cl-store:restore (place &optional (backend *default-backend*))
=> restored-objects
Where place and backend is as above.
@@ -31,6 +31,34 @@
NOTE.
All errors signalled within store and restore can
be handled by catching store-error and restore-error respectively.
-
+
+2. Optimizing.
+
+ While cl-store is generally quickish it still has a tendency to
+ do a lot of consing. Thanks to profilers this has been pinned down
+ to the rehashing of the hash-tables which track object circularities.
+ From 0.4.0 cl-store has three new variables *store-hash-size*, *restore-hash-size*
+ and *check-for-circs*, proper usage of these new variables can greatly reduce
+ the consing (and time taken) when storing and restoring large objects.
+
+ - *store-hash-size* and *restore-hash-size
+ At the beginning of storing and restoring an eq hash-table is created with a
+ default size of 1000 to track objects which have been (re)stored. On large objects however
+ the rehashing of these hash-tables imposes a severe drain on performance.
+ By binding these two variables to appropriately large values
+ about (100010 for a hash-table with 100000 int->string mappings) you
+ can obtain a decent performance improvement. This may require a bit
+ of fiddling to find the best tradeoff between rehashing and creating
+ a large hash-table.
+
+ - *check-for-circs*
+ Binding this variable to nil when storing or restoring
+ an object inhibits all checks for circularities which gives a
+ severe boost to performance. The downside of this is that no
+ restored objects will be eq and attempting to store circular objects
+ will hang. The speed improvements are definitely worth it if you
+ know that there will be no circularities or shared references in
+ your data (eg spam-filter hash-tables).
+
Enjoy
Sean.
Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.4 cl-store/backends.lisp:1.5
--- cl-store/backends.lisp:1.4 Wed Nov 10 11:43:16 2004
+++ cl-store/backends.lisp Wed Nov 24 14:27:03 2004
@@ -7,7 +7,7 @@
;; in default-backend.lisp and xml-backend.lisp
(in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
+;(declaim (optimize (speed 3) (safety 1) (debug 0)))
(defun required-arg (name)
Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.11 cl-store/circularities.lisp:1.12
--- cl-store/circularities.lisp:1.11 Wed Nov 10 11:43:16 2004
+++ cl-store/circularities.lisp Wed Nov 24 14:27:03 2004
@@ -21,6 +21,10 @@
(in-package :cl-store)
(declaim (optimize (speed 3) (safety 1) (debug 1)))
+
+(defvar *check-for-circs* t)
+
+
(defvar *postfix-setters* '(gethash)
"Setfable places which take the object to set after
the rest of the arguments.")
@@ -91,15 +95,17 @@
()
(:documentation "A backend which does the setup for resolving circularities."))
-(declaim (type (or null fixnum) *stored-counter*))
+(declaim (type (or fixnum null) *stored-counter*))
(defvar *stored-counter*)
(defvar *stored-values*)
+(defvar *store-hash-size* 1000)
+
(defmethod backend-store ((obj t) (place stream) (backend resolving-backend))
"Store OBJ into PLACE. Does the setup for counters and seen values."
(let ((*stored-counter* 0)
- (*stored-values* (make-hash-table :test #'eq)))
+ (*stored-values* (make-hash-table :test #'eq :size *store-hash-size*)))
(store-backend-code place backend)
(backend-store-object obj place backend)
obj))
@@ -109,12 +115,10 @@
(incf *stored-counter*)
(gethash obj *stored-values*))
-(declaim (inline update-seen))
-
(defun update-seen (obj)
"Register OBJ as having been stored."
- (setf (gethash obj *stored-values*) *stored-counter*)
- obj)
+ (setf (gethash obj *stored-values*) *stored-counter*)
+ nil)
(deftype not-circ ()
"Type grouping integer, characters and symbols, which we
@@ -125,67 +129,93 @@
"Do we need to check if this object has been stored before?"
(not (typep obj 'not-circ)))
-(defun value-or-referrer (obj)
- "Returns the number of the referrer and t if this object
- has already been stored in this STORE call."
- (if (needs-checkp obj)
- (aif (seen obj)
- (values it t)
- (values (update-seen obj) nil))
- obj))
-
(defgeneric store-referrer (obj place backend)
(:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.")
(:method ((obj t) (place t) (backend resolving-backend))
(store-error "store-referrer must be specialized for backend ~(~A~)."
(name backend))))
+
+(defun get-ref (obj)
+ (if (needs-checkp obj)
+ (aif (seen obj)
+ it
+ (update-seen obj))
+ nil))
+
(defmethod backend-store-object ((obj t) (place t) (backend resolving-backend))
"Store object if we have not seen this object before, otherwise retrieve
the referrer object for it and store that using store-referrer."
- (multiple-value-bind (obj referrerp) (value-or-referrer obj)
- (if referrerp
- (store-referrer obj place backend)
- (internal-store-object obj place backend))))
-
-
-
+ (aif (and *check-for-circs* (get-ref obj))
+ (store-referrer it place backend)
+ (internal-store-object obj place backend)))
+
;; Restoration.
-(declaim (type (or null fixnum) *restore-counter*))
+(declaim (type (or fixnum null) *restore-counter*))
(defvar *restore-counter*)
(defvar *need-to-fix*)
(defvar *restored-values*)
+(defvar *restore-hash-size* 1000)
(defmethod backend-restore ((place stream) (backend resolving-backend))
"Restore an object from PLACE using BACKEND. Does the setup for
various variables used by resolving-object."
(let ((*restore-counter* 0)
(*need-to-fix* nil)
- (*restored-values* (make-hash-table)))
+ (*restored-values* (make-hash-table :test #'eq :size *restore-hash-size*)))
(check-magic-number place backend)
(multiple-value-prog1
- (backend-restore-object place backend)
+ (backend-restore-object place backend)
(dolist (fn *need-to-fix*)
(funcall (the function fn))))))
-(defmethod backend-restore-object ((place t) (backend resolving-backend))
- "Retrieve a object from PLACE, does housekeeping for circularity fixing."
- (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)
- place)))))
- (setf (gethash spot *restored-values*)
- (car vals))
- (apply #'values vals))
- (funcall (the function reader) place))))
+(defun update-restored (spot val)
+ (setf (gethash spot *restored-values*) val))
+(defun all-vals (reader place)
+ (declare (type function reader))
+ (multiple-value-list (funcall reader place)))
+
+(defun get-vals (reader place)
+ (declare (type function reader))
+ (mapcar #'new-val (all-vals reader place)))
+
+(defun handle-values (reader place)
+ (let ((spot (incf *restore-counter*))
+ (vals (get-vals reader place)))
+ (update-restored spot (car vals))
+ (values-list vals)))
+
+(defun call-it (reader place)
+ (funcall (the function reader) place))
+
+(defun handle-normal (reader place)
+ (let ((spot (incf *restore-counter*))
+ (vals (new-val (call-it reader place))))
+ (update-restored spot vals)
+ vals))
+(defun handle-restore (place backend)
+ (multiple-value-bind (reader sym) (find-function-for-type place backend)
+ (declare (type function reader) (type symbol sym))
+ (cond ((eq sym 'values-object)
+ (handle-values reader place))
+ ((eq sym 'referrer)
+ (incf *restore-counter*)
+ (new-val (call-it reader place)))
+ ((not (int-sym-or-char-p sym backend))
+ (handle-normal reader place))
+ (t (new-val (funcall reader place))))))
+
+(defmethod backend-restore-object ((place stream) (backend resolving-backend))
+ "Retrieve a object from PLACE, does housekeeping for circularity fixing."
+ (if *check-for-circs*
+ (handle-restore place backend)
+ (funcall (the function (find-function-for-type place backend)) place)))
(defgeneric int-sym-or-char-p (fn backend)
(:argument-precedence-order backend fn)
- (:method ((fn t) (backend t))
+ (:method ((fn symbol) (backend backend))
"Is function FN registered to restore an integer, character or symbol
in BACKEND."
(member fn '(integer character symbol))))
@@ -197,5 +227,6 @@
it
val)
val))
+
;; EOF
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.13 cl-store/cl-store.asd:1.14
--- cl-store/cl-store.asd:1.13 Wed Nov 10 11:43:16 2004
+++ cl-store/cl-store.asd Wed Nov 24 14:27:03 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.6"
+ :version "0.4"
: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.12 cl-store/default-backend.lisp:1.13
--- cl-store/default-backend.lisp:1.12 Wed Nov 10 12:14:30 2004
+++ cl-store/default-backend.lisp Wed Nov 24 14:27:03 2004
@@ -9,11 +9,13 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *cl-store-backend*
- (defbackend cl-store :magic-number 1349732684
+ (defbackend cl-store :magic-number 1886611820
:stream-type 'binary
- :old-magic-numbers (1912923 1886611788 1347635532 1347643724)
+ :old-magic-numbers (1912923 1886611788 1347635532
+ 1884506444 1347643724 1349732684)
:extends resolving-backend
- :fields ((restorers :accessor restorers :initform (make-hash-table)))))
+ :fields ((restorers :accessor restorers
+ :initform (make-hash-table :size 100)))))
(defun register-code (code name &optional (errorp t))
(aif (and (gethash code (restorers *cl-store-backend*)) errorp)
(error "Code ~A is already defined for ~A." code name)
@@ -57,6 +59,12 @@
(defconstant +function-code+ (register-code 26 'function nil))
(defconstant +gf-code+ (register-code 27 'generic-function nil))
+;; Used by SBCL.
+(defconstant +structure-class-code+ (register-code 28 'structure-class nil))
+(defconstant +struct-def-code+ (register-code 29 'struct-def nil))
+
+(defconstant +gensym-code+ (register-code 30 'gensym nil))
+
;; setups for type code mapping
(defun output-type-code (code stream)
(declare (type ub32 code))
@@ -65,13 +73,17 @@
(defun read-type-code (stream)
(read-byte stream))
-
+(defvar *restorers* (restorers *cl-store-backend*))
;; get-next-reader needs to return a symbol which will be used by the
;; backend to lookup the function that was defined by
;; defrestore-cl-store to restore it, or nil if not found.
+
+(defun lookup-code (code)
+ (gethash code *restorers*))
+
(defmethod get-next-reader ((stream stream) (backend cl-store-backend))
(let ((type-code (read-type-code stream)))
- (or (gethash type-code (restorers backend))
+ (or (lookup-code type-code) ;(gethash type-code *restorers*)
(values nil (format nil "Type ~A" type-code)))))
@@ -89,7 +101,7 @@
;; 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))
+(defmethod int-sym-or-char-p ((fn symbol) (backend cl-store-backend))
(member fn '(integer character 32-bit-integer symbol)))
(defstore-cl-store (obj integer stream)
@@ -98,7 +110,6 @@
(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))))
@@ -109,7 +120,6 @@
(2 (read-32-bit stream nil))))
(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)
(dump-int (abs obj) stream))
@@ -132,7 +142,7 @@
counter)
stream)
(dolist (num collect)
- (store-32-bit num stream)))))
+ (dump-int num stream)))))
(defrestore-cl-store (integer buff)
(let ((count (restore-object buff))
@@ -140,7 +150,7 @@
(declare (type integer result count))
(loop repeat (abs count) do
(setf result (the integer (+ (ash result 32)
- (the ub32 (read-32-bit buff nil))))))
+ (the ub32 (undump-int buff))))))
(if (minusp count)
(- result)
result)))
@@ -198,16 +208,22 @@
;; symbols
(defstore-cl-store (obj symbol stream)
- (output-type-code +symbol-code+ stream)
- (store-object (symbol-name obj) stream)
- (store-object (package-name (or (symbol-package obj)
- *package*))
- stream))
+ (cond ((symbol-package obj)
+ (output-type-code +symbol-code+ stream)
+ (store-object (symbol-name obj) stream)
+ (store-object (package-name (symbol-package obj))
+ stream))
+ ;; Symbols with no home package
+ (t (output-type-code +gensym-code+ stream)
+ (store-object (symbol-name obj) stream))))
(defrestore-cl-store (symbol stream)
(values (intern (restore-object stream)
(restore-object stream))))
+(defrestore-cl-store (gensym stream)
+ (make-symbol (restore-object stream)))
+
;; lists
(defstore-cl-store (obj cons stream)
@@ -451,10 +467,10 @@
(defun dump-string (dumper obj stream)
(declare (simple-string obj) (function dumper) (stream stream))
- ;(store-object (length obj) stream)
- (dump-int (length obj) stream)
+ (dump-int (the array-size (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))
@@ -463,15 +479,13 @@
(defun undump-string (reader stream)
(declare (type function reader) (type stream stream))
- (let* ((length (undump-int stream)) ;(restore-object stream))
+ (let* ((length (the array-size (undump-int 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)
@@ -495,22 +509,32 @@
;; Function storing hack.
;; This just stores the function name if we can find it
;; or signal a store-error.
+(defun parse-name (name)
+ (let ((name (subseq name 21)))
+ (if (search name "SB!" :end1 3)
+ (replace name "SB-" :end1 3)
+ name)))
+
(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))
- (cond ((and name (or (symbolp name) (consp name))) (store-object name stream))
+ (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)))
+ ((and name (stringp name) (search "top level local call "
+ (the simple-string name)))
+ (let ((new-name (parse-name name)))
(when (not (string= new-name ""))
(handler-case (store-object (read-from-string new-name) stream)
(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)))))
+ (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)))
Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.14 cl-store/package.lisp:1.15
--- cl-store/package.lisp:1.14 Wed Nov 10 11:43:16 2004
+++ cl-store/package.lisp Wed Nov 24 14:27:03 2004
@@ -14,7 +14,7 @@
#:backend-store-object #:get-class-details #:get-array-values
#:restore #:backend-restore
#:check-magic-number #:get-next-reader #:int-sym-or-char-p
- #:restore-object #:backend-restore-object #:cl-store
+ #:restore-object #:backend-restore-object
#:defstore-cl-store #:defrestore-cl-store #:register-code
#:output-type-code #:store-referrer #:resolving-object
#:internal-store-object #:setting #:simple-standard-string
@@ -25,7 +25,8 @@
#:class-direct-superclasses #:class-direct-slots
#:ensure-class #:make-referrer #:setting-hash
#:multiple-value-store #:*postfix-setters* #:caused-by
- #:store-32-bit #:read-32-bit)
+ #:store-32-bit #:read-32-bit #:*check-for-circs*
+ #:*store-hash-size* #:*restore-hash-size*)
#+sbcl (:import-from #:sb-mop
#:generic-function-name
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.6 cl-store/plumbing.lisp:1.7
--- cl-store/plumbing.lisp:1.6 Wed Nov 10 11:43:16 2004
+++ cl-store/plumbing.lisp Wed Nov 24 14:27:03 2004
@@ -5,7 +5,7 @@
;;
(in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defvar *nuke-existing-classes* nil
"Do we overwrite existing class definitions on restoration.")
@@ -14,7 +14,7 @@
(defvar *store-class-slots* t
"Whether or not to serialize slots which are class allocated.")
-
+(declaim (type backend *default-backend* *current-backend*))
(defvar *default-backend*)
(defvar *current-backend*)
@@ -58,6 +58,7 @@
;; entry points
(defun store-to-file (obj place backend)
+ (declare (type backend backend))
(let* ((backend-type (stream-type backend))
(element-type (ecase backend-type
(character 'character)
@@ -78,16 +79,16 @@
(defgeneric backend-store (obj place backend)
(:argument-precedence-order backend place obj)
- (:method ((obj t) (place stream) (backend t))
+ (:method ((obj t) (place stream) (backend backend))
"The default. Checks the streams element-type, stores the backend code
and calls store-object."
(store-backend-code place backend)
(store-object obj place backend)
obj)
- (:method ((obj t) (place string) (backend t))
+ (:method ((obj t) (place string) (backend backend))
"Store OBJ into file designator PLACE."
(store-to-file obj place backend))
- (:method ((obj t) (place pathname) (backend t))
+ (:method ((obj t) (place pathname) (backend backend))
"Store OBJ into file designator PLACE."
(store-to-file obj place backend))
(:documentation "Method wrapped by store, override this method for
@@ -95,12 +96,13 @@
(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)))
+ (:method ((stream t) (backend backend))
+ (awhen (magic-number backend)
+ (store-32-bit it stream)))
(:documentation
"Store magic-number of BACKEND, when present, into STREAM."))
+(declaim (inline store-object))
(defun store-object (obj stream &optional (backend *current-backend*))
"Store OBJ into STREAM. Not meant to be overridden,
use backend-store-object instead"
@@ -110,14 +112,14 @@
(:documentation
"Wrapped by store-object, override this to do custom storing
(see circularities.lisp for an example).")
- (:method ((obj t) (stream t) (backend t))
+ (:method ((obj t) (stream t) (backend backend))
"The default, just calls internal-store-object."
(internal-store-object obj stream backend)))
(defgeneric internal-store-object (obj place backend)
(:documentation "Method which is specialized by defstore-? macros.")
- (:method ((obj t) (place t) (backend t))
+ (:method ((obj t) (place t) (backend backend))
"If call falls back here then OBJ cannot be serialized with BACKEND."
(store-error "Cannot store objects of type ~A with backend ~(~A~)."
(type-of obj) (name backend))))
@@ -139,15 +141,15 @@
(defgeneric backend-restore (place backend)
(:argument-precedence-order backend place)
(:documentation "Wrapped by restore. Override this to do custom restoration")
- (:method ((place stream) (backend t))
+ (:method ((place stream) (backend backend))
"Restore the object found in stream PLACE using backend BACKEND.
Checks the magic-number and invokes backend-restore-object"
(check-magic-number place backend)
(backend-restore-object place backend))
- (:method ((place string) (backend t))
+ (:method ((place string) (backend backend))
"Restore the object found in file designator PLACE using backend BACKEND."
(restore-from-file place backend))
- (:method ((place pathname) (backend t ))
+ (:method ((place pathname) (backend backend))
"Restore the object found in file designator PLACE using backend BACKEND."
(restore-from-file place backend)))
@@ -157,7 +159,7 @@
(character 'character)
(integer '(unsigned-byte 8)))))
(with-open-file (s place :element-type element-type :direction :input)
- (restore s backend))))
+ (backend-restore s backend))))
(defclass values-object ()
((vals :accessor vals :initarg :vals))
@@ -177,9 +179,9 @@
(defgeneric check-magic-number (stream backend)
(:argument-precedence-order backend stream)
- (:method ((stream t) (backend t))
+ (:method ((stream t) (backend backend))
(let ((magic-number (magic-number backend)))
- (declare (type ub32 magic-number))
+ (declare (type (or null ub32) magic-number))
(when magic-number
(let ((val (read-32-bit stream nil)))
(declare (type ub32 val))
@@ -202,16 +204,17 @@
the next function to restore an object from PLACE.
If no reader is found return a second value which will be included
in the error.")
- (:method ((place t) (backend t))
+ (:method ((place t) (backend backend))
"The default, throw an error."
(restore-error "get-next-reader must be specialized for backend ~(~A~)."
(name backend))))
-(defgeneric find-function-for-type (place backend)
- (:documentation
- "Return a function registered with defrestore-? which knows
- how to retrieve an object from PLACE, uses get-next-reader.")
- (:method (place backend)
+(defun find-function-for-type (place backend)
+ (declare (type backend backend))
+;; (:documentation
+;; "Return a function registered with defrestore-? which knows
+;; how to retrieve an object from PLACE, uses get-next-reader.")
+;; (:method ((place t) (backend backend))
(multiple-value-bind (val info) (get-next-reader place backend)
(let ((reader (lookup-reader val (restorer-funs backend))))
(cond ((and val reader) (values reader val))
@@ -220,23 +223,22 @@
(or info "Unknown Type") (name backend)))
((not reader)
(restore-error "No restorer defined for ~A in backend ~(~A~)."
- val (name backend))))))))
+ val (name backend)))))))
;; Wrapper for backend-restore-object so we don't have to pass
;; a backend object around all the time
-(defgeneric restore-object (place &optional backend)
- (:documentation
- "Restore the object in PLACE using BACKEND")
- (:method ((place t) &optional (backend *current-backend*))
- (backend-restore-object place backend)))
+(declaim (inline restore-object))
+(defun restore-object (place &optional (backend *current-backend*))
+ "Restore the object in PLACE using BACKEND"
+ (backend-restore-object place backend))
+
(defgeneric backend-restore-object (place backend)
(:documentation
"Find the next function to call with BACKEND and invoke it with PLACE.")
- (:method ((place t) (backend t))
+ (:method ((place t) (backend backend))
"The default"
- (funcall (the function (find-function-for-type place backend))
- place)))
+ (funcall (the function (find-function-for-type place backend)) place)))
;; EOF
Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.10 cl-store/tests.lisp:1.11
--- cl-store/tests.lisp:1.10 Wed Nov 10 11:43:16 2004
+++ cl-store/tests.lisp Wed Nov 24 14:27:03 2004
@@ -23,7 +23,6 @@
(defmacro deftestit (name val)
`(deftest ,name (restores ,val) t))
-
;; integers
(deftestit integer.1 1)
(deftestit integer.2 0)
@@ -297,7 +296,6 @@
;; circular objects
-
(defvar circ1 (let ((x (list 1 2 3 4)))
(setf (cdr (last x)) x)))
(deftest circ.1 (progn (store circ1 *test-file*)
@@ -489,7 +487,49 @@
#-(or clisp lispworks openmcl)
(deftestit gfunction.3 #'(setf cl-store:restore))
+(deftest nocirc.1
+ (let* ((string "FOO")
+ (list `(,string . ,string))
+ (*check-for-circs* nil))
+ (store list *test-file*)
+ (let ((res (restore *test-file*)))
+ (and (not (eq (car res) (cdr res)))
+ (string= (car res) (cdr res)))))
+ t)
+
+(defstruct st.bar x)
+(defstruct (st.foo (:conc-name f-)
+ (:constructor fooo (z y x))
+ (:copier cp-foo)
+ (:include st.bar)
+ (:predicate is-foo)
+ (:print-function (lambda (obj st dep)
+ (declare (ignore dep))
+ (print-unreadable-object (obj st :type t)
+ (format st "~A" (f-x obj))))))
+ (y 0 :type integer) (z "" :type simple-string))
+
+
+#+sbcl
+(deftest struct-class.1
+ (let* ((obj (fooo "Z" 2 3))
+ (string (format nil "~A" obj)))
+ (let ((*nuke-existing-classes* t))
+ (store (find-class 'st.foo) *test-file*)
+ (fmakunbound 'cp-foo)
+ (fmakunbound 'is-foo)
+ (fmakunbound 'fooo)
+ (fmakunbound 'f-x)
+ (fmakunbound 'f-y)
+ (fmakunbound 'f-z)
+ (restore *test-file*)
+ (let* ((new-obj (cp-foo (fooo "Z" 2 3)))
+ (new-string (format nil "~A" new-obj)))
+ (list (is-foo new-obj) (equalp obj new-obj)
+ (string= new-string string)
+ (f-x new-obj) (f-y new-obj) (f-z new-obj)))))
+ (t t t 3 2 "Z"))
(defun run-tests (backend)
(with-backend backend
Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.7 cl-store/utils.lisp:1.8
--- cl-store/utils.lisp:1.7 Wed Nov 10 11:43:16 2004
+++ cl-store/utils.lisp Wed Nov 24 14:27:03 2004
@@ -60,11 +60,11 @@
(defun store-32-bit (obj stream)
"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))
+ (let ((obj (logand #XFFFFFFFF 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)
@@ -91,6 +91,9 @@
(defun retrieve-string-code (stream)
"Retrieve a String written by store-string-code from STREAM"
(read stream))
+
+(defun kwd (name)
+ (values (intern (string-upcase name) :keyword)))
;; EOF
More information about the Cl-store-cvs
mailing list