[cl-store-cvs] CVS cl-store
sross
sross at common-lisp.net
Mon Sep 17 18:40:04 UTC 2007
Update of /project/cl-store/cvsroot/cl-store
In directory clnet:/tmp/cvs-serv1189
Modified Files:
ChangeLog cl-store.asd default-backend.lisp package.lisp
plumbing.lisp tests.lisp
Log Message:
faster (simple-array (unsigned-byte 8) (*)) storing. Thanks to Chris Dean
more lenient parsing of sbcl version. Thanks to Gustavo
--- /project/cl-store/cvsroot/cl-store/ChangeLog 2007/01/26 15:02:24 1.48
+++ /project/cl-store/cvsroot/cl-store/ChangeLog 2007/09/17 18:40:02 1.49
@@ -1,3 +1,8 @@
+2007-09-17 Sean Ross <sross at common-lisp.net>
+ * sbcl/custom.lisp: be lenient when parsing parts of sbcls version string. Thanks to Gustavo.
+ * default-backend.lisp: faster serializing of (simple-array
+ unsigned-byte 8). Thanks to Chris Dean
+
2007-01-26 Sean Ross <sross at common-lisp.net>
* default-backend.lisp : Checked in a fix for non sb32 integers, certain
large number numbers where incorrectly serialize.
--- /project/cl-store/cvsroot/cl-store/cl-store.asd 2007/01/23 15:37:17 1.43
+++ /project/cl-store/cvsroot/cl-store/cl-store.asd 2007/09/17 18:40:02 1.44
@@ -20,7 +20,7 @@
(defun lisp-system-shortname ()
#+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl
- #+allegro :acl #+ecl :ecl #+openmcl :openmcl #+abcl :abcl)
+ #+allegro :allegrocl #+ecl :ecl #+openmcl :openmcl #+abcl :abcl)
(defmethod component-pathname ((component non-required-file))
(let ((pathname (call-next-method))
@@ -45,7 +45,7 @@
:name "CL-STORE"
:author "Sean Ross <sross at common-lisp.net>"
:maintainer "Sean Ross <sross at common-lisp.net>"
- :version "0.7.9"
+ :version "0.7.12"
:description "Serialization package"
:long-description "Portable CL Package to serialize data"
:licence "MIT"
--- /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/01/26 15:02:24 1.39
+++ /project/cl-store/cvsroot/cl-store/default-backend.lisp 2007/09/17 18:40:02 1.40
@@ -43,6 +43,7 @@
(defparameter +array-code+ (register-code 19 'array))
(defparameter +simple-vector-code+ (register-code 20 'simple-vector))
(defparameter +package-code+ (register-code 21 'package))
+(defparameter +simple-byte-vector-code+ (register-code 22 'simple-byte-vector))
;; fast storing for 32 bit ints
(defparameter +32-bit-integer-code+ (register-code 24 '32-bit-integer))
@@ -220,7 +221,7 @@
(declare (optimize speed))
(block body
(let (significand exponent sign)
- (handler-bind (((or simple-error arithmetic-error)
+ (handler-bind (((or simple-error arithmetic-error type-error)
#'(lambda (err)
(declare (ignore err))
(when-let (type (cdr (assoc obj *special-floats*)))
@@ -513,6 +514,7 @@
(simple-base-string (store-simple-base-string obj stream))
(simple-string (store-simple-string obj stream))
(simple-vector (store-simple-vector obj stream))
+ ((simple-array (unsigned-byte 8) (*)) (store-simple-byte-vector obj stream))
(t (store-array obj stream))))
@@ -533,6 +535,9 @@
(loop for x from 0 below (array-total-size obj) do
(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))
@@ -576,6 +581,27 @@
(setting (aref obj x) (restore-object stream)))))
res))
+(defun store-simple-byte-vector (obj stream)
+ (declare (optimize speed (safety 0) (debug 0))
+ (type (simple-array (unsigned-byte 8) (*)) obj))
+ (output-type-code +simple-byte-vector-code+ stream)
+ (store-object (length obj) stream)
+ (loop for x across obj do
+ (write-byte x stream)))
+
+(defrestore-cl-store (simple-byte-vector stream)
+ (declare (optimize speed (safety 1) (debug 0)))
+ (let* ((size (restore-object stream))
+ (res (make-array size :element-type '(unsigned-byte 8))))
+ (declare (type array-size size))
+ (resolving-object (obj res)
+ (dotimes (i size)
+ ;; we need to copy the index so that
+ ;; it's value at this time is preserved.
+ (let ((x i))
+ (setting (aref obj x) (read-byte stream)))))
+ res))
+
;; Dumping (unsigned-byte 32) for each character seems
;; like a bit much when most of them will be
;; base-chars. So we try to cater for them.
--- /project/cl-store/cvsroot/cl-store/package.lisp 2007/01/26 15:02:24 1.27
+++ /project/cl-store/cvsroot/cl-store/package.lisp 2007/09/17 18:40:02 1.28
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;; See the file LICENCE for licence information.
-(in-package :cl-store.system)
+;(in-package :cl-store.system)
(defpackage #:cl-store
(:use #:cl)
--- /project/cl-store/cvsroot/cl-store/plumbing.lisp 2007/01/22 17:59:20 1.20
+++ /project/cl-store/cvsroot/cl-store/plumbing.lisp 2007/09/17 18:40:02 1.21
@@ -105,7 +105,6 @@
(:documentation
"Store magic-number of BACKEND, when present, into STREAM."))
-(declaim (inline store-object))
(defun store-object (obj stream &optional (backend *current-backend*))
"Store OBJ into STREAM. Not meant to be overridden,
use backend-store-object instead"
@@ -204,10 +203,11 @@
;; Wrapper for backend-restore-object so we don't have to pass
;; a backend object around all the time
-(declaim (inline restore-object))
-(defun restore-object (place &optional (backend *current-backend*))
- "Restore the object in PLACE using BACKEND"
- (backend-restore-object backend place))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun restore-object (place &optional (backend *current-backend*))
+ "Restore the object in PLACE using BACKEND"
+ (backend-restore-object backend place)))
(defgeneric backend-restore-object (backend place)
(:documentation
--- /project/cl-store/cvsroot/cl-store/tests.lisp 2007/01/26 15:02:25 1.32
+++ /project/cl-store/cvsroot/cl-store/tests.lisp 2007/09/17 18:40:03 1.33
@@ -126,6 +126,11 @@
(deftestit vector.6 #())
+;; (array octect (*))
+
+(deftestit vector.octet.1 (make-array 10 :element-type '(unsigned-byte 8)))
+
+
;; arrays
(deftestit array.1
(make-array '(2 2) :initial-contents '((1 2) (3 4))))
@@ -507,6 +512,7 @@
(eql (aref ret 1) (aref ret 2)))))
t)
+
(defclass foo.1 ()
((a :accessor foo1-a)))
@@ -644,8 +650,6 @@
(f-x new-obj) (f-y new-obj) (f-z new-obj)))))
(t t t 3 2 "Z"))
-
-
(deftest serialization-unit.1
(with-serialization-unit ()
(with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
@@ -663,5 +667,7 @@
(when (probe-file *test-file*)
(ignore-errors (delete-file *test-file*))))
+(run-tests 'cl-store:cl-store)
+
;; EOF
More information about the Cl-store-cvs
mailing list