[cl-store-cvs] CVS update: cl-store/cl-store-xml.asd cl-store/xml-package.lisp cl-store/xml-tests.lisp 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
Sean Ross
sross at common-lisp.net
Wed Oct 6 14:41:07 UTC 2004
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 at jhb.ucs.co.za>
+2004-10-06 Sean Ross <sross at 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 at 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 at 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 at 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 at jhb.ucs.co.za>
+2004-09-27 Sean Ross <sross at 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 at jhb.ucs.co.za>
+2004-09-01 Sean Ross <sross at 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 at jhb.ucs.co.za>
+2004-07-29 Sean Ross <sross at 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 at jhb.ucs.co.za>
+2004-06-04 Sean Ross <sross at 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 at jhb.ucs.co.za>
+2004-05-21 Sean Ross <sross at 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 at jhb.ucs.co.za>
+2004-05-18 Sean Ross <sross at 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 at jhb.ucs.co.za>
+2004-05-17 Sean Ross <sross at 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 @@
, at 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))))
, at 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 at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at 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 at jhb.ucs.co.za>"
- :maintainer "Sean Ross <sdr at 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
More information about the Cl-store-cvs
mailing list