Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv6976
Modified Files: ChangeLog README circularities.lisp cl-store.asd package.lisp store.lisp tests.lisp utils.lisp Log Message: Changelog 2004-05-21
Date: Fri May 21 10:14:40 2004 Author: sross
Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.2 cl-store/ChangeLog:1.3 --- cl-store/ChangeLog:1.2 Tue May 18 10:56:27 2004 +++ cl-store/ChangeLog Fri May 21 10:14:39 2004 @@ -1,3 +1,10 @@ +2004-05-21 Sean Ross sdr@jhb.ucs.co.za + * store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp + tests.lisp, utils.lisp, cl-store.asd: + Added ability to specify the type code of an object + when using defstore. Added code to autogenerate the + accessor methods for CLISP when restoring classes. + EQ floats are now restored correctly. 2004-05-18 Sean Ross sdr@jhb.ucs.co.za * store.lisp, fix-clisp.lisp, sbcl/sockets.lisp: Added fix for sbcl to use non-blocking IO when working with sockets.
Index: cl-store/README diff -u cl-store/README:1.1 cl-store/README:1.2 --- cl-store/README:1.1 Tue May 18 10:56:27 2004 +++ cl-store/README Fri May 21 10:14:40 2004 @@ -18,9 +18,6 @@ Otherwise symlink cl-store.asd to somewhere on asdf:*central-registry* and run (asdf:oos 'asdf:load-op :cl-store).
- If you cannot use asdf just compile and load each file in the - order you see them appearing in cl-store.asd - Run (asdf:oos 'asdf:test-op :cl-store) to make sure that everything works. Running these tests will try to load the RT package, which is asdf-installable. @@ -44,11 +41,24 @@ 3. Extending CL-STORE is more or less extensible. Using defstore and defrestore allows you to customize the storing and restoring of your own classes. - For examples see the last couple of tests in tests.lisp. - + contrived eg. + + (defclass random () ((a :accessor a :initarg :a))) + + (defstore (obj random buffer) + (store-object (a obj) buffer)) + + (defrestore (random buff) + (random (restore-object buff))) + + (store (make-instance 'random :a 10) "/tmp/random") + + (restore "/tmp/random") + => ; some number from 0 to 9 +
4. Issues - There are a number of issues with CL-STORE as it stands (0.1.1). + There are a number of issues with CL-STORE as it stands (0.1.2).
- Functions, closures and anything remotely funcallable is unserializable. - MOP classes are largely unsupported at the moment. @@ -56,11 +66,8 @@ - Structure definitions aren't supported at all. - The code for resolving object circularities is a touch dodgy, hopefully a better way will be found at some point. - - CLISP's ensure-class-using-class does not create accessors for - the created class. It all seems to be done in the defclass expansion. - - EQ floating point numbers aren't restored correctly. - No documentation. - - CL-STORE uses read-sequence to pull values out of stream. Unfortunately + - CL-STORE uses read-sequence to pull values out of streams. Unfortunately read-sequence doesn't just block but waits until the entire buffer is filled. As a quick workaround the evil variable *full-write* was created to force write-sequence to write the entire buffer
Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.2 cl-store/circularities.lisp:1.3 --- cl-store/circularities.lisp:1.2 Tue May 18 10:56:27 2004 +++ cl-store/circularities.lisp Fri May 21 10:14:40 2004 @@ -7,6 +7,7 @@ (defvar *stored-values* nil) (declaim (type fixnum *stored-counter*)) (defvar *stored-counter* 0) +(defvar *seen-while-fixing* nil)
(defun referrerp (sym) @@ -20,24 +21,31 @@ hash))
+(defgeneric innner-fix-circularities (hash obj))
-(defgeneric fix-circularities (hash obj)) +(defun fix-circularities (val1 val2 ) + (aif (gethash val2 *seen-while-fixing*) + nil + (progn (setf (gethash val2 *seen-while-fixing*) t) + (inner-fix-circularities val1 val2)))) +
;; hash tables and objects require some extra fiddling. -(defmethod fix-circularities ((hash hash-table) (obj hash-table)) +(defmethod inner-fix-circularities ((hash hash-table) (obj hash-table)) (fix-circularities hash nil) (loop for key being the hash-keys of obj for val being the hash-values of obj do + (fix-circularities hash key) (fix-circularities hash val) (when (referrerp val) (setf (gethash key obj) (referred-value val hash)))))
-(defmethod fix-circularities ((hash hash-table) (obj standard-class)) +(defmethod inner-fix-circularities ((hash hash-table) (obj standard-class)) nil)
-(defmethod fix-circularities ((hash hash-table) (obj standard-object)) +(defmethod inner-fix-circularities ((hash hash-table) (obj standard-object)) (fix-circularities hash nil) (dolist (slot (mapcar #'slot-definition-name (class-slots (class-of obj)))) @@ -47,7 +55,7 @@ (setf (slot-value obj slot) (referred-value (slot-value obj slot) hash))))))
-(defmethod fix-circularities ((hash hash-table) (obj structure-object)) +(defmethod inner-fix-circularities ((hash hash-table) (obj structure-object)) (fix-circularities hash nil) (dolist (slot (mapcar #'slot-definition-name (class-slots (class-of obj)))) @@ -58,7 +66,7 @@ (referred-value (slot-value obj slot) hash))))))
-(defmethod fix-circularities ((hash hash-table) obj) +(defmethod inner-fix-circularities ((hash hash-table) obj) (loop for counter from 1 to (hash-table-count hash) do (let ((ref (gethash counter hash)) changed) @@ -131,9 +139,7 @@ (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) (not (or (typep obj 'integer) (symbolp obj) - (characterp obj) - (floatp obj)))) - + (characterp obj))))
;; instead of constructing symbols here we rather ;; just return a second value indicating we have
Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.2 cl-store/cl-store.asd:1.3 --- cl-store/cl-store.asd:1.2 Tue May 18 10:56:27 2004 +++ cl-store/cl-store.asd Fri May 21 10:14:40 2004 @@ -34,14 +34,14 @@ :name "Store" :author "Sean Ross sdr@jhb.ucs.co.za" :maintainer "Sean Ross sdr@jhb.ucs.co.za" - :version "0.1.1" + :version "0.1.2" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" :components ((:file "package") - (:non-required-file "fix-clisp" :depends-on ("package")) (:file "fast-io" :depends-on ("package")) (:file "utils" :depends-on ("fast-io")) + (:non-required-file "fix-clisp" :depends-on ("package")) (:file "circularities" :depends-on ("utils")) (:file "store" :depends-on ("circularities")) (:non-required-file "sockets" :depends-on ("store")))
Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.2 cl-store/package.lisp:1.3 --- cl-store/package.lisp:1.2 Tue May 18 10:56:27 2004 +++ cl-store/package.lisp Fri May 21 10:14:40 2004 @@ -15,6 +15,7 @@ :store-executable :store-object :restore-object + :register-code :flush :fill-buffer :make-buffer
Index: cl-store/store.lisp diff -u cl-store/store.lisp:1.2 cl-store/store.lisp:1.3 --- cl-store/store.lisp:1.2 Tue May 18 10:56:27 2004 +++ cl-store/store.lisp Fri May 21 10:14:40 2004 @@ -10,8 +10,6 @@ ===== - Add some sort of EOF mechanism.
-- fix up circularity stuff so that eq floats are restored correctly. - - add support for working directly with an implementations sockets and maybe support for acl-compat. Done for sbcl. @@ -69,7 +67,7 @@ (in-package :cl-store)
(defvar +store-magic-number+ 1912923) -(defvar *registered-types* (make-hash-table)) +(defvar *registered-types* ()) (defvar *registered-type-counter* 0) (defvar *restore-funs* (make-hash-table)) (defvar *nuke-existing-classes* nil @@ -109,7 +107,8 @@ (*to-eval* nil) (obj (restore-object place))) (when *need-to-fix* - (fix-circularities *stored-values* obj)) + (let ((*seen-while-fixing* (make-hash-table))) + (fix-circularities *stored-values* obj))) (dolist (x *to-eval*) (eval x)) obj)))
@@ -184,6 +183,7 @@ (logior (ash -1 32) ret) ret))))
+ (defun store-32byte (obj buf) "Write OBJ down STREAM as a 32 byte integer." (write-buf-byte (ldb (byte 8 0) obj) buf) @@ -192,22 +192,44 @@ (write-buf-byte (+ 0 (ldb (byte 8 24) obj)) buf))
-(defun register-code (type) - (aif (gethash type *registered-types*) - it - (setf-it (incf *registered-type-counter*)))) +(defun output-type-code (code buf) + (write-buf-byte (ldb (byte 8 0) code) buf) + (write-buf-byte (ldb (byte 8 8) code) buf)) + +(defun read-type-code (buf) + (let* ((byte1 (read-buf-byte buf)) + (byte2 (read-buf-byte buf))) + (+ byte1 (* 256 byte2)))) + + +(defun lookup-type (type) + (cdr (assoc type *registered-types*))) + +(defun lookup-code (code) + (car (rassoc code *registered-types*))) + +(defun register-code (type &optional code ) + (cond ((lookup-type type) (lookup-type type)) + ((and code (lookup-code code)) + (error "Code ~S is already being used" code)) + (t (let ((code (or code (incf *registered-type-counter*)))) + (setf *registered-types* + (acons type code *registered-types*)) + code)))) +
-(defmacro defstore ((var type buffer &rest method-args) &body body) +(defmacro defstore ((var type buffer &key qualifier type-code) &body body) "Defines method store-object specialized on TYPE. BODY is executed with VAR and STREAM bound to the value to be serialized and the output stream respectively. When present METHOD-ARGS are used as qualifers to the generated method." (with-gensyms (code) - `(let ((,code (register-code ',type))) + `(let ((,code (register-code ',type ,type-code))) (declare (ignorable ,code)) - (defmethod internal-store-object ,@method-args ((,var ,type) ,buffer) - ,@(unless method-args - `((write-buf-byte ,code ,buffer))) + (defmethod internal-store-object ,@(if qualifier (list qualifier) nil) + ((,var ,type) ,buffer) + ,@(unless qualifier + `((output-type-code ,code ,buffer))) ,@body))))
(defmacro defrestore ((type buff) &body body) @@ -216,7 +238,7 @@ ;; than an anonymous function. `(flet ((,fn-name (,buff) ,@body)) - (let ((type-code (or (gethash ',type *registered-types*) + (let ((type-code (or (lookup-type ',type) (error "Cannot define a restorer for this type.")))) (when (gethash type-code *restore-funs*) (warn "Redefining restorer for type ~S ." ',type)) @@ -224,22 +246,25 @@ #',fn-name)))))
+;; According to the notes for eq in the CLHS, +;; Common Lisp makes no guarantee that eq is true even when both +;; its arguments are the 'same thing' if that thing is a character or number. +;; but we attempt to handle it for anything thats not an integer. (defun integer-or-symbolp (code) - (member code `(,(gethash 'integer *registered-types*) - ,(gethash 'symbol *registered-types*) - ,(gethash 'character *registered-types*) - ,(gethash 'float *registered-types*)))) + (member code `(,(lookup-type 'integer) + ,(lookup-type 'symbol) + ,(lookup-type 'character))))
(defun restore-object (buff) "Reads a byte from buffer and calls the appropriate restorer for the type returned or throws an error" - (let* ((val (read-buf-byte buff)) + (let* ((val (read-type-code buff)) (restorer (gethash val *restore-funs*))) (if restorer (if (not (integer-or-symbolp val)) (setf (gethash (incf *stored-counter*) *stored-values*) (multiple-value-bind (x referrerp) - (funcall (the function restorer) buff) + (multiple-value-call #'new-val (funcall (the function restorer) buff)) (cond (referrerp (setf *need-to-fix* t) (ref-name x)) @@ -249,9 +274,17 @@ :datum "No restore defined for type ~S." :args val))))
+(defun new-val (val &optional referrerp) + "Tries to get a referred value to reduce unnecessary cirularity fixing." + (if referrerp + (aif (gethash val *stored-values*) + it + (values val referrerp)) + val)) + (let ((code (register-code 'referrer))) (defun store-referrer (obj buff) - (write-buf-byte code buff) + (output-type-code code buff) (store-32byte obj buff)))
(defrestore (referrer buff) @@ -270,7 +303,7 @@ ;; store non-return (let ((code (register-code 'non-return))) (defun store-non-return (obj buff) - (write-buf-byte code buff) + (output-type-code code buff) (store-object obj buff)))
(defrestore (non-return buff) @@ -281,7 +314,7 @@
(let ((code (register-code 'executable))) (defun store-executable (obj buff) - (write-buf-byte code buff) + (output-type-code code buff) (store-object obj buff)))
(defrestore (executable buff) @@ -322,7 +355,7 @@ (let ((length (length obj))) (store-32byte length buff) (loop for x across obj do - (write-buf-byte (char-code x) buff)))) + (store-32byte (char-code x) buff))))
#-clisp (defstore (obj simple-string buff) @@ -334,7 +367,7 @@ (let* ((length (read-32-byte buff nil)) (res (make-string length))) (loop for x from 1 to length do - (setf (aref res (1- x)) (code-char (read-buf-byte buff)))) + (setf (aref res (1- x)) (code-char (read-32-byte buff)))) res))
#-clisp @@ -516,14 +549,16 @@ #+lispworks :default-initargs :direct-slots :direct-superclasses :metaclass)) - (final (apply #'append (mapcar #'list - keywords - (cdr vals))))) - (if (find-class (car vals) nil) - (if *nuke-existing-classes* - (apply #'ensure-class (car vals) final) - (find-class (car vals))) - (apply #'ensure-class (car vals) final)))) + (final (mappend #'list keywords (cdr vals))) + (class (car vals))) + (cond ((find-class class nil) + (cond (*nuke-existing-classes* + (apply #'ensure-class class final) + #+clisp (add-methods-for-class class (third vals))) + (t (find-class class)))) + (t (apply #'ensure-class class final) + #+clisp (add-methods-for-class class (third vals)))))) +
;; built in classes @@ -536,7 +571,7 @@ ;; just in case it is not built in (cmucl, sbcl, lispworks) (let ((code (register-code 'built-in-class))) (defmethod internal-store-object ((obj (eql (find-class 'hash-table))) buff) - (write-buf-byte code buff) + (output-type-code code buff) (store-object 'cl:hash-table buff)))
Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.2 cl-store/tests.lisp:1.3 --- cl-store/tests.lisp:1.2 Tue May 18 10:56:27 2004 +++ cl-store/tests.lisp Fri May 21 10:14:40 2004 @@ -2,7 +2,7 @@ ;; See the file LICENCE for licence information.
(defpackage :cl-store-tests - (:use :cl :rt :cl-store)) + (:use :cl :regression-test :cl-store))
(in-package :cl-store-tests)
@@ -303,7 +303,7 @@ (defclass foobar ()()) (defclass barfoo ()())
-(defstore (obj foobar buff :before) +(defstore (obj foobar buff :qualifier :before) (store-executable '(incf *count*) buff))
(deftest executable.1 @@ -316,7 +316,7 @@ (defvar *hash* (make-hash-table))
-(defstore (obj barfoo buff :before) +(defstore (obj barfoo buff :qualifier :before) (store-executable `(let ((foo *hash*)) (setf (gethash 1 foo) ,obj) @@ -348,9 +348,22 @@ (equal "foo" (x (restore *test-file*)))) t)
+(defclass random-obj () ((size :accessor size :initarg :size))) + +(defstore (obj random-obj buff :type-code 10232) + (store-object (size obj) buff)) + +(defrestore (random-obj buff) + (random (restore-object buff))) + +(deftest custom.2 + (progn (store (make-instance 'random-obj :size 5) *test-file*) + (typep (restore *test-file*) '(integer 0 4))) + t) +
(defun run-tests () - (rt:do-tests) + (regression-test:do-tests) (when (probe-file *test-file*) (delete-file *test-file*)))
Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.1.1.1 cl-store/utils.lisp:1.2 --- cl-store/utils.lisp:1.1.1.1 Mon May 17 11:41:24 2004 +++ cl-store/utils.lisp Fri May 21 10:14:40 2004 @@ -13,6 +13,10 @@ `(let ,(mapcar #'(lambda (x) `(,x (gensym))) names) ,@body))
+(defun mappend (fn &rest lsts) + (apply #'append (apply #'mapcar fn lsts))) + + (defvar *store-class-slots* t "Whether or not to serialize class allocation slots.")