- cl-store-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/backends.lisp
by sross＠common-lisp.net 06 Oct '05

06 Oct '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv13921 Modified Files: ChangeLog backends.lisp Log Message: Changelog 2004-10-06 Date: Thu Oct 6 09:49:57 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.36 cl-store/ChangeLog:1.37 --- cl-store/ChangeLog:1.36 Tue Oct 4 10:10:26 2005 +++ cl-store/ChangeLog Thu Oct 6 09:49:45 2005 @@ -1,3 +1,8 @@ +2005-10-06 Sean Ross <sross(a)common-lisp.net> + * backends.lisp: Fixed type definition for + compatible-magic-numbers from integer to list. + Reported by Bryan O'Connor. + 2005-10-04 Sean Ross <sross(a)common-lisp.net> * sbcl/custom.lisp: sb-kernel:instance is no longer a class (since 0.9.5.3 or so). Fixed Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.11 cl-store/backends.lisp:1.12 --- cl-store/backends.lisp:1.11 Wed May 18 17:34:09 2005 +++ cl-store/backends.lisp Thu Oct 6 09:49:46 2005 @@ -15,9 +15,9 @@ ((name :accessor name :initform "Unknown" :initarg :name :type symbol) (magic-number :accessor magic-number :initarg :magic-number :type integer) (compatible-magic-numbers :accessor compatible-magic-numbers - :initarg :compatible-magic-numbers :type integer) + :initarg :compatible-magic-numbers :type list) (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers - :type cons) + :type list) (stream-type :accessor stream-type :initarg :stream-type :type (or symbol cons) :initform (required-arg :stream-type))) (:documentation "Core class which custom backends must extend"))

1 0

[cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp
by sross＠common-lisp.net 04 Oct '05

04 Oct '05

Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv8226/sbcl Modified Files: custom.lisp Log Message: Changelog 2005-10-04 Date: Tue Oct 4 10:14:02 2005 Author: sross Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.9 cl-store/sbcl/custom.lisp:1.10 --- cl-store/sbcl/custom.lisp:1.9 Tue Oct 4 10:10:29 2005 +++ cl-store/sbcl/custom.lisp Tue Oct 4 10:14:02 2005 @@ -54,7 +54,7 @@ (defvar *sbcl-struct-inherits* `(,(get-layout (find-class t)) ,@(when-let (class (find-class 'sb-kernel:instance nil)) - (list (get-layout (find-class 'sb-kernel:instance)))) + (list (get-layout class))) ,(get-layout (find-class 'cl:structure-object)))) (defstruct (struct-def (:conc-name sdef-))

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/plumbing.lisp
by sross＠common-lisp.net 04 Oct '05

04 Oct '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv8165 Modified Files: ChangeLog circularities.lisp cl-store.asd default-backend.lisp plumbing.lisp Log Message: Changelog 2005-10-04 Date: Tue Oct 4 10:10:26 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.35 cl-store/ChangeLog:1.36 --- cl-store/ChangeLog:1.35 Fri Sep 9 16:59:17 2005 +++ cl-store/ChangeLog Tue Oct 4 10:10:26 2005 @@ -1,3 +1,13 @@ +2005-10-04 Sean Ross <sross(a)common-lisp.net> + * sbcl/custom.lisp: sb-kernel:instance is no + longer a class (since 0.9.5.3 or so). Fixed + definition of *sbcl-struct-inherits* to work + with or without this class. Reported by Rafał Strzaliński. + +2005-09-20 Sean Ross <sross(a)common-lisp.net> + * default-backend.lisp: Changed storing and restoring + of standard-object to not create unnecessary garbage. + 2005-09-09 Sean Ross <sross(a)common-lisp.net> * default-backend.lisp: Altered list serialization to store all types of lists (proper, dotted and circular) in N time, Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.23 cl-store/circularities.lisp:1.24 --- cl-store/circularities.lisp:1.23 Thu Sep 1 12:24:55 2005 +++ cl-store/circularities.lisp Tue Oct 4 10:10:26 2005 @@ -170,7 +170,7 @@ (make-hash-table :test #'eq :size *restore-hash-size*)))) (check-magic-number backend place) - (multiple-value-prog1 + (prog1 (backend-restore-object backend place) (dolist (fn *need-to-fix*) (force fn))))) @@ -192,7 +192,7 @@ (defun handle-restore (place backend) (declare (optimize speed (safety 1) (debug 0))) - (multiple-value-bind (reader) (get-next-reader backend place) + (let ((reader (get-next-reader backend place))) (declare (type symbol reader)) (cond ((referrerp backend reader) (incf *restore-counter*) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.32 cl-store/cl-store.asd:1.33 --- cl-store/cl-store.asd:1.32 Fri Sep 9 16:59:17 2005 +++ cl-store/cl-store.asd Tue Oct 4 10:10:26 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.6.1" + :version "0.6.3" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.31 cl-store/default-backend.lisp:1.32 --- cl-store/default-backend.lisp:1.31 Fri Sep 9 16:59:17 2005 +++ cl-store/default-backend.lisp Tue Oct 4 10:10:26 2005 @@ -21,7 +21,6 @@ code) - ;; Type code constants (defvar +referrer-code+ (register-code 1 'referrer nil)) (defvar +unicode-string-code+ (register-code 3 'unicode-string nil)) @@ -78,6 +77,7 @@ (read-byte stream)) (defmethod referrerp ((backend cl-store) (reader t)) + (declare (optimize speed (safety 0) (space 0) (debug 0))) (eql reader 'referrer)) (defvar *restorers* (restorers (find-backend 'cl-store))) @@ -86,10 +86,11 @@ ;; backend to lookup the function that was defined by ;; defrestore-cl-store to restore it, or nil if not found. (defun lookup-code (code) + (declare (optimize speed (safety 0) (space 0) (debug 0))) (gethash code *restorers*)) (defmethod get-next-reader ((backend cl-store) (stream stream)) - (declare (optimize speed)) + (declare (optimize speed (safety 0) (space 0) (debug 0))) (let ((type-code (read-type-code stream))) (or (lookup-code type-code) (error "Type code ~A is not registered." type-code)))) @@ -104,13 +105,19 @@ (make-referrer :val (undump-int stream))) + ;; integers ;; The theory is that most numbers will fit in 32 bits ;; so we we have a little optimization for it ;; We need this for circularity stuff. (defmethod int-or-char-p ((backend cl-store) (type symbol)) - (find type '(integer character 32-bit-integer))) + (declare (optimize speed (safety 0) (space 0) (debug 0))) + (or (eql type '32-bit-integer) + (eql type 'integer) + (eql type 'character))) + +; (find type '(integer character 32-bit-integer))) (defstore-cl-store (obj integer stream) (declare (optimize speed (safety 1) (debug 0))) @@ -238,6 +245,7 @@ (/ (the integer (restore-object stream)) (the integer (restore-object stream)))) + ;; chars (defstore-cl-store (obj character stream) (output-type-code +character-code+ stream) @@ -377,25 +385,34 @@ (restore-object stream)))) hash))) +;; The dumping of objects works by serializing the type of the object which +;; is followed by applicable slot-name and value (depending on whether the +;; slot is bound, it's allocation and *store-class-slots*). Once each slot +;; is serialized a counter is incremented which is stored at the end. +;; When restoring the object a new instance is allocated and then +;; restore-type-object starts reading objects from the stream. +;; If the restored object is a symbol the it names a slot and it's value +;; is pulled out and set on the newly allocated object. +;; If the restored object is an integer then this is the end marker +;; for the object and the number of slots restored is checked against +;; this counter. + ;; Object and Conditions (defun store-type-object (obj stream) (declare (optimize speed)) - (let* ((all-slots (remove-if-not (lambda (x) - (slot-boundp obj (slot-definition-name x))) - (serializable-slots obj))) - (slots (if *store-class-slots* - all-slots - (delete-if #'(lambda (x) (eql (slot-definition-allocation x) - :class)) - all-slots)))) - (declare (type list slots)) + (let ((all-slots (serializable-slots obj)) + (length 0)) (store-object (type-of obj) stream) - (store-object (length slots) stream) - (dolist (slot slots) + (dolist (slot all-slots) (let ((slot-name (slot-definition-name slot))) - (store-object slot-name stream) - (store-object (slot-value obj slot-name) stream))))) - + (when (and (slot-boundp obj slot-name) + (or *store-class-slots* + (not (eql (slot-definition-allocation slot) + :class)))) + (store-object (slot-definition-name slot) stream) + (store-object (slot-value obj slot-name) stream) + (incf length)))) + (store-object length stream))) (defstore-cl-store (obj standard-object stream) (output-type-code +standard-object-code+ stream) @@ -408,15 +425,18 @@ (defun restore-type-object (stream) (declare (optimize speed)) (let* ((class (find-class (restore-object stream))) - (length (restore-object stream)) (new-instance (allocate-instance class))) - (declare (type integer length)) - (loop repeat length do - (let ((slot-name (restore-object stream))) - ;; slot-names are always symbols so we don't - ;; have to worry about circularities - (resolving-object (obj new-instance) - (setting (slot-value obj slot-name) (restore-object stream))))) + (resolving-object (obj new-instance) + (loop for count from 0 do + (let ((slot-name (restore-object stream))) + (etypecase slot-name + (integer (assert (= count slot-name) (count slot-name) + "Number of slots restored does not match slots stored.") + (return)) + (symbol + ;; slot-names are always symbols so we don't + ;; have to worry about circularities + (setting (slot-value obj slot-name) (restore-object stream))))))) new-instance)) (defrestore-cl-store (standard-object stream) Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.17 cl-store/plumbing.lisp:1.18 --- cl-store/plumbing.lisp:1.17 Thu Sep 1 12:24:55 2005 +++ cl-store/plumbing.lisp Tue Oct 4 10:10:26 2005 @@ -62,7 +62,7 @@ (defun store-to-file (obj place backend) (declare (type backend backend) (optimize speed)) - (let* ((element-type (stream-type backend))) + (let ((element-type (stream-type backend))) (with-open-file (s place :element-type element-type :direction :output :if-exists :supersede) (backend-store backend s obj)))) @@ -163,7 +163,7 @@ (defun restore-from-file (place backend) (declare (optimize speed)) - (let* ((element-type (stream-type backend))) + (let ((element-type (stream-type backend))) (with-open-file (s place :element-type element-type :direction :input) (backend-restore backend s))))

1 0

[cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp
by sross＠common-lisp.net 04 Oct '05

04 Oct '05

Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv8165/sbcl Modified Files: custom.lisp Log Message: Changelog 2005-10-04 Date: Tue Oct 4 10:10:29 2005 Author: sross Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.8 cl-store/sbcl/custom.lisp:1.9 --- cl-store/sbcl/custom.lisp:1.8 Thu May 5 14:58:57 2005 +++ cl-store/sbcl/custom.lisp Tue Oct 4 10:10:29 2005 @@ -52,9 +52,10 @@ (slot-value dd 'sb-kernel::name)) (defvar *sbcl-struct-inherits* - (list (get-layout (find-class t)) - (get-layout (find-class 'sb-kernel:instance)) - (get-layout (find-class 'cl:structure-object)))) + `(,(get-layout (find-class t)) + ,@(when-let (class (find-class 'sb-kernel:instance nil)) + (list (get-layout (find-class 'sb-kernel:instance)))) + ,(get-layout (find-class 'cl:structure-object)))) (defstruct (struct-def (:conc-name sdef-)) (supers (required-arg :supers) :type list)

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/tests.lisp cl-store/utils.lisp
by sross＠common-lisp.net 09 Sep '05

09 Sep '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv3376 Modified Files: ChangeLog cl-store.asd default-backend.lisp tests.lisp utils.lisp Log Message: Changelog 2005-09-09 Date: Fri Sep 9 16:59:17 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.34 cl-store/ChangeLog:1.35 --- cl-store/ChangeLog:1.34 Thu Sep 1 12:24:55 2005 +++ cl-store/ChangeLog Fri Sep 9 16:59:17 2005 @@ -1,3 +1,8 @@ +2005-09-09 Sean Ross <sross(a)common-lisp.net> + * default-backend.lisp: Altered list serialization to store + all types of lists (proper, dotted and circular) in N time, + thanks to Alain Picard for parts of the code. + 2005-09-01 Sean Ross <sross(a)common-lisp.net> Version 0.6 Release. * cl-store.asd, package.lisp: Added support for the new release Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.31 cl-store/cl-store.asd:1.32 --- cl-store/cl-store.asd:1.31 Thu Sep 1 12:24:55 2005 +++ cl-store/cl-store.asd Fri Sep 9 16:59:17 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.6" + :version "0.6.1" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.30 cl-store/default-backend.lisp:1.31 --- cl-store/default-backend.lisp:1.30 Thu Sep 1 12:24:55 2005 +++ cl-store/default-backend.lisp Fri Sep 9 16:59:17 2005 @@ -4,15 +4,15 @@ ;; The cl-store backend. (in-package :cl-store) -(defbackend cl-store :magic-number 1953713219 +(defbackend cl-store :magic-number 1416850499 :stream-type '(unsigned-byte 8) - :compatible-magic-numbers (1349740876 1414745155) - :old-magic-numbers (1912923 1886611788 1347635532 1886611820 - 1884506444 1347643724 1349732684) + :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155 + 1349740876 1884506444 1347643724 1349732684 1953713219) :extends (resolving-backend) :fields ((restorers :accessor restorers :initform (make-hash-table :size 100)))) + (defun register-code (code name &optional (errorp t)) (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp) (error "Code ~A is already defined for ~A." code name) @@ -20,6 +20,8 @@ name)) code) + + ;; Type code constants (defvar +referrer-code+ (register-code 1 'referrer nil)) (defvar +unicode-string-code+ (register-code 3 'unicode-string nil)) @@ -64,10 +66,6 @@ (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 @@ -279,49 +277,26 @@ ;; Lists -(defun dump-proper-list (list length stream) - (output-type-code +proper-list-code+ stream) +(defun dump-list (list length last stream) + (declare (optimize speed (safety 1) (debug 0)) + (type cons list)) + (output-type-code +cons-code+ stream) (store-object length stream) - (dolist (x list) - (store-object x stream))) - - + (loop repeat length + for x on list do + (store-object (car x) stream)) + (store-object last 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))) +(defun restore-list (stream) + (declare (optimize speed (safety 1) (debug 0))) + (let* ((conses (restore-object stream)) + (ret ()) + (tail ret)) (dotimes (x conses) (let ((obj (restore-object stream))) + ;; we can't use setting here since we wan't to + ;; be fairly efficient when adding objects to the + ;; end of the list. (when (and *check-for-circs* (referrer-p obj)) (let ((x x)) (push (delay (setf (nth x ret) @@ -332,37 +307,21 @@ tail (cdr tail)) (setf ret (list obj) tail (last ret))))) - (setf (cdr tail) (restore-object stream)) + (let ((last1 (restore-object stream))) + ;; and check for the last possible circularity + (if (and *check-for-circs* (referrer-p last1)) + (push (delay (setf (cdr tail) + (referred-value last1 *restored-values*))) + *need-to-fix*) + (setf (cdr tail) last1))) 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)))) + (multiple-value-bind (length last) (safe-length list) + (dump-list list length last stream))) -;; kept for backwards compatibility (defrestore-cl-store (cons stream) - (resolving-object (ret (cons nil nil)) - (setting (car ret) (restore-object stream)) - (setting (cdr ret) (restore-object stream)))) + (restore-list stream)) ;; pathnames @@ -513,7 +472,6 @@ (find-class (restore-object stream))) - ;; Arrays, vectors and strings. (defstore-cl-store (obj array stream) (declare (optimize speed (safety 1) (debug 0))) @@ -524,7 +482,8 @@ (t (store-array obj stream)))) (defun store-array (obj stream) - (declare (optimize speed (safety 1) (debug 0))) + (declare (optimize speed (safety 0) (debug 0)) + (type array obj)) (output-type-code +array-code+ stream) (if (and (= (array-rank obj) 1) (array-has-fill-pointer-p obj)) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.24 cl-store/tests.lisp:1.25 --- cl-store/tests.lisp:1.24 Thu Sep 1 13:59:30 2005 +++ cl-store/tests.lisp Fri Sep 9 16:59:17 2005 @@ -231,6 +231,7 @@ (equalp (cl-store::external-symbols (find-package :foo)) (make-array 1 :initial-element (find-symbol "BAR" "FOO")))))) + ; unfortunately it's difficult to portably test the internal symbols ; in a package so we just assume that it's OK. (deftest package.2 @@ -286,7 +287,6 @@ 9))) t) - ;; classes (deftest standard-class.1 (progn (store (find-class 'foo) *test-file*) (restore *test-file*) @@ -302,7 +302,7 @@ (restore *test-file*) t) t) - + ;; conditions @@ -550,6 +550,18 @@ (eq ret (third ret))))) t) +;; large circular lists +(deftest large.1 (let ((list (make-list 100000))) + (setf (cdr (last list)) list) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (eq (nthcdr 100000 ret) ret))) + t) + +;; large dotted lists +(deftestit large.2 (let ((list (make-list 100000))) + (setf (cdr (last list)) 'foo) + list)) Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.18 cl-store/utils.lisp:1.19 --- cl-store/utils.lisp:1.18 Thu Sep 1 12:24:55 2005 +++ cl-store/utils.lisp Fri Sep 9 16:59:17 2005 @@ -147,19 +147,20 @@ "Concatenate all symbol names into one big symbol" (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))) +;; Taken straight from swank.lisp --- public domain +;; and then slightly modified +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +Modified to work on circular lists." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return (values (/ n 2) list))) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) ;; EOF

1 0

[cl-store-cvs] CVS update: cl-store/tests.lisp
by sross＠common-lisp.net 01 Sep '05

01 Sep '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv16011 Modified Files: tests.lisp Log Message: Fixed tests Date: Thu Sep 1 13:59:30 2005 Author: sross Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.23 cl-store/tests.lisp:1.24 --- cl-store/tests.lisp:1.23 Thu Sep 1 12:24:55 2005 +++ cl-store/tests.lisp Thu Sep 1 13:59:30 2005 @@ -315,10 +315,11 @@ (deftest condition.2 (handler-case (car (read-from-string "3")) - (#-allegro type-error #+allegro simple-error (c) + ;; allegro pre 7.0 signalled a simple-error here + ((or type-error simple-error) (c) (store c *test-file*) (typep (restore *test-file*) - #-allegro 'type-error #+allegro 'simple-error))) + '(or type-error simple-error)))) t) ;; structure-object

1 0

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by sross＠common-lisp.net 01 Sep '05

01 Sep '05

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv9950/doc Modified Files: cl-store.texi Log Message: Changelog 2005-09-01 Date: Thu Sep 1 12:25:00 2005 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.11 cl-store/doc/cl-store.texi:1.12 --- cl-store/doc/cl-store.texi:1.11 Fri May 6 16:19:30 2005 +++ cl-store/doc/cl-store.texi Thu Sep 1 12:24:59 2005 @@ -82,7 +82,7 @@ The CL-STORE Home Page is at @uref{http://common-lisp.net/project/cl-store} where one can find details about mailing lists, cvs repositories and various releases. -This documentation is for CL-STORE version 0.5 . +This documentation is for CL-STORE version 0.6 . Enjoy Sean.

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 cl-store/xml-package.lisp
by sross＠common-lisp.net 01 Sep '05

01 Sep '05

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(a)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(a)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(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)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

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/backends.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp
by sross＠common-lisp.net 18 May '05

18 May '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv6678 Modified Files: ChangeLog backends.lisp cl-store.asd default-backend.lisp plumbing.lisp tests.lisp utils.lisp Log Message: Changelog 2005-05-18 Date: Wed May 18 17:34:10 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.32 cl-store/ChangeLog:1.33 --- cl-store/ChangeLog:1.32 Fri May 6 16:19:29 2005 +++ cl-store/ChangeLog Wed May 18 17:34:09 2005 @@ -1,3 +1,9 @@ +2005-05-18 Sean Ross <sross(a)common-lisp.net> + * utils.lisp: Removed awhen + * backends.lisp: Added a compatible-magic-numbers slot. + * default-backend.lisp: misc cleanups. + New magic number (can still restore previous versions files). + 2005-05-06 Sean Ross <sross(a)common-lisp.net> * backends.lisp: Added optional errorp argument to find-backend (default false). Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.10 cl-store/backends.lisp:1.11 --- cl-store/backends.lisp:1.10 Fri May 6 16:19:29 2005 +++ cl-store/backends.lisp Wed May 18 17:34:09 2005 @@ -14,6 +14,8 @@ (defclass backend () ((name :accessor name :initform "Unknown" :initarg :name :type symbol) (magic-number :accessor magic-number :initarg :magic-number :type integer) + (compatible-magic-numbers :accessor compatible-magic-numbers + :initarg :compatible-magic-numbers :type integer) (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers :type cons) (stream-type :accessor stream-type :initarg :stream-type :type (or symbol cons) @@ -38,8 +40,7 @@ (defun backend-designator->backend (designator) (check-type designator backend-designator) (etypecase designator - (symbol (or (find-backend designator) - (error "~A does not designate a backend." designator))) + (symbol (find-backend designator t)) (backend designator))) (defun get-store-macro (name) @@ -65,12 +66,14 @@ (declare (ignorable ,gbackend ,gtype)) ,@body))))) -(defun register-backend (name class magic-number stream-type old-magic-numbers) +(defun register-backend (name class magic-number stream-type old-magic-numbers + compatible-magic-numbers) (declare (type symbol name)) (let ((instance (make-instance class :name name :magic-number magic-number :old-magic-numbers old-magic-numbers + :compatible-magic-numbers compatible-magic-numbers :stream-type stream-type))) (if (assoc name *registered-backends*) (cerror "Redefine backend" "Backend ~A is already defined." name) @@ -86,7 +89,7 @@ (defmacro defbackend (name &key (stream-type ''(unsigned-byte 8)) (magic-number nil) fields (extends '(backend)) - (old-magic-numbers nil)) + (old-magic-numbers nil) (compatible-magic-numbers nil)) "Defines a new backend called NAME. Stream type must be either 'char or 'binary. FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will be written down stream as verification and checked on restoration. @@ -99,15 +102,11 @@ ,(get-store-macro name) ,(get-restore-macro name)) (register-backend ',name ',name ,magic-number - ,stream-type ',old-magic-numbers))) + ,stream-type ',old-magic-numbers ',compatible-magic-numbers))) (defmacro with-backend (backend &body body) "Run BODY with *default-backend* bound to BACKEND" - (with-gensyms (gbackend) - `(let* ((,gbackend ,backend) - (*default-backend* (or (backend-designator->backend ,gbackend) - (error "~A is not a legal backend" - ,gbackend)))) - ,@body))) + `(let* ((*default-backend* (backend-designator->backend ,backend))) + ,@body)) ;; EOF Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.29 cl-store/cl-store.asd:1.30 --- cl-store/cl-store.asd:1.29 Fri May 6 16:19:29 2005 +++ cl-store/cl-store.asd Wed May 18 17:34:09 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.5.12" + :version "0.5.15" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.28 cl-store/default-backend.lisp:1.29 --- cl-store/default-backend.lisp:1.28 Fri May 6 16:19:29 2005 +++ cl-store/default-backend.lisp Wed May 18 17:34:09 2005 @@ -4,8 +4,9 @@ ;; The cl-store backend. (in-package :cl-store) -(defbackend cl-store :magic-number 1349740876 +(defbackend cl-store :magic-number 1414745155 :stream-type '(unsigned-byte 8) + :compatible-magic-numbers (1349740876) :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1884506444 1347643724 1349732684) :extends (resolving-backend) @@ -177,8 +178,8 @@ (handler-bind ((simple-error #'(lambda (err) (declare (ignore err)) - (awhen (cdr (assoc obj *special-floats*)) - (output-type-code it stream) + (when-let (type (cdr (assoc obj *special-floats*))) + (output-type-code type stream) (return-from body))))) (multiple-value-setq (significand exponent sign) (integer-decode-float obj)) @@ -316,7 +317,7 @@ (store-object (hash-table-test obj) stream) (store-object (hash-table-count obj) stream) (loop for key being the hash-keys of obj - for value being the hash-values of obj do + using (hash-value value) do (store-object key stream) (store-object value stream))) @@ -349,7 +350,7 @@ (serializable-slots obj))) (slots (if *store-class-slots* all-slots - (remove-if #'(lambda (x) (eql (slot-definition-allocation x) + (delete-if #'(lambda (x) (eql (slot-definition-allocation x) :class)) all-slots)))) (declare (type list slots)) @@ -459,7 +460,7 @@ (dolist (x (multiple-value-list (array-displacement obj))) (store-object x stream)) (store-object (array-total-size obj) stream) - (loop for x from 0 to (1- (array-total-size obj)) do + (loop for x from 0 below (array-total-size obj) do (store-object (row-major-aref obj x) stream))) (defrestore-cl-store (array stream) @@ -480,7 +481,7 @@ (adjust-array res dimensions :displaced-to displaced-to :displaced-index-offset displaced-offset)) (resolving-object (obj res) - (loop for x from 0 to (1- size) do + (loop for x from 0 below size do (let ((pos x)) (setting (row-major-aref obj pos) (restore-object stream))))))) @@ -488,10 +489,9 @@ (declare (optimize speed (safety 1) (debug 0)) (type simple-vector obj)) (output-type-code +simple-vector-code+ stream) - (let ((size (length obj))) - (store-object size stream) - (loop for x across obj do - (store-object x stream)))) + (store-object (length obj) stream) + (loop for x across obj do + (store-object x stream))) (defrestore-cl-store (simple-vector stream) (declare (optimize speed (safety 1) (debug 0))) @@ -508,7 +508,7 @@ ;; Dumping (unsigned-byte 32) for each character seems ;; like a bit much when most of them will be -;; standard-chars. So we try to cater for them. +;; base-chars. So we try to cater for them. (defvar *char-marker* (code-char 255) "Largest character that can be represented in 8 bits") Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.15 cl-store/plumbing.lisp:1.16 --- cl-store/plumbing.lisp:1.15 Thu May 5 14:58:54 2005 +++ cl-store/plumbing.lisp Wed May 18 17:34:09 2005 @@ -100,8 +100,8 @@ (defgeneric store-backend-code (backend stream) (:method ((backend backend) (stream t)) (declare (optimize speed)) - (awhen (magic-number backend) - (store-32-bit it stream))) + (when-let (magic (magic-number backend)) + (store-32-bit magic stream))) (:documentation "Store magic-number of BACKEND, when present, into STREAM.")) @@ -166,8 +166,8 @@ (with-open-file (s place :element-type element-type :direction :input) (backend-restore backend s)))) -(defun (setf restore) (new-val place) - (store new-val place)) +(defun (setf restore) (new-val place &optional (backend *default-backend*)) + (store new-val place backend)) (defgeneric check-magic-number (backend stream) (:method ((backend backend) (stream t)) @@ -177,7 +177,9 @@ (let ((val (read-32-bit stream nil))) (declare (type ub32 val)) (cond ((= val magic-number) nil) - ((member val (old-magic-numbers backend) :test #'=) + ((member val (compatible-magic-numbers backend)) + nil) + ((member val (old-magic-numbers backend)) (restore-error "Stream contains an object stored with an ~ incompatible version of backend ~A." (name backend))) (t (restore-error "Stream does not contain a stored object~ Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.21 cl-store/tests.lisp:1.22 --- cl-store/tests.lisp:1.21 Fri May 6 16:19:29 2005 +++ cl-store/tests.lisp Wed May 18 17:34:09 2005 @@ -157,6 +157,8 @@ (deftestit symbol.3 :foo) (deftestit symbol.4 'cl-store-tests::foo) (deftestit symbol.5 'make-hash-table) +(deftestit symbol.6 '|foo bar|) +(deftestit symbol.7 'foo\ bar\ baz) (deftest gensym.1 (progn (store (gensym "Foobar") *test-file*) Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.16 cl-store/utils.lisp:1.17 --- cl-store/utils.lisp:1.16 Thu May 5 14:58:54 2005 +++ cl-store/utils.lisp Wed May 18 17:34:09 2005 @@ -65,9 +65,10 @@ :type (slot-definition-type slot-definition) :writers (slot-definition-writers slot-definition)))) -(defmacro awhen (test &body body) - `(aif ,test - (progn ,@body))) +(defmacro when-let ((var test) &body body) + `(let ((,var ,test)) + (when ,var + ,@body))) ;; because clisp doesn't have the class single-float or double-float. @@ -145,5 +146,6 @@ (defun symbolicate (&rest syms) "Concatenate all symbol names into one big symbol" (values (intern (apply #'mkstr syms)))) + ;; EOF

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/backends.lisp cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/tests.lisp
by sross＠common-lisp.net 06 May '05

06 May '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv11930 Modified Files: ChangeLog backends.lisp circularities.lisp cl-store.asd default-backend.lisp tests.lisp Log Message: Changelog 2005-05-06 Date: Fri May 6 16:19:29 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.31 cl-store/ChangeLog:1.32 --- cl-store/ChangeLog:1.31 Thu May 5 14:58:54 2005 +++ cl-store/ChangeLog Fri May 6 16:19:29 2005 @@ -1,3 +1,15 @@ +2005-05-06 Sean Ross <sross(a)common-lisp.net> + * backends.lisp: Added optional errorp argument + to find-backend (default false). + * default-backend.lisp: Changed simple-string storing + to keep the upgraded-array-element-type of the + restored string the same as the string which was stored. + This seems to give a performance boost (more in memory usage) + with SBCL and Lispworks. + * circularities.lisp: Stopped binding *stored-values* + and *restored-values* when circularity checking is inhibited. + * doc/cl-store.texi: Miscellaneous fixes. + 2005-05-05 Sean Ross <sross(a)common-lisp.net> * all: After much experimentation with Lispworks I discovered that globally declaiming unsafe code is Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.9 cl-store/backends.lisp:1.10 --- cl-store/backends.lisp:1.9 Wed Mar 23 13:58:43 2005 +++ cl-store/backends.lisp Fri May 6 16:19:29 2005 @@ -9,7 +9,7 @@ (in-package :cl-store) (defun required-arg (name) - (error "~A is a required argument" name)) + (error "~S is a required argument" name)) (defclass backend () ((name :accessor name :initform "Unknown" :initarg :name :type symbol) @@ -17,7 +17,7 @@ (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers :type cons) (stream-type :accessor stream-type :initarg :stream-type :type (or symbol cons) - :initform (required-arg "stream-type"))) + :initform (required-arg :stream-type))) (:documentation "Core class which custom backends must extend")) (deftype backend-designator () @@ -26,10 +26,14 @@ (defparameter *registered-backends* nil "An assoc list mapping backend-names to the backend objects") -(defun find-backend (name) +(defun find-backend (name &optional errorp) (declare (type symbol name)) - "Return backup called NAME or NIL if not found." - (cdr (assoc name *registered-backends*))) + "Return backup called NAME. If there is no such backend NIL is returned +if ERRORP is false, otherwise an error is signalled." + (or (cdr (assoc name *registered-backends*)) + (if errorp + (error "Backend named ~S does not exist." name) + nil))) (defun backend-designator->backend (designator) (check-type designator backend-designator) Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.21 cl-store/circularities.lisp:1.22 --- cl-store/circularities.lisp:1.21 Thu May 5 14:58:54 2005 +++ cl-store/circularities.lisp Fri May 6 16:19:29 2005 @@ -98,7 +98,8 @@ "Store OBJ into PLACE. Does the setup for counters and seen values." (declare (optimize speed (safety 1) (debug 0))) (let ((*stored-counter* 0) - (*stored-values* (make-hash-table :test #'eq :size *store-hash-size*))) + (*stored-values* (and *check-for-circs* + (make-hash-table :test #'eq :size *store-hash-size*)))) (store-backend-code backend place) (backend-store-object backend obj place) obj)) @@ -159,7 +160,8 @@ various variables used by resolving-object." (let ((*restore-counter* 0) (*need-to-fix* nil) - (*restored-values* (make-hash-table :test #'eq :size *restore-hash-size*))) + (*restored-values* (and *check-for-circs* + (make-hash-table :test #'eq :size *restore-hash-size*)))) (check-magic-number backend place) (multiple-value-prog1 (backend-restore-object backend place) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.28 cl-store/cl-store.asd:1.29 --- cl-store/cl-store.asd:1.28 Thu May 5 14:58:54 2005 +++ cl-store/cl-store.asd Fri May 6 16:19:29 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.5.9" + :version "0.5.12" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.27 cl-store/default-backend.lisp:1.28 --- cl-store/default-backend.lisp:1.27 Thu May 5 14:58:54 2005 +++ cl-store/default-backend.lisp Fri May 6 16:19:29 2005 @@ -61,6 +61,9 @@ (defvar +positive-double-infinity-code+ (register-code 31 'positive-double-infinity nil)) (defvar +negative-double-infinity-code+ (register-code 32 'negative-double-infinity nil)) (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)) + ;; setups for type code mapping (defun output-type-code (code stream) @@ -438,6 +441,7 @@ (defstore-cl-store (obj array stream) (declare (optimize speed (safety 1) (debug 0))) (typecase obj + (simple-base-string (store-simple-base-string obj stream)) (simple-string (store-simple-string obj stream)) (simple-vector (store-simple-vector obj stream)) (t (store-array obj stream)))) @@ -524,32 +528,46 @@ (t (output-type-code +simple-string-code+ stream) (dump-string #'write-byte obj stream)))) +(defun store-simple-base-string (obj stream) + (declare (type simple-string obj) + (optimize speed (safety 1) (debug 0))) + (cond ((unicode-string-p obj) + (output-type-code +unicode-base-string-code+ stream) + (dump-string #'dump-int obj stream)) + (t (output-type-code +simple-base-string-code+ stream) + (dump-string #'write-byte obj stream)))) + (defun dump-string (dumper obj stream) (declare (simple-string obj) (function dumper) (stream stream) (optimize speed (safety 1) (debug 0))) (dump-int (the array-size (length obj)) stream) (loop for x across obj do (funcall dumper (char-code x) stream))) - (defrestore-cl-store (simple-string stream) (declare (optimize speed)) - (undump-string #'read-byte stream)) + (undump-string #'read-byte 'character stream)) (defrestore-cl-store (unicode-string stream) (declare (optimize speed)) - (undump-string #'undump-int stream)) + (undump-string #'undump-int 'character stream)) + +(defrestore-cl-store (simple-base-string stream) + (declare (optimize speed)) + (undump-string #'read-byte 'base-char stream)) -(defun undump-string (reader stream) +(defrestore-cl-store (unicode-base-string stream) + (declare (optimize speed)) + (undump-string #'undump-int 'base-char stream)) + +(defun undump-string (reader type stream) (declare (type function reader) (type stream stream) (optimize speed (safety 1) (debug 0))) (let* ((length (the array-size (undump-int stream)) ) - (res (make-string length - #+lispworks :element-type #+lispworks 'character))) + (res (make-string length :element-type type))) (declare (type simple-string res)) (dotimes (x length) (setf (schar res x) (code-char (funcall reader stream)))) res)) - ;; packages (from Thomas Stenhaug) (defstore-cl-store (obj package stream) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.20 cl-store/tests.lisp:1.21 --- cl-store/tests.lisp:1.20 Thu May 5 14:58:54 2005 +++ cl-store/tests.lisp Fri May 6 16:19:29 2005 @@ -345,6 +345,23 @@ (deftestit built-in.2 (find-class 'integer)) +;; find-backend tests +(deftest find-backend.1 + (and (find-backend 'cl-store) t) + t) + +(deftest find-backend.2 + (find-backend (gensym)) + nil) + +(deftest find-backend.3 + (handler-case (find-backend (gensym) t) + (error (c) (and c t)) + (:no-error (val) (and val nil))) + t) + + + ;; circular objects (defvar circ1 (let ((x (list 1 2 3 4))) (setf (cdr (last x)) x)))

1 0