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 sross@common-lisp.net + * 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 sross@common-lisp.net * 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 sdr@jhb.ucs.co.za" :maintainer "Sean Ross sdr@jhb.ucs.co.za" - :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))