- cl-store-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[cl-store-cvs] CVS update: cl-store/acl/.cvsignore
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store/acl In directory common-lisp.net:/tmp/cvs-serv7914 Added Files: .cvsignore Log Message: Added acl .cvsignore Date: Wed Nov 10 11:47:48 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv7159/sbcl Modified Files: custom.lisp Log Message: Changelog 2004-11-10 Date: Wed Nov 10 11:43:34 2004 Author: sross Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.2 cl-store/sbcl/custom.lisp:1.3 --- cl-store/sbcl/custom.lisp:1.2 Wed Oct 6 16:41:45 2004 +++ cl-store/sbcl/custom.lisp Wed Nov 10 11:43:33 2004 @@ -7,7 +7,7 @@ ;; Custom float storing (defstore-cl-store (obj float stream) - (output-type-code +float-code+ stream) + (output-type-code +float-code+ stream) (write-byte (float-type obj) stream) (etypecase obj (single-float (store-object (sb-kernel:single-float-bits obj) @@ -18,20 +18,21 @@ stream)))) (defun sbcl-restore-single-float (stream) - (sb-kernel:make-single-float (restore-object stream))) + (sb-kernel:make-single-float (the integer (restore-object stream)))) (defun sbcl-restore-double-float (stream) - (sb-kernel:make-double-float (restore-object stream) - (restore-object stream))) + (sb-kernel:make-double-float (the integer (restore-object stream)) + (the integer (restore-object stream)))) (defvar *sbcl-float-restorers* - (list (cons 0 'sbcl-restore-single-float) - (cons 1 'sbcl-restore-double-float))) + (list (cons 0 #'sbcl-restore-single-float) + (cons 1 #'sbcl-restore-double-float))) (defrestore-cl-store (float stream) (let ((byte (read-byte stream))) - (aif (cdr (assoc byte *sbcl-float-restorers*)) - (funcall it stream) + (declare (type (integer 0 1) byte)) + (aif (cdr (assoc byte *sbcl-float-restorers* :test #'=)) + (funcall (the function it) stream) (restore-error "Unknown float type designator ~S." byte))))

1 0

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv7159/doc Modified Files: cl-store.texi Log Message: Changelog 2004-11-10 Date: Wed Nov 10 11:43:27 2004 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.1 cl-store/doc/cl-store.texi:1.2 --- cl-store/doc/cl-store.texi:1.1 Mon Nov 1 15:49:03 2004 +++ cl-store/doc/cl-store.texi Wed Nov 10 11:43:26 2004 @@ -108,6 +108,7 @@ @item CLOS Classes @item Structure Instances @item Functions (where function-lambda-expression returns a symbol as a function name) +@item Generic Functions (stores generic-function-name) @end itemize @section Supported Implementations @@ -126,10 +127,8 @@ CL-STORE uses @uref{http://cliki.net/asdf,,asdf} as it's system definition tool and is required whenever you load the package. -You will need to download it, or if you have @uref{http://sbcl.org,,sbcl} try -@lisp -(require 'asdf) -@end lisp +You will need to download it, or if you have @uref{http://sbcl.org,,sbcl} +@lisp (require 'asdf) @end lisp @section Downloading @@ -137,9 +136,7 @@ @item ASDF-INSTALL CL-STORE is available through asdf-install. If you are new to Common Lisp this is the suggested download method. With asdf-install loaded run -@lisp -(asdf-install:install :cl-store) -@end lisp +@lisp (asdf-install:install :cl-store) @end lisp This will download and install the package for you. Asdf-install will try to verify that the package signature is correct and that you trust the author. If the key is not found or the trust level is not sufficient a continuable error will be signalled. @@ -163,9 +160,7 @@ @section Installing Once downloaded and symlinked you can load CL-STORE at anytime using -@lisp -(asdf:oos 'asdf:load-op :cl-store) -@end lisp +@lisp (asdf:oos 'asdf:load-op :cl-store) @end lisp This will compile CL-STORE the first time it is loaded. @section Testing @@ -711,9 +706,8 @@ @itemize @bullet @item CLISP, OpenMCL, Allegro CL cannot store structure instances. @item Structure definitions aren't supported. -@item Anything remotely funcallable isn't supported. @item MOP classes aren't supported. -@item Due to the fact that function's aren't supported CLOS Classes initfunction slot cannot be serialized. +@item Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized. @end itemize @node Credits

1 0

[cl-store-cvs] CVS update: cl-store/clisp/fix-clisp.lisp
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store/clisp In directory common-lisp.net:/tmp/cvs-serv7159/clisp Modified Files: fix-clisp.lisp Log Message: Changelog 2004-11-10 Date: Wed Nov 10 11:43:25 2004 Author: sross Index: cl-store/clisp/fix-clisp.lisp diff -u cl-store/clisp/fix-clisp.lisp:1.4 cl-store/clisp/fix-clisp.lisp:1.5 --- cl-store/clisp/fix-clisp.lisp:1.4 Mon Nov 1 15:30:32 2004 +++ cl-store/clisp/fix-clisp.lisp Wed Nov 10 11:43:23 2004 @@ -65,4 +65,9 @@ (setf (slot-value clos::object ',x) clos::new-value)))) (find-class class))) +(defmethod generic-function-name ((gf generic-function)) + (multiple-value-bind (l cp name) (function-lambda-expression gf) + (declare (ignore l cp)) + name)) + ;; EOF

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README cl-store/backends.lisp cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp cl-store/xml-backend.lisp
by Sean Ross 10 Nov '04

10 Nov '04

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv7159 Modified Files: ChangeLog README backends.lisp circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp utils.lisp xml-backend.lisp Log Message: Changelog 2004-11-10 Date: Wed Nov 10 11:43:17 2004 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.13 cl-store/ChangeLog:1.14 --- cl-store/ChangeLog:1.13 Mon Nov 1 15:49:00 2004 +++ cl-store/ChangeLog Wed Nov 10 11:43:16 2004 @@ -1,3 +1,19 @@ +2004-11-10 Sean Ross <sross(a)common-lisp.net> + New Version: 0.3.6 New Magic Number (Breaks backwards compatibility) + * default-backend.lisp: Storing for functions and generic functions. + * tests.lisp: Tests for functions and GF's. + * plumbing.lisp, circularities.lisp, default-backend.lisp: + Optimized int-sym-or-charp. + * clisp/fix-clisp.lisp: Added generic-function-name. + * package.lisp: Import generic-function-name. + * default-backend.lisp: More optimizations for strings and ints. + +2004-11-03 Sean Ross <sross(a)common-lisp.net> + * tests.lisp: Added tests for unicode strings and symbols. + * default-backend.lisp: We definitely support unicode now. + Added small optimization to stop the size of files from + ballooning. + 2004-11-01 Sean Ross <sross(a)common-lisp.net> * default-backend.lisp: Changed storing of sizes of integers and strings from store-32-bit to store-object. Changed all Index: cl-store/README diff -u cl-store/README:1.10 cl-store/README:1.11 --- cl-store/README:1.10 Mon Nov 1 15:30:18 2004 +++ cl-store/README Wed Nov 10 11:43:16 2004 @@ -1,7 +1,7 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.3.2 +Version: 0.3.6 0. About. CL-STORE is an portable serialization package which Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.3 cl-store/backends.lisp:1.4 --- cl-store/backends.lisp:1.3 Mon Nov 1 15:30:18 2004 +++ cl-store/backends.lisp Wed Nov 10 11:43:16 2004 @@ -7,7 +7,7 @@ ;; in default-backend.lisp and xml-backend.lisp (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 0))) (defun required-arg (name) @@ -45,6 +45,7 @@ ((,var ,type) ,stream (backend ,',class-name)) ,(format nil "Definition for storing an object of type ~A with ~ backend ~A" type ',name) +; (declare (optimize (speed 3) (safety 1) (debug 0))) ,@body)))) (defun get-restore-macro (name) @@ -52,7 +53,9 @@ (let ((macro-name (symbolicate 'defrestore- name))) `(defmacro ,macro-name ((type place) &body body) (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type))))) - `(flet ((,fn-name (,place) ,@body)) + `(flet ((,fn-name (,place) +; (declare (optimize (speed 3) (safety 1) (debug 0))) + ,@body)) (let* ((backend (find-backend ',',name)) (restorers (restorer-funs backend))) (when (gethash ',type restorers) Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.10 cl-store/circularities.lisp:1.11 --- cl-store/circularities.lisp:1.10 Mon Nov 1 15:30:18 2004 +++ cl-store/circularities.lisp Wed Nov 10 11:43:16 2004 @@ -19,7 +19,7 @@ ;; programs according to the Hyperspec(notes in EQ). (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 1))) (defvar *postfix-setters* '(gethash) "Setfable places which take the object to set after @@ -27,9 +27,8 @@ (defun get-setf-place (place obj) "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*." - (declare (type (or cons symbol) place)) (cond ((atom place) `(,place ,obj)) - ((member (car place) *postfix-setters*) + ((member (the symbol (car place)) *postfix-setters*) `(,@place ,obj)) (t `(,(car place) ,obj ,@(cdr place))))) @@ -48,52 +47,51 @@ (declare (ignore getting-key getting-value)) (error "setting-hash can only be used inside a resolving-object form.")) - (defmacro resolving-object (create &body body) "Execute body attempting to resolve circularities found in form CREATE." (with-gensyms (obj value key) `(macrolet ((setting (place getting) - (let ((setf-place (get-setf-place place ',obj))) - `(let ((,',value ,getting)) - (if (referrer-p ,',value) - (push (lambda () - (setf ,setf-place - (referred-value ,',value - *restored-values*))) - *need-to-fix*) - (setf ,setf-place ,',value))))) - (setting-hash (getting-key getting-place) - `(let ((,',key ,getting-key)) - (if (referrer-p ,',key) - (let ((,',value ,getting-place)) - (push (lambda () - (setf (gethash - (referred-value ,',key *restored-values*) - ,',obj) - (if (referrer-p ,',value) + (let ((setf-place (get-setf-place place ',obj))) + `(let ((,',value ,getting)) + (if (referrer-p ,',value) + (push #'(lambda () + (setf ,setf-place (referred-value ,',value - *restored-values*) - ,',value))) - *need-to-fix*)) - (setting (gethash ,',key) ,getting-place))))) - (let ((,obj ,create)) - ,@body - ,obj)))) + *restored-values*))) + *need-to-fix*) + (setf ,setf-place ,',value))))) + (setting-hash (getting-key getting-place) + `(let ((,',key ,getting-key)) + (if (referrer-p ,',key) + (let ((,',value ,getting-place)) + (push #'(lambda () + (setf (gethash + (referred-value ,',key *restored-values*) + ,',obj) + (if (referrer-p ,',value) + (referred-value ,',value + *restored-values*) + ,',value))) + *need-to-fix*)) + (setting (gethash ,',key) ,getting-place))))) + (let ((,obj ,create)) + ,@body + ,obj)))) (defstruct referrer val) (defun referred-value (referrer hash) "Return the value REFERRER is meant to be by looking in HASH." - (gethash (referrer-val referrer) ;(read-from-string (subseq (symbol-name referrer) 11)) + (gethash (referrer-val referrer) hash)) (defclass resolving-backend (backend) () (:documentation "A backend which does the setup for resolving circularities.")) -(declaim (type fixnum *stored-counter*)) +(declaim (type (or null fixnum) *stored-counter*)) (defvar *stored-counter*) (defvar *stored-values*) @@ -153,7 +151,7 @@ ;; Restoration. -(declaim (type fixnum *restore-counter*)) +(declaim (type (or null fixnum) *restore-counter*)) (defvar *restore-counter*) (defvar *need-to-fix*) (defvar *restored-values*) @@ -170,12 +168,10 @@ (dolist (fn *need-to-fix*) (funcall (the function fn)))))) -;; Change to backend-restore-object to allow support for -;; multiple return values. (defmethod backend-restore-object ((place t) (backend resolving-backend)) "Retrieve a object from PLACE, does housekeeping for circularity fixing." - (let ((reader (find-function-for-type place backend))) - (if (not (int-sym-or-char-p reader backend)) + (multiple-value-bind (reader sym) (find-function-for-type place backend) + (if (not (int-sym-or-char-p sym backend)) (let ((spot (incf *restore-counter*)) (vals (mapcar #'new-val (multiple-value-list (funcall (the function reader) @@ -186,16 +182,13 @@ (funcall (the function reader) place)))) + (defgeneric int-sym-or-char-p (fn backend) (:argument-precedence-order backend fn) (:method ((fn t) (backend t)) "Is function FN registered to restore an integer, character or symbol in BACKEND." - (let ((readers (restorer-funs backend))) - (or (eq fn (lookup-reader 'integer readers)) - (eq fn (lookup-reader 'character readers)) - (eq fn (lookup-reader 'symbol readers)))))) - + (member fn '(integer character symbol)))) (defun new-val (val) "Tries to get a referred value to reduce unnecessary cirularity fixing." Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.12 cl-store/cl-store.asd:1.13 --- cl-store/cl-store.asd:1.12 Mon Nov 1 15:30:18 2004 +++ cl-store/cl-store.asd Wed Nov 10 11:43:16 2004 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.3.2" + :version "0.3.6" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.10 cl-store/default-backend.lisp:1.11 --- cl-store/default-backend.lisp:1.10 Mon Nov 1 15:30:18 2004 +++ cl-store/default-backend.lisp Wed Nov 10 11:43:16 2004 @@ -5,13 +5,13 @@ (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 1))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cl-store-backend* - (defbackend cl-store :magic-number 1347643724 + (defbackend cl-store :magic-number 1349732684 :stream-type 'binary - :old-magic-numbers (1912923 1886611788 1347635532) + :old-magic-numbers (1912923 1886611788 1347635532 1347643724) :extends resolving-backend :fields ((restorers :accessor restorers :initform (make-hash-table))))) (defun register-code (code name &optional (errorp t)) @@ -24,6 +24,7 @@ ;; Type code constants (defconstant +referrer-code+ (register-code 1 'referrer nil)) (defconstant +values-code+ (register-code 2 'values-object nil)) +(defconstant +unicode-string-code+ (register-code 3 'unicode-string nil)) (defconstant +integer-code+ (register-code 4 'integer nil)) (defconstant +simple-string-code+ (register-code 5 'simple-string nil)) (defconstant +float-code+ (register-code 6 'float nil)) @@ -54,11 +55,11 @@ (defconstant +float-nan-code+ (register-code 25 'nan-float nil)) (defconstant +function-code+ (register-code 26 'function nil)) - +(defconstant +gf-code+ (register-code 27 'generic-function nil)) ;; setups for type code mapping (defun output-type-code (code stream) - (declare (type (mod 256) code)) + (declare (type ub32 code)) (write-byte (ldb (byte 8 0) code) stream)) (defun read-type-code (stream) @@ -77,43 +78,48 @@ ;; referrer, Required for a resolving backend (defmethod store-referrer (ref stream (backend cl-store-backend)) (output-type-code +referrer-code+ stream) - (store-32-bit ref stream)) + (dump-int ref stream)) (defrestore-cl-store (referrer stream) - (make-referrer :val (read-32-bit stream nil))) + (make-referrer :val (undump-int stream))) ;; integers ;; The theory is that most numbers will fit in 32 bits -;; so we try and cater for them +;; so we we have a little optimization for it ;; We need this for circularity stuff. (defmethod int-sym-or-char-p ((fn t) (backend cl-store-backend)) - (let ((readers (restorer-funs backend))) - (or (eq fn (lookup-reader 'integer readers)) - (eq fn (lookup-reader 'character readers)) - (eq fn (lookup-reader '32-bit-integer readers)) - (eq fn (lookup-reader 'symbol readers))))) + (member fn '(integer character 32-bit-integer symbol))) (defstore-cl-store (obj integer stream) - (if (typep obj '(signed-byte 32)) + (if (typep obj 'sb32) (store-32-bit-integer obj stream) (store-arbitrary-integer obj stream))) +(defun dump-int (obj stream) + (declare (type ub32 obj)) + (typecase obj + ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream)) + (t (write-byte 2 stream) (store-32-bit obj stream)))) + +(defun undump-int (stream) + (ecase (read-byte stream) + (1 (read-byte stream)) + (2 (read-32-bit stream nil)))) - - -;; Should be 32-bit (defun store-32-bit-integer (obj stream) + (declare (type sb32 obj)) (output-type-code +32-bit-integer-code+ stream) (write-byte (if (minusp obj) 1 0) stream) - (store-32-bit (abs obj) stream)) + (dump-int (abs obj) stream)) (defrestore-cl-store (32-bit-integer stream) - (funcall (if (zerop (read-byte stream)) #'+ #'-) - (read-32-bit stream nil))) + (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-) + (undump-int stream))) (defun store-arbitrary-integer (obj stream) + (declare (type integer obj) (stream stream)) (output-type-code +integer-code+ stream) (loop for n = (abs obj) then (ash n -32) for counter from 0 @@ -131,46 +137,14 @@ (defrestore-cl-store (integer buff) (let ((count (restore-object buff)) (result 0)) + (declare (type integer result count)) (loop repeat (abs count) do - (setf result (+ (ash result 32) (read-32-bit buff nil)))) + (setf result (the integer (+ (ash result 32) + (the ub32 (read-32-bit buff nil)))))) (if (minusp count) (- result) result))) - -;; Strings -;; If the string to be stored is of type simple-standard-string -;; we can write it down byte by byte. Otherwise we treat it as -;; an array. -(deftype simple-standard-string () - `(simple-array standard-char (*))) - -(defun output-simple-standard-string (obj stream) - (store-object (length obj) stream) - (loop for x across obj do - (write-byte (char-code x) stream))) - -(defun restore-simple-standard-string (stream) - (let* ((length (restore-object stream)) - (res (make-string length - #+lispworks :element-type #+lispworks 'character))) - (dotimes (x length) - (setf (schar res x) (code-char (read-byte stream)))) - res)) - -(defun store-simple-standard-string (string stream) - (output-type-code +simple-string-code+ stream) - (output-simple-standard-string string stream)) - - -(defstore-cl-store (obj string stream) - (if (typep obj 'simple-standard-string) - (store-simple-standard-string obj stream) - (store-array obj stream))) - -(defrestore-cl-store (simple-string stream) - (restore-simple-standard-string stream)) - ;; Floats ;; SBCL and CMUCL use a different mechanism for dealing ;; with floats which supports infinities. @@ -201,7 +175,8 @@ (store-object (denominator obj) stream)) (defrestore-cl-store (ratio stream) - (/ (restore-object stream) (restore-object stream))) + (/ (the integer (restore-object stream)) + (the integer (restore-object stream)))) ;; chars (defstore-cl-store (obj character stream) @@ -284,6 +259,7 @@ (size (restore-object stream)) (test (restore-object stream)) (count (restore-object stream))) + (declare (type integer count size)) (let ((hash (make-hash-table :test (symbol-function test) :rehash-size rehash-size :rehash-threshold rehash-threshold @@ -298,6 +274,8 @@ (restore-object stream)))) hash))) + +;; Object and Conditions (defun store-type-object (obj stream) (let* ((all-slots (remove-if-not (lambda (x) (slot-boundp obj (slot-definition-name x))) @@ -307,6 +285,7 @@ (remove-if #'(lambda (x) (eql (slot-definition-allocation x) :class)) all-slots)))) + (declare (type list slots)) (store-object (type-of obj) stream) (store-object (length slots) stream) (dolist (slot slots) @@ -328,6 +307,7 @@ (let* ((class (find-class (restore-object stream))) (length (restore-object stream)) (new-instance (allocate-instance class))) + (declare (type integer length)) (loop repeat length do (let ((slot-name (restore-object stream))) ;; slot-names are always symbols so we don't @@ -387,9 +367,14 @@ (defrestore-cl-store (built-in-class stream) (find-class (restore-object stream))) -;; arrays and vectors + + +;; Arrays and Vectors and Strings (defstore-cl-store (obj array stream) - (store-array obj stream)) + (typecase obj + (simple-string (store-simple-string obj stream)) + (simple-vector (store-simple-vector obj stream)) + (t (store-array obj stream)))) (defun store-array (obj stream) (output-type-code +array-code+ stream) @@ -418,6 +403,7 @@ :element-type element-type :adjustable adjustable :fill-pointer fill-pointer))) + (declare (type cons dimensions) (type array-size size)) (when displaced-to (adjust-array res dimensions :displaced-to displaced-to :displaced-index-offset displaced-offset)) @@ -427,29 +413,65 @@ (setting (row-major-aref pos) (restore-object stream))))) res)) - -;; clisp and allegro doesn't have the class simple-vector -#-(or clisp allegro) -(defstore-cl-store (obj simple-vector stream) +(defun store-simple-vector (obj stream) + (declare (type simple-vector obj)) (output-type-code +simple-vector-code+ stream) (let ((size (length obj))) (store-object size stream) (loop for x across obj do (store-object x stream)))) -#-(or clisp allegro) (defrestore-cl-store (simple-vector stream) (let* ((size (restore-object stream)) (res (make-array size))) + (declare (type array-size size)) (resolving-object res - (loop repeat size - for i from 0 do + (loop for i from 0 to (1- size) do ;; we need to copy the index so that ;; it's value is preserved for after the loop. (let ((x i)) (setting (aref x) (restore-object stream))))) res)) +;; Dumping (unsigned-byte 32) for each character seems +;; like a bit much when most of them will be +;; standard-chars. So we try to cater for them. +(defvar *char-marker* (code-char 255) + "Largest character that can be represented in 8 bits") + +(defun store-simple-string (obj stream) + (declare (type simple-string obj)) + ;; must be a better test than this. + (cond ((some #'(lambda (x) (char> x *char-marker*)) obj) + ;; contains wide characters + (output-type-code +unicode-string-code+ stream) + (dump-string #'dump-int obj stream)) + (t (output-type-code +simple-string-code+ stream) + (dump-string #'write-byte obj stream)))) + +(defun dump-string (dumper obj stream) + (declare (simple-string obj) (function dumper) (stream stream)) + ;(store-object (length obj) stream) + (dump-int (length obj) stream) + (loop for x across obj do (funcall dumper (char-code x) stream))) + +(defrestore-cl-store (simple-string stream) + (undump-string #'read-byte stream)) + +(defrestore-cl-store (unicode-string stream) + (undump-string #'undump-int stream)) + +(defun undump-string (reader stream) + (declare (type function reader) (type stream stream)) + (let* ((length (undump-int stream)) ;(restore-object stream)) + (res (make-string length + #+lispworks :element-type #+lispworks 'character))) + (dotimes (x length) + (setf (schar res x) (code-char (funcall reader stream)))) + res)) + + + ;; packages (defstore-cl-store (obj package stream) (output-type-code +package-code+ stream) @@ -472,16 +494,35 @@ ;; Function storing hack. ;; This just stores the function name if we can find it -;; or signals a store-error. +;; or signal a store-error. (defstore-cl-store (obj function stream) (output-type-code +function-code+ stream) (multiple-value-bind (l cp name) (function-lambda-expression obj) (declare (ignore l cp)) - (if (and name (symbolp name)) - (store-object name stream) - (store-error "Unable to determine function name for ~A." obj)))) + (cond ((and name (or (symbolp name) (consp name))) (store-object name stream)) + ;; Try to deal with sbcl's naming convention + ;; of built in functions + #+sbcl + ((and name (stringp name) (search "top level local call " name)) + (let ((new-name (subseq name 21))) + (when (not (string= new-name "")) + (handler-case (store-object (read-from-string new-name) stream) + (sb-ext:package-locked-error (c) + (declare (ignore c)) + (store-error "Unable to determine function name for ~A." obj)))))) + (t (store-error "Unable to determine function name for ~A." obj))))) (defrestore-cl-store (function stream) + (fdefinition (restore-object stream))) + +;; Generic function, just dumps the gf-name +(defstore-cl-store (obj generic-function stream) + (output-type-code +gf-code+ stream) + (aif (generic-function-name obj) + (store-object it stream) + (store-error "No generic function name for ~A." obj))) + +(defrestore-cl-store (generic-function stream) (fdefinition (restore-object stream))) (setf *default-backend* (find-backend 'cl-store)) Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.13 cl-store/package.lisp:1.14 --- cl-store/package.lisp:1.13 Mon Nov 1 15:30:18 2004 +++ cl-store/package.lisp Wed Nov 10 11:43:16 2004 @@ -12,7 +12,7 @@ #:cl-store-error #:store-error #:restore-error #:store #:restore #:backend-store #:store-backend-code #:store-object #:backend-store-object #:get-class-details #:get-array-values - #:check-stream-element-type #:restore #:backend-restore + #:restore #:backend-restore #:check-magic-number #:get-next-reader #:int-sym-or-char-p #:restore-object #:backend-restore-object #:cl-store #:defstore-cl-store #:defrestore-cl-store #:register-code @@ -28,6 +28,7 @@ #:store-32-bit #:read-32-bit) #+sbcl (:import-from #:sb-mop + #:generic-function-name #:slot-definition-name #:slot-value-using-class #:slot-boundp-using-class @@ -44,8 +45,9 @@ #:class-direct-superclasses #:class-slots #:ensure-class) - + #+cmu (:import-from #:pcl + #:generic-function-name #:slot-definition-name #:slot-value-using-class #:slot-boundp-using-class @@ -70,6 +72,7 @@ #:class-of) #+openmcl (:import-from #:openmcl-mop + #:generic-function-name #:slot-definition-name #:slot-value-using-class #:slot-boundp-using-class @@ -99,6 +102,7 @@ #+lispworks (:import-from #:clos #:slot-definition-name + #:generic-function-name #:slot-value-using-class #:slot-boundp-using-class #:slot-definition-allocation @@ -117,6 +121,7 @@ #+allegro (:import-from #:mop #:slot-definition-name + #:generic-function-name #:slot-value-using-class #:slot-boundp-using-class #:slot-definition-allocation Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.5 cl-store/plumbing.lisp:1.6 --- cl-store/plumbing.lisp:1.5 Mon Nov 1 15:30:18 2004 +++ cl-store/plumbing.lisp Wed Nov 10 11:43:16 2004 @@ -5,7 +5,7 @@ ;; (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 0))) (defvar *nuke-existing-classes* nil "Do we overwrite existing class definitions on restoration.") @@ -24,6 +24,7 @@ ;; store or restore will signal a store-error or a ;; restore-error respectively inside a handler-bind. (defun cl-store-report (condition stream) + (declare (stream stream)) (aif (caused-by condition) (format stream "~A" it) (apply #'format stream (format-string condition) @@ -92,15 +93,13 @@ (:documentation "Method wrapped by store, override this method for custom behaviour (see circularities.lisp).")) -(defun store-backend-code (stream backend) - "Store magic-number of BACKEND, when present, into STREAM." - (let ((code (magic-number backend))) - (when code - (ecase (stream-type backend) - (character (store-string-code code stream)) - (integer (store-32-bit code stream)))))) - - +(defgeneric store-backend-code (stream backend) + (:argument-precedence-order backend stream) + (:method ((stream t) (backend t)) + (let ((code (magic-number backend))) + (store-32-bit code stream))) + (:documentation + "Store magic-number of BACKEND, when present, into STREAM.")) (defun store-object (obj stream &optional (backend *current-backend*)) "Store OBJ into STREAM. Not meant to be overridden, @@ -136,10 +135,6 @@ :caused-by c))))) (backend-restore place backend))))) -(declaim (inline check-stream-element-type)) -(defun check-stream-element-type (stream) - (declare (ignore stream)) - nil) (defgeneric backend-restore (place backend) (:argument-precedence-order backend place) @@ -180,20 +175,23 @@ (defun (setf restore) (new-val place) (store new-val place)) -(defun check-magic-number (stream backend) - "Check to see if STREAM actually contains a stored object for BACKEND." - (let ((magic-number (magic-number backend))) - (when magic-number - (let ((val (ecase (stream-type backend) - (integer (read-32-bit stream nil)) - (character (retrieve-string-code stream))))) - (cond ((eql val magic-number) nil) - ((member val (old-magic-numbers backend)) - (restore-error "Stream contains an object stored with a ~ +(defgeneric check-magic-number (stream backend) + (:argument-precedence-order backend stream) + (:method ((stream t) (backend t)) + (let ((magic-number (magic-number backend))) + (declare (type ub32 magic-number)) + (when magic-number + (let ((val (read-32-bit stream nil))) + (declare (type ub32 val)) + (cond ((= val magic-number) nil) + ((member val (old-magic-numbers backend) :test #'=) + (restore-error "Stream contains an object stored with a ~ incompatible version of backend ~A." (name backend))) - (t (restore-error "Stream does not contain a stored object~ + (t (restore-error "Stream does not contain a stored object~ for backend ~A." - (name backend)))))))) + (name backend)))))))) + (:documentation + "Check to see if STREAM actually contains a stored object for BACKEND.")) (defun lookup-reader (val readers) (gethash val readers)) @@ -216,7 +214,7 @@ (:method (place backend) (multiple-value-bind (val info) (get-next-reader place backend) (let ((reader (lookup-reader val (restorer-funs backend)))) - (cond ((and val reader) reader) + (cond ((and val reader) (values reader val)) ((not val) (restore-error "~A is not registered with backend ~(~A~)." (or info "Unknown Type") (name backend))) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.9 cl-store/tests.lisp:1.10 --- cl-store/tests.lisp:1.9 Mon Nov 1 15:30:18 2004 +++ cl-store/tests.lisp Wed Nov 10 11:43:16 2004 @@ -95,6 +95,12 @@ (make-array 10 :initial-element #\f :element-type 'character :fill-pointer 3)) +#+(or (and sbcl sb-unicode) lispworks clisp acl) +(progn + (deftestit unicode.1 (map 'string #'code-char (list #X20AC #X3BB))) + (deftestit unicode.2 (intern (map 'string #'code-char (list #X20AC #X3BB)) + :cl-store-tests))) + ;; vectors (deftestit vector.1 #(1 2 3 4)) @@ -470,6 +476,19 @@ (let ((val (multiple-value-list (restore *test-file*)))) (eq (car val) (cadr val)))) t) + + +(deftestit function.1 #'restores) +(deftestit function.2 #'car) +(deftestit function.3 #'cl-store::get-setf-place) +#-(or clisp lispworks allegro openmcl) +(deftestit function.4 #'(setf car)) + +(deftestit gfunction.1 #'cl-store:restore) +(deftestit gfunction.2 #'cl-store:store) +#-(or clisp lispworks openmcl) +(deftestit gfunction.3 #'(setf cl-store:restore)) + (defun run-tests (backend) Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.6 cl-store/utils.lisp:1.7 --- cl-store/utils.lisp:1.6 Mon Nov 1 15:30:18 2004 +++ cl-store/utils.lisp Wed Nov 10 11:43:16 2004 @@ -3,7 +3,7 @@ ;; Miscellaneous utilities used throughout the package. (in-package :cl-store) -;;(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 1))) (defmacro aif (test then &optional else) @@ -47,15 +47,29 @@ (0 1.0) (1 1.0d0))) +(deftype ub32 () + `(unsigned-byte 32)) + +(deftype sb32 () + `(signed-byte 32)) + +(deftype array-size () + "The maximum size of an array" + `(integer 0 ,array-dimension-limit)) + (defun store-32-bit (obj stream) - "Write OBJ down STREAM as a 32 byte integer." + "Write OBJ down STREAM as a 32 bit integer." + (declare (ub32 obj)) (write-byte (ldb (byte 8 0) obj) stream) (write-byte (ldb (byte 8 8) obj) stream) (write-byte (ldb (byte 8 16) obj) stream) (write-byte (+ 0 (ldb (byte 8 24) obj)) stream)) +(defmacro make-ub32 (a b c d) + `(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d))) + (defun read-32-bit (buf &optional (signed t)) "Read a signed or unsigned byte off STREAM." (let ((byte1 (read-byte buf)) @@ -63,7 +77,7 @@ (byte3 (read-byte buf)) (byte4 (read-byte buf))) (declare (type (mod 256) byte1 byte2 byte3 byte4)) - (let ((ret (+ byte1 (* 256 (+ byte2 (* 256 (+ byte3 (* 256 byte4)))))))) + (let ((ret (make-ub32 byte4 byte3 byte2 byte1))) (if (and signed (> byte1 127)) (logior (ash -1 32) ret) ret)))) @@ -71,7 +85,7 @@ (defun store-string-code (string stream) "Write length of STRING then STRING into stream" - (declare (type simple-string string)) + (declare (simple-string string) (stream stream)) (format stream "~S" string)) (defun retrieve-string-code (stream) Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.6 cl-store/xml-backend.lisp:1.7 --- cl-store/xml-backend.lisp:1.6 Mon Nov 1 15:30:18 2004 +++ cl-store/xml-backend.lisp Wed Nov 10 11:43:16 2004 @@ -3,7 +3,7 @@ (in-package :cl-store-xml) -(declaim (optimize (speed 3) (safety 0) (debug 0))) +(declaim (optimize (speed 3) (safety 1) (debug 0))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *xml-backend*

1 0

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv28500/doc Added Files: cl-store.texi Log Message: Added acl and new docs. Date: Mon Nov 1 15:49:04 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/acl/custom.lisp
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/acl In directory common-lisp.net:/tmp/cvs-serv28500/acl Added Files: custom.lisp Log Message: Added acl and new docs. Date: Mon Nov 1 15:49:01 2004 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv28500 Modified Files: ChangeLog Log Message: Added acl and new docs. Date: Mon Nov 1 15:49:00 2004 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.12 cl-store/ChangeLog:1.13 --- cl-store/ChangeLog:1.12 Mon Nov 1 15:30:18 2004 +++ cl-store/ChangeLog Mon Nov 1 15:49:00 2004 @@ -3,9 +3,11 @@ and strings from store-32-bit to store-object. Changed all instances of store-32-byte to store-32-bit. Added a simple function storing method. + New Magic Number * docs/cl-store.texi: New documentation. + * lispworks/custom.lisp: Custom storing for conditions + to ignore class allocated slots. - 2004-10-21 Sean Ross <sross(a)common-lisp.net> * package.lisp, acl/custom.lisp: Added support for Allegro CL.

1 0

[cl-store-cvs] CVS update: Directory change: cl-store/acl
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/acl In directory common-lisp.net:/tmp/cvs-serv27571/acl Log Message: Directory /project/cl-store/cvsroot/cl-store/acl added to the repository Date: Mon Nov 1 15:44:20 2004 Author: sross New directory cl-store/acl added

1 0

[cl-store-cvs] CVS update: cl-store/lispworks/custom.lisp
by Sean Ross 01 Nov '04

01 Nov '04

Update of /project/cl-store/cvsroot/cl-store/lispworks In directory common-lisp.net:/tmp/cvs-serv26326/lispworks Modified Files: custom.lisp Log Message: Removed old documentation, added new docs. Date: Mon Nov 1 15:32:02 2004 Author: sross Index: cl-store/lispworks/custom.lisp diff -u cl-store/lispworks/custom.lisp:1.3 cl-store/lispworks/custom.lisp:1.4 --- cl-store/lispworks/custom.lisp:1.3 Wed Oct 13 14:36:03 2004 +++ cl-store/lispworks/custom.lisp Mon Nov 1 15:32:02 2004 @@ -84,4 +84,30 @@ (setting (slot-value slot-name) (restore-object stream))))) new-instance)) + +;; Condition in lispworks have a reporter-function slot +;; which is sometimes a function (as opposed to a symbol) +;; Fortunately these slots are class allocated so +;; we ignore reporter functions and use make-condition +;; to reconstruct our object. +(defstore-cl-store (obj condition stream) + (output-type-code +condition-code+ stream) + (let ((*store-class-slots* nil)) + (store-type-object obj stream))) + + +(defrestore-cl-store (condition stream) + (let* ((class (find-class (restore-object stream))) + (length (restore-object stream)) + (new-instance (make-condition class))) + (loop repeat length do + (let ((slot-name (restore-object stream))) + ;; slot-names are always symbols so we don't + ;; have to worry about circularities + (resolving-object new-instance + (setting (slot-value slot-name) (restore-object stream))))) + new-instance)) + + + ;; EOF

1 0