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