cl-store-cvs November 2004

cl-store-cvs@common-lisp.net

1 participants
26 discussions

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by Sean Ross 26 Nov '04

26 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv20044/doc Modified Files: cl-store.texi Log Message: Added structure definition support for CMUCL Date: Fri Nov 26 15:35:58 2004 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.3 cl-store/doc/cl-store.texi:1.4 --- cl-store/doc/cl-store.texi:1.3 Wed Nov 24 14:27:20 2004 +++ cl-store/doc/cl-store.texi Fri Nov 26 15:35:54 2004 @@ -107,7 +107,8 @@ @item Instances of CLOS Classes @item CLOS Classes @item Structure Instances -@item Functions (where function-lambda-expression returns a symbol as a function name) +@item Structure Definitions (CMUCL and SBCL only) +@item Functions (stores the function name) @item Generic Functions (stores generic-function-name) @end itemize

1 0

[cl-store-cvs] CVS update: cl-store/cmucl/custom.lisp
by Sean Ross 26 Nov '04

26 Nov '04

Update of /project/cl-store/cvsroot/cl-store/cmucl In directory common-lisp.net:/tmp/cvs-serv20044/cmucl Modified Files: custom.lisp Log Message: Added structure definition support for CMUCL Date: Fri Nov 26 15:35:52 2004 Author: sross Index: cl-store/cmucl/custom.lisp diff -u cl-store/cmucl/custom.lisp:1.3 cl-store/cmucl/custom.lisp:1.4 --- cl-store/cmucl/custom.lisp:1.3 Wed Nov 24 14:27:12 2004 +++ cl-store/cmucl/custom.lisp Fri Nov 26 15:35:51 2004 @@ -36,4 +36,100 @@ (restore-type-object stream)) + + +;; Structure definitions +(defun get-layout (obj) + (slot-value obj 'pcl::wrapper)) + +(defun get-info (obj) + (declare (type kernel:layout obj)) + (slot-value obj 'ext:info)) + +(defun dd-name (dd) + (slot-value dd 'kernel::name)) + +(defvar *cmucl-struct-inherits* + (list (get-layout (find-class t)) + (get-layout (find-class 'kernel:instance)) + (get-layout (find-class 'cl:structure-object)))) + +(defstruct (struct-def (:conc-name sdef-)) + (supers (required-arg :supers) :type list) + (info (required-arg :info) :type kernel:defstruct-description)) + +(defun info-or-die (obj) + (let ((wrapper (get-layout obj))) + (if wrapper + (or (get-info wrapper) + (store-error "No defstruct-definition for ~A." obj)) + (store-error "No wrapper for ~A." obj)))) + +(defun save-able-supers (obj) + (set-difference (coerce (slot-value (get-layout obj) 'kernel::inherits) + 'list) + *cmucl-struct-inherits*)) + +(defun get-supers (obj) + (loop for x in (save-able-supers obj) + collect (let ((name (dd-name (get-info x)))) + (if *store-class-superclasses* + (find-class name) + name)))) + +(defstore-cl-store (obj structure-class stream) + (output-type-code +structure-class-code+ stream) + (store-object (make-struct-def :info (info-or-die obj) + :supers (get-supers obj)) + stream)) + +(defstore-cl-store (obj struct-def stream) + (output-type-code +struct-def-code+ stream) + (store-object (sdef-supers obj) stream) + (store-object (sdef-info obj) stream)) + +;; Restoring +(defun cmu-struct-defs (dd) + (append (kernel::define-constructors dd) + (kernel::define-raw-accessors dd) + (kernel::define-class-methods dd))) + +(defun create-make-foo (dd) + (dolist (x (cmu-struct-defs dd)) + (eval x)) + (find-class (dd-name dd))) + +(defun cmu-define-structure (dd supers) + (cond ((or *nuke-existing-classes* + (not (find-class (dd-name dd) nil))) + ;; create-struct + (kernel::%defstruct dd supers) + ;; compiler stuff + ;;(kernel::%compiler-defstruct dd) + ;; create make-? + (create-make-foo dd)) + (t (find-class (dd-name dd))))) + +(defun super-layout (super) + (etypecase super + (symbol (get-layout (find-class super))) + (structure-class + (super-layout (dd-name (info-or-die super)))))) + +(defun super-layouts (supers) + (loop for super in supers + collect (super-layout super))) + +(defrestore-cl-store (structure-class stream) + (restore-object stream)) + +(defrestore-cl-store (struct-def stream) + (let* ((supers (super-layouts (restore-object stream))) + (dd (restore-object stream))) + (cmu-define-structure dd (if supers + (coerce (append *cmucl-struct-inherits* + supers) + 'vector) + (coerce *cmucl-struct-inherits* 'vector))))) + ;; EOF

1 0

[cl-store-cvs] CVS update: cl-store/README cl-store/backends.lisp cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/xml-backend.lisp
by Sean Ross 26 Nov '04

26 Nov '04

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv20044 Modified Files: README backends.lisp circularities.lisp cl-store.asd default-backend.lisp plumbing.lisp tests.lisp xml-backend.lisp Log Message: Added structure definition support for CMUCL Date: Fri Nov 26 15:35:37 2004 Author: sross Index: cl-store/README diff -u cl-store/README:1.12 cl-store/README:1.13 --- cl-store/README:1.12 Wed Nov 24 14:27:03 2004 +++ cl-store/README Fri Nov 26 15:35:36 2004 @@ -1,7 +1,7 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.4 +Version: 0.4.1 0. About. CL-STORE is an portable serialization package which Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.5 cl-store/backends.lisp:1.6 --- cl-store/backends.lisp:1.5 Wed Nov 24 14:27:03 2004 +++ cl-store/backends.lisp Fri Nov 26 15:35:36 2004 @@ -104,8 +104,8 @@ (assert (symbolp name)) (let ((class-name (symbolicate name '-backend))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (prog2 - ,(get-class-form class-name fields extends) + (prog2 + ,(get-class-form class-name fields extends) (register-backend ',name ',class-name ,magic-number ,stream-type ',old-magic-numbers) ,(get-store-macro name class-name) Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.12 cl-store/circularities.lisp:1.13 --- cl-store/circularities.lisp:1.12 Wed Nov 24 14:27:03 2004 +++ cl-store/circularities.lisp Fri Nov 26 15:35:36 2004 @@ -198,9 +198,9 @@ (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) + (cond ((eql sym 'values-object) (handle-values reader place)) - ((eq sym 'referrer) + ((eql sym 'referrer) (incf *restore-counter*) (new-val (call-it reader place))) ((not (int-sym-or-char-p sym backend)) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.14 cl-store/cl-store.asd:1.15 --- cl-store/cl-store.asd:1.14 Wed Nov 24 14:27:03 2004 +++ cl-store/cl-store.asd Fri Nov 26 15:35:36 2004 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.4" + :version "0.4.1" :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.13 cl-store/default-backend.lisp:1.14 --- cl-store/default-backend.lisp:1.13 Wed Nov 24 14:27:03 2004 +++ cl-store/default-backend.lisp Fri Nov 26 15:35:36 2004 @@ -511,10 +511,20 @@ ;; or signal a store-error. (defun parse-name (name) (let ((name (subseq name 21))) + (declare (type simple-string name)) (if (search name "SB!" :end1 3) (replace name "SB-" :end1 3) name))) +#+sbcl +(defvar *sbcl-readtable* (copy-readtable *readtable*)) +#+sbcl +(set-macro-character #\# #'(lambda (c s) + (declare (ignore c s)) + (store-error "Invalid character in function name.")) + nil + *sbcl-readtable*) + (defstore-cl-store (obj function stream) (output-type-code +function-code+ stream) (multiple-value-bind (l cp name) (function-lambda-expression obj) @@ -524,10 +534,12 @@ ;; Try to deal with sbcl's naming convention ;; of built in functions #+sbcl - ((and name (stringp name) (search "top level local call " - (the simple-string name))) - (let ((new-name (parse-name name))) - (when (not (string= new-name "")) + ((and name (stringp name) + (search "top level local call " + (the simple-string name))) + (let ((new-name (parse-name name)) + (*readtable* *sbcl-readtable*)) + (unless (string= new-name "") (handler-case (store-object (read-from-string new-name) stream) (error (c) (declare (ignore c)) Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.7 cl-store/plumbing.lisp:1.8 --- cl-store/plumbing.lisp:1.7 Wed Nov 24 14:27:03 2004 +++ cl-store/plumbing.lisp Fri Nov 26 15:35:36 2004 @@ -71,7 +71,8 @@ (:documentation "Entry Point for storing objects.") (:method ((obj t) (place t) &optional (backend *default-backend*)) "Store OBJ into Stream PLACE using backend BACKEND." - (let ((*current-backend* backend)) + (let ((*current-backend* backend) + (*read-eval* nil)) (handler-bind ((error (lambda (c) (signal (make-condition 'store-error :caused-by c))))) @@ -131,7 +132,8 @@ overridden, use backend-restore instead") (:method (place &optional (backend *default-backend*)) "Entry point for restoring objects (setfable)." - (let ((*current-backend* backend)) + (let ((*current-backend* backend) + (*read-eval* nil)) (handler-bind ((error (lambda (c) (signal (make-condition 'restore-error :caused-by c))))) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.11 cl-store/tests.lisp:1.12 --- cl-store/tests.lisp:1.11 Wed Nov 24 14:27:03 2004 +++ cl-store/tests.lisp Fri Nov 26 15:35:36 2004 @@ -508,10 +508,10 @@ (declare (ignore dep)) (print-unreadable-object (obj st :type t) (format st "~A" (f-x obj)))))) - (y 0 :type integer) (z "" :type simple-string)) + (y 0 :type integer) (z nil :type simple-string)) -#+sbcl +#+(or sbcl cmu) (deftest struct-class.1 (let* ((obj (fooo "Z" 2 3)) (string (format nil "~A" obj))) Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.7 cl-store/xml-backend.lisp:1.8 --- cl-store/xml-backend.lisp:1.7 Wed Nov 10 11:43:16 2004 +++ cl-store/xml-backend.lisp Fri Nov 26 15:35:36 2004 @@ -163,7 +163,7 @@ (princ-xml "CHARACTER" (char-code obj) stream)) (defrestore-xml (character place) - (code-char (read-from-string (first-child place)))) + (code-char (parse-integer (first-child place))))

1 0

[cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp
by Sean Ross 24 Nov '04

24 Nov '04

Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv15959/sbcl Modified Files: custom.lisp Log Message: Changelog 2004-11-24 (0.4 Release) Date: Wed Nov 24 14:27:23 2004 Author: sross Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.3 cl-store/sbcl/custom.lisp:1.4 --- cl-store/sbcl/custom.lisp:1.3 Wed Nov 10 11:43:33 2004 +++ cl-store/sbcl/custom.lisp Wed Nov 24 14:27:22 2004 @@ -2,10 +2,11 @@ ;; See the file LICENCE for licence information. (in-package :cl-store) +;; TODO +;; real Functions and closures. ;; Custom float storing - (defstore-cl-store (obj float stream) (output-type-code +float-code+ stream) (write-byte (float-type obj) stream) @@ -24,17 +25,11 @@ (sb-kernel:make-double-float (the integer (restore-object stream)) (the integer (restore-object stream)))) -(defvar *sbcl-float-restorers* - (list (cons 0 #'sbcl-restore-single-float) - (cons 1 #'sbcl-restore-double-float))) - (defrestore-cl-store (float stream) (let ((byte (read-byte stream))) - (declare (type (integer 0 1) byte)) - (aif (cdr (assoc byte *sbcl-float-restorers* :test #'=)) - (funcall (the function it) stream) - (restore-error "Unknown float type designator ~S." byte)))) - + (ecase byte + (0 (sbcl-restore-single-float stream)) + (1 (sbcl-restore-double-float stream))))) ;; Custom structure storing (defstore-cl-store (obj structure-object stream) @@ -44,5 +39,100 @@ (defrestore-cl-store (structure-object stream) (restore-type-object stream)) + +;; Structure definition storing +(defun get-layout (obj) + (slot-value obj 'sb-pcl::wrapper)) + +(defun get-info (obj) + (declare (type sb-kernel:layout obj)) + (slot-value obj 'sb-int:info)) + +(defun dd-name (dd) + (slot-value dd 'sb-kernel::name)) + +(defvar *sbcl-struct-inherits* + (list (get-layout (find-class t)) + (get-layout (find-class 'sb-kernel:instance)) + (get-layout (find-class 'cl:structure-object)))) + +(defstruct (struct-def (:conc-name sdef-)) + (supers (required-arg :supers) :type list) + (info (required-arg :info) :type sb-kernel:defstruct-description)) + +(defun info-or-die (obj) + (let ((wrapper (get-layout obj))) + (if wrapper + (or (get-info wrapper) + (store-error "No defstruct-definition for ~A." obj)) + (store-error "No wrapper for ~A." obj)))) + +(defun save-able-supers (obj) + (set-difference (coerce (slot-value (get-layout obj) 'sb-kernel::inherits) + 'list) + *sbcl-struct-inherits*)) + +(defun get-supers (obj) + (loop for x in (save-able-supers obj) + collect (let ((name (dd-name (get-info x)))) + (if *store-class-superclasses* + (find-class name) + name)))) + +(defstore-cl-store (obj structure-class stream) + (output-type-code +structure-class-code+ stream) + (store-object (make-struct-def :info (info-or-die obj) + :supers (get-supers obj)) + stream)) + +(defstore-cl-store (obj struct-def stream) + (output-type-code +struct-def-code+ stream) + (store-object (sdef-supers obj) stream) + (store-object (sdef-info obj) stream)) + +;; Restoring + +(defun sbcl-struct-defs (info) + (append (sb-kernel::constructor-definitions info) + (sb-kernel::class-method-definitions info))) + +(defun create-make-foo (dd) + (dolist (x (sbcl-struct-defs dd)) + (eval x)) + (find-class (dd-name dd))) + + +(defun sbcl-define-structure (dd supers) + (cond ((or *nuke-existing-classes* + (not (find-class (dd-name dd) nil))) + ;; create-struct + (sb-kernel::%defstruct dd supers) + ;; compiler stuff + (sb-kernel::%compiler-defstruct dd supers) + ;; create make-? + (create-make-foo dd)) + (t (find-class (dd-name dd))))) + +(defun super-layout (super) + (etypecase super + (symbol (get-layout (find-class super))) + (structure-class + (super-layout (dd-name (info-or-die super)))))) + +(defun super-layouts (supers) + (loop for super in supers + collect (super-layout super))) + +(defrestore-cl-store (structure-class stream) + (restore-object stream)) + +(defrestore-cl-store (struct-def stream) + (let* ((supers (super-layouts (restore-object stream))) + (dd (restore-object stream))) + (sbcl-define-structure dd (if supers + (coerce (append *sbcl-struct-inherits* + supers) + 'vector) + (coerce *sbcl-struct-inherits* 'vector))))) ;; EOF

1 0

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by Sean Ross 24 Nov '04

24 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv15959/doc Modified Files: cl-store.texi Log Message: Changelog 2004-11-24 (0.4 Release) Date: Wed Nov 24 14:27:20 2004 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.2 cl-store/doc/cl-store.texi:1.3 --- cl-store/doc/cl-store.texi:1.2 Wed Nov 10 11:43:26 2004 +++ cl-store/doc/cl-store.texi Wed Nov 24 14:27:20 2004 @@ -199,12 +199,46 @@ not be serialized when storing objects. @end deftp + +@anchor {Variable *store-hash-size*} +@vindex *store-hash-size* +@deftp {Variable} *store-hash-size* @emph{Default 1000} +The default size of the hash-table created to keep track of +objects which have already been stored. By binding the +variable to a suitable value you can avoid the consing +involved by rehashing hash-tables. +@end deftp + +@anchor {Variable *restore-hash-size*} +@vindex *restore-hash-size* +@deftp {Variable} *restore-hash-size* @emph{Default 1000} +The default size of the hash-table created to keep track of +objects which have already been restored. By binding the +variable to a suitable value you can avoid the consing +involved by rehashing hash-tables. +@end deftp + + +@anchor {Variable *check-for-circs*} +@vindex *check-for-circs* +@deftp {Variable} *check-for-circs* @emph{Default t} +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). +@end deftp + + @anchor {Variable *default-backend*} @vindex *default-backend* @deftp {Variable} *default-backend* @emph{Default *cl-store-backend*} The backend that will be used by default. @end deftp + @anchor {Variable *cl-store-backend*} @vindex *cl-store-backend* @deftp {Variable} *cl-store-backend* @@ -705,7 +739,7 @@ @section Known Issues @itemize @bullet @item CLISP, OpenMCL, Allegro CL cannot store structure instances. -@item Structure definitions aren't supported. +@item Structure definitions are only supported in SBCL. @item MOP classes aren't supported. @item Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized. @end itemize

1 0

[cl-store-cvs] CVS update: cl-store/cmucl/custom.lisp
by Sean Ross 24 Nov '04

24 Nov '04

Update of /project/cl-store/cvsroot/cl-store/cmucl In directory common-lisp.net:/tmp/cvs-serv15959/cmucl Modified Files: custom.lisp Log Message: Changelog 2004-11-24 (0.4 Release) Date: Wed Nov 24 14:27:12 2004 Author: sross Index: cl-store/cmucl/custom.lisp diff -u cl-store/cmucl/custom.lisp:1.2 cl-store/cmucl/custom.lisp:1.3 --- cl-store/cmucl/custom.lisp:1.2 Wed Oct 6 16:41:07 2004 +++ cl-store/cmucl/custom.lisp Wed Nov 24 14:27:12 2004 @@ -3,7 +3,6 @@ (in-package :cl-store) - (defstore-cl-store (obj float stream) (output-type-code +float-code+ stream) (write-byte (float-type obj) stream) @@ -22,15 +21,11 @@ (kernel:make-double-float (restore-object stream) (restore-object stream))) -(defvar *cmucl-float-restorers* - (list (cons 0 'cmucl-restore-single-float) - (cons 1 'cmucl-restore-double-float))) - (defrestore-cl-store (float stream) (let ((byte (read-byte stream))) - (aif (cdr (assoc byte *cmucl-float-restorers*)) - (funcall it stream) - (restore-error "Unknown float type designator ~S." byte)))) + (ecase byte + (0 (cmucl-restore-single-float stream)) + (1 (cmucl-restore-double-float stream))))) ;; Custom Structures (defstore-cl-store (obj structure-object stream)

1 0

[cl-store-cvs] CVS update: cl-store/acl/custom.lisp
by Sean Ross 24 Nov '04

24 Nov '04

Update of /project/cl-store/cvsroot/cl-store/acl In directory common-lisp.net:/tmp/cvs-serv15959/acl Modified Files: custom.lisp Log Message: Changelog 2004-11-24 (0.4 Release) Date: Wed Nov 24 14:27:10 2004 Author: sross Index: cl-store/acl/custom.lisp diff -u cl-store/acl/custom.lisp:1.1 cl-store/acl/custom.lisp:1.2 --- cl-store/acl/custom.lisp:1.1 Mon Nov 1 15:49:00 2004 +++ cl-store/acl/custom.lisp Wed Nov 24 14:27:10 2004 @@ -29,8 +29,8 @@ (defrestore-cl-store (float stream) (let ((byte (read-byte stream))) - (aif (cdr (assoc byte *acl-float-restorers*)) - (funcall it stream) - (restore-error "Unknown float type designator ~S." byte)))) + (ecase byte + (0 (acl-restore-single-float stream)) + (1 (acl-restore-double-float stream))))) ;; EOF

1 0

[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
by Sean Ross 24 Nov '04

24 Nov '04

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

1 0

[cl-store-cvs] CVS update: cl-store/default-backend.lisp
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv9184 Modified Files: default-backend.lisp Log Message: Date: Wed Nov 10 12:14:30 2004 Author: sross Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.11 cl-store/default-backend.lisp:1.12 --- cl-store/default-backend.lisp:1.11 Wed Nov 10 11:43:16 2004 +++ cl-store/default-backend.lisp Wed Nov 10 12:14:30 2004 @@ -507,7 +507,7 @@ (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) + (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)))))

1 0

[cl-store-cvs] CVS update: cl-store/acl/.cvsignore
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store/acl In directory common-lisp.net:/tmp/cvs-serv7914 Added Files: .cvsignore Log Message: Added acl .cvsignore Date: Wed Nov 10 11:47:48 2004 Author: sross

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-store-cvs November 2004