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@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@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@jhb.ucs.co.za>" :maintainer "Sean Ross <sdr@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