- cl-store-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[cl-store-cvs] CVS update: cl-store/doc/html/icons/README cl-store/doc/html/icons/exported.png cl-store/doc/html/icons/gnome_down.png cl-store/doc/html/icons/gnome_home.png cl-store/doc/html/icons/gnome_index.png cl-store/doc/html/icons/gnome_left.png cl-store/doc/html/icons/gnome_no.png cl-store/doc/html/icons/gnome_right.png cl-store/doc/html/icons/gnome_up.png cl-store/doc/html/icons/gnome_yes.png cl-store/doc/html/icons/internal.png
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc/html/icons In directory common-lisp.net:/tmp/cvs-serv26326/doc/html/icons Removed Files: README exported.png gnome_down.png gnome_home.png gnome_index.png gnome_left.png gnome_no.png gnome_right.png gnome_up.png gnome_yes.png internal.png Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:31:44 2004 Author: sross

1 0

[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

[cl-store-cvs] CVS update: cl-store/lispworks/custom-xml.lisp cl-store/lispworks/custom.lisp
by Sean Ross 13 Oct '04

13 Oct '04

Update of /project/cl-store/cvsroot/cl-store/lispworks In directory common-lisp.net:/tmp/cvs-serv10507/lispworks Modified Files: custom-xml.lisp custom.lisp Log Message: Changelogs 2004-10-07 to 2004-10-13 Date: Wed Oct 13 14:36:03 2004 Author: sross Index: cl-store/lispworks/custom-xml.lisp diff -u cl-store/lispworks/custom-xml.lisp:1.2 cl-store/lispworks/custom-xml.lisp:1.3 --- cl-store/lispworks/custom-xml.lisp:1.2 Wed Oct 6 16:41:40 2004 +++ cl-store/lispworks/custom-xml.lisp Wed Oct 13 14:36:03 2004 @@ -30,12 +30,15 @@ #'(lambda (err) (declare (ignore err)) (cond - ((positive-infinity-p obj) + ((cl-store::positive-infinity-p obj) (with-tag ("POSITIVE-INFINITY" stream)) (return-from body)) - ((negative-infinity-p obj) + ((cl-store::negative-infinity-p obj) (with-tag ("NEGATIVE-INFINITY" stream)) (return-from body)) + ((cl-store::float-nan-p obj) + (with-tag ("FLOAT-NAN" stream)) + (return-from body)) (t nil))))) (multiple-value-bind (signif exp sign) (integer-decode-float obj) @@ -47,11 +50,14 @@ (defrestore-xml (positive-infinity stream) (declare (ignore stream)) - +positive-infinity+) + cl-store::+positive-infinity+) (defrestore-xml (negative-infinity stream) (declare (ignore stream)) - +negative-infinity+) + cl-store::+negative-infinity+) +(defrestore-xml (float-nan stream) + (declare (ignore stream)) + cl-store::+nan-float+) ;; EOF Index: cl-store/lispworks/custom.lisp diff -u cl-store/lispworks/custom.lisp:1.2 cl-store/lispworks/custom.lisp:1.3 --- cl-store/lispworks/custom.lisp:1.2 Fri Oct 1 10:49:47 2004 +++ cl-store/lispworks/custom.lisp Wed Oct 13 14:36:03 2004 @@ -6,6 +6,8 @@ ;; custom support for infinite floats from Alain Picard. (defconstant +positive-infinity+ (expt most-positive-double-float 2)) (defconstant +negative-infinity+ (expt most-negative-double-float 3)) +(defconstant +nan-float+ (/ (expt most-positive-double-float 2) + (expt most-positive-double-float 2))) (defun positive-infinity-p (number) (> number most-positive-double-float)) @@ -13,6 +15,9 @@ (defun negative-infinity-p (number) (< number most-negative-double-float)) +(defun float-nan-p (number) + (eql number +nan-float+)) + ;; Attempt at fixing broken storing infinity problem (defstore-cl-store (obj float stream) (block body @@ -27,6 +32,9 @@ ((negative-infinity-p obj) (output-type-code +negative-infinity-code+ stream) (return-from body)) ; success + ((float-nan-p obj) + (output-type-code +float-nan-code+ stream) + (return-from body)) (t ;; Unclear what _other_ sort of error we can ;; get by failing to decode a float, but, @@ -49,6 +57,10 @@ (declare (ignore stream)) +positive-infinity+) +(defrestore-cl-store (nan-float stream) + (declare (ignore stream)) + +nan-float+) + ;; Custom structure storing from Alain Picard. (defstore-cl-store (obj structure-object stream) @@ -72,4 +84,4 @@ (setting (slot-value slot-name) (restore-object stream))))) new-instance)) -;; EOF \ No newline at end of file +;; EOF

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README 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 13 Oct '04

13 Oct '04

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv10507 Modified Files: ChangeLog README circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp utils.lisp xml-backend.lisp Log Message: Changelogs 2004-10-07 to 2004-10-13 Date: Wed Oct 13 14:35:58 2004 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.10 cl-store/ChangeLog:1.11 --- cl-store/ChangeLog:1.10 Wed Oct 6 16:41:02 2004 +++ cl-store/ChangeLog Wed Oct 13 14:35:57 2004 @@ -1,3 +1,23 @@ +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: + Changed referrer representation to a structure. + Removed cl-store-referrer package. + +2004-10-12 Sean Ross <sross(a)common-lisp.net> + * lispworks/custom.lisp, lispworks/custom-xml.lisp, default-backend.lisp: + Added support for NaN floats. + * tests.lisp: Test NaN floats, Test multiple values. + * default-backend.lisp: fix typo which broke clisp support. + +2004-10-11 Sean Ross <sross(a)common-lisp.net> + * default-backend: Added multiple-value-store. + * xml-backend: Added support for multiple return values. + +2004-10-07 Sean Ross <sross(a)common-lisp.net> + * circularities.lisp: Added support for multiple return values from + functions defined with defrestore-?. + 2004-10-06 Sean Ross <sross(a)common-lisp.net> * cl-store-xml.asd, xml-package.lisp, xml-tests.lisp: Moved the xml backend into it's own package files. @@ -25,7 +45,7 @@ 2004-10-01 Sean Ross <sross(a)common-lisp.net> * lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard. - * tests.lisp: Infite float tests for lispworks. + * tests.lisp: Infinite float tests for lispworks. 2004-09-27 Sean Ross <sross(a)common-lisp.net> * plumbing.lisp: Slightly nicer error handling (I think). Index: cl-store/README diff -u cl-store/README:1.8 cl-store/README:1.9 --- cl-store/README:1.8 Wed Oct 6 16:41:03 2004 +++ cl-store/README Wed Oct 13 14:35:57 2004 @@ -1,12 +1,12 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.2.9 +Version: 0.3 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 files, streams or whatever. + data types (well not all yet) into streams. 1. Installation. @@ -31,20 +31,29 @@ 2. Usage - The two main entry points are - - cl-store:store (obj place &optional (backend *default-backend*)) i + The main entry points are + - [Function] 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. - - cl-store:restore (place &optional (backend *default-backend*)) - => restored-obj + - [Function] cl-store:restore (place &optional (backend *default-backend*)) + => restored-objects Where place and backend is as above. + - [Macro] cl-store:multiple-value-store (values-form place &optional (backend *default-backend*)) + => objects + Stores all the values returned by VALUES-FORM into place as per cl-store:store. + - 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> @@ -92,7 +101,7 @@ 5. Issues - There are a number of issues with CL-STORE as it stands (0.2.9). + 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. Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.8 cl-store/circularities.lisp:1.9 --- cl-store/circularities.lisp:1.8 Wed Oct 6 16:41:03 2004 +++ cl-store/circularities.lisp Wed Oct 13 14:35:57 2004 @@ -61,7 +61,7 @@ `(macrolet ((setting (place getting) (let ((setf-place (get-setf-place place ',obj))) `(let ((,',value ,getting)) - (if (referrerp ,',value) + (if (referrer-p ,',value) (push (lambda () (setf ,setf-place (referred-value ,',value @@ -70,13 +70,13 @@ (setf ,setf-place ,',value))))) (setting-hash (getting-key getting-place) `(let ((,',key ,getting-key)) - (if (referrerp ,',key) + (if (referrer-p ,',key) (let ((,',value ,getting-place)) (push (lambda () (setf (gethash (referred-value ,',key *restored-values*) ,',obj) - (if (referrerp ,',value) + (if (referrer-p ,',value) (referred-value ,',value *restored-values*) ,',value))) @@ -86,27 +86,14 @@ ,@body ,obj)))) -(defun referrerp (val) - "Is val a referrer?" - (and (symbolp val) - (eq (symbol-package val) #.(find-package :cl-store-referrers)) - (equal (subseq (symbol-name val) 0 11) - *referrer-string*))) +(defstruct referrer + val) (defun referred-value (referrer hash) "Return the value REFERRER is meant to be by looking in HASH." - (gethash (read-from-string (subseq (symbol-name referrer) 11)) + (gethash (referrer-val referrer) ;(read-from-string (subseq (symbol-name referrer) 11)) hash)) - -(defun make-referrer (x) - "Create a new referrer suffixed with X." - (declare (type fixnum x)) - (let ((name (intern (format nil "%%Referrer-~D" x) - :cl-store-referrers))) - name)) - - (defclass resolving-backend (backend) () (:documentation "A backend which does the setup for resolving circularities.")) @@ -182,18 +169,25 @@ (let ((*restore-counter* 0) (*need-to-fix* nil) (*restored-values* (make-hash-table))) - (prog2 - (check-magic-number place backend) + (check-magic-number place backend) + (multiple-value-prog1 (backend-restore-object place backend) (dolist (fn *need-to-fix*) (funcall (the function fn)))))) +;; Change to backend-restore-object to allow support for +;; multiple return values. (defmethod backend-restore-object ((place t) (backend resolving-backend)) "Retrieve a object from PLACE, does housekeeping for circularity fixing." (let ((reader (find-function-for-type place backend))) (if (not (int-sym-or-char-p reader backend)) - (setf (gethash (incf *restore-counter*) *restored-values*) - (new-val (funcall (the function reader) place))) + (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)))) @@ -210,7 +204,7 @@ (defun new-val (val) "Tries to get a referred value to reduce unnecessary cirularity fixing." - (if (referrerp val) + (if (referrer-p val) (aif (referred-value val *restored-values*) it val) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.10 cl-store/cl-store.asd:1.11 --- cl-store/cl-store.asd:1.10 Wed Oct 6 16:41:03 2004 +++ cl-store/cl-store.asd Wed Oct 13 14:35:57 2004 @@ -39,7 +39,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.2.9" + :version "0.3" :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.8 cl-store/default-backend.lisp:1.9 --- cl-store/default-backend.lisp:1.8 Wed Oct 6 16:41:03 2004 +++ cl-store/default-backend.lisp Wed Oct 13 14:35:57 2004 @@ -2,8 +2,7 @@ ;; See the file LICENCE for licence information. ;; The cl-store backend. - -;; DOCUMENTATION +;; TODO: Change condition storing in lispworks to ignore reporter-function (in-package :cl-store) @@ -15,13 +14,15 @@ :stream-type 'binary :old-magic-numbers (1912923 1886611788) :extends resolving-backend - :fields ((restorers :accessor restorers :initform nil)))) + :fields ((restorers :accessor restorers :initform (make-hash-table))))) (defun register-code (code name) - (push (cons code name) (restorers *cl-store-backend*)) + (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)) @@ -44,6 +45,7 @@ ;; 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)) ;; new storing for 32 byte ints (defconstant +32-byte-integer-code+ (register-code 24 '32-byte-integer)) @@ -62,8 +64,9 @@ ;; backend to lookup the function that was defined by ;; defrestore-cl-store to restore it, or nil if not found. (defmethod get-next-reader ((stream stream) (backend cl-store-backend)) - (cdr (assoc (read-type-code stream) - (restorers backend)))) + (let ((type-code (read-type-code stream))) + (or (gethash type-code (restorers backend)) + (values nil (format nil "Type ~A" type-code))))) ;; referrer, Required for a resolving backend @@ -72,7 +75,7 @@ (store-32-byte ref stream)) (defrestore-cl-store (referrer stream) - (make-referrer (read-32-byte stream nil))) + (make-referrer :val (read-32-byte stream nil))) ;; integers @@ -140,7 +143,7 @@ (defun restore-simple-standard-string (stream) (let* ((length (read-32-byte stream nil)) - (res (make-string length))) + (res (make-string length #+lispworks :element-type #+lispworks 'character))) (dotimes (x length) (setf (schar res x) (code-char (read-byte stream)))) res)) @@ -288,7 +291,7 @@ (let* ((all-slots (remove-if-not (lambda (x) (slot-boundp obj (slot-definition-name x))) (compute-slots (class-of obj)))) - (slots (if *store-class-slots* + (slots (if *store-class-slots* all-slots (remove-if #'(lambda (x) (eql (slot-definition-allocation x) :class)) @@ -353,10 +356,10 @@ (cond ((find-class class nil) (cond (*nuke-existing-classes* (apply #'ensure-class class final) - #+clisp (add-methods-for-class class (second vals))) + #+clisp (add-methods-for-class class slots)) (t (find-class class)))) (t (apply #'ensure-class class final) - #+clisp (add-methods-for-class class (second vals)))))) + #+clisp (add-methods-for-class class slots))))) ;; built in classes (defstore-cl-store (obj built-in-class stream) @@ -443,4 +446,15 @@ (find-package (restore-object stream))) (setf *default-backend* (find-backend 'cl-store)) + +;; multiple values + +(defstore-cl-store (obj values-object stream) + (output-type-code +values-code+ stream) + (store-object (vals obj) stream)) + +(defrestore-cl-store (values-object stream) + (apply #'values (restore-object stream))) + + ;; EOF Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.11 cl-store/package.lisp:1.12 --- cl-store/package.lisp:1.11 Wed Oct 6 16:41:03 2004 +++ cl-store/package.lisp Wed Oct 13 14:35:57 2004 @@ -24,8 +24,8 @@ #:slot-definition-readers #:slot-definition-writers #:class-direct-superclasses #:class-direct-slots #:ensure-class #:make-referrer #:setting-hash - #:+positive-infinity+ #:+negative-infinity+ - #:positive-infinity-p #:negative-infinity-p) + #:multiple-value-store) + #+sbcl (:import-from #:sb-mop #:slot-definition-name #:slot-value-using-class @@ -113,10 +113,4 @@ #:class-slots #:class-direct-superclasses #:ensure-class)) - - - -;; package used to unclutter cl-store by holding all %referrer symbols. -(defpackage #:cl-store-referrers) - ;; EOF Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.3 cl-store/plumbing.lisp:1.4 --- cl-store/plumbing.lisp:1.3 Wed Oct 6 16:41:03 2004 +++ cl-store/plumbing.lisp Wed Oct 13 14:35:58 2004 @@ -24,17 +24,19 @@ ;; From 0.2.3 all conditions which are signalled from ;; store or restore will signal a store-error or a ;; restore-error respectively inside a handler-bind. +(defun cl-store-report (condition stream) + (aif (caused-by condition) + (format stream "~A" it) + (apply #'format stream (format-string condition) + (format-args condition)))) + (define-condition cl-store-error (condition) ((caused-by :accessor caused-by :initarg :caused-by :initform nil) (format-string :accessor format-string :initarg :format-string :initform "Unknown") (format-args :accessor format-args :initarg :format-args :initform nil)) - (:report (lambda (condition stream) - (aif (caused-by condition) - (format stream "~A" it) - (apply #'format stream (format-string condition) - (format-args condition))))) + (:report cl-store-report) (:documentation "Root cl-store condition")) (define-condition store-error (cl-store-error) @@ -164,10 +166,22 @@ (with-open-file (s place :element-type element-type :direction :input) (restore s backend)))) +(defclass values-object () + ((vals :accessor vals :initarg :vals)) + (:documentation "Backends supporting multiple return values +should define a custom storer and restorer for this class")); + +(defmacro multiple-value-store (values-form place + &optional (backend '*default-backend*)) + "Store all values returned from VALUES-FORM into PLACE" + `(let ((vals (multiple-value-list ,values-form))) + (store (make-instance 'values-object :vals vals) + ,place ,backend) + (apply #'values vals))) + (defun (setf restore) (new-val place) (store new-val place)) - (defun check-magic-number (stream backend) "Check to see if STREAM actually contains a stored object for BACKEND." (let ((magic-number (magic-number backend))) @@ -189,7 +203,9 @@ (defgeneric get-next-reader (place backend) (:documentation "Method which must be specialized for BACKEND to return - the next function to restore an object from PLACE.") + 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)) "The default, throw an error." (restore-error "get-next-reader must be specialized for backend ~(~A~)." @@ -200,15 +216,15 @@ "Return a function registered with defrestore-? which knows how to retrieve an object from PLACE, uses get-next-reader.") (:method (place backend) - (let* ((val (get-next-reader place backend)) - (reader (lookup-reader val (restorer-funs backend)))) - (cond ((and val reader) reader) - ((not val) - (restore-error "~A is not registered with backend ~(~A~)." - val (name backend))) - ((not reader) - (restore-error "No restorer defined for ~A in backend ~(~A~)." - val (name backend))))))) + (multiple-value-bind (val info) (get-next-reader place backend) + (let ((reader (lookup-reader val (restorer-funs backend)))) + (cond ((and val reader) reader) + ((not val) + (restore-error "~A is not registered with backend ~(~A~)." + (or info "Unknown Type") (name backend))) + ((not reader) + (restore-error "No restorer defined for ~A in backend ~(~A~)." + val (name backend)))))))) ;; Wrapper for backend-restore-object so we don't have to pass ;; a backend object around all the time Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.7 cl-store/tests.lisp:1.8 --- cl-store/tests.lisp:1.7 Wed Oct 6 16:41:04 2004 +++ cl-store/tests.lisp Wed Oct 13 14:35:58 2004 @@ -71,7 +71,11 @@ (deftestit infinite-float.1 (expt most-positive-single-float 3)) (deftestit infinite-float.2 (expt most-positive-double-float 3)) (deftestit infinite-float.3 (expt most-negative-single-float 3)) - (deftestit infinite-float.4 (expt most-negative-double-float 3))) + (deftestit infinite-float.4 (expt most-negative-double-float 3)) + (deftestit infinite-float.5 (/ (expt most-positive-single-float 3) + (expt most-positive-single-float 3))) + (deftestit infinite-float.6 (/ (expt most-positive-double-float 3) + (expt most-positive-double-float 3)))) ;; characters @@ -452,6 +456,19 @@ (deftest custom.1 (progn (store (make-instance 'random-obj :size 5) *test-file* ) (typep (restore *test-file*) '(integer 0 4))) + t) + + +(deftest values.1 + (progn (multiple-value-store (values 1 2 3) *test-file*) + (multiple-value-list (restore *test-file*))) + (1 2 3)) + +(deftest values.2 + (let ((string "foo")) + (multiple-value-store (values string string) *test-file*) + (let ((val (multiple-value-list (restore *test-file*)))) + (eq (car val) (cadr val)))) t) Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.4 cl-store/utils.lisp:1.5 --- cl-store/utils.lisp:1.4 Wed Oct 6 16:41:04 2004 +++ cl-store/utils.lisp Wed Oct 13 14:35:58 2004 @@ -43,7 +43,7 @@ (t 0))) (defun get-float-type (num) - (case num + (ecase num (0 1.0) (1 1.0d0))) Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.4 cl-store/xml-backend.lisp:1.5 --- cl-store/xml-backend.lisp:1.4 Wed Oct 6 16:41:04 2004 +++ cl-store/xml-backend.lisp Wed Oct 13 14:35:58 2004 @@ -36,6 +36,7 @@ (add-xml-mapping "ARRAY") (add-xml-mapping "SIMPLE-VECTOR") (add-xml-mapping "PACKAGE") +(add-xml-mapping "VALUES-OBJECT") ;; Used by cmucl and sbcl (add-xml-mapping "DOUBLE-FLOAT") @@ -44,10 +45,12 @@ ;; Used by lispworks (add-xml-mapping "POSITIVE-INFINITY") (add-xml-mapping "NEGATIVE-INFINITY") +(add-xml-mapping "FLOAT-NAN") (defmethod get-next-reader ((place list) (backend xml-backend)) - (gethash (car place) *xml-mapping*)) + (or (gethash (car place) *xml-mapping*) + (values nil (format nil "Unknown tag ~A" (car place))))) ;; required methods and miscellaneous util functions (defun princ-xml (tag value stream) @@ -90,18 +93,19 @@ (let ((*restore-counter* 0) (*need-to-fix* nil) (*restored-values* (make-hash-table))) - (let ((obj (backend-restore-object (xmls:parse place) backend))) + (multiple-value-prog1 + (backend-restore-object (or (xmls:parse place) + (restore-error "Invalid xml")) + backend) (dolist (fn *need-to-fix*) - (funcall (the function fn))) - obj))) - + (funcall (the function fn)))))) ;; referrer, Required for a resolving backend (defmethod store-referrer (ref stream (backend xml-backend)) (princ-xml "REFERRER" ref stream)) (defrestore-xml (referrer place) - (make-referrer (parse-integer (third place)))) + (make-referrer :val (parse-integer (third place)))) ;; integer @@ -448,6 +452,19 @@ (defrestore-xml (package place) (find-package (restore-first place))) + +;; multiple values + +(defstore-xml (obj cl-store::values-object stream) + (with-tag ("VALUES-OBJECT" stream) + (dolist (x (cl-store::vals obj)) + (princ-and-store "VALUE" x stream)))) + + +(defrestore-xml (values-object stream) + (apply #'values (loop for x in (xmls:node-children stream) + collect (restore-first x)))) + (setf *default-backend* *xml-backend*)

1 0

[cl-store-cvs] CVS update: cl-store/sbcl/.cvsignore cl-store/sbcl/custom-xml.lisp cl-store/sbcl/custom.lisp
by Sean Ross 06 Oct '04

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv6638/sbcl Modified Files: custom-xml.lisp custom.lisp Added Files: .cvsignore Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:45 2004 Author: sross Index: cl-store/sbcl/custom-xml.lisp diff -u cl-store/sbcl/custom-xml.lisp:1.1 cl-store/sbcl/custom-xml.lisp:1.2 --- cl-store/sbcl/custom-xml.lisp:1.1 Mon Aug 30 17:10:24 2004 +++ cl-store/sbcl/custom-xml.lisp Wed Oct 6 16:41:45 2004 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. -(in-package :cl-store) +(in-package :cl-store-xml) (defstore-xml (obj structure-object stream) @@ -12,6 +12,27 @@ (defrestore-xml (structure-object place) (restore-xml-type-object place)) + + +(defstore-xml (obj single-float stream) + (with-tag ("SINGLE-FLOAT" stream) + (princ-and-store "BITS" (sb-kernel::single-float-bits obj) + stream))) + +(defrestore-xml (single-float stream) + (sb-kernel::make-single-float + (restore-first (get-child "BITS" stream)))) + +(defstore-xml (obj double-float stream) + (with-tag ("DOUBLE-FLOAT" stream) + (princ-and-store "HIGH-BITS" (sb-kernel::double-float-high-bits obj) + stream) + (princ-and-store "LOW-BITS" (sb-kernel::double-float-low-bits obj) + stream))) + +(defrestore-xml (double-float stream) + (sb-kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream)) + (restore-first (get-child "LOW-BITS" stream)))) ;; EOF Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.1 cl-store/sbcl/custom.lisp:1.2 --- cl-store/sbcl/custom.lisp:1.1 Mon Aug 30 17:10:24 2004 +++ cl-store/sbcl/custom.lisp Wed Oct 6 16:41:45 2004 @@ -4,6 +4,38 @@ (in-package :cl-store) +;; Custom float storing + +(defstore-cl-store (obj float stream) + (output-type-code +float-code+ stream) + (write-byte (float-type obj) stream) + (etypecase obj + (single-float (store-object (sb-kernel:single-float-bits obj) + stream)) + (double-float (store-object (sb-kernel:double-float-high-bits obj) + stream) + (store-object (sb-kernel:double-float-low-bits obj) + stream)))) + +(defun sbcl-restore-single-float (stream) + (sb-kernel:make-single-float (restore-object stream))) + +(defun sbcl-restore-double-float (stream) + (sb-kernel:make-double-float (restore-object stream) + (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))) + (aif (cdr (assoc byte *sbcl-float-restorers*)) + (funcall it stream) + (restore-error "Unknown float type designator ~S." byte)))) + + +;; Custom structure storing (defstore-cl-store (obj structure-object stream) (output-type-code +structure-object-code+ stream) (store-type-object obj stream))

1 0