Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv7159
Modified Files: ChangeLog README backends.lisp circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp utils.lisp xml-backend.lisp Log Message: Changelog 2004-11-10
Date: Wed Nov 10 11:43:17 2004 Author: sross
Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.13 cl-store/ChangeLog:1.14 --- cl-store/ChangeLog:1.13 Mon Nov 1 15:49:00 2004 +++ cl-store/ChangeLog Wed Nov 10 11:43:16 2004 @@ -1,3 +1,19 @@ +2004-11-10 Sean Ross sross@common-lisp.net + New Version: 0.3.6 New Magic Number (Breaks backwards compatibility) + * default-backend.lisp: Storing for functions and generic functions. + * tests.lisp: Tests for functions and GF's. + * plumbing.lisp, circularities.lisp, default-backend.lisp: + Optimized int-sym-or-charp. + * clisp/fix-clisp.lisp: Added generic-function-name. + * package.lisp: Import generic-function-name. + * default-backend.lisp: More optimizations for strings and ints. + +2004-11-03 Sean Ross sross@common-lisp.net + * tests.lisp: Added tests for unicode strings and symbols. + * default-backend.lisp: We definitely support unicode now. + Added small optimization to stop the size of files from + ballooning. + 2004-11-01 Sean Ross sross@common-lisp.net * default-backend.lisp: Changed storing of sizes of integers and strings from store-32-bit to store-object. Changed all
Index: cl-store/README diff -u cl-store/README:1.10 cl-store/README:1.11 --- cl-store/README:1.10 Mon Nov 1 15:30:18 2004 +++ cl-store/README Wed Nov 10 11:43:16 2004 @@ -1,7 +1,7 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.3.2 +Version: 0.3.6
0. About. CL-STORE is an portable serialization package which
Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.3 cl-store/backends.lisp:1.4 --- cl-store/backends.lisp:1.3 Mon Nov 1 15:30:18 2004 +++ cl-store/backends.lisp Wed Nov 10 11:43:16 2004 @@ -7,7 +7,7 @@ ;; in default-backend.lisp and xml-backend.lisp
(in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 0)))
(defun required-arg (name) @@ -45,6 +45,7 @@ ((,var ,type) ,stream (backend ,',class-name)) ,(format nil "Definition for storing an object of type ~A with ~ backend ~A" type ',name) +; (declare (optimize (speed 3) (safety 1) (debug 0))) ,@body))))
(defun get-restore-macro (name) @@ -52,7 +53,9 @@ (let ((macro-name (symbolicate 'defrestore- name))) `(defmacro ,macro-name ((type place) &body body) (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type))))) - `(flet ((,fn-name (,place) ,@body)) + `(flet ((,fn-name (,place) +; (declare (optimize (speed 3) (safety 1) (debug 0))) + ,@body)) (let* ((backend (find-backend ',',name)) (restorers (restorer-funs backend))) (when (gethash ',type restorers)
Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.10 cl-store/circularities.lisp:1.11 --- cl-store/circularities.lisp:1.10 Mon Nov 1 15:30:18 2004 +++ cl-store/circularities.lisp Wed Nov 10 11:43:16 2004 @@ -19,7 +19,7 @@ ;; programs according to the Hyperspec(notes in EQ).
(in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defvar *postfix-setters* '(gethash) "Setfable places which take the object to set after @@ -27,9 +27,8 @@
(defun get-setf-place (place obj) "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*." - (declare (type (or cons symbol) place)) (cond ((atom place) `(,place ,obj)) - ((member (car place) *postfix-setters*) + ((member (the symbol (car place)) *postfix-setters*) `(,@place ,obj)) (t `(,(car place) ,obj ,@(cdr place)))))
@@ -48,52 +47,51 @@ (declare (ignore getting-key getting-value)) (error "setting-hash can only be used inside a resolving-object form."))
- (defmacro resolving-object (create &body body) "Execute body attempting to resolve circularities found in form CREATE." (with-gensyms (obj value key) `(macrolet ((setting (place getting) - (let ((setf-place (get-setf-place place ',obj))) - `(let ((,',value ,getting)) - (if (referrer-p ,',value) - (push (lambda () - (setf ,setf-place - (referred-value ,',value - *restored-values*))) - *need-to-fix*) - (setf ,setf-place ,',value))))) - (setting-hash (getting-key getting-place) - `(let ((,',key ,getting-key)) - (if (referrer-p ,',key) - (let ((,',value ,getting-place)) - (push (lambda () - (setf (gethash - (referred-value ,',key *restored-values*) - ,',obj) - (if (referrer-p ,',value) + (let ((setf-place (get-setf-place place ',obj))) + `(let ((,',value ,getting)) + (if (referrer-p ,',value) + (push #'(lambda () + (setf ,setf-place (referred-value ,',value - *restored-values*) - ,',value))) - *need-to-fix*)) - (setting (gethash ,',key) ,getting-place))))) - (let ((,obj ,create)) - ,@body - ,obj)))) + *restored-values*))) + *need-to-fix*) + (setf ,setf-place ,',value))))) + (setting-hash (getting-key getting-place) + `(let ((,',key ,getting-key)) + (if (referrer-p ,',key) + (let ((,',value ,getting-place)) + (push #'(lambda () + (setf (gethash + (referred-value ,',key *restored-values*) + ,',obj) + (if (referrer-p ,',value) + (referred-value ,',value + *restored-values*) + ,',value))) + *need-to-fix*)) + (setting (gethash ,',key) ,getting-place))))) + (let ((,obj ,create)) + ,@body + ,obj))))
(defstruct referrer val)
(defun referred-value (referrer hash) "Return the value REFERRER is meant to be by looking in HASH." - (gethash (referrer-val referrer) ;(read-from-string (subseq (symbol-name referrer) 11)) + (gethash (referrer-val referrer) hash))
(defclass resolving-backend (backend) () (:documentation "A backend which does the setup for resolving circularities."))
-(declaim (type fixnum *stored-counter*)) +(declaim (type (or null fixnum) *stored-counter*)) (defvar *stored-counter*) (defvar *stored-values*)
@@ -153,7 +151,7 @@
;; Restoration. -(declaim (type fixnum *restore-counter*)) +(declaim (type (or null fixnum) *restore-counter*)) (defvar *restore-counter*) (defvar *need-to-fix*) (defvar *restored-values*) @@ -170,12 +168,10 @@ (dolist (fn *need-to-fix*) (funcall (the function fn))))))
-;; Change to backend-restore-object to allow support for -;; multiple return values. (defmethod backend-restore-object ((place t) (backend resolving-backend)) "Retrieve a object from PLACE, does housekeeping for circularity fixing." - (let ((reader (find-function-for-type place backend))) - (if (not (int-sym-or-char-p reader backend)) + (multiple-value-bind (reader sym) (find-function-for-type place backend) + (if (not (int-sym-or-char-p sym backend)) (let ((spot (incf *restore-counter*)) (vals (mapcar #'new-val (multiple-value-list (funcall (the function reader) @@ -186,16 +182,13 @@ (funcall (the function reader) place))))
+ (defgeneric int-sym-or-char-p (fn backend) (:argument-precedence-order backend fn) (:method ((fn t) (backend t)) "Is function FN registered to restore an integer, character or symbol in BACKEND." - (let ((readers (restorer-funs backend))) - (or (eq fn (lookup-reader 'integer readers)) - (eq fn (lookup-reader 'character readers)) - (eq fn (lookup-reader 'symbol readers)))))) - + (member fn '(integer character symbol))))
(defun new-val (val) "Tries to get a referred value to reduce unnecessary cirularity fixing."
Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.12 cl-store/cl-store.asd:1.13 --- cl-store/cl-store.asd:1.12 Mon Nov 1 15:30:18 2004 +++ cl-store/cl-store.asd Wed Nov 10 11:43:16 2004 @@ -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.3.2" + :version "0.3.6" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT"
Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.10 cl-store/default-backend.lisp:1.11 --- cl-store/default-backend.lisp:1.10 Mon Nov 1 15:30:18 2004 +++ cl-store/default-backend.lisp Wed Nov 10 11:43:16 2004 @@ -5,13 +5,13 @@
(in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 1)))
(eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cl-store-backend* - (defbackend cl-store :magic-number 1347643724 + (defbackend cl-store :magic-number 1349732684 :stream-type 'binary - :old-magic-numbers (1912923 1886611788 1347635532) + :old-magic-numbers (1912923 1886611788 1347635532 1347643724) :extends resolving-backend :fields ((restorers :accessor restorers :initform (make-hash-table))))) (defun register-code (code name &optional (errorp t)) @@ -24,6 +24,7 @@ ;; Type code constants (defconstant +referrer-code+ (register-code 1 'referrer nil)) (defconstant +values-code+ (register-code 2 'values-object nil)) +(defconstant +unicode-string-code+ (register-code 3 'unicode-string nil)) (defconstant +integer-code+ (register-code 4 'integer nil)) (defconstant +simple-string-code+ (register-code 5 'simple-string nil)) (defconstant +float-code+ (register-code 6 'float nil)) @@ -54,11 +55,11 @@ (defconstant +float-nan-code+ (register-code 25 'nan-float nil))
(defconstant +function-code+ (register-code 26 'function nil)) - +(defconstant +gf-code+ (register-code 27 'generic-function nil))
;; setups for type code mapping (defun output-type-code (code stream) - (declare (type (mod 256) code)) + (declare (type ub32 code)) (write-byte (ldb (byte 8 0) code) stream))
(defun read-type-code (stream) @@ -77,43 +78,48 @@ ;; referrer, Required for a resolving backend (defmethod store-referrer (ref stream (backend cl-store-backend)) (output-type-code +referrer-code+ stream) - (store-32-bit ref stream)) + (dump-int ref stream))
(defrestore-cl-store (referrer stream) - (make-referrer :val (read-32-bit stream nil))) + (make-referrer :val (undump-int stream)))
;; integers ;; The theory is that most numbers will fit in 32 bits -;; so we try and cater for them +;; so we we have a little optimization for it
;; We need this for circularity stuff. (defmethod int-sym-or-char-p ((fn t) (backend cl-store-backend)) - (let ((readers (restorer-funs backend))) - (or (eq fn (lookup-reader 'integer readers)) - (eq fn (lookup-reader 'character readers)) - (eq fn (lookup-reader '32-bit-integer readers)) - (eq fn (lookup-reader 'symbol readers))))) + (member fn '(integer character 32-bit-integer symbol)))
(defstore-cl-store (obj integer stream) - (if (typep obj '(signed-byte 32)) + (if (typep obj 'sb32) (store-32-bit-integer obj stream) (store-arbitrary-integer obj stream)))
+(defun dump-int (obj stream) + (declare (type ub32 obj)) + (typecase obj + ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream)) + (t (write-byte 2 stream) (store-32-bit obj stream)))) + +(defun undump-int (stream) + (ecase (read-byte stream) + (1 (read-byte stream)) + (2 (read-32-bit stream nil))))
- - -;; Should be 32-bit (defun store-32-bit-integer (obj stream) + (declare (type sb32 obj)) (output-type-code +32-bit-integer-code+ stream) (write-byte (if (minusp obj) 1 0) stream) - (store-32-bit (abs obj) stream)) + (dump-int (abs obj) stream))
(defrestore-cl-store (32-bit-integer stream) - (funcall (if (zerop (read-byte stream)) #'+ #'-) - (read-32-bit stream nil))) + (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-) + (undump-int stream)))
(defun store-arbitrary-integer (obj stream) + (declare (type integer obj) (stream stream)) (output-type-code +integer-code+ stream) (loop for n = (abs obj) then (ash n -32) for counter from 0 @@ -131,46 +137,14 @@ (defrestore-cl-store (integer buff) (let ((count (restore-object buff)) (result 0)) + (declare (type integer result count)) (loop repeat (abs count) do - (setf result (+ (ash result 32) (read-32-bit buff nil)))) + (setf result (the integer (+ (ash result 32) + (the ub32 (read-32-bit buff nil)))))) (if (minusp count) (- result) result)))
- -;; Strings -;; If the string to be stored is of type simple-standard-string -;; we can write it down byte by byte. Otherwise we treat it as -;; an array. -(deftype simple-standard-string () - `(simple-array standard-char (*))) - -(defun output-simple-standard-string (obj stream) - (store-object (length obj) stream) - (loop for x across obj do - (write-byte (char-code x) stream))) - -(defun restore-simple-standard-string (stream) - (let* ((length (restore-object stream)) - (res (make-string length - #+lispworks :element-type #+lispworks 'character))) - (dotimes (x length) - (setf (schar res x) (code-char (read-byte stream)))) - res)) - -(defun store-simple-standard-string (string stream) - (output-type-code +simple-string-code+ stream) - (output-simple-standard-string string stream)) - - -(defstore-cl-store (obj string stream) - (if (typep obj 'simple-standard-string) - (store-simple-standard-string obj stream) - (store-array obj stream))) - -(defrestore-cl-store (simple-string stream) - (restore-simple-standard-string stream)) - ;; Floats ;; SBCL and CMUCL use a different mechanism for dealing ;; with floats which supports infinities. @@ -201,7 +175,8 @@ (store-object (denominator obj) stream))
(defrestore-cl-store (ratio stream) - (/ (restore-object stream) (restore-object stream))) + (/ (the integer (restore-object stream)) + (the integer (restore-object stream))))
;; chars (defstore-cl-store (obj character stream) @@ -284,6 +259,7 @@ (size (restore-object stream)) (test (restore-object stream)) (count (restore-object stream))) + (declare (type integer count size)) (let ((hash (make-hash-table :test (symbol-function test) :rehash-size rehash-size :rehash-threshold rehash-threshold @@ -298,6 +274,8 @@ (restore-object stream)))) hash)))
+ +;; Object and Conditions (defun store-type-object (obj stream) (let* ((all-slots (remove-if-not (lambda (x) (slot-boundp obj (slot-definition-name x))) @@ -307,6 +285,7 @@ (remove-if #'(lambda (x) (eql (slot-definition-allocation x) :class)) all-slots)))) + (declare (type list slots)) (store-object (type-of obj) stream) (store-object (length slots) stream) (dolist (slot slots) @@ -328,6 +307,7 @@ (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 @@ -387,9 +367,14 @@ (defrestore-cl-store (built-in-class stream) (find-class (restore-object stream)))
-;; arrays and vectors + + +;; Arrays and Vectors and Strings (defstore-cl-store (obj array stream) - (store-array obj stream)) + (typecase obj + (simple-string (store-simple-string obj stream)) + (simple-vector (store-simple-vector obj stream)) + (t (store-array obj stream))))
(defun store-array (obj stream) (output-type-code +array-code+ stream) @@ -418,6 +403,7 @@ :element-type element-type :adjustable adjustable :fill-pointer fill-pointer))) + (declare (type cons dimensions) (type array-size size)) (when displaced-to (adjust-array res dimensions :displaced-to displaced-to :displaced-index-offset displaced-offset)) @@ -427,29 +413,65 @@ (setting (row-major-aref pos) (restore-object stream))))) res))
- -;; clisp and allegro doesn't have the class simple-vector -#-(or clisp allegro) -(defstore-cl-store (obj simple-vector stream) +(defun store-simple-vector (obj stream) + (declare (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))))
-#-(or clisp allegro) (defrestore-cl-store (simple-vector stream) (let* ((size (restore-object stream)) (res (make-array size))) + (declare (type array-size size)) (resolving-object res - (loop repeat size - for i from 0 do + (loop for i from 0 to (1- size) do ;; we need to copy the index so that ;; it's value is preserved for after the loop. (let ((x i)) (setting (aref x) (restore-object stream))))) res))
+;; 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. +(defvar *char-marker* (code-char 255) + "Largest character that can be represented in 8 bits") + +(defun store-simple-string (obj stream) + (declare (type simple-string obj)) + ;; must be a better test than this. + (cond ((some #'(lambda (x) (char> x *char-marker*)) obj) + ;; contains wide characters + (output-type-code +unicode-string-code+ stream) + (dump-string #'dump-int obj stream)) + (t (output-type-code +simple-string-code+ stream) + (dump-string #'write-byte obj stream)))) + +(defun dump-string (dumper obj stream) + (declare (simple-string obj) (function dumper) (stream stream)) + ;(store-object (length obj) stream) + (dump-int (length obj) stream) + (loop for x across obj do (funcall dumper (char-code x) stream))) + +(defrestore-cl-store (simple-string stream) + (undump-string #'read-byte stream)) + +(defrestore-cl-store (unicode-string stream) + (undump-string #'undump-int stream)) + +(defun undump-string (reader stream) + (declare (type function reader) (type stream stream)) + (let* ((length (undump-int stream)) ;(restore-object stream)) + (res (make-string length + #+lispworks :element-type #+lispworks 'character))) + (dotimes (x length) + (setf (schar res x) (code-char (funcall reader stream)))) + res)) + + + ;; packages (defstore-cl-store (obj package stream) (output-type-code +package-code+ stream) @@ -472,16 +494,35 @@
;; Function storing hack. ;; This just stores the function name if we can find it -;; or signals a store-error. +;; or signal a store-error. (defstore-cl-store (obj function stream) (output-type-code +function-code+ stream) (multiple-value-bind (l cp name) (function-lambda-expression obj) (declare (ignore l cp)) - (if (and name (symbolp name)) - (store-object name stream) - (store-error "Unable to determine function name for ~A." obj)))) + (cond ((and name (or (symbolp name) (consp name))) (store-object name stream)) + ;; Try to deal with sbcl's naming convention + ;; of built in functions + #+sbcl + ((and name (stringp name) (search "top level local call " name)) + (let ((new-name (subseq name 21))) + (when (not (string= new-name "")) + (handler-case (store-object (read-from-string new-name) stream) + (sb-ext:package-locked-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)))))
(defrestore-cl-store (function stream) + (fdefinition (restore-object stream))) + +;; Generic function, just dumps the gf-name +(defstore-cl-store (obj generic-function stream) + (output-type-code +gf-code+ stream) + (aif (generic-function-name obj) + (store-object it stream) + (store-error "No generic function name for ~A." obj))) + +(defrestore-cl-store (generic-function stream) (fdefinition (restore-object stream)))
(setf *default-backend* (find-backend 'cl-store))
Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.13 cl-store/package.lisp:1.14 --- cl-store/package.lisp:1.13 Mon Nov 1 15:30:18 2004 +++ cl-store/package.lisp Wed Nov 10 11:43:16 2004 @@ -12,7 +12,7 @@ #:cl-store-error #:store-error #:restore-error #:store #:restore #:backend-store #:store-backend-code #:store-object #:backend-store-object #:get-class-details #:get-array-values - #:check-stream-element-type #:restore #:backend-restore + #:restore #:backend-restore #:check-magic-number #:get-next-reader #:int-sym-or-char-p #:restore-object #:backend-restore-object #:cl-store #:defstore-cl-store #:defrestore-cl-store #:register-code @@ -28,6 +28,7 @@ #:store-32-bit #:read-32-bit)
#+sbcl (:import-from #:sb-mop + #:generic-function-name #:slot-definition-name #:slot-value-using-class #:slot-boundp-using-class @@ -44,8 +45,9 @@ #:class-direct-superclasses #:class-slots #:ensure-class) - + #+cmu (:import-from #:pcl + #:generic-function-name #:slot-definition-name #:slot-value-using-class #:slot-boundp-using-class @@ -70,6 +72,7 @@ #:class-of)
#+openmcl (:import-from #:openmcl-mop + #:generic-function-name #:slot-definition-name #:slot-value-using-class #:slot-boundp-using-class @@ -99,6 +102,7 @@
#+lispworks (:import-from #:clos #:slot-definition-name + #:generic-function-name #:slot-value-using-class #:slot-boundp-using-class #:slot-definition-allocation @@ -117,6 +121,7 @@
#+allegro (:import-from #:mop #:slot-definition-name + #:generic-function-name #:slot-value-using-class #:slot-boundp-using-class #:slot-definition-allocation
Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.5 cl-store/plumbing.lisp:1.6 --- cl-store/plumbing.lisp:1.5 Mon Nov 1 15:30:18 2004 +++ cl-store/plumbing.lisp Wed Nov 10 11:43:16 2004 @@ -5,7 +5,7 @@ ;;
(in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 0)))
(defvar *nuke-existing-classes* nil "Do we overwrite existing class definitions on restoration.") @@ -24,6 +24,7 @@ ;; store or restore will signal a store-error or a ;; restore-error respectively inside a handler-bind. (defun cl-store-report (condition stream) + (declare (stream stream)) (aif (caused-by condition) (format stream "~A" it) (apply #'format stream (format-string condition) @@ -92,15 +93,13 @@ (:documentation "Method wrapped by store, override this method for custom behaviour (see circularities.lisp)."))
-(defun store-backend-code (stream backend) - "Store magic-number of BACKEND, when present, into STREAM." - (let ((code (magic-number backend))) - (when code - (ecase (stream-type backend) - (character (store-string-code code stream)) - (integer (store-32-bit code stream)))))) - - +(defgeneric store-backend-code (stream backend) + (:argument-precedence-order backend stream) + (:method ((stream t) (backend t)) + (let ((code (magic-number backend))) + (store-32-bit code stream))) + (:documentation + "Store magic-number of BACKEND, when present, into STREAM."))
(defun store-object (obj stream &optional (backend *current-backend*)) "Store OBJ into STREAM. Not meant to be overridden, @@ -136,10 +135,6 @@ :caused-by c))))) (backend-restore place backend)))))
-(declaim (inline check-stream-element-type)) -(defun check-stream-element-type (stream) - (declare (ignore stream)) - nil)
(defgeneric backend-restore (place backend) (:argument-precedence-order backend place) @@ -180,20 +175,23 @@ (defun (setf restore) (new-val place) (store new-val place))
-(defun check-magic-number (stream backend) - "Check to see if STREAM actually contains a stored object for BACKEND." - (let ((magic-number (magic-number backend))) - (when magic-number - (let ((val (ecase (stream-type backend) - (integer (read-32-bit stream nil)) - (character (retrieve-string-code stream))))) - (cond ((eql val magic-number) nil) - ((member val (old-magic-numbers backend)) - (restore-error "Stream contains an object stored with a ~ +(defgeneric check-magic-number (stream backend) + (:argument-precedence-order backend stream) + (:method ((stream t) (backend t)) + (let ((magic-number (magic-number backend))) + (declare (type ub32 magic-number)) + (when magic-number + (let ((val (read-32-bit stream nil))) + (declare (type ub32 val)) + (cond ((= val magic-number) nil) + ((member val (old-magic-numbers backend) :test #'=) + (restore-error "Stream contains an object stored with a ~ incompatible version of backend ~A." (name backend))) - (t (restore-error "Stream does not contain a stored object~ + (t (restore-error "Stream does not contain a stored object~ for backend ~A." - (name backend)))))))) + (name backend)))))))) + (:documentation + "Check to see if STREAM actually contains a stored object for BACKEND."))
(defun lookup-reader (val readers) (gethash val readers)) @@ -216,7 +214,7 @@ (:method (place backend) (multiple-value-bind (val info) (get-next-reader place backend) (let ((reader (lookup-reader val (restorer-funs backend)))) - (cond ((and val reader) reader) + (cond ((and val reader) (values reader val)) ((not val) (restore-error "~A is not registered with backend ~(~A~)." (or info "Unknown Type") (name backend)))
Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.9 cl-store/tests.lisp:1.10 --- cl-store/tests.lisp:1.9 Mon Nov 1 15:30:18 2004 +++ cl-store/tests.lisp Wed Nov 10 11:43:16 2004 @@ -95,6 +95,12 @@ (make-array 10 :initial-element #\f :element-type 'character :fill-pointer 3))
+#+(or (and sbcl sb-unicode) lispworks clisp acl) +(progn + (deftestit unicode.1 (map 'string #'code-char (list #X20AC #X3BB))) + (deftestit unicode.2 (intern (map 'string #'code-char (list #X20AC #X3BB)) + :cl-store-tests))) + ;; vectors (deftestit vector.1 #(1 2 3 4))
@@ -470,6 +476,19 @@ (let ((val (multiple-value-list (restore *test-file*)))) (eq (car val) (cadr val)))) t) + + +(deftestit function.1 #'restores) +(deftestit function.2 #'car) +(deftestit function.3 #'cl-store::get-setf-place) +#-(or clisp lispworks allegro openmcl) +(deftestit function.4 #'(setf car)) + +(deftestit gfunction.1 #'cl-store:restore) +(deftestit gfunction.2 #'cl-store:store) +#-(or clisp lispworks openmcl) +(deftestit gfunction.3 #'(setf cl-store:restore)) +
(defun run-tests (backend)
Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.6 cl-store/utils.lisp:1.7 --- cl-store/utils.lisp:1.6 Mon Nov 1 15:30:18 2004 +++ cl-store/utils.lisp Wed Nov 10 11:43:16 2004 @@ -3,7 +3,7 @@
;; Miscellaneous utilities used throughout the package. (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defmacro aif (test then &optional else) @@ -47,15 +47,29 @@ (0 1.0) (1 1.0d0)))
+(deftype ub32 () + `(unsigned-byte 32)) + +(deftype sb32 () + `(signed-byte 32)) + +(deftype array-size () + "The maximum size of an array" + `(integer 0 ,array-dimension-limit)) +
(defun store-32-bit (obj stream) - "Write OBJ down STREAM as a 32 byte integer." + "Write OBJ down STREAM as a 32 bit integer." + (declare (ub32 obj)) (write-byte (ldb (byte 8 0) obj) stream) (write-byte (ldb (byte 8 8) obj) stream) (write-byte (ldb (byte 8 16) obj) stream) (write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
+(defmacro make-ub32 (a b c d) + `(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d))) + (defun read-32-bit (buf &optional (signed t)) "Read a signed or unsigned byte off STREAM." (let ((byte1 (read-byte buf)) @@ -63,7 +77,7 @@ (byte3 (read-byte buf)) (byte4 (read-byte buf))) (declare (type (mod 256) byte1 byte2 byte3 byte4)) - (let ((ret (+ byte1 (* 256 (+ byte2 (* 256 (+ byte3 (* 256 byte4)))))))) + (let ((ret (make-ub32 byte4 byte3 byte2 byte1))) (if (and signed (> byte1 127)) (logior (ash -1 32) ret) ret)))) @@ -71,7 +85,7 @@
(defun store-string-code (string stream) "Write length of STRING then STRING into stream" - (declare (type simple-string string)) + (declare (simple-string string) (stream stream)) (format stream "~S" string))
(defun retrieve-string-code (stream)
Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.6 cl-store/xml-backend.lisp:1.7 --- cl-store/xml-backend.lisp:1.6 Mon Nov 1 15:30:18 2004 +++ cl-store/xml-backend.lisp Wed Nov 10 11:43:16 2004 @@ -3,7 +3,7 @@
(in-package :cl-store-xml)
-(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 0)))
(eval-when (:compile-toplevel :load-toplevel :execute) (defvar *xml-backend*