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