From sross at common-lisp.net Mon Sep 17 18:32:16 2007 From: sross at common-lisp.net (sross) Date: Mon, 17 Sep 2007 14:32:16 -0400 (EDT) Subject: [cl-store-cvs] CVS cl-store/allegrocl Message-ID: <20070917183216.0866D450C9@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/allegrocl In directory clnet:/tmp/cvs-serv1114/allegrocl Log Message: Directory /project/cl-store/cvsroot/cl-store/allegrocl added to the repository From sross at common-lisp.net Mon Sep 17 18:40:04 2007 From: sross at common-lisp.net (sross) Date: Mon, 17 Sep 2007 14:40:04 -0400 (EDT) Subject: [cl-store-cvs] CVS cl-store Message-ID: <20070917184004.0FB07450CB@common-lisp.net> 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 + * 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 * 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 " :maintainer "Sean Ross " - :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 From sross at common-lisp.net Mon Sep 17 18:40:04 2007 From: sross at common-lisp.net (sross) Date: Mon, 17 Sep 2007 14:40:04 -0400 (EDT) Subject: [cl-store-cvs] CVS cl-store/acl Message-ID: <20070917184004.917BF490A0@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/acl In directory clnet:/tmp/cvs-serv1189/acl Removed Files: custom.lisp Log Message: faster (simple-array (unsigned-byte 8) (*)) storing. Thanks to Chris Dean more lenient parsing of sbcl version. Thanks to Gustavo From sross at common-lisp.net Mon Sep 17 18:40:05 2007 From: sross at common-lisp.net (sross) Date: Mon, 17 Sep 2007 14:40:05 -0400 (EDT) Subject: [cl-store-cvs] CVS cl-store/allegrocl Message-ID: <20070917184005.566C05832F@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/allegrocl In directory clnet:/tmp/cvs-serv1189/allegrocl Added Files: custom.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/allegrocl/custom.lisp 2007/09/17 18:40:04 NONE +++ /project/cl-store/cvsroot/cl-store/allegrocl/custom.lisp 2007/09/17 18:40:04 1.1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. (in-package :cl-store) (defun setup-special-floats () (flet ((short-float-values () (list (cons #.excl::*infinity-single* +short-float-inf+) (cons #.excl::*negative-infinity-single* +short-float-neg-inf+) (cons #.excl::*nan-single* +short-float-nan+))) (single-float-values () (list (cons #.excl::*infinity-single* +single-float-inf+) (cons #.excl::*negative-infinity-single* +single-float-neg-inf+) (cons #.excl::*nan-single* +single-float-nan+))) (double-float-values () (list (cons #.excl::*infinity-double* +double-float-inf+) (cons #.excl::*negative-infinity-double* +double-float-neg-inf+) (cons #.excl::*nan-double* +double-float-nan+))) (long-float-values () (list (cons #.excl::*infinity-double* +long-float-inf+) (cons #.excl::*negative-infinity-double* +long-float-neg-inf+) (cons #.excl::*nan-double* +long-float-nan+)))) (setf *special-floats* (append (short-float-values) (single-float-values) (double-float-values) (long-float-values))))) ;; EOF From sross at common-lisp.net Mon Sep 17 18:40:09 2007 From: sross at common-lisp.net (sross) Date: Mon, 17 Sep 2007 14:40:09 -0400 (EDT) Subject: [cl-store-cvs] CVS cl-store/sbcl Message-ID: <20070917184009.975266B565@common-lisp.net> Update of /project/cl-store/cvsroot/cl-store/sbcl In directory clnet:/tmp/cvs-serv1189/sbcl Modified Files: custom.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/sbcl/custom.lisp 2006/12/14 18:15:43 1.13 +++ /project/cl-store/cvsroot/cl-store/sbcl/custom.lisp 2007/09/17 18:40:05 1.14 @@ -85,13 +85,30 @@ (funcall (compile nil `(lambda () ,@(sbcl-struct-defs dd)))) (find-class (dd-name dd))) +;;; with apologies to christophe rhodes ... +;; takes a source location as a third argument. +(eval-when (:compile-toplevel) + (defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end)))))))) + ;; From 0.9.6.25 sb-kernel::%defstruct ;; takes a source location as a third argument. (eval-when (:compile-toplevel) (labels ((make-version (string) (map-into (make-list 4 :initial-element 0) - #'parse-integer - (asdf::split string nil '(#\.)))) + #'(lambda (part) + (parse-integer part :junk-allowed t)) + (split string nil '(#\.)))) (version>= (v1 v2) (loop for x in (make-version v1) for y in (make-version v2)