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@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@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@common-lisp.net" :maintainer "Sean Ross sross@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