[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
Sean Ross
sross at common-lisp.net
Wed Oct 13 12:36:03 UTC 2004
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 at 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 at 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 at common-lisp.net>
+ * default-backend: Added multiple-value-store.
+ * xml-backend: Added support for multiple return values.
+
+2004-10-07 Sean Ross <sross at common-lisp.net>
+ * circularities.lisp: Added support for multiple return values from
+ functions defined with defrestore-?.
+
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.
@@ -25,7 +45,7 @@
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.
+ * tests.lisp: Infinite float tests for lispworks.
2004-09-27 Sean Ross <sross at 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 @@
, at 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 at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at 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*)
More information about the Cl-store-cvs
mailing list