November 2004 - cl-store-cvs@common-lisp.net

[cl-store-cvs] CVS update: cl-store/doc/html/CL-STORE-XML/contentlist.xml
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE-XML In directory common-lisp.net:/tmp/cvs-serv26326/doc/html/CL-STORE-XML Removed Files: contentlist.xml Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:31:40 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/doc/html/CL-STORE/BACKEND.xml cl-store/doc/html/CL-STORE/RESOLVING-BACKEND.xml cl-store/doc/html/CL-STORE/contentlist.xml
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE In directory common-lisp.net:/tmp/cvs-serv26326/doc/html/CL-STORE Removed Files: BACKEND.xml RESOLVING-BACKEND.xml contentlist.xml Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:31:29 2004 Author: sross

1 0

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc/html In directory common-lisp.net:/tmp/cvs-serv26326/doc/html Removed Files: albert.css book.xml classxcl-storexbackend.html classxcl-storexresolving-backend.html global-index.xml globalindex.html index.html indexreference.html packagexcl-store-xml.html packagexcl-store.html packagexcl-storexcontent.html packagexcl-storexvariables.html packagexcontentxcl-store-xml.html packagexcontentxcl-store.html Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:30:46 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/doc/index.html
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv26326/doc Modified Files: index.html Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:30:37 2004 Author: sross Index: cl-store/doc/index.html diff -u cl-store/doc/index.html:1.1 cl-store/doc/index.html:1.2 --- cl-store/doc/index.html:1.1 Wed Oct 6 16:41:12 2004 +++ cl-store/doc/index.html Mon Nov 1 15:30:37 2004 @@ -17,8 +17,8 @@ <h2>Documentation</h2> <ul> - <li>Most details can be found in the <a href="../README">README</a> file.</li> - <li><a href="html/index.html">Reference Docs</a> (Courtesy of <a href="http://www.cliki.net/Albert">Albert</a>)</li> + <li>Basic details can be found in the <a href="../README">README</a> file.</li> + <li><a href="cl-store.texi">Texinfo Manual</a></li> <li>List of <a href="../ChangeLog">Changes</a></li> </ul>

1 0

[cl-store-cvs] CVS update: cl-store/clisp/fix-clisp.lisp
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/clisp In directory common-lisp.net:/tmp/cvs-serv26326/clisp Modified Files: fix-clisp.lisp Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:30:32 2004 Author: sross Index: cl-store/clisp/fix-clisp.lisp diff -u cl-store/clisp/fix-clisp.lisp:1.3 cl-store/clisp/fix-clisp.lisp:1.4 --- cl-store/clisp/fix-clisp.lisp:1.3 Tue Aug 17 13:12:42 2004 +++ cl-store/clisp/fix-clisp.lisp Mon Nov 1 15:30:32 2004 @@ -2,7 +2,7 @@ ;; See the file LICENCE for licence information. (in-package :cl-store) -(declaim (optimize (speed 3) (safety 0) (debug 0))) +;;(declaim (optimize (speed 3) (safety 0) (debug 0))) ;; this is such a pain.

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 cl-store/xml-backend.lisp
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv26326 Modified Files: ChangeLog README backends.lisp circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp utils.lisp xml-backend.lisp Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:30:19 2004 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.11 cl-store/ChangeLog:1.12 --- cl-store/ChangeLog:1.11 Wed Oct 13 14:35:57 2004 +++ cl-store/ChangeLog Mon Nov 1 15:30:18 2004 @@ -1,3 +1,14 @@ +2004-11-01 Sean Ross <sross(a)common-lisp.net> + * default-backend.lisp: Changed storing of sizes of integers + and strings from store-32-bit to store-object. Changed all + instances of store-32-byte to store-32-bit. + Added a simple function storing method. + * docs/cl-store.texi: New documentation. + + +2004-10-21 Sean Ross <sross(a)common-lisp.net> + * package.lisp, acl/custom.lisp: Added support for Allegro CL. + 2004-10-13 Sean Ross <sross(a)common-lisp.net> * cl-store.asd: New Version (0.3) * circularities.lisp, default-backend.lisp, xml-backend.lisp: Index: cl-store/README diff -u cl-store/README:1.9 cl-store/README:1.10 --- cl-store/README:1.9 Wed Oct 13 14:35:57 2004 +++ cl-store/README Mon Nov 1 15:30:18 2004 @@ -1,36 +1,15 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.3 +Version: 0.3.2 0. About. CL-STORE is an portable serialization package which should give you the ability to store all common-lisp data types (well not all yet) into streams. + See the cl-store manual (docs/cl-store.texi) for more in depth information. - -1. Installation. - The first thing you need is a common-lisp, CL-STORE currently - supports SBCL, CMUCL, Lispworks, CLISP and OpenMCL. - - Hopefully you've asdf-install to install this in which case - all should be fine. - - Otherwise symlink cl-store.asd to somewhere on asdf:*central-registry* - and run (asdf:oos 'asdf:load-op :cl-store). - - The xml backend can be loaded with (asdf:oos 'asdf:loaded :cl-store-xml). - This requires xmls which can be found on http://www.cliki.net and - is asdf-installable. - - Run (asdf:oos 'asdf:test-op :cl-store) and (asdf:oos 'asdf:test-op :cl-store-xml) - to make sure that everything works. Running these tests will try to - load the RT package, which is asdf-installable. - If anything breaks drop me a line, see - http://www.common-lisp.net/project/cl-store/ for mailing-lists. - - -2. Usage +1. Usage The main entry points are - [Function] cl-store:store (obj place &optional (backend *default-backend*)) i => obj @@ -48,70 +27,10 @@ - cl-store:restore is setfable, which I think makes for a great serialized hit counter. eg. (incf (restore place)) - NOTE. All errors signalled within store and restore can be handled by catching store-error and restore-error respectively. - -3. Extending - CL-STORE is more or less extensible. Using defstore-<backend-name> - and defrestore-<backend-name> allows you to customize the storing - and restoring of your own classes. - - contrived eg. - - (in-package :cl-user) - - (use-package :cl-store) - - (setf *default-backend* *cl-store-backend*) - - (defclass random-obj () ((a :accessor a :initarg :a))) - - (defvar *random-obj-code* (register-code 110 'random-obj)) - - (defstore-cl-store (obj random-obj stream) - (output-type-code *random-obj-code* stream) - (store-object (a obj) stream)) - - (defrestore-cl-store (random-obj stream) - (random (restore-object stream))) - - (store (make-instance 'random-obj :a 10) "/tmp/random") - - (restore "/tmp/random") - => ; some number from 0 to 9 - - -4. Backends - CL-STORE now has a concept of backends, suggested by Robert Sedgewick. - Two backends are in releases now, a default backend which is much - what cl-store used to be (pre 0.2) and an xml backend which writes out - xml to character streams. - - Store and Restore now take an optional backend argument which - currently can be one of *default-backend*, *xml-backend* or - a self defined backend. - - The xml written out is not very human readable. - I recommend using a tool like tidy <http://tidy.sourceforge.net/> - to view it in a nice format. - - -5. Issues - There are a number of issues with CL-STORE as it stands. - - - Functions, closures and anything remotely funcallable is unserializable. - - MOP classes are largely unsupported at the moment. - - Structure instances are not supported in MCL, OpenMCL and Clisp. - - Structure definitions aren't supported at all. - - No documentation. - - Older cmucl versions, where (eq 'cl:class 'pcl::class) - returns nil, cannot store classes obtained using cl:find-class. - The solution for this is to use pcl::find-class. - - Enjoy Sean. Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.2 cl-store/backends.lisp:1.3 --- cl-store/backends.lisp:1.2 Wed Oct 6 16:41:03 2004 +++ cl-store/backends.lisp Mon Nov 1 15:30:18 2004 @@ -7,7 +7,7 @@ ;; in default-backend.lisp and xml-backend.lisp (in-package :cl-store) -(declaim (optimize (speed 3) (safety 0) (debug 0))) +;;(declaim (optimize (speed 3) (safety 0) (debug 0))) (defun required-arg (name) Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.9 cl-store/circularities.lisp:1.10 --- cl-store/circularities.lisp:1.9 Wed Oct 13 14:35:57 2004 +++ cl-store/circularities.lisp Mon Nov 1 15:30:18 2004 @@ -19,24 +19,19 @@ ;; programs according to the Hyperspec(notes in EQ). (in-package :cl-store) -(declaim (optimize (speed 3) (safety 0) (debug 0))) +;;(declaim (optimize (speed 3) (safety 0) (debug 0))) -(defvar *referrer-string* "%%Referrer-" - "String which will be interned to create a symbol we - can recognize as a referrer.") - -(defvar *prefix-setters* - '(slot-value aref row-major-aref) - "Setfable places which take the object to set before the - rest of the arguments.") +(defvar *postfix-setters* '(gethash) + "Setfable places which take the object to set after + the rest of the arguments.") (defun get-setf-place (place obj) "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*." (declare (type (or cons symbol) place)) (cond ((atom place) `(,place ,obj)) - ((member (car place) *prefix-setters*) - `(,(car place) ,obj ,@(cdr place))) - (t `(,@place ,obj)))) + ((member (car place) *postfix-setters*) + `(,@place ,obj)) + (t `(,(car place) ,obj ,@(cdr place))))) ;; The definitions for setting and setting-hash sits in resolving-object. Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.11 cl-store/cl-store.asd:1.12 --- cl-store/cl-store.asd:1.11 Wed Oct 13 14:35:57 2004 +++ cl-store/cl-store.asd Mon Nov 1 15:30:18 2004 @@ -14,7 +14,8 @@ "File containing implementation dependent code which may or may not be there.")) (defun lisp-system-shortname () - #+mcl mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl) + #+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl + #+allegro :acl) (defmethod component-pathname ((component non-required-file)) (let ((pathname (call-next-method)) @@ -39,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" + :version "0.3.2" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" @@ -69,4 +70,4 @@ (error "Test-op Failed."))) -;; EOF \ No newline at end of file +;; EOF Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.9 cl-store/default-backend.lisp:1.10 --- cl-store/default-backend.lisp:1.9 Wed Oct 13 14:35:57 2004 +++ cl-store/default-backend.lisp Mon Nov 1 15:30:18 2004 @@ -2,53 +2,58 @@ ;; See the file LICENCE for licence information. ;; The cl-store backend. -;; TODO: Change condition storing in lispworks to ignore reporter-function (in-package :cl-store) -(declaim (optimize (speed 3) (safety 0) (debug 0))) +;;(declaim (optimize (speed 3) (safety 0) (debug 0))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cl-store-backend* - (defbackend cl-store :magic-number 1347635532 + (defbackend cl-store :magic-number 1347643724 :stream-type 'binary - :old-magic-numbers (1912923 1886611788) + :old-magic-numbers (1912923 1886611788 1347635532) :extends resolving-backend :fields ((restorers :accessor restorers :initform (make-hash-table))))) - (defun register-code (code name) - (setf (gethash code (restorers *cl-store-backend*)) - name) + (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) + (setf (gethash code (restorers *cl-store-backend*)) + name)) code)) ;; Type code constants -(defconstant +referrer-code+ (register-code 1 'referrer)) -(defconstant +values-code+ (register-code 2 'values-object)) -(defconstant +integer-code+ (register-code 4 'integer)) -(defconstant +simple-string-code+ (register-code 5 'simple-string)) -(defconstant +float-code+ (register-code 6 'float)) -(defconstant +ratio-code+ (register-code 7 'ratio)) -(defconstant +character-code+ (register-code 8 'character)) -(defconstant +complex-code+ (register-code 9 'complex)) -(defconstant +symbol-code+ (register-code 10 'symbol)) -(defconstant +cons-code+ (register-code 11 'cons)) -(defconstant +pathname-code+ (register-code 12 'pathname)) -(defconstant +hash-table-code+ (register-code 13 'hash-table)) -(defconstant +standard-object-code+ (register-code 14 'standard-object)) -(defconstant +condition-code+ (register-code 15 'condition)) -(defconstant +structure-object-code+ (register-code 16 'structure-object)) -(defconstant +standard-class-code+ (register-code 17 'standard-class)) -(defconstant +built-in-class-code+ (register-code 18 'built-in-class)) -(defconstant +array-code+ (register-code 19 'array)) -(defconstant +simple-vector-code+ (register-code 20 'simple-vector)) -(defconstant +package-code+ (register-code 21 'package)) +(defconstant +referrer-code+ (register-code 1 'referrer nil)) +(defconstant +values-code+ (register-code 2 'values-object nil)) +(defconstant +integer-code+ (register-code 4 'integer nil)) +(defconstant +simple-string-code+ (register-code 5 'simple-string nil)) +(defconstant +float-code+ (register-code 6 'float nil)) +(defconstant +ratio-code+ (register-code 7 'ratio nil)) +(defconstant +character-code+ (register-code 8 'character nil)) +(defconstant +complex-code+ (register-code 9 'complex nil)) +(defconstant +symbol-code+ (register-code 10 'symbol nil)) +(defconstant +cons-code+ (register-code 11 'cons nil)) +(defconstant +pathname-code+ (register-code 12 'pathname nil)) +(defconstant +hash-table-code+ (register-code 13 'hash-table nil)) +(defconstant +standard-object-code+ (register-code 14 'standard-object nil)) +(defconstant +condition-code+ (register-code 15 'condition nil)) +(defconstant +structure-object-code+ (register-code 16 'structure-object nil)) +(defconstant +standard-class-code+ (register-code 17 'standard-class nil)) +(defconstant +built-in-class-code+ (register-code 18 'built-in-class nil)) +(defconstant +array-code+ (register-code 19 'array nil)) +(defconstant +simple-vector-code+ (register-code 20 'simple-vector nil)) +(defconstant +package-code+ (register-code 21 'package nil)) ;; Used by lispworks -(defconstant +positive-infinity-code+ (register-code 22 'positive-infinity)) -(defconstant +negative-infinity-code+ (register-code 23 'negative-infinity)) -(defconstant +float-nan-code+ (register-code 25 'nan-float)) +(defconstant +positive-infinity-code+ (register-code 22 'positive-infinity nil)) +(defconstant +negative-infinity-code+ (register-code 23 'negative-infinity nil)) -;; new storing for 32 byte ints -(defconstant +32-byte-integer-code+ (register-code 24 '32-byte-integer)) +;; new storing for 32 bit ints +(defconstant +32-bit-integer-code+ (register-code 24 '32-bit-integer nil)) + +;; More for lispworks +(defconstant +float-nan-code+ (register-code 25 'nan-float nil)) + +(defconstant +function-code+ (register-code 26 'function nil)) ;; setups for type code mapping @@ -72,14 +77,14 @@ ;; referrer, Required for a resolving backend (defmethod store-referrer (ref stream (backend cl-store-backend)) (output-type-code +referrer-code+ stream) - (store-32-byte ref stream)) + (store-32-bit ref stream)) (defrestore-cl-store (referrer stream) - (make-referrer :val (read-32-byte stream nil))) + (make-referrer :val (read-32-bit stream nil))) ;; integers -;; The theory is that most numbers will fit in 32 bytes +;; The theory is that most numbers will fit in 32 bits ;; so we try and cater for them ;; We need this for circularity stuff. @@ -87,22 +92,26 @@ (let ((readers (restorer-funs backend))) (or (eq fn (lookup-reader 'integer readers)) (eq fn (lookup-reader 'character readers)) - (eq fn (lookup-reader '32-byte-integer readers)) + (eq fn (lookup-reader '32-bit-integer readers)) (eq fn (lookup-reader 'symbol readers))))) (defstore-cl-store (obj integer stream) (if (typep obj '(signed-byte 32)) - (store-32-byte-integer obj stream) + (store-32-bit-integer obj stream) (store-arbitrary-integer obj stream))) -(defun store-32-byte-integer (obj stream) - (output-type-code +32-byte-integer-code+ stream) + + + +;; Should be 32-bit +(defun store-32-bit-integer (obj stream) + (output-type-code +32-bit-integer-code+ stream) (write-byte (if (minusp obj) 1 0) stream) - (store-32-byte (abs obj) stream)) + (store-32-bit (abs obj) stream)) -(defrestore-cl-store (32-byte-integer stream) +(defrestore-cl-store (32-bit-integer stream) (funcall (if (zerop (read-byte stream)) #'+ #'-) - (read-32-byte stream nil))) + (read-32-bit stream nil))) (defun store-arbitrary-integer (obj stream) (output-type-code +integer-code+ stream) @@ -112,18 +121,18 @@ until (zerop n) do (push n collect) finally (progn - (store-32-byte (if (minusp obj) + (store-object (if (minusp obj) (- counter) counter) stream) (dolist (num collect) - (store-32-byte num stream))))) + (store-32-bit num stream))))) (defrestore-cl-store (integer buff) - (let ((count (read-32-byte buff)) + (let ((count (restore-object buff)) (result 0)) (loop repeat (abs count) do - (setf result (+ (ash result 32) (read-32-byte buff nil)))) + (setf result (+ (ash result 32) (read-32-bit buff nil)))) (if (minusp count) (- result) result))) @@ -137,13 +146,14 @@ `(simple-array standard-char (*))) (defun output-simple-standard-string (obj stream) - (store-32-byte (length obj) stream) - (dotimes (x (length obj)) - (write-byte (char-code (schar obj x)) stream))) + (store-object (length obj) stream) + (loop for x across obj do + (write-byte (char-code x) stream))) (defun restore-simple-standard-string (stream) - (let* ((length (read-32-byte stream nil)) - (res (make-string length #+lispworks :element-type #+lispworks 'character))) + (let* ((length (restore-object stream)) + (res (make-string length + #+lispworks :element-type #+lispworks 'character))) (dotimes (x length) (setf (schar res x) (code-char (read-byte stream)))) res)) @@ -166,7 +176,8 @@ ;; with floats which supports infinities. ;; Lispworks uses a slightly different version as well ;; manually handling negative and positive infinity -#-(or lispworks cmu sbcl) +;; Allegro uses excl:double-float-to-shorts and friends +#-(or lispworks cmu sbcl allegro) (defstore-cl-store (obj float stream) (output-type-code +float-code+ stream) (multiple-value-bind (significand exponent sign) @@ -176,7 +187,7 @@ (store-object exponent stream) (store-object sign stream))) -#-(or cmu sbcl) +#-(or cmu sbcl allegro) (defrestore-cl-store (float stream) (float (* (get-float-type (read-byte stream)) (* (restore-object stream) @@ -308,6 +319,7 @@ (output-type-code +standard-object-code+ stream) (store-type-object obj stream)) +#-lispworks (defstore-cl-store (obj condition stream) (output-type-code +condition-code+ stream) (store-type-object obj stream)) @@ -324,6 +336,7 @@ (setting (slot-value slot-name) (restore-object stream))))) new-instance)) +#-lispworks (defrestore-cl-store (condition stream) (restore-type-object stream)) @@ -415,8 +428,8 @@ res)) -;; clisp doesn't have the class simple-vector -#-clisp +;; clisp and allegro doesn't have the class simple-vector +#-(or clisp allegro) (defstore-cl-store (obj simple-vector stream) (output-type-code +simple-vector-code+ stream) (let ((size (length obj))) @@ -424,7 +437,7 @@ (loop for x across obj do (store-object x stream)))) -#-clisp +#-(or clisp allegro) (defrestore-cl-store (simple-vector stream) (let* ((size (restore-object stream)) (res (make-array size))) @@ -445,7 +458,6 @@ (defrestore-cl-store (package stream) (find-package (restore-object stream))) -(setf *default-backend* (find-backend 'cl-store)) ;; multiple values @@ -456,5 +468,22 @@ (defrestore-cl-store (values-object stream) (apply #'values (restore-object stream))) + + +;; Function storing hack. +;; This just stores the function name if we can find it +;; or signals a store-error. +(defstore-cl-store (obj function stream) + (output-type-code +function-code+ stream) + (multiple-value-bind (l cp name) (function-lambda-expression obj) + (declare (ignore l cp)) + (if (and name (symbolp name)) + (store-object name stream) + (store-error "Unable to determine function name for ~A." obj)))) + +(defrestore-cl-store (function stream) + (fdefinition (restore-object stream))) + +(setf *default-backend* (find-backend 'cl-store)) ;; EOF Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.12 cl-store/package.lisp:1.13 --- cl-store/package.lisp:1.12 Wed Oct 13 14:35:57 2004 +++ cl-store/package.lisp Mon Nov 1 15:30:18 2004 @@ -24,7 +24,8 @@ #:slot-definition-readers #:slot-definition-writers #:class-direct-superclasses #:class-direct-slots #:ensure-class #:make-referrer #:setting-hash - #:multiple-value-store) + #:multiple-value-store #:*postfix-setters* #:caused-by + #:store-32-bit #:read-32-bit) #+sbcl (:import-from #:sb-mop #:slot-definition-name @@ -112,5 +113,24 @@ #:class-direct-slots #:class-slots #:class-direct-superclasses - #:ensure-class)) + #:ensure-class) + + #+allegro (:import-from #:mop + #:slot-definition-name + #:slot-value-using-class + #:slot-boundp-using-class + #:slot-definition-allocation + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + ) ;; EOF Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.4 cl-store/plumbing.lisp:1.5 --- cl-store/plumbing.lisp:1.4 Wed Oct 13 14:35:58 2004 +++ cl-store/plumbing.lisp Mon Nov 1 15:30:18 2004 @@ -5,12 +5,11 @@ ;; (in-package :cl-store) -(declaim (optimize (speed 3) (safety 0) (debug 0))) - +;;(declaim (optimize (speed 3) (safety 0) (debug 0))) (defvar *nuke-existing-classes* nil "Do we overwrite existing class definitions on restoration.") -(defvar *store-class-superclasses* t +(defvar *store-class-superclasses* nil "Whether or not to store the superclasses of a stored class.") (defvar *store-class-slots* t "Whether or not to serialize slots which are class allocated.") @@ -99,7 +98,7 @@ (when code (ecase (stream-type backend) (character (store-string-code code stream)) - (integer (store-32-byte code stream)))))) + (integer (store-32-bit code stream)))))) @@ -147,8 +146,7 @@ (:documentation "Wrapped by restore. Override this to do custom restoration") (:method ((place stream) (backend t)) "Restore the object found in stream PLACE using backend BACKEND. - Checks stream-element-type and magic-number and - invokes backend-restore-object" + Checks the magic-number and invokes backend-restore-object" (check-magic-number place backend) (backend-restore-object place backend)) (:method ((place string) (backend t)) @@ -187,7 +185,7 @@ (let ((magic-number (magic-number backend))) (when magic-number (let ((val (ecase (stream-type backend) - (integer (read-32-byte stream)) + (integer (read-32-bit stream nil)) (character (retrieve-string-code stream))))) (cond ((eql val magic-number) nil) ((member val (old-magic-numbers backend)) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.8 cl-store/tests.lisp:1.9 --- cl-store/tests.lisp:1.8 Wed Oct 13 14:35:58 2004 +++ cl-store/tests.lisp Mon Nov 1 15:30:18 2004 @@ -64,7 +64,7 @@ (deftestit double-float.6 most-negative-double-float) ;; infinite floats -#+(or sbcl cmu lispworks) +#+(or sbcl cmu lispworks allegro) (progn #+sbcl (sb-int:set-floating-point-modes :traps nil) #+cmu (ext:set-floating-point-modes :traps nil) @@ -257,9 +257,10 @@ (deftest condition.2 (handler-case (car (read-from-string "3")) - (type-error (c) + (#-allegro type-error #+allegro simple-error (c) (store c *test-file*) - (typep (restore *test-file*) 'type-error))) + (typep (restore *test-file*) + #-allegro 'type-error #+allegro 'simple-error))) t) ;; structure-object @@ -286,9 +287,8 @@ (deftestit pathname.1 #P"/home/foo") (deftestit pathname.2 (make-pathname :name "foo")) -(deftestit pathname.3 (make-pathname :name "foo" :type "bar" - #-clisp :device #-clisp "foobar" - )) +(deftestit pathname.3 (make-pathname :name "foo" :type "bar")) + ;; circular objects Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.5 cl-store/utils.lisp:1.6 --- cl-store/utils.lisp:1.5 Wed Oct 13 14:35:58 2004 +++ cl-store/utils.lisp Mon Nov 1 15:30:18 2004 @@ -3,7 +3,7 @@ ;; Miscellaneous utilities used throughout the package. (in-package :cl-store) -(declaim (optimize (speed 3) (safety 0) (debug 0))) +;;(declaim (optimize (speed 3) (safety 0) (debug 0))) (defmacro aif (test then &optional else) @@ -48,7 +48,7 @@ (1 1.0d0))) -(defun store-32-byte (obj stream) +(defun store-32-bit (obj stream) "Write OBJ down STREAM as a 32 byte integer." (write-byte (ldb (byte 8 0) obj) stream) (write-byte (ldb (byte 8 8) obj) stream) @@ -56,7 +56,7 @@ (write-byte (+ 0 (ldb (byte 8 24) obj)) stream)) -(defun read-32-byte (buf &optional (signed t)) +(defun read-32-bit (buf &optional (signed t)) "Read a signed or unsigned byte off STREAM." (let ((byte1 (read-byte buf)) (byte2 (read-byte buf)) Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.5 cl-store/xml-backend.lisp:1.6 --- cl-store/xml-backend.lisp:1.5 Wed Oct 13 14:35:58 2004 +++ cl-store/xml-backend.lisp Mon Nov 1 15:30:18 2004 @@ -117,8 +117,8 @@ ;; simple-string (defun xml-dump-simple-string (string place) - (princ-xml "SIMPLE-STRING" string place)) - + (with-tag ("SIMPLE-STRING" place) + (format place "~S" string))) (defstore-xml (obj string stream) (if (typep obj 'simple-standard-string) @@ -126,7 +126,7 @@ (xml-dump-array obj stream))) (defrestore-xml (simple-string place) - (third place)) + (read-from-string (third place))) ;; float @@ -425,7 +425,7 @@ (restore-first value))))))) -#-clisp +#-(or allegro clisp) (defstore-xml (obj simple-vector stream) (with-tag ("SIMPLE-VECTOR" stream) (princ-and-store "LENGTH" (length obj) stream) @@ -433,7 +433,7 @@ (loop for x across obj do (princ-and-store "ELEMENT" x stream))))) -#-clisp +#-(or allegro clisp) (defrestore-xml (simple-vector place) (let* ((size (restore-first (get-child "LENGTH" place))) (res (make-array size)))

1 0