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