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@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@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@common-lisp.net> + * default-backend: Added multiple-value-store. + * xml-backend: Added support for multiple return values. + +2004-10-07 Sean Ross <sross@common-lisp.net> + * circularities.lisp: Added support for multiple return values from + functions defined with defrestore-?. + 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. @@ -25,7 +45,7 @@ 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. + * tests.lisp: Infinite float tests for lispworks. 2004-09-27 Sean Ross <sross@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@jhb.ucs.co.za>" :maintainer "Sean Ross <sdr@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*)