Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv6638 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 Added Files: cl-store-xml.asd xml-package.lisp xml-tests.lisp Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:04 2004 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.9 cl-store/ChangeLog:1.10 --- cl-store/ChangeLog:1.9 Fri Oct 1 10:49:46 2004 +++ cl-store/ChangeLog Wed Oct 6 16:41:02 2004 @@ -1,20 +1,45 @@ -2004-10-01 Sean Ross <sdr@jhb.ucs.co.za> +2004-10-06 Sean Ross <sross@common-lisp.net> + * cl-store-xml.asd, xml-package.lisp, xml-tests.lisp: Moved the xml backend + into it's own package files. + * xml-backend.lisp, sbcl/custom-xml.lisp, cmucl/custom-xml.lisp, lispworks/custom-xml.lisp: + Added support for infinite floats to sbcl, cmucl and lispworks. + * xml-backend.lisp, default-backend.lisp: + Fixed floating point contagion warning signalled by clisp. + * plumbing.lisp: Changed error handing to signal a store-error or restore-error + inside a handler-bind and leave the original error unhandled. + * docs/: Rudimentary Documentation. + +2004-10-05 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: New Magic number. + * backends.lisp: Changed with-backend to take a variable instead of a backend name. + * backends.lisp, plumbing.lisp: Added previous magic number field to backends and + an appropriate error if an incompatible magic number is read. + * circularities.lisp, plumbing.lisp: Removed check-stream-element-type. + * default-backend.lisp: Added a small optimization for 32 byte integers and + support for symbols with unicode strings as names. + +2004-10-04 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp: Custom float storing (supports inifinities). + * cmucl/custom.lisp: Custom float storing (supports inifinities). + * xml-backend.lisp, tests.xml: Deprecated xml-backend. + +2004-10-01 Sean Ross <sross@common-lisp.net> * lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard. * tests.lisp: Infite float tests for lispworks. -2004-09-27 Sean Ross <sdr@jhb.ucs.co.za> +2004-09-27 Sean Ross <sross@common-lisp.net> * plumbing.lisp: Slightly nicer error handling (I think). All conditions caught in store and restore are resignalled and rethrown as a store or restore error respectively. -2004-09-01 Sean Ross <sdr@jhb.ucs.co.za> +2004-09-01 Sean Ross <sross@common-lisp.net> * sbcl/custom.lisp, sbcl/custom-xml.lisp: Custom structure storing. * cmucl/custom.lisp, cmucl/custom-xml.lisp: Custom structure storing. * lispworks/custom.lisp, lispworks/custom-xml.lisp: Custom structure storing for Lispworks from Alain Picard. * test.lisp: Enabled structure tests for Lispworks. -2004-07-29 Sean Ross <sdr@jhb.ucs.co.za> +2004-07-29 Sean Ross <sross@common-lisp.net> * cl-store.asd: New version (0.2) * sbcl/sockets.lisp: Removed. * store.lisp: Removed. @@ -27,13 +52,13 @@ objects in xml format. * tests.lisp : More and more tests. -2004-06-04 Sean Ross <sdr@jhb.ucs.co.za> +2004-06-04 Sean Ross <sross@common-lisp.net> * circularities.lisp: spelling fix. * cl-store.asd: Specialized operation-done-p to stop some errors in asdf. * package.lisp: Imports for openmcl from Robert Sedgewick, Along with extra imports for cmucl. -2004-05-21 Sean Ross <sdr@jhb.ucs.co.za> +2004-05-21 Sean Ross <sross@common-lisp.net> * store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp, tests.lisp, utils.lisp, cl-store.asd: Added ability to specify the type code of an object @@ -41,12 +66,12 @@ accessor methods for CLISP when restoring classes. EQ floats are now restored correctly. -2004-05-18 Sean Ross <sdr@jhb.ucs.co.za> +2004-05-18 Sean Ross <sross@common-lisp.net> * store.lisp, fix-clisp.lisp, sbcl/sockets.lisp: Added fix for sbcl to use non-blocking IO when working with sockets. Created directory structure and moved fix-clisp -2004-05-17 Sean Ross <sdr@jhb.ucs.co.za> +2004-05-17 Sean Ross <sross@common-lisp.net> * store.lisp, fast-io.lisp, circularities.lisp, package.lisp, fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp: Initial import Index: cl-store/README diff -u cl-store/README:1.7 cl-store/README:1.8 --- cl-store/README:1.7 Fri Oct 1 10:49:46 2004 +++ cl-store/README Wed Oct 6 16:41: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.2.5 +Version: 0.2.9 0. About. CL-STORE is an portable serialization package which @@ -23,8 +23,8 @@ This requires xmls which can be found on http://www.cliki.net and is asdf-installable. - Run (asdf:oos 'asdf:test-op :cl-store) to make sure that - everything works. Running these tests will try to + 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. @@ -61,7 +61,7 @@ (defclass random-obj () ((a :accessor a :initarg :a))) - (defvar *random-obj-code* (register-code 22 'random-obj)) + (defvar *random-obj-code* (register-code 110 'random-obj)) (defstore-cl-store (obj random-obj stream) (output-type-code *random-obj-code* stream) @@ -82,20 +82,17 @@ what cl-store used to be (pre 0.2) and an xml backend which writes out xml to character streams. - NOTE: As of 0.2.5 the xml backend isn't actively being developed. - It's turning out to more of a pain than it's worth. It is now - only there as an example. - Store and Restore now take an optional backend argument which - currently can be one of *default-backend* or *xml-backend*. - + 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 (0.2.5). + There are a number of issues with CL-STORE as it stands (0.2.9). - Functions, closures and anything remotely funcallable is unserializable. - MOP classes are largely unsupported at the moment. @@ -105,7 +102,7 @@ - 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.1 cl-store/backends.lisp:1.2 --- cl-store/backends.lisp:1.1 Tue Aug 17 13:12:43 2004 +++ cl-store/backends.lisp Wed Oct 6 16:41:03 2004 @@ -14,12 +14,14 @@ (error "~A is a required argument" name)) (defclass backend () - ((name :accessor name :initform "Unknown" :initarg :name) - (magic-number :accessor magic-number :initarg :magic-number) - (stream-type :accessor stream-type :initarg :stream-type + ((name :accessor name :initform "Unknown" :initarg :name :type symbol) + (magic-number :accessor magic-number :initarg :magic-number :type integer) + (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers + :type integer) + (stream-type :accessor stream-type :initarg :stream-type :type symbol :initform (required-arg "stream-type")) (restorer-funs :accessor restorer-funs :initform (make-hash-table) - :initarg :restorer-funs)) + :initarg :restorer-funs :type hash-table)) (:documentation "Core class which custom backends must extend")) (defparameter *registered-backends* nil @@ -46,7 +48,7 @@ ,@body)))) (defun get-restore-macro (name) - "Return the defrestore-? macros which will be used by a custom backend" + "Return the defrestore-? macro which will be used by a custom backend" (let ((macro-name (symbolicate 'defrestore- name))) `(defmacro ,macro-name ((type place) &body body) (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type))))) @@ -64,12 +66,13 @@ (char 'character) (binary 'integer))) -(defun register-backend (name class magic-number stream-type) +(defun register-backend (name class magic-number stream-type old-magic-numbers) (declare (type symbol name)) (assert (member stream-type '(char binary))) (let ((instance (make-instance class :name name :magic-number magic-number + :old-magic-numbers old-magic-numbers :stream-type (real-stream-type stream-type)))) (if (assoc name *registered-backends*) (cerror "Redefine backend" "Backend is already defined ~A" name) @@ -84,11 +87,12 @@ (defun get-class-form (name fields extends) `(defclass ,name (,extends) ,fields - (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)." + (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)." name)))) (defmacro defbackend (name &key (stream-type (required-arg "stream-type")) - (magic-number nil) fields (extends 'backend)) + (magic-number nil) fields (extends 'backend) + (old-magic-numbers nil)) "Defines a new backend called NAME. Stream type must be either 'char or 'binary. FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will be written down stream as verification and checked on restoration. @@ -99,16 +103,18 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (prog2 ,(get-class-form class-name fields extends) - (register-backend ',name ',class-name ,magic-number ,stream-type ) + (register-backend ',name ',class-name ,magic-number + ,stream-type ',old-magic-numbers) ,(get-store-macro name class-name) ,(get-restore-macro name))))) -(defmacro with-backend ((backend-name) &body body) - "Run BODY with *default-backend* bound to the backend BACKEND-NAME" - `(let ((*default-backend* (or (find-backend ',backend-name) - (error "Can't find backend ~A" - ',backend-name)))) +(defmacro with-backend (backend &body body) + "Run BODY with *default-backend* bound to BACKEND" + `(let ((*default-backend* (or (and (typep ,backend 'backend) + ,backend) + (error "~A is not a legal backend" + ,backend)))) ,@body)) ;; EOF Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.7 cl-store/circularities.lisp:1.8 --- cl-store/circularities.lisp:1.7 Mon Sep 27 13:24:18 2004 +++ cl-store/circularities.lisp Wed Oct 6 16:41:03 2004 @@ -120,7 +120,6 @@ "Store OBJ into PLACE. Does the setup for counters and seen values." (let ((*stored-counter* 0) (*stored-values* (make-hash-table :test #'eq))) - (check-stream-element-type place backend) (store-backend-code place backend) (backend-store-object obj place backend) obj)) @@ -183,9 +182,8 @@ (let ((*restore-counter* 0) (*need-to-fix* nil) (*restored-values* (make-hash-table))) - (check-stream-element-type place backend) - (check-magic-number place backend) - (prog1 + (prog2 + (check-magic-number place backend) (backend-restore-object place backend) (dolist (fn *need-to-fix*) (funcall (the function fn)))))) @@ -198,13 +196,16 @@ (new-val (funcall (the function reader) place))) (funcall (the function reader) place)))) -(defun int-sym-or-char-p (fn backend) - "Is function FN registered to restore an integer, character or symbol + +(defgeneric int-sym-or-char-p (fn backend) + (:argument-precedence-order backend fn) + (:method ((fn t) (backend t)) + "Is function FN registered to restore an integer, character or symbol in BACKEND." - (let ((readers (restorer-funs backend))) - (or (eq fn (lookup-reader 'integer readers)) - (eq fn (lookup-reader 'character readers)) - (eq fn (lookup-reader 'symbol readers))))) + (let ((readers (restorer-funs backend))) + (or (eq fn (lookup-reader 'integer readers)) + (eq fn (lookup-reader 'character readers)) + (eq fn (lookup-reader 'symbol readers)))))) (defun new-val (val) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.9 cl-store/cl-store.asd:1.10 --- cl-store/cl-store.asd:1.9 Fri Oct 1 10:49:46 2004 +++ cl-store/cl-store.asd Wed Oct 6 16:41:03 2004 @@ -3,7 +3,8 @@ (in-package #:cl-user) (defpackage #:cl-store.system - (:use #:cl #:asdf)) + (:use #:cl #:asdf) + (:export #:non-required-file)) (in-package #:cl-store.system) @@ -34,12 +35,11 @@ (when (probe-file (component-pathname c)) (call-next-method))) - (defsystem cl-store :name "CL-STORE" :author "Sean Ross <sdr@jhb.ucs.co.za>" :maintainer "Sean Ross <sdr@jhb.ucs.co.za>" - :version "0.2.5" + :version "0.2.9" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" @@ -52,34 +52,20 @@ (:file "default-backend" :depends-on ("circularities")) (:non-required-file "custom" :depends-on ("default-backend")))) -(defsystem cl-store-xml - :name "CL-STORE-XML" - :author "Sean Ross <sdr@jhb.ucs.co.za>" - :maintainer "Sean Ross <sdr@jhb.ucs.co.za>" - :description "Xml Backend for cl-store" - :licence "MIT" - :components ((:file "xml-backend") - (:non-required-file "custom-xml" :depends-on ("xml-backend"))) - :depends-on (:cl-store :xmls)) - - (defmethod perform :after ((o load-op) (c (eql (find-system :cl-store)))) (provide 'cl-store)) -(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store-xml)))) - (provide 'cl-store-xml)) - - (defmethod perform ((op test-op) (sys (eql (find-system :cl-store)))) (oos 'load-op :cl-store-tests) (oos 'test-op :cl-store-tests)) (defsystem cl-store-tests - :depends-on (rt cl-store cl-store-xml) + :depends-on (rt cl-store) :components ((:file "tests"))) (defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests)))) - (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")) + (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS") + (symbol-value (find-symbol "*CL-STORE-BACKEND*" "CL-STORE"))) (error "Test-op Failed."))) Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.7 cl-store/default-backend.lisp:1.8 --- cl-store/default-backend.lisp:1.7 Fri Oct 1 10:49:46 2004 +++ cl-store/default-backend.lisp Wed Oct 6 16:41:03 2004 @@ -3,13 +3,7 @@ ;; The cl-store backend. -;; functions -;; closures (once done add initform, and default-initargs) -;; funcallable instances (methods and generic functions) -;; add variable *store-methods-with-classes* -;; some sort of optimization for bignums -;; cater for unicode characters in symbol names -;; Other MOP classes. +;; DOCUMENTATION (in-package :cl-store) @@ -17,17 +11,17 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cl-store-backend* - (defbackend cl-store :magic-number 1886611788 :stream-type 'binary + (defbackend cl-store :magic-number 1347635532 + :stream-type 'binary + :old-magic-numbers (1912923 1886611788) :extends resolving-backend - :fields ((restorers :accessor restorers :initform - nil)))) + :fields ((restorers :accessor restorers :initform nil)))) (defun register-code (code name) (push (cons code name) (restorers *cl-store-backend*)) code)) ;; Type code constants (defconstant +referrer-code+ (register-code 1 'referrer)) -(defconstant +non-return-code+ (register-code 2 'non-return)) (defconstant +integer-code+ (register-code 4 'integer)) (defconstant +simple-string-code+ (register-code 5 'simple-string)) (defconstant +float-code+ (register-code 6 'float)) @@ -50,7 +44,10 @@ ;; Used by lispworks (defconstant +positive-infinity-code+ (register-code 22 'positive-infinity)) (defconstant +negative-infinity-code+ (register-code 23 'negative-infinity)) - + +;; new storing for 32 byte ints +(defconstant +32-byte-integer-code+ (register-code 24 '32-byte-integer)) + ;; setups for type code mapping (defun output-type-code (code stream) @@ -61,7 +58,6 @@ (read-byte stream)) - ;; 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. @@ -79,19 +75,33 @@ (make-referrer (read-32-byte stream nil))) +;; integers +;; The theory is that most numbers will fit in 32 bytes +;; so we try and cater for them -;; non return only used with standard-classes -(defun store-non-return (obj stream) - (output-type-code +non-return-code+ stream) - (store-object obj stream)) - -(defrestore-cl-store (non-return stream) - (restore-object stream) - (restore-object stream)) - +;; We need this for circularity stuff. +(defmethod int-sym-or-char-p ((fn t) (backend cl-store-backend)) + (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 'symbol readers))))) -;; integers (defstore-cl-store (obj integer stream) + (if (typep obj '(signed-byte 32)) + (store-32-byte-integer obj stream) + (store-arbitrary-integer obj stream))) + +(defun store-32-byte-integer (obj stream) + (output-type-code +32-byte-integer-code+ stream) + (write-byte (if (minusp obj) 1 0) stream) + (store-32-byte (abs obj) stream)) + +(defrestore-cl-store (32-byte-integer stream) + (funcall (if (zerop (read-byte stream)) #'+ #'-) + (read-32-byte stream nil))) + +(defun store-arbitrary-integer (obj stream) (output-type-code +integer-code+ stream) (loop for n = (abs obj) then (ash n -32) for counter from 0 @@ -149,10 +159,11 @@ (restore-simple-standard-string stream)) ;; Floats -;; Is integer-decode-float the Right Thing, or should we -;; be using something like sb-kernel:single-float-bits -;; and sb-kernel:make-single-float -#-lispworks +;; SBCL and CMUCL use a different mechanism for dealing +;; with floats which supports infinities. +;; Lispworks uses a slightly different version as well +;; manually handling negative and positive infinity +#-(or lispworks cmu sbcl) (defstore-cl-store (obj float stream) (output-type-code +float-code+ stream) (multiple-value-bind (significand exponent sign) @@ -162,10 +173,11 @@ (store-object exponent stream) (store-object sign stream))) +#-(or cmu sbcl) (defrestore-cl-store (float stream) (float (* (get-float-type (read-byte stream)) (* (restore-object stream) - (* 1.0d0 (expt 2 (restore-object stream)))) + (expt 2 (restore-object stream))) (restore-object stream)))) ;; ratio @@ -198,17 +210,16 @@ ;; symbols (defstore-cl-store (obj symbol stream) (output-type-code +symbol-code+ stream) - (output-simple-standard-string (package-name (or (symbol-package obj) - *package*)) - stream) - (output-simple-standard-string (symbol-name obj) - stream)) + (store-object (symbol-name obj) stream) + (store-object (package-name (or (symbol-package obj) + *package*)) + stream)) (defrestore-cl-store (symbol stream) - (let ((package (restore-simple-standard-string stream)) - (name (restore-simple-standard-string stream))) - (values (intern name package)))) + (values (intern (restore-object stream) + (restore-object stream)))) + ;; lists (defstore-cl-store (obj cons stream) (output-type-code +cons-code+ stream) @@ -317,23 +328,28 @@ (restore-type-object stream)) - - ;; classes (defstore-cl-store (obj standard-class stream) (output-type-code +standard-class-code+ stream) - (when *store-class-superclasses* - (loop for x in (class-direct-superclasses obj) do - (when (and x (not (eql x #.(find-class 'standard-object)))) - (store-non-return x stream)))) - (store-object (get-class-details obj) stream)) + (store-object (class-name obj) stream) + (store-object (mapcar #'get-slot-details (class-direct-slots obj)) + stream) + (store-object (mapcar (if *store-class-superclasses* + #'identity + #'class-name) + (remove (find-class 'standard-object) + (class-direct-superclasses obj))) + stream) + (store-object (type-of obj) stream)) (defrestore-cl-store (standard-class stream) - (let* ((vals (restore-object stream)) + (let* ((class (restore-object stream)) + (slots (restore-object stream)) + (supers (restore-object stream)) + (meta (restore-object stream)) (keywords '(:direct-slots :direct-superclasses :metaclass)) - (final (mappend #'list keywords (cdr vals))) - (class (car vals))) + (final (mappend #'list keywords (list slots supers meta)))) (cond ((find-class class nil) (cond (*nuke-existing-classes* (apply #'ensure-class class final) Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.10 cl-store/package.lisp:1.11 --- cl-store/package.lisp:1.10 Mon Sep 27 13:24:18 2004 +++ cl-store/package.lisp Wed Oct 6 16:41:03 2004 @@ -3,45 +3,29 @@ (defpackage #:cl-store (:use #:cl) - (:export #:backend - #:magic-number - #:stream-type - #:restorer-funs - #:restorers - #:find-backend - #:defbackend - #:with-backend - #:fix-circularities - #:*default-backend* - #:*cl-store-backend* - #:*current-backend* - #:*store-class-slots* - #:*nuke-existing-classes* - #:*store-class-superclasses* - #:cl-store-error - #:store-error - #:restore-error - #:store - #:restore - #:backend-store - #:check-stream-element-type - #:store-backend-code - #:store-object - #:backend-store-object - #:get-class-details - #:get-array-values - #:restore - #:backend-restore - #:check-magic-number - #:get-next-reader - #:restore-object - #:backend-restore-object - #:cl-store - #:defstore-cl-store - #:defrestore-cl-store - #:register-code - #:output-type-code - #:xml) + (:export #:backend #:magic-number #:stream-type #:restorer-funs + #:restorers #:resolving-backend #:find-backend #:defbackend + #:*restore-counter* #:*need-to-fix* #:*restored-values* + #:with-backend #:fix-circularities #:*default-backend* + #:*cl-store-backend* #:*current-backend* #:*store-class-slots* + #:*nuke-existing-classes* #:*store-class-superclasses* + #:cl-store-error #:store-error #:restore-error #:store + #:restore #:backend-store #:store-backend-code #:store-object + #:backend-store-object #:get-class-details #:get-array-values + #:check-stream-element-type #:restore #:backend-restore + #:check-magic-number #:get-next-reader #:int-sym-or-char-p + #:restore-object #:backend-restore-object #:cl-store + #:defstore-cl-store #:defrestore-cl-store #:register-code + #:output-type-code #:store-referrer #:resolving-object + #:internal-store-object #:setting #:simple-standard-string + #:float-type #:get-float-type #:compute-slots + #:slot-definition-allocation #:slot-definition-name + #:slot-definition-type #:slot-definition-initargs + #: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) #+sbcl (:import-from #:sb-mop #:slot-definition-name #:slot-value-using-class Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.2 cl-store/plumbing.lisp:1.3 --- cl-store/plumbing.lisp:1.2 Mon Sep 27 13:24:18 2004 +++ cl-store/plumbing.lisp Wed Oct 6 16:41:03 2004 @@ -22,9 +22,8 @@ ;; conditions ;; From 0.2.3 all conditions which are signalled from -;; store or restore will be rethrown as store-error and -;; restore-error respectively. The original condition -;; is still signalled. +;; store or restore will signal a store-error or a +;; restore-error respectively inside a handler-bind. (define-condition cl-store-error (condition) ((caused-by :accessor caused-by :initarg :caused-by :initform nil) @@ -70,18 +69,16 @@ (:method ((obj t) (place t) &optional (backend *default-backend*)) "Store OBJ into Stream PLACE using backend BACKEND." (let ((*current-backend* backend)) - (handler-case (backend-store obj place backend) - (condition (c) - (signal c) - (error (make-condition 'store-error - :caused-by c))))))) + (handler-bind ((error (lambda (c) + (signal (make-condition 'store-error + :caused-by c))))) + (backend-store obj place backend))))) (defgeneric backend-store (obj place backend) (:argument-precedence-order backend place obj) (:method ((obj t) (place stream) (backend t)) "The default. Checks the streams element-type, stores the backend code and calls store-object." - (check-stream-element-type place backend) (store-backend-code place backend) (store-object obj place backend) obj) @@ -94,16 +91,6 @@ (:documentation "Method wrapped by store, override this method for custom behaviour (see circularities.lisp).")) - - -(defun check-stream-element-type (stream backend) - "Ensure that the stream-element-type of STREAM is compatible with BACKEND." - (let ((stream-type (stream-element-type stream)) - (backend-type (stream-type backend))) - (unless (subtypep stream-type backend-type) - (store-error "Streams element type is ~A, backend expecting ~A." - stream-type backend-type)))) - (defun store-backend-code (stream backend) "Store magic-number of BACKEND, when present, into STREAM." (let ((code (magic-number backend))) @@ -143,10 +130,15 @@ (:method (place &optional (backend *default-backend*)) "Entry point for restoring objects (setfable)." (let ((*current-backend* backend)) - (handler-case (backend-restore place backend) - (condition (c) (signal c) - (error (make-condition 'restore-error - :caused-by c))))))) + (handler-bind ((error (lambda (c) + (signal (make-condition 'restore-error + :caused-by c))))) + (backend-restore place backend))))) + +(declaim (inline check-stream-element-type)) +(defun check-stream-element-type (stream) + (declare (ignore stream)) + nil) (defgeneric backend-restore (place backend) (:argument-precedence-order backend place) @@ -155,7 +147,6 @@ "Restore the object found in stream PLACE using backend BACKEND. Checks stream-element-type and magic-number and invokes backend-restore-object" - (check-stream-element-type place backend) (check-magic-number place backend) (backend-restore-object place backend)) (:method ((place string) (backend t)) @@ -184,9 +175,13 @@ (let ((val (ecase (stream-type backend) (integer (read-32-byte stream)) (character (retrieve-string-code stream))))) - (unless (equal val magic-number) - (restore-error "Stream does not contain a stored object for backend ~A." - (name backend))))))) + (cond ((eql val magic-number) nil) + ((member val (old-magic-numbers backend)) + (restore-error "Stream contains an object stored with a ~ +incompatible version of backend ~A." (name backend))) + (t (restore-error "Stream does not contain a stored object~ + for backend ~A." + (name backend)))))))) (defun lookup-reader (val readers) (gethash val readers)) @@ -232,4 +227,4 @@ place))) -;; EOF \ No newline at end of file +;; EOF Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.6 cl-store/tests.lisp:1.7 --- cl-store/tests.lisp:1.6 Fri Oct 1 10:49:46 2004 +++ cl-store/tests.lisp Wed Oct 6 16:41:04 2004 @@ -6,7 +6,6 @@ (in-package :cl-store-tests) - (rem-all-tests) (defvar *test-file* "filetest.cls") @@ -14,6 +13,8 @@ (store val *test-file*) (let ((restored (restore *test-file*))) (or (and (numberp val) (= val restored)) + (and (stringp val) (string= val restored)) + (and (characterp val) (char= val restored)) (eq val restored) (eql val restored) (equal val restored) @@ -30,6 +31,7 @@ (deftestit integer.4 -2322993) (deftestit integer.5 most-positive-fixnum) (deftestit integer.6 most-negative-fixnum) + ;; ratios (deftestit ratio.1 1/2) (deftestit ratio.2 234232/23434) @@ -62,10 +64,14 @@ (deftestit double-float.6 most-negative-double-float) ;; infinite floats -#+lispworks -(deftestit infinite-float.1 cl-store::+negative-infinity+) -#+lispworks -(deftestit infinite-float.2 cl-store::+positive-infinity+) +#+(or sbcl cmu lispworks) +(progn + #+sbcl (sb-int:set-floating-point-modes :traps nil) + #+cmu (ext:set-floating-point-modes :traps nil) + (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))) ;; characters @@ -442,23 +448,15 @@ (defrestore-cl-store (random-obj buff) (random (restore-object buff))) - -(add-xml-mapping "RANDOM-OBJ") -(defstore-xml (obj random-obj stream) - (princ-and-store "RANDOM-OBJ" (size obj) stream)) - -(defrestore-xml (random-obj stream) - (random (restore-first stream))) - + (deftest custom.1 (progn (store (make-instance 'random-obj :size 5) *test-file* ) (typep (restore *test-file*) '(integer 0 4))) t) -(defun run-tests () - (format t "~&RUNNING TESTS USING CL-STORE-BACKEND~%") - (with-backend (cl-store) +(defun run-tests (backend) + (with-backend backend (regression-test:do-tests)) (when (probe-file *test-file*) (delete-file *test-file*))) Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.3 cl-store/utils.lisp:1.4 --- cl-store/utils.lisp:1.3 Tue Aug 17 13:12:43 2004 +++ cl-store/utils.lisp Wed Oct 6 16:41:04 2004 @@ -6,7 +6,6 @@ (declaim (optimize (speed 3) (safety 0) (debug 0))) - (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) @@ -30,18 +29,6 @@ :readers (slot-definition-readers slot-definition) :type (slot-definition-type slot-definition) :writers (slot-definition-writers slot-definition))) - -(defun get-class-details (x) - "Return a list of class details which can be - used as arguments to ensure-class" - (list (class-name x) - ;; can't use this value either (see get-slot-details) - ;;(class-direct-default-initargs x) - (mapcar #'get-slot-details (class-direct-slots x)) - (mapcar #'class-name - (class-direct-superclasses x)) - (type-of x))) - (defmacro awhen (test &body body) `(aif ,test Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.3 cl-store/xml-backend.lisp:1.4 --- cl-store/xml-backend.lisp:1.3 Mon Aug 30 17:10:20 2004 +++ cl-store/xml-backend.lisp Wed Oct 6 16:41:04 2004 @@ -1,14 +1,10 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. -(in-package :cl-store) +(in-package :cl-store-xml) (declaim (optimize (speed 3) (safety 0) (debug 0))) -(export '(*xml-backend* xml-backend defstore-xml defrestore-xml princ-and-store - princ-xml restore-first with-tag first-child second-child get-child - add-xml-mapping)) - (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *xml-backend* (defbackend xml :stream-type 'char :extends resolving-backend))) @@ -41,6 +37,15 @@ (add-xml-mapping "SIMPLE-VECTOR") (add-xml-mapping "PACKAGE") +;; Used by cmucl and sbcl +(add-xml-mapping "DOUBLE-FLOAT") +(add-xml-mapping "SINGLE-FLOAT") + +;; Used by lispworks +(add-xml-mapping "POSITIVE-INFINITY") +(add-xml-mapping "NEGATIVE-INFINITY") + + (defmethod get-next-reader ((place list) (backend xml-backend)) (gethash (car place) *xml-mapping*)) @@ -85,7 +90,6 @@ (let ((*restore-counter* 0) (*need-to-fix* nil) (*restored-values* (make-hash-table))) - (check-stream-element-type place backend) (let ((obj (backend-restore-object (xmls:parse place) backend))) (dolist (fn *need-to-fix*) (funcall (the function fn))) @@ -100,8 +104,6 @@ (make-referrer (parse-integer (third place)))) - - ;; integer (defstore-xml (obj integer stream) (princ-xml "INTEGER" obj stream)) @@ -124,6 +126,7 @@ ;; float +#-(or lispworks sbcl cmu) (defstore-xml (obj float stream) (with-tag ("FLOAT" stream) (multiple-value-bind (signif exp sign) @@ -133,9 +136,10 @@ (princ-and-store "SIGN" sign stream) (princ-and-store "TYPE" (float-type obj) stream)))) +#-(or sbcl cmu) (defrestore-xml (float place) (float (* (* (restore-first (get-child "SIGNIFICAND" place)) - (* 1.0d0 (expt 2 (restore-first (get-child "EXPONENT" place))))) + (expt 2 (restore-first (get-child "EXPONENT" place)))) (restore-first (get-child "SIGN" place))) (get-float-type (restore-first (get-child "TYPE" place))))) @@ -445,4 +449,6 @@ (defrestore-xml (package place) (find-package (restore-first place))) + +(setf *default-backend* *xml-backend*) ;; EOF