[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
Sean Ross
sross at common-lisp.net
Fri May 6 14:19:31 UTC 2005
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 <sross at common-lisp.net>
+ * 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 <sross at common-lisp.net>
* 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 <sdr at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
- :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)))
More information about the Cl-store-cvs
mailing list