[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 cl-store/xml-package.lisp
Sean Ross
sross at common-lisp.net
Thu Sep 1 10:25:03 UTC 2005
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 at 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 at 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 at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at 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)
, at 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
More information about the Cl-store-cvs
mailing list