Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv9950

Modified Files: ChangeLog README circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp utils.lisp xml-backend.lisp xml-package.lisp Log Message: Changelog 2005-09-01 Date: Thu Sep 1 12:24:56 2005 Author: sross

Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.33 cl-store/ChangeLog:1.34 --- cl-store/ChangeLog:1.33 Wed May 18 17:34:09 2005 +++ cl-store/ChangeLog Thu Sep 1 12:24:55 2005 @@ -1,3 +1,13 @@ +2005-09-01 Sean Ross sross@common-lisp.net + Version 0.6 Release. + * cl-store.asd, package.lisp: Added support for the new release + of CLISP with a MOP. + * default-backend.lisp: Fixed storing of long lists. + (Reported by and help by Alain Picard) + * default-backend.lisp: New magic number, due to the + change in approach of storing lists, although previous + files can still be restored. + 2005-05-18 Sean Ross sross@common-lisp.net * utils.lisp: Removed awhen * backends.lisp: Added a compatible-magic-numbers slot.

Index: cl-store/README diff -u cl-store/README:1.16 cl-store/README:1.17 --- cl-store/README:1.16 Thu May 5 15:02:29 2005 +++ cl-store/README Thu Sep 1 12:24:55 2005 @@ -1,7 +1,7 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.5.9 +Version: 0.6

0. About. CL-STORE is an portable serialization package which

Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.22 cl-store/circularities.lisp:1.23 --- cl-store/circularities.lisp:1.22 Fri May 6 16:19:29 2005 +++ cl-store/circularities.lisp Thu Sep 1 12:24:55 2005 @@ -58,13 +58,19 @@ `(macrolet ((setting (place getting) `(let ((,',value ,getting)) (if (referrer-p ,',value) - (push (delay (setf ,place (referred-value ,',value *restored-values*))) - *need-to-fix*) + (if *check-for-circs* + (push (delay (setf ,place + (referred-value ,',value + *restored-values*))) + *need-to-fix*) + (restore-error "Found a circular values with *check-for-circs* = nil")) (setf ,place ,',value)))) (setting-hash (getting-key getting-place) `(let ((,',key ,getting-key)) (if (referrer-p ,',key) (let ((,',value ,getting-place)) + (unless *check-for-circs* + (restore-error "Found a circular values with *check-for-circs* = nil")) (push (delay (setf (gethash (referred-value ,',key *restored-values*) ,',var) (if (referrer-p ,',value) @@ -161,7 +167,8 @@ (let ((*restore-counter* 0) (*need-to-fix* nil) (*restored-values* (and *check-for-circs* - (make-hash-table :test #'eq :size *restore-hash-size*)))) + (make-hash-table :test #'eq + :size *restore-hash-size*)))) (check-magic-number backend place) (multiple-value-prog1 (backend-restore-object backend place) @@ -179,7 +186,9 @@ (update-restored spot vals) vals))

-(defgeneric referrerp (backend reader)) +(defgeneric referrerp (backend reader) + (:method ((backend t) (reader t)) + (error "referrerp must be specialized for backend ~A." (name backend))))

(defun handle-restore (place backend) (declare (optimize speed (safety 1) (debug 0))) @@ -192,7 +201,7 @@ (handle-normal backend reader place)) (t (new-val (internal-restore-object backend reader place))))))

-(defmethod backend-restore-object ((backend resolving-backend) (place stream)) +(defmethod backend-restore-object ((backend resolving-backend) (place t)) "Retrieve a object from PLACE, does housekeeping for circularity fixing." (declare (optimize speed (safety 1) (debug 0))) (if *check-for-circs*

Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.30 cl-store/cl-store.asd:1.31 --- cl-store/cl-store.asd:1.30 Wed May 18 17:34:09 2005 +++ cl-store/cl-store.asd Thu Sep 1 12:24:55 2005 @@ -40,11 +40,12 @@ :name "CL-STORE" :author "Sean Ross sdr@jhb.ucs.co.za" :maintainer "Sean Ross sdr@jhb.ucs.co.za" - :version "0.5.15" + :version "0.6" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" :components ((:file "package") + #+(and clisp (not mop)) (:non-required-file "mop" :depends-on ("package")) (:file "utils" :depends-on ("package")) (:file "backends" :depends-on ("utils"))

Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.29 cl-store/default-backend.lisp:1.30 --- cl-store/default-backend.lisp:1.29 Wed May 18 17:34:09 2005 +++ cl-store/default-backend.lisp Thu Sep 1 12:24:55 2005 @@ -4,9 +4,9 @@ ;; The cl-store backend. (in-package :cl-store)

-(defbackend cl-store :magic-number 1414745155 +(defbackend cl-store :magic-number 1953713219 :stream-type '(unsigned-byte 8) - :compatible-magic-numbers (1349740876) + :compatible-magic-numbers (1349740876 1414745155) :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1884506444 1347643724 1349732684) :extends (resolving-backend) @@ -64,6 +64,10 @@ (defvar +float-double-nan-code+ (register-code 33 'float-double-nan nil)) (defvar +unicode-base-string-code+ (register-code 34 'unicode-base-string nil)) (defvar +simple-base-string-code+ (register-code 35 'simple-base-string nil)) +(defvar +proper-list-code+ (register-code 36 'proper-list)) +(defvar +circular-list-code+ (register-code 37 'circular-list)) +(defvar +dotted-list-code+ (register-code 38 'dotted-list)) +

;; setups for type code mapping @@ -274,19 +278,91 @@ (make-symbol (restore-object stream)))

-;; lists -(defstore-cl-store (obj cons stream) - (declare (optimize speed)) - (output-type-code +cons-code+ stream) - (store-object (car obj) stream) - (store-object (cdr obj) stream)) +;; Lists +(defun dump-proper-list (list length stream) + (output-type-code +proper-list-code+ stream) + (store-object length stream) + (dolist (x list) + (store-object x stream))) + + + + +(defun restore-proper-list (stream) + (let ((fixes ())) + (let ((ret (loop for count below (restore-object stream) + for elt = (restore-object stream) + if (and *check-for-circs* (referrer-p elt)) + do (push (cons count elt) fixes) + collect elt))) + ;; This requires a bit of fiddling + (when *check-for-circs* + (dolist (referrer fixes) + (let ((ref (cdr referrer)) + (pos (car referrer))) + (push (delay (setf (nth pos ret) + (referred-value ref *restored-values*))) + *need-to-fix*)))) + ret))) + +(defun dump-dotted-list (list stream) + (output-type-code +dotted-list-code+ stream) + (store-object (count-conses list) stream) + (labels ((rec (list) + (cond ((atom (cdr list)) ;; last cons cell + (store-object (car list) stream) + (store-object (cdr list) stream)) + (t (store-object (car list) stream) + (rec (cdr list)))))) + (rec list))) + +(defun restore-dotted-list (stream) + (let* ((ret ()) + (tail ret) + (conses (restore-object stream))) + (dotimes (x conses) + (let ((obj (restore-object stream))) + (when (and *check-for-circs* (referrer-p obj)) + (let ((x x)) + (push (delay (setf (nth x ret) + (referred-value obj *restored-values*))) + *need-to-fix*))) + (if ret + (setf (cdr tail) (list obj) + tail (cdr tail)) + (setf ret (list obj) + tail (last ret))))) + (setf (cdr tail) (restore-object stream)) + ret)) + +(defun dump-circular-list (list stream) + (output-type-code +circular-list-code+ stream) + (store-object (car list) stream) + (store-object (cdr list) stream)) + +(defstore-cl-store (list cons stream) + (multiple-value-bind (length errorp) + (proper-list-length list) + (cond (errorp (dump-dotted-list list stream)) + (length (dump-proper-list list length stream)) + (t (dump-circular-list list stream))))) + +(defrestore-cl-store (proper-list stream) + (restore-proper-list stream)) + +(defrestore-cl-store (dotted-list stream) + (restore-dotted-list stream)) + +(defrestore-cl-store (circular-list stream) + (resolving-object (ret (cons nil nil)) + (setting (car ret) (restore-object stream)) + (setting (cdr ret) (restore-object stream))))

-;; this is an examples of a restorer which handles -;; circularities using resolving-object and setting. +;; kept for backwards compatibility (defrestore-cl-store (cons stream) - (resolving-object (x (cons nil nil)) - (setting (car x) (restore-object stream)) - (setting (cdr x) (restore-object stream)))) + (resolving-object (ret (cons nil nil)) + (setting (car ret) (restore-object stream)) + (setting (cdr ret) (restore-object stream))))

;; pathnames @@ -417,10 +493,10 @@ (cond ((find-class class nil) (cond (*nuke-existing-classes* (apply #'ensure-class class final) - #+clisp (add-methods-for-class class slots)) + #+(and clisp (not mop)) (add-methods-for-class class slots)) (t (find-class class)))) (t (apply #'ensure-class class final) - #+clisp (add-methods-for-class class slots))))) + #+(and clisp (not mop)) (add-methods-for-class class slots)))))

;; built in classes

@@ -517,7 +593,8 @@ (declare (optimize speed (safety 0) (debug 0)) (type simple-string string)) #+cmu nil ;; cmucl doesn't support unicode yet. - #-(or cmu) (some #'(lambda (x) (char> x *char-marker*)) string)) + #+lispworks (not (typep string 'lw:8-bit-string)) + #-(or cmu lispworks) (some #'(lambda (x) (char> x *char-marker*)) string))

(defun store-simple-string (obj stream) (declare (type simple-string obj) @@ -641,28 +718,31 @@ nil *sbcl-readtable*)

-(defstore-cl-store (obj function stream) - (output-type-code +function-code+ stream) +(defun get-function-name (obj) (multiple-value-bind (l cp name) (function-lambda-expression obj) (declare (ignore l cp)) - (cond ((and name (or (symbolp name) (consp name))) - (store-object name stream)) + (cond ((and name (or (symbolp name) (consp name))) name) ;; Try to deal with sbcl's naming convention ;; of built in functions (pre 0.9) #+sbcl ((and name (stringp name) - (search "top level local call " - (the simple-string name))) + (search "top level local call " (the simple-string name))) (let ((new-name (parse-name name)) (*readtable* *sbcl-readtable*)) (unless (string= new-name "") - (handler-case (store-object (read-from-string new-name) stream) - (error (c) - (declare (ignore c)) - (store-error "Unable to determine function name for ~A." - obj)))))) + (handler-case (read-from-string new-name) + (error (c) (declare (ignore c)) + (store-error "Unable to determine function name for ~A." + obj)))))) (t (store-error "Unable to determine function name for ~A." obj))))) + + +(defstore-cl-store (obj function stream) + (output-type-code +function-code+ stream) + (store-object (get-function-name obj) stream)) + +

(defrestore-cl-store (function stream) (fdefinition (restore-object stream)))

Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.21 cl-store/package.lisp:1.22 --- cl-store/package.lisp:1.21 Thu Mar 24 09:25:17 2005 +++ cl-store/package.lisp Thu Sep 1 12:24:55 2005 @@ -94,7 +94,7 @@ #:class-slots #:ensure-class)

- #+clisp (:import-from #:clos + #+(and clisp (not mop)) (:import-from #:clos #:slot-value #:std-compute-slots #:slot-boundp @@ -104,23 +104,41 @@ #:class-slots #:ensure-class)

- #+lispworks (:import-from #:clos - #:slot-definition-name - #:generic-function-name - #:slot-definition-allocation - #:compute-slots - #:slot-definition - #:slot-definition-initform - #:slot-definition-initargs - #:slot-definition-name - #:slot-definition-readers - #:slot-definition-type - #:slot-definition-writers - #:class-direct-default-initargs - #:class-direct-slots - #:class-slots - #:class-direct-superclasses - #:ensure-class) + #+lispworks (:import-from #:clos + #:slot-definition-name + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:class-direct-superclasses + #:ensure-class) + + #+(and clisp mop) (:import-from #:clos + #:slot-definition-name + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:class-direct-superclasses + #:ensure-class)

#+allegro (:import-from #:mop #:slot-definition-name @@ -140,4 +158,4 @@ #:class-slots #:ensure-class) ) -;; EOF \ No newline at end of file +;; EOF

Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.16 cl-store/plumbing.lisp:1.17 --- cl-store/plumbing.lisp:1.16 Wed May 18 17:34:09 2005 +++ cl-store/plumbing.lisp Thu Sep 1 12:24:55 2005 @@ -68,17 +68,18 @@ (backend-store backend s obj))))

(defgeneric store (obj place &optional designator) - (:documentation "Entry Point for storing objects.") + (:documentation "Store OBJ into Stream PLACE using backend BACKEND.") (:method ((obj t) (place t) &optional (designator *default-backend*)) - "Store OBJ into Stream PLACE using backend BACKEND." - (declare (optimize speed)) - (let* ((backend (backend-designator->backend designator)) - (*current-backend* backend) - (*read-eval* nil)) - (handler-bind ((error (lambda (c) - (signal (make-condition 'store-error - :caused-by c))))) - (backend-store backend place obj))))) + "Store OBJ into Stream PLACE using backend BACKEND." + (declare (optimize speed)) + (let* ((backend (backend-designator->backend designator)) + (*current-backend* backend) + (*read-eval* nil)) + (handler-bind ((error (lambda (c) + (signal (make-condition 'store-error + :caused-by c))))) + (backend-store backend place obj))))) +

(defgeneric backend-store (backend place obj) (:method ((backend backend) (place stream) (obj t))

Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.22 cl-store/tests.lisp:1.23 --- cl-store/tests.lisp:1.22 Wed May 18 17:34:09 2005 +++ cl-store/tests.lisp Thu Sep 1 12:24:55 2005 @@ -183,7 +183,13 @@

(deftestit cons.4 '(1 . 2)) (deftestit cons.5 '(t . nil)) - +(deftestit cons.6 '(1 2 3 . 5)) +(deftest cons.7 (let ((list (cons nil nil))) ; '#1=(#1#))) + (setf (car list) list) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (eq ret (car ret)))) + t)

;; hash tables @@ -254,7 +260,7 @@ (deftest standard-object.2 (let ((val (store (make-instance 'bar :x (list 1 "foo" 1.0) - :y #(1 2 3 4)) + :y (vector 1 2 3 4)) *test-file*))) (let ((ret (restore *test-file*))) (and (equalp (get-x val) (get-x ret)) @@ -454,11 +460,11 @@ (deftest circ.8 (progn (store circ.8 *test-file*) (let ((x (restore *test-file*))) (eql (pathname-name x) - (pathname-type x)))) + (pathname-type x)))) t)

-(deftest circ.9 (let ((val #("foo" "bar" "baz" 1 2))) +(deftest circ.9 (let ((val (vector "foo" "bar" "baz" 1 2))) (setf (aref val 3) val) (setf (aref val 4) (aref val 0)) (store val *test-file*) @@ -487,7 +493,7 @@ (eql val (gethash val val)))) t)

-(deftest circ.12 (let ((x #(1 2 "foo" 4 5))) +(deftest circ.12 (let ((x (vector 1 2 "foo" 4 5))) (setf (aref x 0) x) (setf (aref x 1) (aref x 2)) (store x *test-file*) @@ -513,7 +519,40 @@ t)

+(deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#))) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (and (eq ret (cddddr ret)) + (eq (fourth ret) ret)))) + t) + + + + +(deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#))) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (and (eq ret (cddddr ret)) + (eq (fourth ret) + (car (fourth ret)))))) + t) + + + +;; this had me confused for a while since what was +;; restored #1=(1 (#1#) #1#) looks nothing like this list, +;; but it turns out that it is correct +(deftest circ.16 (let ((list '#1=(1 #2=(#1#) . #2#))) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (and (eq ret (caadr ret)) + (eq ret (third ret))))) + t) + + +

+;; custom storing (defclass random-obj () ((size :accessor size :initarg :size)))

(defvar *random-obj-code* (register-code 100 'random-obj))

Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.17 cl-store/utils.lisp:1.18 --- cl-store/utils.lisp:1.17 Wed May 18 17:34:09 2005 +++ cl-store/utils.lisp Thu Sep 1 12:24:55 2005 @@ -148,4 +148,18 @@ (values (intern (apply #'mkstr syms))))

+(defun count-conses (list) + "Somewhat like length but will work on dotted lists. +Circular lists will cause this to hang." + (declare (optimize speed) + (type list list)) + (loop for x on list + if (not (listp (cdr x))) + do (return (1+ ret)) + else sum 1 into ret + finally (return ret))) + +(defun proper-list-length (list) + (ignore-errors (list-length list))) + ;; EOF

Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.10 cl-store/xml-backend.lisp:1.11 --- cl-store/xml-backend.lisp:1.10 Tue Feb 1 09:27:26 2005 +++ cl-store/xml-backend.lisp Thu Sep 1 12:24:55 2005 @@ -3,85 +3,62 @@

;; THIS BACKEND IS DEPRECATED AND WILL NOT WORK ;; ITS PRESENCE IS FOR POSTERITY ONLY - (in-package :cl-store-xml)

-(declaim (optimize (speed 3) (safety 1) (debug 0))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *xml-backend* - (defbackend xml :stream-type 'char :extends resolving-backend)))

+(defbackend xml :stream-type 'character :extends (resolving-backend))

;; The xml backend does not use any type codes ;; we figure it out when we read the tag of each object (defvar *xml-mapping* (make-hash-table :test #'equal)) (defun add-xml-mapping (name) (setf (gethash name *xml-mapping*) - (intern name))) + (intern name :cl-store-xml)))

(add-xml-mapping "REFERRER") (add-xml-mapping "INTEGER") -(add-xml-mapping "SIMPLE-STRING") (add-xml-mapping "FLOAT") +(add-xml-mapping "SIMPLE-STRING") +(add-xml-mapping "SYMBOL") +(add-xml-mapping "CONS") (add-xml-mapping "RATIO") (add-xml-mapping "CHARACTER") (add-xml-mapping "COMPLEX") -(add-xml-mapping "SYMBOL") -(add-xml-mapping "CONS") (add-xml-mapping "PATHNAME") -(add-xml-mapping "HASH-TABLE") -(add-xml-mapping "STANDARD-OBJECT") -(add-xml-mapping "CONDITION") -(add-xml-mapping "STRUCTURE-OBJECT") -(add-xml-mapping "STANDARD-CLASS") -(add-xml-mapping "BUILT-IN-CLASS") -(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") -(add-xml-mapping "SINGLE-FLOAT") - -;; Used by lispworks -(add-xml-mapping "POSITIVE-INFINITY") -(add-xml-mapping "NEGATIVE-INFINITY") -(add-xml-mapping "FLOAT-NAN") - +(add-xml-mapping "FUNCTION") +(add-xml-mapping "GENERIC-FUNCTION")

-(defmethod get-next-reader ((place list) (backend xml-backend)) +(defmethod get-next-reader ((backend xml) (place list)) (or (gethash (car place) *xml-mapping*) - (values nil (format nil "Unknown tag ~A" (car place))))) + (error "Unknown tag ~A" (car place))))

-;; required methods and miscellaneous util functions (defun princ-xml (tag value stream) - (format stream "<~A>~A</~A>" tag value tag)) + (format stream "<~A>" tag) + (xmls:write-xml value stream) + (format stream "</~A>" tag))

(defun princ-and-store (tag obj stream) (format stream "<~A>" tag) (store-object obj stream) (format stream "</~A>" tag))

- (defmacro with-tag ((tag stream) &body body) `(progn (format ,stream "<~A>" ,tag) ,@body (format ,stream "</~A>" ,tag))) - + (defun first-child (elmt) (first (xmls:node-children elmt)))

(defun second-child (elmt) (second (xmls:node-children elmt)))

-(defun get-child (name elmt) +(defun get-child (name elmt &optional (errorp t)) (or (assoc name (xmls:node-children elmt) :test #'equal) - (error 'restore-error - :datum "No child called ~A in xml ~a" - :args (list name elmt)))) + (and errorp + (restore-error "No child called ~A in xml ~a" + (list name elmt)))))

(defun get-attr (name elmt) (cadr (assoc name (xmls:node-attrs elmt) :test #'equal))) @@ -89,84 +66,90 @@ (declaim (inline restore-first)) (defun restore-first (place) (restore-object (first-child place))) - + +(defmethod store-referrer ((backend xml) (ref t) (stream t)) + (princ-xml "REFERRER" ref stream)) + +(defrestore-xml (referrer place) + (make-referrer :val (parse-integer (third place)))) + +(defmethod referrerp ((backend xml) (reader t)) + (eql reader 'referrer))

;; override backend restore to parse the incoming stream -(defmethod backend-restore ((backend xml-backend) (place stream)) +(defmethod backend-restore ((backend xml) (place stream)) (let ((*restore-counter* 0) (*need-to-fix* nil) (*print-circle* nil) - (*restored-values* (make-hash-table))) + (*restored-values* (and *check-for-circs* + (make-hash-table :test #'eq :size *restore-hash-size*)))) (multiple-value-prog1 - (backend-restore-object (or (xmls:parse place) - (restore-error "Invalid xml")) - backend) + (backend-restore-object backend + (or (xmls:parse place) + (restore-error "Invalid xml"))) (dolist (fn *need-to-fix*) - (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 :val (parse-integer (third place)))) - + (force fn)))))

;; integer (defstore-xml (obj integer stream) (princ-xml "INTEGER" obj stream))

-(defrestore-xml (integer place) - (parse-integer (third place))) +(defrestore-xml (integer from) + (values (parse-integer (first-child from))))

-;; simple-string -(defun xml-dump-simple-string (string place) - (with-tag ("SIMPLE-STRING" place) - (format place "~S" string))) +;; floats +(defvar *special-floats* nil) ;; setup in custom-xml files

-(defstore-xml (obj simple-string stream) - (xml-dump-simple-string obj stream)) +;; FIXME: add support for *special-floats* +(defstore-xml (obj float stream) + (with-tag ("FLOAT" stream) (print obj stream)))

-(defrestore-xml (simple-string place) - (remove #" (third place))) +(defrestore-xml (float from) + (cl-l10n:parse-number (first-child from)))

+#| +(defstore-xml (obj single-float stream) + (store-float "SINGLE-FLOAT" obj stream)) + +(defstore-xml (obj double-float stream) + (store-float "DOUBLE-FLOAT" obj stream)) + +(defun store-float (type obj stream) + (block body + (let (significand exponent sign) + (handler-bind ((simple-error + #'(lambda (err) + (declare (ignore err)) + (when-let (type (cdr (assoc obj *special-floats*))) + (output-float-type type stream) + (return-from body))))) + (multiple-value-setq (significand exponent sign) + (integer-decode-float obj)) + (with-tag (type stream) + (princ-and-store "SIGNIFICAND" significand stream) + (princ-and-store "RADIX"(float-radix obj) stream) + (princ-and-store "EXPONENT" exponent stream) + (princ-and-store "SIGN" sign stream)))))) +|#

-;; float -#-(or lispworks sbcl cmu) -(defstore-xml (obj float stream) - (with-tag ("FLOAT" stream) - (multiple-value-bind (signif exp sign) - (integer-decode-float obj) - (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)))) - -#-(or sbcl cmu) -(defrestore-xml (float place) - (float (* (* (restore-first (get-child "SIGNIFICAND" place)) - (expt 2 (restore-first (get-child "EXPONENT" place)))) - (restore-first (get-child "SIGN" place))) - (get-float-type (restore-first (get-child "TYPE" place))))) +; FIXME: restore flaot

;; ratio (defstore-xml (obj ratio stream) (with-tag ("RATIO" stream) - (princ-and-store "NUMERATOR" (numerator obj) stream) + (princ-and-store "NUMERATOR" (numerator obj) stream) (princ-and-store "DENOMINATOR" (denominator obj) stream)))

-(defrestore-xml (ratio place) - (/ (restore-first (get-child "NUMERATOR" place)) - (restore-first (get-child "DENOMINATOR" place)))) +(defrestore-xml (ratio from) + (/ (restore-first (get-child "NUMERATOR" from)) + (restore-first (get-child "DENOMINATOR" from))))

- -;; character +;; char (defstore-xml (obj character stream) - (princ-xml "CHARACTER" (char-code obj) stream)) - -(defrestore-xml (character place) - (code-char (parse-integer (first-child place)))) + (princ-and-store "CHARACTER" (char-code obj) stream))

+(defrestore-xml (character from) + (code-char (restore-first from)))

;; complex @@ -175,43 +158,47 @@ (princ-and-store "REALPART" (realpart obj) stream) (princ-and-store "IMAGPART" (imagpart obj) stream)))

-(defrestore-xml (complex place) - (complex (restore-first (get-child "REALPART" place)) - (restore-first (get-child "IMAGPART" place))))

-;; symbol +(defrestore-xml (complex from) + (complex (restore-first (get-child "REALPART" from)) + (restore-first (get-child "IMAGPART" from)))) + + +;; symbols (defstore-xml (obj symbol stream) (with-tag ("SYMBOL" stream) - (princ-xml "NAME" (symbol-name obj) stream) - (princ-and-store "PACKAGE" (symbol-package obj) stream))) - -(store 'foo "/home/sdr/test.out") -(restore "/home/sdr/test.out") -(defrestore-xml (symbol place) - (intern (restore-first (get-child "NAME" place)) - (or (restore-first (get-child "PACKAGE" place)) - *package*))) + (princ-and-store "NAME" (symbol-name obj) stream) + (cl-store::when-let (package (symbol-package obj)) + (princ-and-store "PACKAGE" (package-name package) stream)))) + +(defrestore-xml (symbol from) + (let ((name (restore-first (get-child "NAME" from))) + (package (when (get-child "PACKAGE" from nil) + (restore-first (get-child "PACKAGE" from))))) + (if package + (values (intern name package)) + (make-symbol name))))

-;; cons +;; lists (defstore-xml (obj cons stream) (with-tag ("CONS" stream) - (with-tag ("CAR" stream) - (store-object (car obj) stream)) - (with-tag ("CDR" stream) - (store-object (cdr obj) stream)))) + (princ-and-store "CAR" (car obj) stream) + (princ-and-store "CDR" (cdr obj) stream)))

+(defrestore-xml (cons from) + (resolving-object (x (cons nil nil)) + (setting (car x) (restore-first (get-child "CAR" from))) + (setting (cdr x) (restore-first (get-child "CDR" from)))))

-(defrestore-xml (cons place) - (let ((ret (cons nil nil)) - (car (get-child "CAR" place)) - (cdr (get-child "CDR" place))) - (resolving-object ret - (setting car (restore-first car)) - (setting cdr (restore-first cdr))))) +;; simple string +(defstore-xml (obj simple-string stream) + (princ-xml "SIMPLE-STRING" obj stream))

+(defrestore-xml (simple-string from) + (first-child from))

-;; pathname +;; pathnames (defstore-xml (obj pathname stream) (with-tag ("PATHNAME" stream) (princ-and-store "DEVICE" (pathname-device obj) stream) @@ -229,55 +216,35 @@ :version (restore-first (get-child "VERSION" place))))

-;; hash-table +; hash table (defstore-xml (obj hash-table stream) (with-tag ("HASH-TABLE" stream) (princ-and-store "REHASH-SIZE" (hash-table-rehash-size obj) stream) - (princ-and-store "REHASH-THRESHOLD" (hash-table-rehash-threshold obj) - stream) + (princ-and-store "REHASH-THRESHOLD" (hash-table-rehash-threshold obj) stream) (princ-and-store "SIZE" (hash-table-size obj) stream) - (princ-and-store "TEST"(hash-table-test obj) stream) + (princ-and-store "TEST" (hash-table-test obj) stream) (with-tag ("ENTRIES" stream) (loop for key being the hash-keys of obj - for value being the hash-values of obj do + using (hash-value value) do (with-tag ("ENTRY" stream) (princ-and-store "KEY" key stream) (princ-and-store "VALUE" value stream))))))

-(defrestore-xml (hash-table place) - (let ((hash1 (make-hash-table - :rehash-size (restore-first (get-child "REHASH-SIZE" place)) - :rehash-threshold (restore-first - (get-child "REHASH-THRESHOLD" place)) - :size (restore-first (get-child "SIZE" place)) - :test (symbol-function (restore-first (get-child "TEST" place)))))) - (resolving-object hash1 - (dolist (entry (xmls:node-children (get-child "ENTRIES" place))) - (let* ((key-place (first-child (first-child entry))) - (val-place (first-child (second-child entry)))) - (setting-hash (restore-object key-place) - (restore-object val-place))))) - hash1)) - - +;; FIXME: restore hash tables

+;; objects and conditions

-;; objects, conditions and structures (defun xml-dump-type-object (obj stream) - (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* - all-slots - (remove-if #'(lambda (x) (eql (slot-definition-allocation x) - :class)) - all-slots)))) + (let* ((all-slots (serializable-slots obj))) (with-tag ("SLOTS" stream) - (dolist (slot slots) - (with-tag ("SLOT" stream) - (let ((slot-name (slot-definition-name slot))) - (princ-and-store "NAME" slot-name stream) - (princ-and-store "VALUE" (slot-value obj slot-name) stream))))))) + (dolist (slot all-slots) + (when (slot-boundp obj (slot-definition-name slot)) + (when (or *store-class-slots* + (eql (slot-definition-allocation slot) :instance)) + (with-tag ("SLOT" stream) + (let ((slot-name (slot-definition-name slot))) + (princ-and-store "NAME" slot-name stream) + (princ-and-store "VALUE" (slot-value obj slot-name) stream)))))))))

(defstore-xml (obj standard-object stream) (with-tag ("STANDARD-OBJECT" stream) @@ -289,6 +256,71 @@ (princ-and-store "CLASS" (type-of obj) stream) (xml-dump-type-object obj stream)))

+ +;; FIXME: restore objects + + + +;; classes + +;; FIXME : Write me + +;; built in classes +(defstore-xml (obj built-in-class stream) + (princ-and-store "BUILT-IN-CLASS" (class-name obj) stream)) + +#-ecl ;; for some reason this doesn't work with ecl +(defmethod internal-store-object ((backend xml) (obj (eql (find-class 'hash-table))) stream) + (princ-and-store "BUILT-IN-CLASS" 'cl:hash-table stream)) + +;; FIXME: restore built in classes + +;; arrays and vectors +;; FIXME : Write me + +;; packages +;; FIXME : Write me + +;; functions +(defstore-xml (obj function stream) + (princ-and-store "FUNCTION" (get-function-name obj) stream)) + +(defrestore-xml (function from) + (fdefinition (restore-first from))) + +;; generic functions +(defstore-xml (obj generic-function stream) + (if (generic-function-name obj) + (princ-and-store "GENERIC-FUNCTION" + (generic-function-name obj) stream) + (store-error "No generic function name for ~A." obj))) + +(defrestore-xml (generic-function from) + (fdefinition (restore-first from))) + +(setf *default-backend* (find-backend 'xml)) + +#| + +;; required methods and miscellaneous util functions + + +(defrestore-xml (hash-table place) + (let ((hash1 (make-hash-table + :rehash-size (restore-first (get-child "REHASH-SIZE" place)) + :rehash-threshold (restore-first + (get-child "REHASH-THRESHOLD" place)) + :size (restore-first (get-child "SIZE" place)) + :test (symbol-function (restore-first (get-child "TEST" place)))))) + (resolving-object (hash1 hash1) + (dolist (entry (xmls:node-children (get-child "ENTRIES" place))) + (let* ((key-place (first-child (first-child entry))) + (val-place (first-child (second-child entry)))) + (setting-hash (restore-object key-place) + (restore-object val-place))))) + hash1)) + + (defun restore-xml-type-object (place) (let* ((class (find-class (restore-first (get-child "CLASS" place)))) (new-instance (allocate-instance class))) @@ -450,27 +482,5 @@ (restore-first element)))))))

- -;; packages -(defstore-xml (obj package stream) - (princ-and-store "PACKAGE" (package-name obj) stream)) - -(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*) +|# ;; EOF

Index: cl-store/xml-package.lisp diff -u cl-store/xml-package.lisp:1.1 cl-store/xml-package.lisp:1.2 --- cl-store/xml-package.lisp:1.1 Wed Oct 6 16:41:04 2004 +++ cl-store/xml-package.lisp Thu Sep 1 12:24:55 2005 @@ -2,14 +2,129 @@ ;; See the file LICENCE for licence information.

(defpackage #:cl-store-xml - (:use #:cl #:cl-store #:xmls) + (:use #:cl #:cl-store) (:export #:*xml-backend* #:add-xml-mapping #:defstore-xml #:defrestore-xml #:princ-and-store #:princ-xml #:restore-first #:with-tag #:first-child #:second-child #:get-child) - (:import-from #:cl-store - #:aif - #:it)) + (:import-from #:cl-store #:when-let #:generic-function-name #:get-function-name + #:force #:setting #:resolving-object) + + #+sbcl (:import-from #:sb-mop + #:generic-function-name + #:slot-definition-name + #:slot-definition-allocation + #:slot-definition + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+ecl (:import-from #:clos + #:generic-function-name + #:compute-slots + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+cmu (:import-from #:pcl + #:generic-function-name + #:slot-definition-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+cmu (:shadowing-import-from #:pcl + #:class-name + #:find-class + #:standard-class + #:class-of) + + #+openmcl (:import-from #:openmcl-mop + #:generic-function-name + #:slot-definition-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+clisp (:import-from #:clos + #:slot-value + #:std-compute-slots + #:slot-boundp + #:class-name + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:ensure-class) + + #+lispworks (:import-from #:clos + #:slot-definition-name + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:class-direct-superclasses + #:ensure-class) + + #+allegro (:import-from #:mop + #:slot-definition-name + #:generic-function-name + #:slot-definition-allocation + #:slot-definition + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + )

;; EOF