From sross at common-lisp.net Thu May 5 12:58:56 2005 From: sross at common-lisp.net (Sean Ross) Date: Thu, 5 May 2005 14:58:56 +0200 (CEST) Subject: [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 cl-store/tests.lisp cl-store/utils.lisp Message-ID: <20050505125856.23BEB8871F@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv11637 Modified Files: ChangeLog circularities.lisp cl-store.asd default-backend.lisp plumbing.lisp tests.lisp utils.lisp Log Message: ChangeLog 2005-05-05 Date: Thu May 5 14:58:54 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.30 cl-store/ChangeLog:1.31 --- cl-store/ChangeLog:1.30 Thu Mar 24 09:29:48 2005 +++ cl-store/ChangeLog Thu May 5 14:58:54 2005 @@ -1,8 +1,15 @@ +2005-05-05 Sean Ross + * all: After much experimentation with Lispworks I + discovered that globally declaiming unsafe code is + not a good idea. Changed to per function declarations. + * default-backend.lisp: Removed lispworks unicode string + test as it was incorrect. + 2005-03-24 Sean Ross * backends.lisp, circularities.lisp, tests.lisp: Added test gensym.2 which crashed in previous versions (pre 0.5.7). Symbols are now tested - for equality when storing. + for eq-ality when storing. int-sym-or-char-p renamed to int-or-char-p. * plumbing.lisp: Added error to the superclasses of restore-error and store-error. Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.20 cl-store/circularities.lisp:1.21 --- cl-store/circularities.lisp:1.20 Thu Mar 24 09:29:48 2005 +++ cl-store/circularities.lisp Thu May 5 14:58:54 2005 @@ -19,7 +19,6 @@ ;; programs according to the Hyperspec(notes in EQ). (in-package :cl-store) -(declaim (optimize speed (debug 0) (safety 1))) (defvar *check-for-circs* t) @@ -97,6 +96,7 @@ (defmethod backend-store ((backend resolving-backend) (place stream) (obj t)) "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*))) (store-backend-code backend place) @@ -105,11 +105,13 @@ (defun seen (obj) "Has this object already been stored?" + (declare (optimize speed (safety 0) (debug 0))) (incf *stored-counter*) (gethash obj *stored-values*)) (defun update-seen (obj) "Register OBJ as having been stored." + (declare (optimize speed (safety 0) (debug 0))) (setf (gethash obj *stored-values*) *stored-counter*) nil) @@ -130,6 +132,7 @@ (defun get-ref (obj) + (declare (optimize speed (safety 0) (debug 0))) (if (needs-checkp obj) (multiple-value-bind (val win) (seen obj) (if (or val win) @@ -164,9 +167,11 @@ (force fn))))) (defun update-restored (spot val) + (declare (optimize speed (safety 0) (debug 0))) (setf (gethash spot *restored-values*) val)) (defun handle-normal (backend reader place) + (declare (optimize speed (safety 1) (debug 0))) (let ((spot (incf *restore-counter*)) (vals (new-val (internal-restore-object backend reader place)))) (update-restored spot vals) @@ -175,6 +180,7 @@ (defgeneric referrerp (backend reader)) (defun handle-restore (place backend) + (declare (optimize speed (safety 1) (debug 0))) (multiple-value-bind (reader) (get-next-reader backend place) (declare (type symbol reader)) (cond ((referrerp backend reader) @@ -186,6 +192,7 @@ (defmethod backend-restore-object ((backend resolving-backend) (place stream)) "Retrieve a object from PLACE, does housekeeping for circularity fixing." + (declare (optimize speed (safety 1) (debug 0))) (if *check-for-circs* (handle-restore place backend) (call-next-method))) @@ -204,6 +211,7 @@ (defun new-val (val) "Tries to get a referred value to reduce unnecessary cirularity fixing." + (declare (optimize speed (safety 1) (debug 0))) (if (referrer-p val) (multiple-value-bind (new-val win) (referred-value val *restored-values*) (if (or new-val win) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.27 cl-store/cl-store.asd:1.28 --- cl-store/cl-store.asd:1.27 Thu Mar 24 09:25:17 2005 +++ cl-store/cl-store.asd Thu May 5 14:58:54 2005 @@ -40,9 +40,9 @@ :name "CL-STORE" :author "Sean Ross " :maintainer "Sean Ross " - :version "0.5.8" + :version "0.5.9" :description "Serialization package" - :long-description "Portable CL Package to serialize data types" + :long-description "Portable CL Package to serialize data" :licence "MIT" :components ((:file "package") (:non-required-file "mop" :depends-on ("package")) Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.26 cl-store/default-backend.lisp:1.27 --- cl-store/default-backend.lisp:1.26 Thu Mar 24 09:25:17 2005 +++ cl-store/default-backend.lisp Thu May 5 14:58:54 2005 @@ -4,8 +4,6 @@ ;; The cl-store backend. (in-package :cl-store) -(declaim (optimize speed (debug 0) (safety 1))) - (defbackend cl-store :magic-number 1349740876 :stream-type '(unsigned-byte 8) :old-magic-numbers (1912923 1886611788 1347635532 1886611820 @@ -69,6 +67,7 @@ (declare (type ub32 code)) (write-byte (ldb (byte 8 0) code) stream)) +(declaim (inline read-type-code)) (defun read-type-code (stream) (read-byte stream)) @@ -84,6 +83,7 @@ (gethash code *restorers*)) (defmethod get-next-reader ((backend cl-store) (stream stream)) + (declare (optimize speed)) (let ((type-code (read-type-code stream))) (or (lookup-code type-code) (error "Type code ~A is not registered." type-code)))) @@ -107,30 +107,31 @@ (find type '(integer character 32-bit-integer))) (defstore-cl-store (obj integer stream) + (declare (optimize speed (safety 1) (debug 0))) (if (typep obj 'sb32) (store-32-bit-integer obj stream) (store-arbitrary-integer obj stream))) (defun dump-int (obj stream) - (declare (optimize speed)) + (declare (optimize speed (safety 0) (debug 0))) (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) - (declare (optimize speed)) + (declare (optimize speed (safety 0) (debug 0))) (ecase (read-byte stream) (1 (read-byte stream)) (2 (read-32-bit stream nil)))) (defun store-32-bit-integer (obj stream) - (declare (optimize speed) (type sb32 obj)) + (declare (optimize speed (safety 1) (debug 0)) (type sb32 obj)) (output-type-code +32-bit-integer-code+ stream) (write-byte (if (minusp obj) 1 0) stream) (dump-int (abs obj) stream)) (defrestore-cl-store (32-bit-integer stream) - (declare (optimize speed)) + (declare (optimize speed (safety 1) (debug 0))) (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-) (undump-int stream))) @@ -167,6 +168,7 @@ (defvar *special-floats* nil) (defstore-cl-store (obj float stream) + (declare (optimize speed)) (block body (let (significand exponent sign) (handler-bind ((simple-error @@ -250,6 +252,7 @@ ;; symbols (defstore-cl-store (obj symbol stream) + (declare (optimize speed)) (cond ((symbol-package obj) (output-type-code +symbol-code+ stream) (store-object (symbol-name obj) stream) @@ -269,6 +272,7 @@ ;; 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)) @@ -301,6 +305,7 @@ ;; hash tables (defstore-cl-store (obj hash-table stream) + (declare (optimize speed)) (output-type-code +hash-table-code+ stream) (store-object (hash-table-rehash-size obj) stream) (store-object (hash-table-rehash-threshold obj) stream) @@ -335,6 +340,7 @@ ;; 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))) @@ -361,6 +367,7 @@ (store-type-object obj stream)) (defun restore-type-object (stream) + (declare (optimize speed)) (let* ((class (find-class (restore-object stream))) (length (restore-object stream)) (new-instance (allocate-instance class))) @@ -429,12 +436,14 @@ ;; Arrays, vectors and strings. (defstore-cl-store (obj array stream) + (declare (optimize speed (safety 1) (debug 0))) (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) + (declare (optimize speed (safety 1) (debug 0))) (output-type-code +array-code+ stream) (if (and (= (array-rank obj) 1) (array-has-fill-pointer-p obj)) @@ -450,6 +459,7 @@ (store-object (row-major-aref obj x) stream))) (defrestore-cl-store (array stream) + (declare (optimize speed (safety 1) (debug 0))) (let* ((fill-pointer (restore-object stream)) (element-type (restore-object stream)) (adjustable (restore-object stream)) @@ -471,7 +481,8 @@ (setting (row-major-aref obj pos) (restore-object stream))))))) (defun store-simple-vector (obj stream) - (declare (type simple-vector obj)) + (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) @@ -479,6 +490,7 @@ (store-object x stream)))) (defrestore-cl-store (simple-vector stream) + (declare (optimize speed (safety 1) (debug 0))) (let* ((size (restore-object stream)) (res (make-array size))) (declare (type array-size size)) @@ -498,13 +510,14 @@ (defun unicode-string-p (string) "An implementation specific test for a unicode string." - #+lispworks (typep string 'lw:16-bit-string) - #+cmu nil - #-(or lispworks cmu) (some #'(lambda (x) (char> x *char-marker*)) string)) + (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)) (defun store-simple-string (obj stream) (declare (type simple-string obj) - (optimize speed)) + (optimize speed (safety 1) (debug 0))) (cond ((unicode-string-p obj) (output-type-code +unicode-string-code+ stream) (dump-string #'dump-int obj stream)) @@ -513,7 +526,7 @@ (defun dump-string (dumper obj stream) (declare (simple-string obj) (function dumper) (stream stream) - (optimize speed)) + (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))) @@ -528,10 +541,11 @@ (defun undump-string (reader stream) (declare (type function reader) (type stream stream) - (optimize speed)) + (optimize speed (safety 1) (debug 0))) (let* ((length (the array-size (undump-int stream)) ) (res (make-string length #+lispworks :element-type #+lispworks 'character))) + (declare (type simple-string res)) (dotimes (x length) (setf (schar res x) (code-char (funcall reader stream)))) res)) @@ -550,7 +564,7 @@ (store-object (external-symbols obj) stream)) (defun remove-remaining (times stream) - (declare (type fixnum times)) + (declare (optimize speed) (type fixnum times)) (dotimes (x times) (restore-object stream))) @@ -616,7 +630,7 @@ (cond ((and name (or (symbolp name) (consp name))) (store-object name stream)) ;; Try to deal with sbcl's naming convention - ;; of built in functions + ;; of built in functions (pre 0.9) #+sbcl ((and name (stringp name) (search "top level local call " Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.14 cl-store/plumbing.lisp:1.15 --- cl-store/plumbing.lisp:1.14 Thu Mar 24 09:25:17 2005 +++ cl-store/plumbing.lisp Thu May 5 14:58:54 2005 @@ -6,8 +6,6 @@ (in-package :cl-store) -(declaim (optimize speed (debug 0) (safety 1))) - (defvar *store-used-packages* nil "If non-nil will serialize each used package otherwise will only store the package name") @@ -62,7 +60,8 @@ ;; entry points (defun store-to-file (obj place backend) - (declare (type backend backend)) + (declare (type backend backend) + (optimize speed)) (let* ((element-type (stream-type backend))) (with-open-file (s place :element-type element-type :direction :output :if-exists :supersede) @@ -72,6 +71,7 @@ (:documentation "Entry Point for storing objects.") (: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)) @@ -84,6 +84,7 @@ (:method ((backend backend) (place stream) (obj t)) "The default. Checks the streams element-type, stores the backend code and calls store-object." + (declare (optimize speed)) (store-backend-code backend place) (store-object obj place backend) obj) @@ -98,6 +99,7 @@ (defgeneric store-backend-code (backend stream) (:method ((backend backend) (stream t)) + (declare (optimize speed)) (awhen (magic-number backend) (store-32-bit it stream))) (:documentation @@ -115,6 +117,7 @@ (see circularities.lisp for an example).") (:method ((backend backend) (obj t) (stream t)) "The default, just calls internal-store-object." + (declare (optimize speed)) (internal-store-object backend obj stream))) @@ -132,6 +135,7 @@ overridden, use backend-restore instead") (:method (place &optional (designator *default-backend*)) "Entry point for restoring objects (setfable)." + (declare (optimize speed)) (let* ((backend (backend-designator->backend designator)) (*current-backend* backend) (*read-eval* nil)) @@ -146,6 +150,7 @@ (:method ((backend backend) (place stream)) "Restore the object found in stream PLACE using backend BACKEND. Checks the magic-number and invokes backend-restore-object" + (declare (optimize speed)) (check-magic-number backend place) (backend-restore-object backend place)) (:method ((backend backend) (place string)) @@ -156,6 +161,7 @@ (restore-from-file place backend))) (defun restore-from-file (place backend) + (declare (optimize speed)) (let* ((element-type (stream-type backend))) (with-open-file (s place :element-type element-type :direction :input) (backend-restore backend s)))) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.19 cl-store/tests.lisp:1.20 --- cl-store/tests.lisp:1.19 Thu Mar 24 09:25:17 2005 +++ cl-store/tests.lisp Thu May 5 14:58:54 2005 @@ -15,7 +15,6 @@ (or (and (numberp val) (= val restored)) (and (stringp val) (string= val restored)) (and (characterp val) (char= val restored)) - (eq val restored) (eql val restored) (equal val restored) (equalp val restored)))) @@ -170,7 +169,7 @@ (deftest gensym.2 (let ((x (gensym))) (store (list x x) *test-file*) (let ((new (restore *test-file*))) - (eq (car new) (cadr new)))) + (eql (car new) (cadr new)))) t) @@ -351,14 +350,14 @@ (setf (cdr (last x)) x))) (deftest circ.1 (progn (store circ1 *test-file*) (let ((x (restore *test-file*))) - (eq (cddddr x) x))) + (eql (cddddr x) x))) t) (defvar circ2 (let ((x (list 2 3 4 4 5))) (setf (second x) x))) (deftest circ.2 (progn (store circ2 *test-file*) (let ((x (restore *test-file*))) - (eq (second x) x))) + (eql (second x) x))) t) @@ -372,8 +371,8 @@ (deftest circ.3 (progn (store circ3 *test-file*) (let ((x (restore *test-file*))) - (and (eq (second x) (car x)) - (eq (cdddr x) x)))) + (and (eql (second x) (car x)) + (eql (cdddr x) x)))) t) @@ -385,9 +384,9 @@ (deftest circ.4 (progn (store circ4 *test-file*) (let ((x (restore *test-file*))) - (and (eq (gethash 'first x) + (and (eql (gethash 'first x) (gethash 'second x)) - (eq x + (eql x (gethash 'inner (gethash 'first x)))))) t) @@ -396,7 +395,7 @@ (setf (get-y circ5) circ5) (store circ5 *test-file*) (let ((x (restore *test-file*))) - (eq x (get-y x)))) + (eql x (get-y x)))) t) @@ -411,8 +410,8 @@ (deftest circ.6 (progn (store circ6 *test-file*) (let ((x (restore *test-file*))) - (and (eq (aref x 1 1 1) x) - (eq (aref x 0 0 0) (aref x 1 1 1))))) + (and (eql (aref x 1 1 1) x) + (eql (aref x 0 0 0) (aref x 1 1 1))))) t) @@ -423,7 +422,7 @@ #+(or sbcl cmu lispworks) (deftest circ.7 (progn (store circ7 *test-file*) (let ((x (restore *test-file*))) - (eq (a-a x) x))) + (eql (a-a x) x))) t) (defvar circ.8 (let ((x "foo")) @@ -435,7 +434,7 @@ #-clisp (deftest circ.8 (progn (store circ.8 *test-file*) (let ((x (restore *test-file*))) - (eq (pathname-name x) + (eql (pathname-name x) (pathname-type x)))) t) @@ -445,8 +444,8 @@ (setf (aref val 4) (aref val 0)) (store val *test-file*) (let ((rest (restore *test-file*))) - (and (eq rest (aref rest 3)) - (eq (aref rest 4) (aref rest 0))))) + (and (eql rest (aref rest 3)) + (eql (aref rest 4) (aref rest 0))))) t) (deftest circ.10 (let* ((a1 (make-array 5)) @@ -457,7 +456,7 @@ (setf (aref a3 1) a3) (store a3 *test-file*) (let ((ret (restore *test-file*))) - (eq a3 (aref a3 1)))) + (eql a3 (aref a3 1)))) t) (defvar circ.11 (let ((x (make-hash-table))) @@ -466,7 +465,7 @@ (deftest circ.11 (progn (store circ.11 *test-file*) (let ((val (restore *test-file*))) - (eq val (gethash val val)))) + (eql val (gethash val val)))) t) (deftest circ.12 (let ((x #(1 2 "foo" 4 5))) @@ -474,8 +473,8 @@ (setf (aref x 1) (aref x 2)) (store x *test-file*) (let ((ret (restore *test-file*))) - (and (eq (aref ret 0) ret) - (eq (aref ret 1) (aref ret 2))))) + (and (eql (aref ret 0) ret) + (eql (aref ret 1) (aref ret 2))))) t) (defclass foo.1 () @@ -489,8 +488,8 @@ (setf (foo1-a bar) foo) (store (list foo) *test-file*) (let ((ret (car (restore *test-file*)))) - (and (eq ret (foo1-a (foo1-a ret))) - (eq (foo1-a ret) + (and (eql ret (foo1-a (foo1-a ret))) + (eql (foo1-a ret) (foo1-a (foo1-a (foo1-a ret))))))) t) @@ -530,7 +529,7 @@ (*check-for-circs* nil)) (store list *test-file*) (let ((res (restore *test-file*))) - (and (not (eq (car res) (cdr res))) + (and (not (eql (car res) (cdr res))) (string= (car res) (cdr res))))) t) Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.15 cl-store/utils.lisp:1.16 --- cl-store/utils.lisp:1.15 Tue Mar 15 10:59:39 2005 +++ cl-store/utils.lisp Thu May 5 14:58:54 2005 @@ -16,6 +16,7 @@ (apply #'append (apply #'mapcar fn lsts))) (defgeneric serializable-slots (object) + (declare (optimize speed)) (:documentation "Return a list of slot-definitions to serialize. The default is to call serializable-slots-using-class with the object @@ -31,6 +32,7 @@ ; unfortunately the metaclass of conditions in sbcl and cmu ; are not standard-class (defgeneric serializable-slots-using-class (object class) + (declare (optimize speed)) (:documentation "Return a list of slot-definitions to serialize. The default calls compute slots with class") (:method ((object t) (class standard-class)) @@ -48,6 +50,7 @@ ; Generify get-slot-details for customization (from Thomas Stenhaug) (defgeneric get-slot-details (slot-definition) + (declare (optimize speed)) (:documentation "Return a list of slot details which can be used as an argument to ensure-class") @@ -97,7 +100,7 @@ (defun store-32-bit (obj stream) "Write OBJ down STREAM as a 32 bit integer." - (declare (optimize speed (debug 0) (safety 1)) + (declare (optimize speed (debug 0) (safety 0)) (type sb32 obj)) (let ((obj (logand #XFFFFFFFF obj))) (write-byte (ldb (byte 8 0) obj) stream) @@ -110,7 +113,7 @@ (defun read-32-bit (buf &optional (signed t)) "Read a signed or unsigned byte off STREAM." - (declare (optimize speed (debug 0) (safety 1))) + (declare (optimize speed (debug 0) (safety 0))) (let ((byte1 (read-byte buf)) (byte2 (read-byte buf)) (byte3 (read-byte buf)) From sross at common-lisp.net Thu May 5 12:58:57 2005 From: sross at common-lisp.net (Sean Ross) Date: Thu, 5 May 2005 14:58:57 +0200 (CEST) Subject: [cl-store-cvs] CVS update: cl-store/clisp/mop.lisp Message-ID: <20050505125857.DC84088720@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/clisp In directory common-lisp.net:/tmp/cvs-serv11637/clisp Modified Files: mop.lisp Log Message: ChangeLog 2005-05-05 Date: Thu May 5 14:58:56 2005 Author: sross Index: cl-store/clisp/mop.lisp diff -u cl-store/clisp/mop.lisp:1.1 cl-store/clisp/mop.lisp:1.2 --- cl-store/clisp/mop.lisp:1.1 Tue Feb 1 09:27:38 2005 +++ cl-store/clisp/mop.lisp Thu May 5 14:58:56 2005 @@ -2,7 +2,6 @@ ;; See the file LICENCE for licence information. (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) ;; this is such a pain. From sross at common-lisp.net Thu May 5 12:58:59 2005 From: sross at common-lisp.net (Sean Ross) Date: Thu, 5 May 2005 14:58:59 +0200 (CEST) Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp Message-ID: <20050505125859.F284F8873B@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv11637/sbcl Modified Files: custom.lisp Log Message: ChangeLog 2005-05-05 Date: Thu May 5 14:58:57 2005 Author: sross Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.7 cl-store/sbcl/custom.lisp:1.8 --- cl-store/sbcl/custom.lisp:1.7 Thu Feb 17 09:23:54 2005 +++ cl-store/sbcl/custom.lisp Thu May 5 14:58:57 2005 @@ -96,6 +96,7 @@ (sb-kernel::class-method-definitions info))) (defun create-make-foo (dd) + (declare (optimize speed)) (funcall (compile nil `(lambda () ,@(sbcl-struct-defs dd)))) (find-class (dd-name dd))) From sross at common-lisp.net Thu May 5 13:02:30 2005 From: sross at common-lisp.net (Sean Ross) Date: Thu, 5 May 2005 15:02:30 +0200 (CEST) Subject: [cl-store-cvs] CVS update: cl-store/README Message-ID: <20050505130230.89D568871F@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv12595 Modified Files: README Log Message: ChangeLog 2005-05-05 Date: Thu May 5 15:02:29 2005 Author: sross Index: cl-store/README diff -u cl-store/README:1.15 cl-store/README:1.16 --- cl-store/README:1.15 Thu Mar 24 09:46:32 2005 +++ cl-store/README Thu May 5 15:02:29 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.8 +Version: 0.5.9 0. About. CL-STORE is an portable serialization package which From sross at common-lisp.net Fri May 6 14:19:31 2005 From: sross at common-lisp.net (Sean Ross) Date: Fri, 6 May 2005 16:19:31 +0200 (CEST) Subject: [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 Message-ID: <20050506141931.C118888716@common-lisp.net> 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 + * 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 * 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 " :maintainer "Sean Ross " - :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))) From sross at common-lisp.net Fri May 6 14:19:31 2005 From: sross at common-lisp.net (Sean Ross) Date: Fri, 6 May 2005 16:19:31 +0200 (CEST) Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi Message-ID: <20050506141931.114AF88729@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv11930/doc Modified Files: cl-store.texi Log Message: Changelog 2005-05-06 Date: Fri May 6 16:19:31 2005 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.10 cl-store/doc/cl-store.texi:1.11 --- cl-store/doc/cl-store.texi:1.10 Thu Mar 24 09:25:20 2005 +++ cl-store/doc/cl-store.texi Fri May 6 16:19:30 2005 @@ -211,7 +211,7 @@ @anchor{Variable *store-used-packages*} @vindex *store-used-packages* @deftp {Variable} *store-used-packages* @emph{Default NIL} -The variable determines the how packages on a package use +The variable determines how packages on a package use list will be serialized. If non-nil the the package will be fully serialized, otherwise only the name will be stored. @end deftp @@ -278,8 +278,9 @@ @anchor{Function find-backend} - at deffn {Function} find-backend name -Returns the backend named by @emph{name} or nil if it does not exist. + at deffn {Function} find-backend name &optional (errorp nil) +Return backup called @emph{name}. If there is no such backend NIL is returned +if @emph{errorp} is false, otherwise an error is signalled. @end deffn @anchor{Function caused-by} @@ -380,7 +381,7 @@ Registers @emph{name} under the code @emph{code} into the cl-store-backend. The backend will use this mapping when restoring values. Will signal an error if code is already registered and @emph{errorp} is not NIL. -Currently codes 1 through 33 are in use. +Currently codes 1 through 35 are in use. @end deffn @anchor{Function output-type-code} @@ -754,6 +755,16 @@ @item Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized. @end itemize + + at section Regarding String Serialization +Users are required to be extremely careful when serializing strings from one +lisp implementation to another since the array-element-type will be tracked +for strings and the Hyperspec does not specify an upper limit for base-chars. +This can be a problem if you serialize a simple-base-string containing wide +characters, in an implementation which specifies no limit on base-char, +to an implementation with a limit. +If you have a solution I would be happy to hear it. + @node Credits @chapter Credits Thanks To @@ -762,6 +773,7 @@ @item Alain Picard : Structure Storing and support for Infinite Floats for Lispworks. @item Robert Sedgewick: Package Imports for OpenMCL and suggesting Multiple Backends. @item Thomas Stenhaug: Comprehensive package storing and miscellaneous improvements. + at item Killian Sprotte: Type specification fixups. @end itemize @node Index From sross at common-lisp.net Wed May 18 15:34:13 2005 From: sross at common-lisp.net (Sean Ross) Date: Wed, 18 May 2005 17:34:13 +0200 (CEST) Subject: [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 Message-ID: <20050518153413.1B35D88740@common-lisp.net> 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 + * 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 * 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)) , at 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)))) - , at body))) + `(let* ((*default-backend* (backend-designator->backend ,backend))) + , at 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 " :maintainer "Sean Ross " - :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 , at body))) +(defmacro when-let ((var test) &body body) + `(let ((,var ,test)) + (when ,var + , at 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