From sross at common-lisp.net Mon May 17 15:37:50 2004 From: sross at common-lisp.net (Sean Ross) Date: Mon, 17 May 2004 11:37:50 -0400 Subject: [cl-store-cvs] CVS update: Module imported: import Message-ID: Update of /project/cl-store/cvsroot/import In directory common-lisp.net:/tmp/cvs-serv31232 Log Message: Initial Status: Vendor Tag: of Release Tags: cl-store clstore sross start N import/fast-io.lisp N import/.cvsignore N import/ChangeLog N import/LICENCE N import/cl-store.asd N import/fix-clisp.lisp N import/package.lisp N import/store.lisp N import/tests.lisp N import/utils.lisp N import/circularities.lisp No conflicts created by this import Date: Mon May 17 11:37:49 2004 Author: sross New module import added From sross at common-lisp.net Mon May 17 15:38:05 2004 From: sross at common-lisp.net (Sean Ross) Date: Mon, 17 May 2004 11:38:05 -0400 Subject: [cl-store-cvs] CVS update: Module imported: import Message-ID: Update of /project/cl-store/cvsroot/import In directory common-lisp.net:/tmp/cvs-serv32152 Log Message: Initial Status: Vendor Tag: of Release Tags: cl-store clstore sross start U import/fast-io.lisp U import/.cvsignore U import/ChangeLog U import/LICENCE U import/cl-store.asd U import/fix-clisp.lisp U import/package.lisp U import/store.lisp U import/tests.lisp U import/utils.lisp U import/circularities.lisp No conflicts created by this import Date: Mon May 17 11:38:05 2004 Author: sross New module import added From sross at common-lisp.net Mon May 17 15:41:26 2004 From: sross at common-lisp.net (Sean Ross) Date: Mon, 17 May 2004 11:41:26 -0400 Subject: [cl-store-cvs] CVS update: Module imported: cl-store Message-ID: Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv3296 Log Message: Initial import of cl-store Status: Vendor Tag: sross Release Tags: start N cl-store/fast-io.lisp N cl-store/.cvsignore N cl-store/ChangeLog N cl-store/LICENCE N cl-store/cl-store.asd N cl-store/fix-clisp.lisp N cl-store/package.lisp N cl-store/store.lisp N cl-store/tests.lisp N cl-store/utils.lisp N cl-store/circularities.lisp No conflicts created by this import Date: Mon May 17 11:41:26 2004 Author: sross New module cl-store added From sross at common-lisp.net Tue May 18 14:52:20 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:52:20 -0400 Subject: [cl-store-cvs] CVS update: Directory change: cl-store/cmucl Message-ID: Update of /project/cl-store/cvsroot/cl-store/cmucl In directory common-lisp.net:/tmp/cvs-serv24240/cmucl Log Message: Directory /project/cl-store/cvsroot/cl-store/cmucl added to the repository Date: Tue May 18 10:52:20 2004 Author: sross New directory cl-store/cmucl added From sross at common-lisp.net Tue May 18 14:52:20 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:52:20 -0400 Subject: [cl-store-cvs] CVS update: Directory change: cl-store/lispworks Message-ID: Update of /project/cl-store/cvsroot/cl-store/lispworks In directory common-lisp.net:/tmp/cvs-serv24240/lispworks Log Message: Directory /project/cl-store/cvsroot/cl-store/lispworks added to the repository Date: Tue May 18 10:52:20 2004 Author: sross New directory cl-store/lispworks added From sross at common-lisp.net Tue May 18 14:52:20 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:52:20 -0400 Subject: [cl-store-cvs] CVS update: Directory change: cl-store/clisp Message-ID: Update of /project/cl-store/cvsroot/cl-store/clisp In directory common-lisp.net:/tmp/cvs-serv24240/clisp Log Message: Directory /project/cl-store/cvsroot/cl-store/clisp added to the repository Date: Tue May 18 10:52:20 2004 Author: sross New directory cl-store/clisp added From sross at common-lisp.net Tue May 18 14:52:21 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:52:21 -0400 Subject: [cl-store-cvs] CVS update: Directory change: cl-store/sbcl Message-ID: Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv24240/sbcl Log Message: Directory /project/cl-store/cvsroot/cl-store/sbcl added to the repository Date: Tue May 18 10:52:20 2004 Author: sross New directory cl-store/sbcl added From sross at common-lisp.net Tue May 18 14:56:29 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:56:29 -0400 Subject: [cl-store-cvs] CVS update: cl-store/clisp/fix-clisp.lisp Message-ID: Update of /project/cl-store/cvsroot/cl-store/clisp In directory common-lisp.net:/tmp/cvs-serv6337/clisp Added Files: fix-clisp.lisp Log Message: Changelog 2004-05-18 Date: Tue May 18 10:56:29 2004 Author: sross From sross at common-lisp.net Tue May 18 14:56:29 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:56:29 -0400 Subject: [cl-store-cvs] CVS update: cl-store/sbcl/sockets.lisp Message-ID: Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv6337/sbcl Added Files: sockets.lisp Log Message: Changelog 2004-05-18 Date: Tue May 18 10:56:29 2004 Author: sross From sross at common-lisp.net Tue May 18 14:56:29 2004 From: sross at common-lisp.net (Sean Ross) Date: Tue, 18 May 2004 10:56:29 -0400 Subject: [cl-store-cvs] CVS update: cl-store/README cl-store/ChangeLog cl-store/circularities.lisp cl-store/cl-store.asd cl-store/fast-io.lisp cl-store/package.lisp cl-store/store.lisp cl-store/tests.lisp cl-store/fix-clisp.lisp Message-ID: Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv6337 Modified Files: ChangeLog circularities.lisp cl-store.asd fast-io.lisp package.lisp store.lisp tests.lisp Added Files: README Removed Files: fix-clisp.lisp Log Message: Changelog 2004-05-18 Date: Tue May 18 10:56:27 2004 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.1.1.1 cl-store/ChangeLog:1.2 --- cl-store/ChangeLog:1.1.1.1 Mon May 17 11:41:19 2004 +++ cl-store/ChangeLog Tue May 18 10:56:27 2004 @@ -1,3 +1,8 @@ +2004-05-18 Sean Ross + * store.lisp, fix-clisp.lisp, sbcl/sockets.lisp: + Added fix for sbcl to use non-blocking IO when working with sockets. + Created directory structure and moved fix-clisp + 2004-05-17 Sean Ross * store.lisp, fast-io.lisp, circularities.lisp, package.lisp, fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp: Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.1.1.1 cl-store/circularities.lisp:1.2 --- cl-store/circularities.lisp:1.1.1.1 Mon May 17 11:41:26 2004 +++ cl-store/circularities.lisp Tue May 18 10:56:27 2004 @@ -116,13 +116,6 @@ ((arrayp sequence) (inner-array))))) - - - - - - - ;; storing already seen objects Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.1.1.1 cl-store/cl-store.asd:1.2 --- cl-store/cl-store.asd:1.1.1.1 Mon May 17 11:41:19 2004 +++ cl-store/cl-store.asd Tue May 18 10:56:27 2004 @@ -7,20 +7,45 @@ (in-package :cl-store.system) +(defclass non-required-file (cl-source-file) () + (:documentation + "File containing implementation dependent code which may or may not be there.")) + +(defun lisp-system-shortname () + #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl) + +(defmethod component-pathname ((component non-required-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (lisp-system-shortname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) + +(defmethod perform ((op compile-op) (component non-required-file)) + (when (probe-file (component-pathname component)) + (call-next-method))) + +(defmethod perform ((op load-op) (component non-required-file)) + (when (probe-file (component-pathname component)) + (call-next-method))) + + (defsystem cl-store :name "Store" :author "Sean Ross " :maintainer "Sean Ross " - :version "0.1" + :version "0.1.1" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" :components ((:file "package") - #+clisp(:file "fix-clisp" :depends-on "package") + (:non-required-file "fix-clisp" :depends-on ("package")) (:file "fast-io" :depends-on ("package")) (:file "utils" :depends-on ("fast-io")) (:file "circularities" :depends-on ("utils")) - (:file "store" :depends-on ("circularities")))) + (:file "store" :depends-on ("circularities")) + (:non-required-file "sockets" :depends-on ("store"))) + :depends-on (#+sbcl :sb-bsd-sockets)) (defmethod perform :after ((o load-op) (c (eql (find-system :cl-store)))) @@ -32,14 +57,12 @@ (oos 'test-op :cl-store-tests)) (defsystem cl-store-tests - #+sbcl :depends-on #+sbcl (sb-rt) + :depends-on (rt) :components ((:file "tests"))) (defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests)))) (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")) (error "Test-op Failed."))) - - ;; EOF Index: cl-store/fast-io.lisp diff -u cl-store/fast-io.lisp:1.1.1.1 cl-store/fast-io.lisp:1.2 --- cl-store/fast-io.lisp:1.1.1.1 Mon May 17 11:41:19 2004 +++ cl-store/fast-io.lisp Tue May 18 10:56:27 2004 @@ -1,3 +1,6 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + (in-package :cl-store) (declaim (optimize speed (safety 0) (space 0) (debug 0) (compilation-speed 0))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -8,11 +11,13 @@ (defvar *full-write* t "An evil, evil variable. Read sequence doesn't just block it also -waits until the buffer has been filled. This forces the full +waits until the buffer has been filled. This variable forces the full 4096 bytes stored in the buffer to be written. Set this to nil if you don't like file sizes being multiples of 4096 when writing to files. This should be removed, or at least -deprecated, when a better solution is found.") +deprecated, when a better solution is found. +If you are using SBCL do not worry about this. +Just store objects to and from sockets.") ;; A structure was chosen over a normal object @@ -36,10 +41,6 @@ ;; reading -;; how should EOF be handled?? - - -;;(declaim (ftype (function (buffer) (unsigned-byte 8)) read-buf-byte)) (defgeneric read-buf-byte (buf)) (defmethod read-buf-byte ((buf buffer)) Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.1.1.1 cl-store/package.lisp:1.2 --- cl-store/package.lisp:1.1.1.1 Mon May 17 11:41:20 2004 +++ cl-store/package.lisp Tue May 18 10:56:27 2004 @@ -23,68 +23,68 @@ :*nuke-existing-classes* :*store-class-superclasses*) #+sbcl (:import-from :sb-mop - slot-definition-name - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - compute-slots - slot-definition-initform - slot-definition-initargs - slot-definition-name - slot-definition-readers - slot-definition-type - slot-definition-writers - class-direct-default-initargs - class-direct-slots - class-direct-superclasses - class-slots - ensure-class) + :slot-definition-name + :slot-value-using-class + :slot-boundp-using-class + :slot-definition-allocation + :compute-slots + :slot-definition-initform + :slot-definition-initargs + :slot-definition-name + :slot-definition-readers + :slot-definition-type + :slot-definition-writers + :class-direct-default-initargs + :class-direct-slots + :class-direct-superclasses + :class-slots + :ensure-class) #+cmu (:import-from :pcl - slot-definition-name - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - compute-slots - slot-definition-initform - slot-definition-initargs - slot-definition-name - slot-definition-readers - slot-definition-type - slot-definition-writers - class-direct-default-initargs - class-direct-slots - class-direct-superclasses - class-slots - ensure-class) + :slot-definition-name + :slot-value-using-class + :slot-boundp-using-class + :slot-definition-allocation + :compute-slots + :slot-definition-initform + :slot-definition-initargs + :slot-definition-name + :slot-definition-readers + :slot-definition-type + :slot-definition-writers + :class-direct-default-initargs + :class-direct-slots + :class-direct-superclasses + :class-slots + :ensure-class) #+clisp (:import-from :clos - slot-value - std-compute-slots - slot-boundp - class-name - class-direct-default-initargs - class-direct-slots - class-slots - ensure-class) + :slot-value + :std-compute-slots + :slot-boundp + :class-name + :class-direct-default-initargs + :class-direct-slots + :class-slots + :ensure-class) #+lispworks (:import-from :clos - slot-definition-name - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - compute-slots - slot-definition-initform - slot-definition-initargs - slot-definition-name - slot-definition-readers - slot-definition-type - slot-definition-writers - class-direct-default-initargs - class-direct-slots - class-slots - class-direct-superclasses - ensure-class)) + :slot-definition-name + :slot-value-using-class + :slot-boundp-using-class + :slot-definition-allocation + :compute-slots + :slot-definition-initform + :slot-definition-initargs + :slot-definition-name + :slot-definition-readers + :slot-definition-type + :slot-definition-writers + :class-direct-default-initargs + :class-direct-slots + :class-slots + :class-direct-superclasses + :ensure-class)) Index: cl-store/store.lisp diff -u cl-store/store.lisp:1.1.1.1 cl-store/store.lisp:1.2 --- cl-store/store.lisp:1.1.1.1 Mon May 17 11:41:23 2004 +++ cl-store/store.lisp Tue May 18 10:56:27 2004 @@ -12,6 +12,10 @@ - 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. + - hopefully find a better way to do circularity fixing - structure storing for non python implementations @@ -88,13 +92,13 @@ (defgeneric restore (place) (:method ((place string)) - "Restore the object found in the String PLACE." + "Restore the object found in the String path designator PLACE." (restore-file place)) (:method ((place pathname)) "Restore the object found in Pathname PLACE." (restore-file place)) (:method ((place stream)) - "Restore the object found in STREAM STREAM" + "Restore the object found in the Stream STREAM" (restore (make-buffer :stream place))) (:method ((place buffer)) "Restore the object found in Stream PLACE." @@ -196,7 +200,8 @@ (defmacro defstore ((var type buffer &rest method-args) &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." +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))) (declare (ignorable ,code)) Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.1.1.1 cl-store/tests.lisp:1.2 --- cl-store/tests.lisp:1.1.1.1 Mon May 17 11:41:24 2004 +++ cl-store/tests.lisp Tue May 18 10:56:27 2004 @@ -2,7 +2,7 @@ ;; See the file LICENCE for licence information. (defpackage :cl-store-tests - (:use :cl #+sbcl :sb-rt #-sbcl :rt :cl-store)) + (:use :cl :rt :cl-store)) (in-package :cl-store-tests) @@ -330,9 +330,27 @@ t) +(defclass foobarbaz () ((x :accessor x :initarg :x))) + + +(defstore (obj foobarbaz buff) + (store-object (x obj) buff)) + +;(defstore (obj foobarbaz buff :before) +; (format t "Storing a foobarbaz object.")) + +(defrestore (foobarbaz buff) + (make-instance 'foobarbaz :x (restore-object buff))) + + +(deftest custom.1 + (progn (store (make-instance 'foobarbaz :x "foo") *test-file*) + (equal "foo" (x (restore *test-file*)))) + t) + + (defun run-tests () - #+sbcl(sb-rt:do-tests) - #-sbcl(rt:do-tests) + (rt:do-tests) (when (probe-file *test-file*) (delete-file *test-file*))) From sross at common-lisp.net Fri May 21 14:14:41 2004 From: sross at common-lisp.net (Sean Ross) Date: Fri, 21 May 2004 10:14:41 -0400 Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README cl-store/circularities.lisp cl-store/cl-store.asd cl-store/package.lisp cl-store/store.lisp cl-store/tests.lisp cl-store/utils.lisp Message-ID: 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 + * 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 * 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 " :maintainer "Sean Ross " - :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 , at 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))) , at body)))) (defmacro defrestore ((type buff) &body body) @@ -216,7 +238,7 @@ ;; than an anonymous function. `(flet ((,fn-name (,buff) , at 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) , at 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.") From sross at common-lisp.net Fri May 21 14:14:41 2004 From: sross at common-lisp.net (Sean Ross) Date: Fri, 21 May 2004 10:14:41 -0400 Subject: [cl-store-cvs] CVS update: cl-store/clisp/fix-clisp.lisp Message-ID: Update of /project/cl-store/cvsroot/cl-store/clisp In directory common-lisp.net:/tmp/cvs-serv6976/clisp Modified Files: fix-clisp.lisp Log Message: Changelog 2004-05-21 Date: Fri May 21 10:14:41 2004 Author: sross Index: cl-store/clisp/fix-clisp.lisp diff -u cl-store/clisp/fix-clisp.lisp:1.1 cl-store/clisp/fix-clisp.lisp:1.2 --- cl-store/clisp/fix-clisp.lisp:1.1 Tue May 18 10:56:29 2004 +++ cl-store/clisp/fix-clisp.lisp Fri May 21 10:14:41 2004 @@ -45,4 +45,20 @@ (or (clos::class-direct-superclasses class) (list (find-class 'standard-object)))) + +(defun add-methods-for-class (class vals) + (let ((readers (mappend #'(lambda (x) + (second (member :readers x))) + vals)) + (writers (mappend #'(lambda (x) + (second (member :writers x))) + vals))) + (loop for x in readers do + (eval `(defmethod ,x ((clos::object ,class)) + (slot-value clos::object ',x)))) + (loop for x in writers do + (eval `(defmethod ,x (clos::new-value (clos::object ,class)) + (setf (slot-value clos::object ',x) clos::new-value)))) + (find-class class))) + ;; EOF