Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv9440
Modified Files:
ChangeLog backends.lisp circularities.lisp cl-store.asd
default-backend.lisp package.lisp plumbing.lisp tests.lisp
utils.lisp xml-backend.lisp
Log Message:
Changelog 2005-02-01
Date: Tue Feb 1 00:27:26 2005
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.17 cl-store/ChangeLog:1.18
--- cl-store/ChangeLog:1.17 Thu Dec 2 02:31:54 2004
+++ cl-store/ChangeLog Tue Feb 1 00:27:26 2005
@@ -1,3 +1,11 @@
+2005-02-01 Sean Ross <sross(a)common-lisp.net>
+ * various: Large patch which has removed pointless
+ argument-precedence-order from various gf's, added the
+ start of support for ecl, renamed fix-clisp.lisp file to
+ mop.lisp, and changed resolving-object and setting
+ to use delays allowing get-setf-place and *postfix-setter*
+ to be removed.
+
2004-12-02 Sean Ross <sross(a)common-lisp.net>
* sbcl/custom.lisp, cmucl/custom.lisp: Changed the evals when restoring
structure definitions to (funcall (compile nil ...))
Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.6 cl-store/backends.lisp:1.7
--- cl-store/backends.lisp:1.6 Fri Nov 26 06:35:36 2004
+++ cl-store/backends.lisp Tue Feb 1 00:27:26 2005
@@ -45,7 +45,6 @@
((,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)
@@ -54,7 +53,6 @@
`(defmacro ,macro-name ((type place) &body body)
(let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
`(flet ((,fn-name (,place)
-; (declare (optimize (speed 3) (safety 1) (debug 0)))
,@body))
(let* ((backend (find-backend ',',name))
(restorers (restorer-funs backend)))
Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.13 cl-store/circularities.lisp:1.14
--- cl-store/circularities.lisp:1.13 Fri Nov 26 06:35:36 2004
+++ cl-store/circularities.lisp Tue Feb 1 00:27:26 2005
@@ -19,22 +19,22 @@
;; programs according to the Hyperspec(notes in EQ).
(in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
+;(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defvar *check-for-circs* t)
+(defstruct delay
+ value (completed nil))
-(defvar *postfix-setters* '(gethash)
- "Setfable places which take the object to set after
- the rest of the arguments.")
-
-(defun get-setf-place (place obj)
- "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*."
- (cond ((atom place) `(,place ,obj))
- ((member (the symbol (car place)) *postfix-setters*)
- `(,@place ,obj))
- (t `(,(car place) ,obj ,@(cdr place)))))
+(defmacro delay (&rest body)
+ `(make-delay :value #'(lambda () ,@body)))
+
+(defun force (delay)
+ (unless (delay-completed delay)
+ (setf (delay-value delay) (funcall (delay-value delay))
+ (delay-completed delay) t))
+ (delay-value delay))
;; The definitions for setting and setting-hash sits in resolving-object.
@@ -51,37 +51,30 @@
(declare (ignore getting-key getting-value))
(error "setting-hash can only be used inside a resolving-object form."))
-(defmacro resolving-object (create &body body)
+(defmacro resolving-object ((var create) &body body)
"Execute body attempting to resolve circularities found in
form CREATE."
- (with-gensyms (obj value key)
+ (with-gensyms (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)))))
+ `(let ((,',value ,getting))
+ (if (referrer-p ,',value)
+ (push (delay (setf ,place (referred-value ,',value *restored-values*)))
+ *need-to-fix*)
+ (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)))
+ (push (delay (setf (gethash (referred-value ,',key *restored-values*)
+ ,',var)
+ (if (referrer-p ,',value)
+ (referred-value ,',value *restored-values*)
+ ,',value)))
*need-to-fix*))
- (setting (gethash ,',key) ,getting-place)))))
- (let ((,obj ,create))
+ (setting (gethash ,',key ,',var) ,getting-place)))))
+ (let ((,var ,create))
,@body
- ,obj))))
+ ,var))))
(defstruct referrer
val)
@@ -102,11 +95,11 @@
(defvar *store-hash-size* 1000)
-(defmethod backend-store ((obj t) (place stream) (backend resolving-backend))
+(defmethod backend-store ((backend resolving-backend) (place stream) (obj t))
"Store OBJ into PLACE. Does the setup for counters and seen values."
(let ((*stored-counter* 0)
(*stored-values* (make-hash-table :test #'eq :size *store-hash-size*)))
- (store-backend-code place backend)
+ (store-backend-code backend place)
(backend-store-object obj place backend)
obj))
@@ -157,17 +150,17 @@
(defvar *restored-values*)
(defvar *restore-hash-size* 1000)
-(defmethod backend-restore ((place stream) (backend resolving-backend))
+(defmethod backend-restore ((backend resolving-backend) (place stream))
"Restore an object from PLACE using BACKEND. Does the setup for
various variables used by resolving-object."
(let ((*restore-counter* 0)
(*need-to-fix* nil)
(*restored-values* (make-hash-table :test #'eq :size *restore-hash-size*)))
- (check-magic-number place backend)
+ (check-magic-number backend place)
(multiple-value-prog1
(backend-restore-object place backend)
(dolist (fn *need-to-fix*)
- (funcall (the function fn))))))
+ (force fn)))))
(defun update-restored (spot val)
(setf (gethash spot *restored-values*) val))
@@ -203,7 +196,7 @@
((eql sym 'referrer)
(incf *restore-counter*)
(new-val (call-it reader place)))
- ((not (int-sym-or-char-p sym backend))
+ ((not (int-sym-or-char-p backend sym))
(handle-normal reader place))
(t (new-val (funcall reader place))))))
@@ -213,9 +206,8 @@
(handle-restore place backend)
(funcall (the function (find-function-for-type place backend)) place)))
-(defgeneric int-sym-or-char-p (fn backend)
- (:argument-precedence-order backend fn)
- (:method ((fn symbol) (backend backend))
+(defgeneric int-sym-or-char-p (backend fn)
+ (:method ((backend backend) (fn symbol))
"Is function FN registered to restore an integer, character or symbol
in BACKEND."
(member fn '(integer character symbol))))
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.16 cl-store/cl-store.asd:1.17
--- cl-store/cl-store.asd:1.16 Thu Dec 2 02:31:54 2004
+++ cl-store/cl-store.asd Tue Feb 1 00:27:26 2005
@@ -15,7 +15,7 @@
(defun lisp-system-shortname ()
#+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl
- #+allegro :acl)
+ #+allegro :acl #+ecl :ecl)
(defmethod component-pathname ((component non-required-file))
(let ((pathname (call-next-method))
@@ -40,12 +40,12 @@
:name "CL-STORE"
:author "Sean Ross <sdr(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>"
- :version "0.4.2"
+ :version "0.4.5"
: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"))
+ (:non-required-file "mop" :depends-on ("package"))
(:file "utils" :depends-on ("package"))
(:file "backends" :depends-on ("utils"))
(:file "plumbing" :depends-on ("backends"))
Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.15 cl-store/default-backend.lisp:1.16
--- cl-store/default-backend.lisp:1.15 Thu Dec 2 02:31:54 2004
+++ cl-store/default-backend.lisp Tue Feb 1 00:27:26 2005
@@ -5,8 +5,6 @@
(in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *cl-store-backend*
(defbackend cl-store :magic-number 1886611820
@@ -82,6 +80,7 @@
(gethash code *restorers*))
(defmethod get-next-reader ((stream stream) (backend cl-store-backend))
+ (declare (ignore backend))
(let ((type-code (read-type-code stream)))
(or (lookup-code type-code) ;(gethash type-code *restorers*)
(values nil (format nil "Type ~A" type-code)))))
@@ -89,6 +88,7 @@
;; referrer, Required for a resolving backend
(defmethod store-referrer (ref stream (backend cl-store-backend))
+ (declare (ignore backend))
(output-type-code +referrer-code+ stream)
(dump-int ref stream))
@@ -101,7 +101,8 @@
;; so we we have a little optimization for it
;; We need this for circularity stuff.
-(defmethod int-sym-or-char-p ((fn symbol) (backend cl-store-backend))
+(defmethod int-sym-or-char-p ((backend cl-store-backend) (fn symbol))
+ (declare (ignore backend))
(member fn '(integer character 32-bit-integer symbol)))
(defstore-cl-store (obj integer stream)
@@ -234,9 +235,9 @@
;; this is an examples of a restorer which handles
;; circularities using resolving-object and setting.
(defrestore-cl-store (cons stream)
- (resolving-object (cons nil nil)
- (setting car (restore-object stream))
- (setting cdr (restore-object stream))))
+ (resolving-object (x (cons nil nil))
+ (setting (car x) (restore-object stream))
+ (setting (cdr x) (restore-object stream))))
;; pathnames
(defstore-cl-store (obj pathname stream)
@@ -280,7 +281,7 @@
:rehash-size rehash-size
:rehash-threshold rehash-threshold
:size size)))
- (resolving-object hash
+ (resolving-object (x hash)
(loop repeat count do
;; Unfortunately we can't use the normal setting here
;; since there could be a circularity in the key
@@ -328,8 +329,8 @@
(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)))))
+ (resolving-object (obj new-instance)
+ (setting (slot-value obj slot-name) (restore-object stream)))))
new-instance))
#-lispworks
@@ -349,8 +350,7 @@
(store-object (mapcar (if *store-class-superclasses*
#'identity
#'class-name)
- (remove (find-class 'standard-object)
- (class-direct-superclasses obj)))
+ (class-direct-superclasses obj))
stream)
(store-object (type-of obj) stream))
@@ -364,7 +364,7 @@
(final (mappend #'list keywords (list slots supers meta))))
(cond ((find-class class nil)
(cond (*nuke-existing-classes*
- (apply #'ensure-class class final)
+ (apply #'ensure-class class final)
#+clisp (add-methods-for-class class slots))
(t (find-class class))))
(t (apply #'ensure-class class final)
@@ -385,7 +385,7 @@
-;; Arrays and Vectors and Strings
+;; Arrays, vectors and strings.
(defstore-cl-store (obj array stream)
(typecase obj
(simple-string (store-simple-string obj stream))
@@ -423,11 +423,10 @@
(when displaced-to
(adjust-array res dimensions :displaced-to displaced-to
:displaced-index-offset displaced-offset))
- (resolving-object res
+ (resolving-object (obj res)
(loop for x from 0 to (1- size) do
(let ((pos x))
- (setting (row-major-aref pos) (restore-object stream)))))
- res))
+ (setting (row-major-aref obj pos) (restore-object stream)))))))
(defun store-simple-vector (obj stream)
(declare (type simple-vector obj))
@@ -441,12 +440,12 @@
(let* ((size (restore-object stream))
(res (make-array size)))
(declare (type array-size size))
- (resolving-object res
+ (resolving-object (obj res)
(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)))))
+ (setting (aref obj x) (restore-object stream)))))
res))
;; Dumping (unsigned-byte 32) for each character seems
Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.15 cl-store/package.lisp:1.16
--- cl-store/package.lisp:1.15 Wed Nov 24 05:27:03 2004
+++ cl-store/package.lisp Tue Feb 1 00:27:26 2005
@@ -31,8 +31,6 @@
#+sbcl (:import-from #:sb-mop
#:generic-function-name
#:slot-definition-name
- #:slot-value-using-class
- #:slot-boundp-using-class
#:slot-definition-allocation
#:compute-slots
#:slot-definition-initform
@@ -47,11 +45,18 @@
#:class-slots
#:ensure-class)
+ #+ecl (:import-from #:clos
+ #:generic-function-name
+ #:compute-slots
+ #:class-direct-default-initargs
+ #:class-direct-slots
+ #: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
#:slot-definition-allocation
#:compute-slots
#:slot-definition-initform
@@ -75,8 +80,6 @@
#+openmcl (:import-from #:openmcl-mop
#:generic-function-name
#:slot-definition-name
- #:slot-value-using-class
- #:slot-boundp-using-class
#:slot-definition-allocation
#:compute-slots
#:slot-definition-initform
@@ -104,8 +107,6 @@
#+lispworks (:import-from #:clos
#:slot-definition-name
#:generic-function-name
- #:slot-value-using-class
- #:slot-boundp-using-class
#:slot-definition-allocation
#:compute-slots
#:slot-definition-initform
@@ -123,8 +124,6 @@
#+allegro (:import-from #:mop
#:slot-definition-name
#:generic-function-name
- #:slot-value-using-class
- #:slot-boundp-using-class
#:slot-definition-allocation
#:compute-slots
#:slot-definition-initform
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.8 cl-store/plumbing.lisp:1.9
--- cl-store/plumbing.lisp:1.8 Fri Nov 26 06:35:36 2004
+++ cl-store/plumbing.lisp Tue Feb 1 00:27:26 2005
@@ -5,7 +5,6 @@
;;
(in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defvar *nuke-existing-classes* nil
"Do we overwrite existing class definitions on restoration.")
@@ -65,7 +64,7 @@
(integer '(unsigned-byte 8)))))
(with-open-file (s place :element-type element-type
:direction :output :if-exists :supersede)
- (backend-store obj s backend))))
+ (backend-store backend s obj))))
(defgeneric store (obj place &optional backend)
(:documentation "Entry Point for storing objects.")
@@ -76,28 +75,26 @@
(handler-bind ((error (lambda (c)
(signal (make-condition 'store-error
:caused-by c)))))
- (backend-store obj place backend)))))
+ (backend-store backend place obj)))))
-(defgeneric backend-store (obj place backend)
- (:argument-precedence-order backend place obj)
- (:method ((obj t) (place stream) (backend backend))
+(defgeneric backend-store (backend place obj)
+ (:method ((backend backend) (place stream) (obj t))
"The default. Checks the streams element-type, stores the backend code
and calls store-object."
- (store-backend-code place backend)
+ (store-backend-code backend place)
(store-object obj place backend)
obj)
- (:method ((obj t) (place string) (backend backend))
+ (:method ((backend backend) (place string) (obj t))
"Store OBJ into file designator PLACE."
(store-to-file obj place backend))
- (:method ((obj t) (place pathname) (backend backend))
+ (:method ((backend backend) (place pathname) (obj t))
"Store OBJ into file designator PLACE."
(store-to-file obj place backend))
(:documentation "Method wrapped by store, override this method for
custom behaviour (see circularities.lisp)."))
-(defgeneric store-backend-code (stream backend)
- (:argument-precedence-order backend stream)
- (:method ((stream t) (backend backend))
+(defgeneric store-backend-code (backend stream)
+ (:method ((backend backend) (stream t))
(awhen (magic-number backend)
(store-32-bit it stream)))
(:documentation
@@ -137,21 +134,20 @@
(handler-bind ((error (lambda (c)
(signal (make-condition 'restore-error
:caused-by c)))))
- (backend-restore place backend)))))
+ (backend-restore backend place)))))
-(defgeneric backend-restore (place backend)
- (:argument-precedence-order backend place)
+(defgeneric backend-restore (backend place)
(:documentation "Wrapped by restore. Override this to do custom restoration")
- (:method ((place stream) (backend backend))
+ (:method ((backend backend) (place stream))
"Restore the object found in stream PLACE using backend BACKEND.
Checks the magic-number and invokes backend-restore-object"
- (check-magic-number place backend)
+ (check-magic-number backend place)
(backend-restore-object place backend))
- (:method ((place string) (backend backend))
+ (:method ((backend backend) (place string))
"Restore the object found in file designator PLACE using backend BACKEND."
(restore-from-file place backend))
- (:method ((place pathname) (backend backend))
+ (:method ((backend backend) (place pathname))
"Restore the object found in file designator PLACE using backend BACKEND."
(restore-from-file place backend)))
@@ -161,7 +157,7 @@
(character 'character)
(integer '(unsigned-byte 8)))))
(with-open-file (s place :element-type element-type :direction :input)
- (backend-restore s backend))))
+ (backend-restore backend s))))
(defclass values-object ()
((vals :accessor vals :initarg :vals))
@@ -180,8 +176,7 @@
(store new-val place))
(defgeneric check-magic-number (stream backend)
- (:argument-precedence-order backend stream)
- (:method ((stream t) (backend backend))
+ (:method ((backend backend) (stream t))
(let ((magic-number (magic-number backend)))
(declare (type (or null ub32) magic-number))
(when magic-number
Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.12 cl-store/tests.lisp:1.13
--- cl-store/tests.lisp:1.12 Fri Nov 26 06:35:36 2004
+++ cl-store/tests.lisp Tue Feb 1 00:27:26 2005
@@ -96,8 +96,12 @@
#+(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))
+ (deftestit unicode.1 (map #-lispworks 'string
+ #+lispworks 'lw:text-string
+ #'code-char (list #X20AC #X3BB)))
+ (deftestit unicode.2 (intern (map #-lispworks 'string
+ #+lispworks 'lw:text-string
+ #'code-char (list #X20AC #X3BB))
:cl-store-tests)))
;; vectors
@@ -478,13 +482,12 @@
(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 function.3 #'(setf car))
(deftestit gfunction.1 #'cl-store:restore)
(deftestit gfunction.2 #'cl-store:store)
-#-(or clisp lispworks openmcl)
+#-(or clisp openmcl)
(deftestit gfunction.3 #'(setf cl-store:restore))
(deftest nocirc.1
Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.8 cl-store/utils.lisp:1.9
--- cl-store/utils.lisp:1.8 Wed Nov 24 05:27:03 2004
+++ cl-store/utils.lisp Tue Feb 1 00:27:26 2005
@@ -3,7 +3,7 @@
;; Miscellaneous utilities used throughout the package.
(in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
+;(declaim (optimize (speed 3) (safety 1) (debug 1)))
(defmacro aif (test then &optional else)
Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.9 cl-store/xml-backend.lisp:1.10
--- cl-store/xml-backend.lisp:1.9 Thu Dec 2 02:31:54 2004
+++ cl-store/xml-backend.lisp Tue Feb 1 00:27:26 2005
@@ -92,7 +92,7 @@
;; override backend restore to parse the incoming stream
-(defmethod backend-restore ((place stream) (backend xml-backend))
+(defmethod backend-restore ((backend xml-backend) (place stream))
(let ((*restore-counter* 0)
(*need-to-fix* nil)
(*print-circle* nil)
