[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