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.")