[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/backends.lisp cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp cl-store/xml-backend.lisp

Sean Ross sross at common-lisp.net
Tue Feb 1 08:27:38 UTC 2005


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 at 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 at 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)))
         , at 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)))
                   , at 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*)
-         `(, at place ,obj))
-        (t `(,(car place) ,obj ,@(cdr place)))))
+(defmacro delay (&rest body)
+  `(make-delay :value #'(lambda () , at 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))
          , at 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 at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at 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)




More information about the Cl-store-cvs mailing list