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