October 2004 - cl-store-cvs@common-lisp.net

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

13 Oct '04

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

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp cl-store/xml-backend.lisp
by Sean Ross 13 Oct '04

13 Oct '04

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

1 0

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

06 Oct '04

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

1 0

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

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/lispworks In directory common-lisp.net:/tmp/cvs-serv6638/lispworks Modified Files: custom-xml.lisp Added Files: .cvsignore Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:40 2004 Author: sross Index: cl-store/lispworks/custom-xml.lisp diff -u cl-store/lispworks/custom-xml.lisp:1.1 cl-store/lispworks/custom-xml.lisp:1.2 --- cl-store/lispworks/custom-xml.lisp:1.1 Mon Aug 30 17:10:23 2004 +++ cl-store/lispworks/custom-xml.lisp Wed Oct 6 16:41:40 2004 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. -(in-package :cl-store) +(in-package :cl-store-xml) (defstore-xml (obj structure-object stream) (with-tag ("STRUCTURE-OBJECT" stream) @@ -23,4 +23,35 @@ (restore-first (get-child "VALUE" slot)))))))) -;; EOF \ No newline at end of file + +(defstore-xml (obj float stream) + (block body + (handler-bind ((simple-error + #'(lambda (err) + (declare (ignore err)) + (cond + ((positive-infinity-p obj) + (with-tag ("POSITIVE-INFINITY" stream)) + (return-from body)) + ((negative-infinity-p obj) + (with-tag ("NEGATIVE-INFINITY" stream)) + (return-from body)) + (t nil))))) + (multiple-value-bind (signif exp sign) + (integer-decode-float obj) + (with-tag ("FLOAT" stream) + (princ-and-store "SIGNIFICAND" signif stream) + (princ-and-store "EXPONENT" exp stream) + (princ-and-store "SIGN" sign stream) + (princ-and-store "TYPE" (float-type obj) stream)))))) + +(defrestore-xml (positive-infinity stream) + (declare (ignore stream)) + +positive-infinity+) + +(defrestore-xml (negative-infinity stream) + (declare (ignore stream)) + +negative-infinity+) + + +;; EOF

1 0

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

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/doc/html/icons In directory common-lisp.net:/tmp/cvs-serv6638/doc/html/icons Added Files: README exported.png gnome_down.png gnome_home.png gnome_index.png gnome_left.png gnome_no.png gnome_right.png gnome_up.png gnome_yes.png internal.png Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:37 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/doc/html/CL-STORE-XML/contentlist.xml
by Sean Ross 06 Oct '04

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE-XML In directory common-lisp.net:/tmp/cvs-serv6638/doc/html/CL-STORE-XML Added Files: contentlist.xml Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:32 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/doc/html/CL-STORE/BACKEND.xml cl-store/doc/html/CL-STORE/RESOLVING-BACKEND.xml cl-store/doc/html/CL-STORE/contentlist.xml
by Sean Ross 06 Oct '04

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE In directory common-lisp.net:/tmp/cvs-serv6638/doc/html/CL-STORE Added Files: BACKEND.xml RESOLVING-BACKEND.xml contentlist.xml Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:30 2004 Author: sross

1 0

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/doc/html In directory common-lisp.net:/tmp/cvs-serv6638/doc/html Added Files: albert.css book.xml classxcl-storexbackend.html classxcl-storexresolving-backend.html global-index.xml globalindex.html index.html indexreference.html packagexcl-store-xml.html packagexcl-store.html packagexcl-storexcontent.html packagexcl-storexvariables.html packagexcontentxcl-store-xml.html packagexcontentxcl-store.html Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:13 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/doc/index.html cl-store/doc/style.css
by Sean Ross 06 Oct '04

06 Oct '04

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv6638/doc Added Files: index.html style.css Log Message: Changelog 2004-10-06 Date: Wed Oct 6 16:41:12 2004 Author: sross

1 0

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

06 Oct '04

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

1 0