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(a)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(a)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(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)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.")
