From sross at common-lisp.net  Thu Sep  1 10:25:03 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  1 Sep 2005 12:25:03 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <20050901102503.E124B8855C@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc
In directory common-lisp.net:/tmp/cvs-serv9950/doc

Modified Files:
	cl-store.texi 
Log Message:
Changelog 2005-09-01
Date: Thu Sep  1 12:25:00 2005
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.11 cl-store/doc/cl-store.texi:1.12
--- cl-store/doc/cl-store.texi:1.11	Fri May  6 16:19:30 2005
+++ cl-store/doc/cl-store.texi	Thu Sep  1 12:24:59 2005
@@ -82,7 +82,7 @@
 The CL-STORE Home Page is at @uref{http://common-lisp.net/project/cl-store}
 where one can find details about mailing lists, cvs repositories and various releases.
 
-This documentation is for CL-STORE version 0.5 .
+This documentation is for CL-STORE version 0.6 .
 
 Enjoy
  Sean.



From sross at common-lisp.net  Thu Sep  1 10:25:03 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  1 Sep 2005 12:25:03 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README
	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
	cl-store/xml-package.lisp 
Message-ID: <20050901102503.A6CBE88552@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv9950

Modified Files:
	ChangeLog README circularities.lisp cl-store.asd 
	default-backend.lisp package.lisp plumbing.lisp tests.lisp 
	utils.lisp xml-backend.lisp xml-package.lisp 
Log Message:
Changelog 2005-09-01
Date: Thu Sep  1 12:24:56 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.33 cl-store/ChangeLog:1.34
--- cl-store/ChangeLog:1.33	Wed May 18 17:34:09 2005
+++ cl-store/ChangeLog	Thu Sep  1 12:24:55 2005
@@ -1,3 +1,13 @@
+2005-09-01 Sean Ross <sross at common-lisp.net>
+    Version 0.6 Release.
+	* cl-store.asd, package.lisp: Added support for the new release
+	of CLISP with a MOP.
+	* default-backend.lisp: Fixed storing of long lists.
+	 (Reported by and help by Alain Picard)
+	* default-backend.lisp: New magic number, due to the
+	change in approach of storing lists, although previous
+	files can still be restored.
+	
 2005-05-18 Sean Ross <sross at common-lisp.net>
 	* utils.lisp: Removed awhen
 	* backends.lisp: Added a compatible-magic-numbers slot.


Index: cl-store/README
diff -u cl-store/README:1.16 cl-store/README:1.17
--- cl-store/README:1.16	Thu May  5 15:02:29 2005
+++ cl-store/README	Thu Sep  1 12:24:55 2005
@@ -1,7 +1,7 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.5.9
+Version: 0.6
 
 0. About.
    CL-STORE is an portable serialization package which 


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.22 cl-store/circularities.lisp:1.23
--- cl-store/circularities.lisp:1.22	Fri May  6 16:19:29 2005
+++ cl-store/circularities.lisp	Thu Sep  1 12:24:55 2005
@@ -58,13 +58,19 @@
     `(macrolet ((setting (place getting)
                   `(let ((,',value ,getting))
                      (if (referrer-p ,',value)
-                         (push (delay (setf ,place (referred-value ,',value *restored-values*)))
-                               *need-to-fix*)
+                         (if *check-for-circs*
+                             (push (delay (setf ,place
+                                                (referred-value ,',value
+                                                                *restored-values*)))
+                                   *need-to-fix*)
+                             (restore-error "Found a circular values with *check-for-circs* = nil"))
                          (setf ,place ,',value))))
                 (setting-hash (getting-key getting-place)
                   `(let ((,',key ,getting-key))
                      (if (referrer-p ,',key)
                          (let ((,',value ,getting-place))
+                           (unless *check-for-circs*
+                             (restore-error "Found a circular values with *check-for-circs* = nil"))
                            (push (delay (setf (gethash (referred-value ,',key *restored-values*)
                                                        ,',var)
                                               (if (referrer-p ,',value)
@@ -161,7 +167,8 @@
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*restored-values* (and *check-for-circs*
-                                (make-hash-table :test #'eq :size *restore-hash-size*))))
+                                (make-hash-table :test #'eq
+                                                 :size *restore-hash-size*))))
     (check-magic-number backend place)
     (multiple-value-prog1
       (backend-restore-object backend place)
@@ -179,7 +186,9 @@
     (update-restored spot vals)
     vals))
 
-(defgeneric referrerp (backend reader))
+(defgeneric referrerp (backend reader)
+  (:method ((backend t) (reader t))
+   (error "referrerp must be specialized for backend ~A." (name backend)))) 
 
 (defun handle-restore (place backend)
   (declare (optimize speed (safety 1) (debug 0)))
@@ -192,7 +201,7 @@
            (handle-normal backend reader place))
           (t (new-val (internal-restore-object backend reader place))))))
 
-(defmethod backend-restore-object ((backend resolving-backend) (place stream))
+(defmethod backend-restore-object ((backend resolving-backend) (place t))
   "Retrieve a object from PLACE, does housekeeping for circularity fixing."
   (declare (optimize speed (safety 1) (debug 0)))
   (if *check-for-circs*


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.30 cl-store/cl-store.asd:1.31
--- cl-store/cl-store.asd:1.30	Wed May 18 17:34:09 2005
+++ cl-store/cl-store.asd	Thu Sep  1 12:24:55 2005
@@ -40,11 +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.5.15"
+  :version "0.6"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data"
   :licence "MIT"
   :components ((:file "package")
+               #+(and clisp (not mop))
                (:non-required-file "mop" :depends-on ("package"))
                (:file "utils" :depends-on ("package"))
                (:file "backends" :depends-on ("utils"))


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.29 cl-store/default-backend.lisp:1.30
--- cl-store/default-backend.lisp:1.29	Wed May 18 17:34:09 2005
+++ cl-store/default-backend.lisp	Thu Sep  1 12:24:55 2005
@@ -4,9 +4,9 @@
 ;; The cl-store backend. 
 (in-package :cl-store)
 
-(defbackend cl-store :magic-number 1414745155  
+(defbackend cl-store :magic-number 1953713219
             :stream-type '(unsigned-byte 8)
-            :compatible-magic-numbers (1349740876)
+            :compatible-magic-numbers (1349740876 1414745155)
             :old-magic-numbers (1912923 1886611788 1347635532 1886611820 
                                         1884506444 1347643724 1349732684)
             :extends (resolving-backend)
@@ -64,6 +64,10 @@
 (defvar +float-double-nan-code+ (register-code 33 'float-double-nan nil))
 (defvar +unicode-base-string-code+ (register-code 34 'unicode-base-string nil))
 (defvar +simple-base-string-code+ (register-code 35 'simple-base-string nil))
+(defvar +proper-list-code+ (register-code 36 'proper-list))
+(defvar +circular-list-code+  (register-code 37 'circular-list))
+(defvar +dotted-list-code+  (register-code 38 'dotted-list))
+
 
 
 ;; setups for type code mapping
@@ -274,19 +278,91 @@
   (make-symbol (restore-object stream)))
 
 
-;; lists
-(defstore-cl-store (obj cons stream)
-  (declare (optimize speed))
-  (output-type-code +cons-code+ stream)    
-  (store-object (car obj) stream)
-  (store-object (cdr obj) stream))
+;; Lists
+(defun dump-proper-list (list length stream)
+  (output-type-code +proper-list-code+ stream)
+  (store-object length stream)
+  (dolist (x list)
+    (store-object x stream)))
+
+
+
+
+(defun restore-proper-list (stream)
+  (let ((fixes ()))
+    (let ((ret (loop for count below (restore-object stream)
+                     for elt = (restore-object stream)
+                     if (and *check-for-circs* (referrer-p elt))
+                       do (push (cons count elt) fixes)
+                     collect elt)))
+      ;; This requires a bit of fiddling
+      (when *check-for-circs*
+        (dolist (referrer fixes)
+          (let ((ref (cdr referrer))
+                (pos (car referrer)))
+            (push (delay (setf (nth pos ret)
+                               (referred-value ref *restored-values*)))
+                  *need-to-fix*))))
+      ret)))
+
+(defun dump-dotted-list (list stream)
+  (output-type-code +dotted-list-code+ stream)
+  (store-object (count-conses list) stream)
+  (labels ((rec (list)
+             (cond ((atom (cdr list)) ;; last cons cell
+                    (store-object (car list) stream)
+                    (store-object (cdr list) stream))
+                   (t (store-object (car list) stream)
+                      (rec (cdr list))))))
+    (rec list)))
+
+(defun restore-dotted-list (stream)
+  (let* ((ret ())
+         (tail ret)
+         (conses (restore-object stream)))
+    (dotimes (x conses)
+      (let ((obj (restore-object stream)))
+        (when (and *check-for-circs* (referrer-p obj))
+          (let ((x x))
+            (push (delay (setf (nth x ret)
+                               (referred-value obj *restored-values*)))
+                  *need-to-fix*)))
+        (if ret
+            (setf (cdr tail) (list obj) 
+                  tail (cdr tail))
+            (setf ret (list obj)
+                  tail (last ret)))))
+    (setf (cdr tail) (restore-object stream))
+    ret))
+
+(defun dump-circular-list (list stream)
+  (output-type-code +circular-list-code+ stream)
+  (store-object (car list) stream)
+  (store-object (cdr list) stream))
+
+(defstore-cl-store (list cons stream)
+  (multiple-value-bind (length errorp)
+      (proper-list-length list)
+    (cond (errorp (dump-dotted-list list stream))
+          (length (dump-proper-list list length stream))
+          (t (dump-circular-list list stream)))))
+
+(defrestore-cl-store (proper-list stream)
+  (restore-proper-list stream))
+
+(defrestore-cl-store (dotted-list stream)
+  (restore-dotted-list stream))
+
+(defrestore-cl-store (circular-list stream)
+  (resolving-object (ret (cons nil nil))
+    (setting (car ret) (restore-object stream))
+    (setting (cdr ret) (restore-object stream))))
 
-;; this is an examples of a restorer which handles 
-;; circularities using resolving-object and setting.
+;; kept for backwards compatibility
 (defrestore-cl-store (cons stream)
-  (resolving-object (x (cons nil nil))
-    (setting (car x) (restore-object stream))
-    (setting (cdr x) (restore-object stream))))
+  (resolving-object (ret (cons nil nil))
+    (setting (car ret) (restore-object stream))
+    (setting (cdr ret) (restore-object stream))))
 
 
 ;; pathnames
@@ -417,10 +493,10 @@
     (cond ((find-class class nil)
            (cond (*nuke-existing-classes*
                   (apply #'ensure-class class final)
-                  #+clisp (add-methods-for-class class slots))
+                  #+(and clisp (not mop)) (add-methods-for-class class slots))
                  (t (find-class class))))
           (t (apply #'ensure-class class final)
-             #+clisp (add-methods-for-class class slots)))))
+             #+(and clisp (not mop)) (add-methods-for-class class slots)))))
 
 ;; built in classes
 
@@ -517,7 +593,8 @@
   (declare (optimize speed (safety 0) (debug 0))
            (type simple-string string))
   #+cmu nil ;; cmucl doesn't support unicode yet.
-  #-(or cmu) (some #'(lambda (x) (char> x *char-marker*)) string))
+  #+lispworks (not (typep string 'lw:8-bit-string))
+  #-(or cmu lispworks) (some #'(lambda (x) (char> x *char-marker*)) string))
 
 (defun store-simple-string (obj stream)
   (declare (type simple-string obj)
@@ -641,28 +718,31 @@
                      nil
                      *sbcl-readtable*)
 
-(defstore-cl-store (obj function stream)
-  (output-type-code +function-code+ stream)
+(defun get-function-name (obj)
   (multiple-value-bind (l cp name) (function-lambda-expression obj) 
     (declare (ignore l cp))
-    (cond ((and name (or (symbolp name) (consp name))) 
-           (store-object name stream))
+    (cond ((and name (or (symbolp name) (consp name))) name)
           ;;  Try to deal with sbcl's naming convention
           ;; of built in functions (pre 0.9)
           #+sbcl
           ((and name (stringp name)
-                (search "top level local call "
-                        (the simple-string name)))
+                (search "top level local call " (the simple-string name)))
            (let ((new-name (parse-name name))
                  (*readtable* *sbcl-readtable*))
              (unless (string= new-name "")
-               (handler-case (store-object (read-from-string new-name) stream)
-                 (error (c)
-                   (declare (ignore c))
-                   (store-error "Unable to determine function name for ~A."
-                                obj))))))
+               (handler-case (read-from-string new-name)
+                 (error (c) (declare (ignore c))
+                        (store-error "Unable to determine function name for ~A."
+                                     obj))))))
           (t (store-error "Unable to determine function name for ~A."
                           obj)))))
+  
+
+(defstore-cl-store (obj function stream)
+  (output-type-code +function-code+ stream)
+  (store-object (get-function-name obj) stream))
+
+
 
 (defrestore-cl-store (function stream)
   (fdefinition (restore-object stream)))


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.21 cl-store/package.lisp:1.22
--- cl-store/package.lisp:1.21	Thu Mar 24 09:25:17 2005
+++ cl-store/package.lisp	Thu Sep  1 12:24:55 2005
@@ -94,7 +94,7 @@
                           #:class-slots
                           #:ensure-class)
   
-  #+clisp (:import-from #:clos
+  #+(and clisp (not mop)) (:import-from #:clos
                         #:slot-value
                         #:std-compute-slots
                         #:slot-boundp
@@ -104,23 +104,41 @@
                         #:class-slots
                         #:ensure-class)
   
-  #+lispworks  (:import-from #:clos
-                             #:slot-definition-name
-                             #:generic-function-name
-                             #:slot-definition-allocation
-                             #:compute-slots
-                             #:slot-definition
-                             #: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)
+  #+lispworks (:import-from #:clos
+               #:slot-definition-name
+               #:generic-function-name
+               #:slot-definition-allocation
+               #:compute-slots
+               #:slot-definition
+               #: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)
+
+  #+(and clisp mop) (:import-from #:clos
+                     #:slot-definition-name
+                     #:generic-function-name
+                     #:slot-definition-allocation
+                     #:compute-slots
+                     #:slot-definition
+                     #: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)
   
   #+allegro (:import-from #:mop
                           #:slot-definition-name
@@ -140,4 +158,4 @@
                           #:class-slots
                           #:ensure-class)
   )
-;; EOF
\ No newline at end of file
+;; EOF


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.16 cl-store/plumbing.lisp:1.17
--- cl-store/plumbing.lisp:1.16	Wed May 18 17:34:09 2005
+++ cl-store/plumbing.lisp	Thu Sep  1 12:24:55 2005
@@ -68,17 +68,18 @@
       (backend-store backend s obj))))
 
 (defgeneric store (obj place &optional designator) 
-  (:documentation "Entry Point for storing objects.")
+  (:documentation "Store OBJ into Stream PLACE using backend BACKEND.")
   (:method ((obj t) (place t) &optional (designator *default-backend*))
-    "Store OBJ into Stream PLACE using backend BACKEND."
-    (declare (optimize speed))
-    (let* ((backend (backend-designator->backend designator))
-           (*current-backend* backend)
-           (*read-eval* nil))
-      (handler-bind ((error (lambda (c)
-                              (signal (make-condition 'store-error 
-                                                      :caused-by c)))))
-        (backend-store backend place obj)))))
+   "Store OBJ into Stream PLACE using backend BACKEND."
+   (declare (optimize speed))
+   (let* ((backend (backend-designator->backend designator))
+          (*current-backend* backend)
+          (*read-eval* nil))
+     (handler-bind ((error (lambda (c)
+                             (signal (make-condition 'store-error 
+                                                     :caused-by c)))))
+       (backend-store backend place obj)))))
+
 
 (defgeneric backend-store (backend place obj)
   (:method ((backend backend) (place stream) (obj t))


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.22 cl-store/tests.lisp:1.23
--- cl-store/tests.lisp:1.22	Wed May 18 17:34:09 2005
+++ cl-store/tests.lisp	Thu Sep  1 12:24:55 2005
@@ -183,7 +183,13 @@
   
 (deftestit cons.4  '(1 . 2))
 (deftestit cons.5  '(t . nil))
-
+(deftestit cons.6 '(1 2 3 . 5))
+(deftest cons.7 (let ((list (cons nil nil))) ;  '#1=(#1#)))
+                  (setf (car list) list)
+                  (store list *test-file*)
+                  (let ((ret (restore *test-file*)))
+                    (eq ret (car ret))))
+         t)
 
 
 ;; hash tables
@@ -254,7 +260,7 @@
 (deftest standard-object.2
   (let ((val (store (make-instance 'bar
                                    :x (list 1 "foo" 1.0)
-                                   :y #(1 2 3 4))
+                                   :y (vector 1 2 3 4))
                     *test-file*)))
     (let ((ret (restore *test-file*)))
       (and (equalp (get-x val) (get-x ret))
@@ -454,11 +460,11 @@
 (deftest circ.8 (progn (store circ.8 *test-file*)
                        (let ((x (restore *test-file*)))
                          (eql (pathname-name x)
-                             (pathname-type x))))
+                              (pathname-type x))))
   t)
 
 
-(deftest circ.9 (let ((val #("foo" "bar" "baz" 1 2)))
+(deftest circ.9 (let ((val (vector "foo" "bar" "baz" 1 2)))
                   (setf (aref val 3) val)
                   (setf (aref val 4) (aref val 0))
                   (store val *test-file*)
@@ -487,7 +493,7 @@
                           (eql val (gethash val val))))
   t)
 
-(deftest circ.12 (let ((x #(1 2 "foo" 4 5)))
+(deftest circ.12 (let ((x (vector 1 2 "foo" 4 5)))
                    (setf (aref x 0) x)
                    (setf (aref x 1) (aref x 2))
                    (store x *test-file*)
@@ -513,7 +519,40 @@
   t)
 
 
+(deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#)))
+                   (store list *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (and (eq ret (cddddr ret))
+                          (eq (fourth ret) ret))))
+         t)
+                   
+
+
+
+(deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#)))
+                   (store list *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (and (eq ret (cddddr ret))
+                          (eq (fourth ret)
+                              (car (fourth ret))))))
+         t)
+
+
+
+;; this had me confused for a while since what was
+;; restored #1=(1 (#1#) #1#) looks nothing like this list,
+;; but it turns out that it is correct
+(deftest circ.16  (let ((list '#1=(1 #2=(#1#) . #2#)))
+                    (store list *test-file*)
+                    (let ((ret (restore *test-file*)))
+                      (and (eq ret (caadr ret))
+                           (eq ret (third ret)))))
+         t)
+
+
+
 
+;; custom storing
 (defclass random-obj () ((size :accessor size :initarg :size)))
 
 (defvar *random-obj-code* (register-code 100 'random-obj))


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.17 cl-store/utils.lisp:1.18
--- cl-store/utils.lisp:1.17	Wed May 18 17:34:09 2005
+++ cl-store/utils.lisp	Thu Sep  1 12:24:55 2005
@@ -148,4 +148,18 @@
   (values (intern (apply #'mkstr syms))))
 
 
+(defun count-conses (list)
+  "Somewhat like length but will work on dotted lists.
+Circular lists will cause this to hang."
+  (declare (optimize speed)
+           (type list list))
+  (loop for x on list
+        if (not (listp (cdr x)))
+            do (return (1+ ret))
+        else sum 1 into ret
+        finally (return ret)))
+
+(defun proper-list-length (list)
+  (ignore-errors (list-length list)))
+
 ;; EOF


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.10 cl-store/xml-backend.lisp:1.11
--- cl-store/xml-backend.lisp:1.10	Tue Feb  1 09:27:26 2005
+++ cl-store/xml-backend.lisp	Thu Sep  1 12:24:55 2005
@@ -3,85 +3,62 @@
 
 ;; THIS BACKEND IS DEPRECATED AND WILL NOT WORK
 ;; ITS PRESENCE IS FOR POSTERITY ONLY
-
 (in-package :cl-store-xml)
 
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *xml-backend*
-    (defbackend xml :stream-type 'char :extends resolving-backend)))
 
+(defbackend xml :stream-type 'character :extends (resolving-backend))
 
 ;; The xml backend does not use any type codes
 ;; we figure it out when we read the tag of each object
 (defvar *xml-mapping* (make-hash-table :test #'equal))
 (defun add-xml-mapping (name)
   (setf (gethash name *xml-mapping*)
-        (intern name)))
+        (intern name :cl-store-xml)))
 
 (add-xml-mapping "REFERRER")
 (add-xml-mapping "INTEGER")
-(add-xml-mapping "SIMPLE-STRING")
 (add-xml-mapping "FLOAT")
+(add-xml-mapping "SIMPLE-STRING")
+(add-xml-mapping "SYMBOL")
+(add-xml-mapping "CONS")
 (add-xml-mapping "RATIO")
 (add-xml-mapping "CHARACTER")
 (add-xml-mapping "COMPLEX")
-(add-xml-mapping "SYMBOL")
-(add-xml-mapping "CONS")
 (add-xml-mapping "PATHNAME")
-(add-xml-mapping "HASH-TABLE")
-(add-xml-mapping "STANDARD-OBJECT")
-(add-xml-mapping "CONDITION")
-(add-xml-mapping "STRUCTURE-OBJECT")
-(add-xml-mapping "STANDARD-CLASS")
-(add-xml-mapping "BUILT-IN-CLASS")
-(add-xml-mapping "ARRAY")
-(add-xml-mapping "SIMPLE-VECTOR")
-(add-xml-mapping "PACKAGE")
-(add-xml-mapping "VALUES-OBJECT")
-
-;; Used by cmucl and sbcl
-(add-xml-mapping "DOUBLE-FLOAT")
-(add-xml-mapping "SINGLE-FLOAT")
-
-;; Used by lispworks
-(add-xml-mapping "POSITIVE-INFINITY")
-(add-xml-mapping "NEGATIVE-INFINITY")
-(add-xml-mapping "FLOAT-NAN")
-
+(add-xml-mapping "FUNCTION")
+(add-xml-mapping "GENERIC-FUNCTION")
 
-(defmethod get-next-reader ((place list) (backend xml-backend))
+(defmethod get-next-reader ((backend xml) (place list))
   (or (gethash (car place) *xml-mapping*)
-      (values nil (format nil "Unknown tag ~A" (car place)))))
+      (error "Unknown tag ~A" (car place))))
 
-;; required methods and miscellaneous util functions
 (defun princ-xml (tag value stream)
-  (format stream "<~A>~A</~A>" tag value tag))
+  (format stream "<~A>" tag)
+  (xmls:write-xml value stream)
+  (format stream "</~A>" tag))
 
 (defun princ-and-store (tag obj stream)
   (format stream "<~A>" tag)
   (store-object obj stream)
   (format stream "</~A>" tag))
 
-
 (defmacro with-tag ((tag stream) &body body)
   `(progn 
     (format ,stream "<~A>" ,tag)
     , at body
     (format ,stream "</~A>" ,tag)))
-  
+
 (defun first-child (elmt)
   (first (xmls:node-children elmt)))
 
 (defun second-child (elmt)
   (second (xmls:node-children elmt)))
 
-(defun get-child (name elmt)
+(defun get-child (name elmt &optional (errorp t))
   (or (assoc name (xmls:node-children elmt) :test #'equal)
-      (error 'restore-error
-             :datum "No child called ~A in xml ~a"
-             :args (list name elmt))))
+      (and errorp
+           (restore-error "No child called ~A in xml ~a"
+                          (list name elmt)))))
 
 (defun get-attr (name elmt)
   (cadr (assoc name (xmls:node-attrs elmt) :test #'equal)))
@@ -89,84 +66,90 @@
 (declaim (inline restore-first))
 (defun restore-first (place)
   (restore-object (first-child place)))
-  
+
+(defmethod store-referrer ((backend xml) (ref t) (stream t))
+  (princ-xml "REFERRER" ref stream))
+
+(defrestore-xml (referrer place)
+  (make-referrer :val (parse-integer (third place))))
+
+(defmethod referrerp ((backend xml) (reader t))
+  (eql reader 'referrer))
 
 ;; override backend restore to parse the incoming stream
-(defmethod backend-restore ((backend xml-backend) (place stream))
+(defmethod backend-restore ((backend xml) (place stream))
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*print-circle* nil)
-        (*restored-values* (make-hash-table)))
+        (*restored-values* (and *check-for-circs*
+                                (make-hash-table :test #'eq :size *restore-hash-size*))))
     (multiple-value-prog1
-        (backend-restore-object (or (xmls:parse place)
-                                    (restore-error "Invalid xml"))
-                                backend)
+        (backend-restore-object backend
+                                (or (xmls:parse place)
+                                    (restore-error "Invalid xml")))
       (dolist (fn *need-to-fix*)
-        (funcall (the function fn))))))
-
-;; referrer, Required for a resolving backend
-(defmethod store-referrer (ref stream (backend xml-backend))
-  (princ-xml "REFERRER" ref stream))
-
-(defrestore-xml (referrer place)
-  (make-referrer :val (parse-integer (third place))))
-
+        (force fn)))))
 
 ;; integer
 (defstore-xml (obj integer stream)
   (princ-xml "INTEGER" obj stream))
 
-(defrestore-xml (integer place) 
-  (parse-integer (third place)))
+(defrestore-xml (integer from)
+  (values (parse-integer (first-child from))))
 
-;; simple-string
-(defun xml-dump-simple-string (string place)
-  (with-tag ("SIMPLE-STRING" place)
-    (format place "~S" string)))
+;; floats
+(defvar *special-floats* nil) ;; setup in custom-xml files
 
-(defstore-xml (obj simple-string stream)
-  (xml-dump-simple-string obj stream))
+;; FIXME: add support for *special-floats*
+(defstore-xml (obj float stream)
+  (with-tag ("FLOAT" stream) (print obj stream)))
 
-(defrestore-xml (simple-string place)
-  (remove #\" (third place)))
+(defrestore-xml (float from)
+  (cl-l10n:parse-number (first-child from)))
 
+#|
+(defstore-xml (obj single-float stream)
+  (store-float "SINGLE-FLOAT" obj stream))
+
+(defstore-xml (obj double-float stream)
+  (store-float "DOUBLE-FLOAT" obj stream))
+
+(defun store-float (type obj stream)
+  (block body
+    (let (significand exponent sign)
+      (handler-bind ((simple-error
+                      #'(lambda (err)
+                          (declare (ignore err))
+                          (when-let (type (cdr (assoc obj *special-floats*)))
+                            (output-float-type type stream)
+                            (return-from body)))))
+        (multiple-value-setq (significand exponent sign)
+            (integer-decode-float obj))
+        (with-tag (type stream)
+          (princ-and-store "SIGNIFICAND" significand stream)
+          (princ-and-store "RADIX"(float-radix obj) stream)
+          (princ-and-store "EXPONENT" exponent stream)
+          (princ-and-store "SIGN" sign stream))))))
+|#
 
-;; float
-#-(or lispworks sbcl cmu)
-(defstore-xml (obj float stream)
-  (with-tag ("FLOAT" stream)
-    (multiple-value-bind (signif exp sign) 
-        (integer-decode-float obj)
-      (princ-and-store "SIGNIFICAND" signif stream)
-      (princ-and-store "EXPONENT" exp stream)
-      (princ-and-store "SIGN" sign stream)
-      (princ-and-store "TYPE" (float-type obj) stream))))
-
-#-(or sbcl cmu)
-(defrestore-xml (float place)
-  (float (* (* (restore-first (get-child "SIGNIFICAND" place))
-               (expt 2 (restore-first (get-child "EXPONENT" place))))
-            (restore-first (get-child "SIGN" place)))
-         (get-float-type (restore-first (get-child "TYPE" place)))))
+; FIXME: restore flaot
 
 ;; ratio
 (defstore-xml (obj ratio stream)
   (with-tag ("RATIO" stream)
-    (princ-and-store  "NUMERATOR" (numerator obj) stream)
+    (princ-and-store "NUMERATOR" (numerator obj) stream)
     (princ-and-store "DENOMINATOR" (denominator obj) stream)))
 
-(defrestore-xml (ratio place)
-  (/ (restore-first (get-child "NUMERATOR" place))
-     (restore-first (get-child "DENOMINATOR" place))))
+(defrestore-xml (ratio from)
+  (/ (restore-first (get-child "NUMERATOR" from))
+     (restore-first (get-child "DENOMINATOR" from))))
 
-  
-;; character
+;; char
 (defstore-xml (obj character stream)
-  (princ-xml "CHARACTER" (char-code obj) stream))
-
-(defrestore-xml (character place)
-  (code-char (parse-integer (first-child place))))
+  (princ-and-store "CHARACTER" (char-code obj) stream))
 
+(defrestore-xml (character from)
+  (code-char (restore-first from)))
 
 
 ;; complex
@@ -175,43 +158,47 @@
     (princ-and-store "REALPART" (realpart obj) stream)
     (princ-and-store "IMAGPART" (imagpart obj) stream)))
 
-(defrestore-xml (complex place)
-  (complex (restore-first (get-child "REALPART" place))
-           (restore-first (get-child "IMAGPART" place))))
 
-;; symbol
+(defrestore-xml (complex from)
+  (complex (restore-first (get-child "REALPART" from))
+           (restore-first (get-child "IMAGPART" from))))
+
+
+;; symbols 
 (defstore-xml (obj symbol stream)
   (with-tag ("SYMBOL" stream)
-    (princ-xml "NAME" (symbol-name obj) stream)
-    (princ-and-store "PACKAGE" (symbol-package obj) stream)))
-
-(store 'foo "/home/sdr/test.out")
-(restore "/home/sdr/test.out")
-(defrestore-xml (symbol place)
-  (intern (restore-first (get-child "NAME" place))
-          (or (restore-first (get-child "PACKAGE" place))
-              *package*)))
+    (princ-and-store "NAME" (symbol-name obj) stream)
+    (cl-store::when-let (package (symbol-package obj))
+      (princ-and-store "PACKAGE" (package-name package) stream))))
+
+(defrestore-xml (symbol from)
+  (let ((name (restore-first (get-child "NAME" from)))
+        (package (when (get-child "PACKAGE" from nil)
+                   (restore-first (get-child "PACKAGE" from)))))
+    (if package
+        (values (intern name package))
+        (make-symbol name))))
 
-;; cons
+;; lists
 (defstore-xml (obj cons stream)
   (with-tag ("CONS" stream)
-    (with-tag ("CAR" stream)
-      (store-object (car obj) stream))
-    (with-tag ("CDR" stream)
-      (store-object (cdr obj) stream))))
+    (princ-and-store "CAR" (car obj) stream)
+    (princ-and-store "CDR" (cdr obj) stream)))
 
+(defrestore-xml (cons from)
+  (resolving-object (x (cons nil nil))
+    (setting (car x) (restore-first (get-child "CAR" from)))
+    (setting (cdr x) (restore-first (get-child "CDR" from)))))
 
-(defrestore-xml (cons place)
-  (let ((ret (cons nil nil))
-        (car (get-child "CAR" place))
-        (cdr (get-child "CDR" place)))
-    (resolving-object ret
-      (setting car (restore-first car))
-      (setting cdr (restore-first cdr)))))
+;; simple string
+(defstore-xml (obj simple-string stream)
+  (princ-xml "SIMPLE-STRING" obj stream))
 
+(defrestore-xml (simple-string from)
+  (first-child from))
 
 
-;; pathname 
+;; pathnames
 (defstore-xml (obj pathname stream)
   (with-tag ("PATHNAME" stream)
     (princ-and-store "DEVICE" (pathname-device obj) stream)
@@ -229,55 +216,35 @@
    :version (restore-first (get-child "VERSION" place))))
 
 
-;; hash-table
+; hash table
 (defstore-xml (obj hash-table stream)
   (with-tag ("HASH-TABLE" stream)
     (princ-and-store "REHASH-SIZE" (hash-table-rehash-size obj) stream)
-    (princ-and-store "REHASH-THRESHOLD" (hash-table-rehash-threshold obj) 
-                     stream)
+    (princ-and-store "REHASH-THRESHOLD" (hash-table-rehash-threshold obj) stream)
     (princ-and-store "SIZE" (hash-table-size obj) stream)
-    (princ-and-store "TEST"(hash-table-test obj) stream)
+    (princ-and-store "TEST" (hash-table-test obj) stream)
     (with-tag ("ENTRIES" stream)
       (loop for key being the hash-keys of obj
-            for value being the hash-values of obj do
+            using (hash-value value) do
             (with-tag ("ENTRY" stream)
               (princ-and-store "KEY" key stream)
               (princ-and-store "VALUE" value stream))))))
 
-(defrestore-xml (hash-table place)
-  (let ((hash1 (make-hash-table 
-                :rehash-size (restore-first (get-child "REHASH-SIZE" place))
-                :rehash-threshold (restore-first 
-                                   (get-child "REHASH-THRESHOLD" place))
-                :size (restore-first (get-child "SIZE" place))
-                :test (symbol-function (restore-first (get-child "TEST" place))))))
-    (resolving-object hash1
-      (dolist (entry (xmls:node-children (get-child "ENTRIES" place)))
-        (let* ((key-place (first-child (first-child entry)))
-               (val-place (first-child (second-child entry))))
-          (setting-hash (restore-object key-place) 
-                        (restore-object val-place)))))
-    hash1))
-
-
+;; FIXME: restore hash tables
 
+;; objects and conditions
 
-;; objects, conditions and structures
 (defun xml-dump-type-object (obj stream)
-  (let* ((all-slots (remove-if-not (lambda (x)
-                                     (slot-boundp obj (slot-definition-name x)))
-                                   (compute-slots (class-of obj))))
-         (slots (if *store-class-slots* 
-                    all-slots
-                    (remove-if #'(lambda (x) (eql (slot-definition-allocation x)
-                                                  :class))
-                               all-slots))))
+  (let* ((all-slots (serializable-slots obj)))
     (with-tag ("SLOTS" stream)
-      (dolist (slot slots)
-        (with-tag ("SLOT" stream)
-          (let ((slot-name (slot-definition-name slot)))
-            (princ-and-store "NAME" slot-name stream)
-            (princ-and-store "VALUE" (slot-value obj slot-name) stream)))))))
+      (dolist (slot all-slots)
+        (when (slot-boundp obj (slot-definition-name slot))
+          (when (or *store-class-slots* 
+                    (eql (slot-definition-allocation slot) :instance))
+            (with-tag ("SLOT" stream)
+              (let ((slot-name (slot-definition-name slot)))
+                (princ-and-store "NAME" slot-name stream)
+                (princ-and-store "VALUE" (slot-value obj slot-name) stream)))))))))
 
 (defstore-xml (obj standard-object stream)
   (with-tag ("STANDARD-OBJECT" stream)
@@ -289,6 +256,71 @@
     (princ-and-store "CLASS" (type-of obj) stream)
     (xml-dump-type-object obj stream)))
 
+
+;; FIXME: restore objects
+
+
+
+;; classes
+
+;; FIXME : Write me 
+
+;; built in classes
+(defstore-xml (obj built-in-class stream)
+  (princ-and-store "BUILT-IN-CLASS" (class-name obj) stream))
+
+#-ecl ;; for some reason this doesn't work with ecl
+(defmethod internal-store-object ((backend xml) (obj (eql (find-class 'hash-table))) stream)
+  (princ-and-store "BUILT-IN-CLASS" 'cl:hash-table stream))
+
+;; FIXME: restore built in classes
+
+;; arrays and vectors
+;; FIXME : Write me 
+
+;; packages
+;; FIXME : Write me 
+
+;; functions
+(defstore-xml (obj function stream)
+  (princ-and-store "FUNCTION" (get-function-name obj) stream))
+
+(defrestore-xml (function from)
+  (fdefinition (restore-first from)))
+
+;; generic functions
+(defstore-xml (obj generic-function stream)
+  (if (generic-function-name obj)
+      (princ-and-store "GENERIC-FUNCTION" 
+                       (generic-function-name obj) stream)
+      (store-error "No generic function name for ~A." obj)))
+
+(defrestore-xml (generic-function from) 
+  (fdefinition (restore-first from)))
+
+(setf *default-backend* (find-backend 'xml))
+
+#|
+
+;; required methods and miscellaneous util functions
+
+
+(defrestore-xml (hash-table place)
+  (let ((hash1 (make-hash-table 
+                :rehash-size (restore-first (get-child "REHASH-SIZE" place))
+                :rehash-threshold (restore-first 
+                                   (get-child "REHASH-THRESHOLD" place))
+                :size (restore-first (get-child "SIZE" place))
+                :test (symbol-function (restore-first (get-child "TEST" place))))))
+    (resolving-object (hash1 hash1)
+      (dolist (entry (xmls:node-children (get-child "ENTRIES" place)))
+        (let* ((key-place (first-child (first-child entry)))
+               (val-place (first-child (second-child entry))))
+          (setting-hash (restore-object key-place) 
+                        (restore-object val-place)))))
+    hash1))
+
+
 (defun restore-xml-type-object (place)
   (let* ((class (find-class (restore-first (get-child "CLASS" place))))
          (new-instance (allocate-instance class)))
@@ -450,27 +482,5 @@
                        (restore-first element)))))))
                                       
 
-
-;; packages
-(defstore-xml (obj package stream)
-  (princ-and-store "PACKAGE" (package-name obj) stream))
-
-(defrestore-xml (package place)
-  (find-package (restore-first place)))
-
-;; multiple values
-
-(defstore-xml (obj cl-store::values-object stream)
-  (with-tag ("VALUES-OBJECT" stream)
-    (dolist (x (cl-store::vals obj))
-      (princ-and-store "VALUE" x stream))))
-
-
-(defrestore-xml (values-object stream)
-  (apply #'values (loop for x in (xmls:node-children stream) 
-                        collect (restore-first x))))
-  
-
-
-(setf *default-backend* *xml-backend*)
+|#
 ;; EOF


Index: cl-store/xml-package.lisp
diff -u cl-store/xml-package.lisp:1.1 cl-store/xml-package.lisp:1.2
--- cl-store/xml-package.lisp:1.1	Wed Oct  6 16:41:04 2004
+++ cl-store/xml-package.lisp	Thu Sep  1 12:24:55 2005
@@ -2,14 +2,129 @@
 ;; See the file LICENCE for licence information.
 
 (defpackage #:cl-store-xml
-  (:use #:cl #:cl-store #:xmls)
+  (:use #:cl #:cl-store)
   (:export #:*xml-backend*
            #:add-xml-mapping #:defstore-xml #:defrestore-xml #:princ-and-store
            #:princ-xml #:restore-first #:with-tag #:first-child 
            #:second-child #:get-child)
-  (:import-from #:cl-store
-                #:aif
-                #:it))
+  (:import-from #:cl-store #:when-let #:generic-function-name #:get-function-name
+                #:force #:setting #:resolving-object)
+  
+  #+sbcl (:import-from #:sb-mop
+                       #:generic-function-name
+                       #:slot-definition-name
+                       #:slot-definition-allocation
+                       #:slot-definition
+                       #: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)
+
+  #+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-definition-allocation
+                       #:compute-slots
+                       #:slot-definition
+                       #: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 (:shadowing-import-from #:pcl
+                                #:class-name
+                                #:find-class
+                                #:standard-class
+                                #:class-of)
+  
+  #+openmcl (:import-from #:openmcl-mop
+                          #:generic-function-name
+                          #:slot-definition-name
+                          #:slot-definition-allocation
+                          #:compute-slots
+                          #:slot-definition
+                          #: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)
+  
+  #+lispworks  (:import-from #:clos
+                             #:slot-definition-name
+                             #:generic-function-name
+                             #:slot-definition-allocation
+                             #:compute-slots
+                             #:slot-definition
+                             #: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)
+  
+  #+allegro (:import-from #:mop
+                          #:slot-definition-name
+                          #:generic-function-name
+                          #:slot-definition-allocation
+                          #:slot-definition
+                          #: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)
+  )
            
 
 ;; EOF



From sross at common-lisp.net  Thu Sep  1 11:59:31 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  1 Sep 2005 13:59:31 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/tests.lisp 
Message-ID: <20050901115931.4375A8853E@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv16011

Modified Files:
	tests.lisp 
Log Message:
Fixed tests

Date: Thu Sep  1 13:59:30 2005
Author: sross

Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.23 cl-store/tests.lisp:1.24
--- cl-store/tests.lisp:1.23	Thu Sep  1 12:24:55 2005
+++ cl-store/tests.lisp	Thu Sep  1 13:59:30 2005
@@ -315,10 +315,11 @@
 
 (deftest condition.2
   (handler-case (car (read-from-string "3"))
-    (#-allegro type-error #+allegro simple-error (c)
+    ;; allegro pre 7.0 signalled a simple-error here
+    ((or type-error simple-error) (c)
       (store c *test-file*)
       (typep (restore *test-file*) 
-             #-allegro 'type-error #+allegro 'simple-error)))
+             '(or type-error simple-error))))
   t)
 
 ;; structure-object



From sross at common-lisp.net  Fri Sep  9 14:59:19 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri,  9 Sep 2005 16:59:19 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/tests.lisp
	cl-store/utils.lisp 
Message-ID: <20050909145919.1CC40880DA@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv3376

Modified Files:
	ChangeLog cl-store.asd default-backend.lisp tests.lisp 
	utils.lisp 
Log Message:
Changelog 2005-09-09
Date: Fri Sep  9 16:59:17 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.34 cl-store/ChangeLog:1.35
--- cl-store/ChangeLog:1.34	Thu Sep  1 12:24:55 2005
+++ cl-store/ChangeLog	Fri Sep  9 16:59:17 2005
@@ -1,3 +1,8 @@
+2005-09-09 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Altered list serialization to store 
+	all types of lists (proper, dotted and circular) in N time,
+	thanks to Alain Picard for parts of the code.
+
 2005-09-01 Sean Ross <sross at common-lisp.net>
     Version 0.6 Release.
 	* cl-store.asd, package.lisp: Added support for the new release


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.31 cl-store/cl-store.asd:1.32
--- cl-store/cl-store.asd:1.31	Thu Sep  1 12:24:55 2005
+++ cl-store/cl-store.asd	Fri Sep  9 16:59:17 2005
@@ -40,7 +40,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.6"
+  :version "0.6.1"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data"
   :licence "MIT"


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.30 cl-store/default-backend.lisp:1.31
--- cl-store/default-backend.lisp:1.30	Thu Sep  1 12:24:55 2005
+++ cl-store/default-backend.lisp	Fri Sep  9 16:59:17 2005
@@ -4,15 +4,15 @@
 ;; The cl-store backend. 
 (in-package :cl-store)
 
-(defbackend cl-store :magic-number 1953713219
+(defbackend cl-store :magic-number 1416850499
             :stream-type '(unsigned-byte 8)
-            :compatible-magic-numbers (1349740876 1414745155)
-            :old-magic-numbers (1912923 1886611788 1347635532 1886611820 
-                                        1884506444 1347643724 1349732684)
+            :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155
+                                1349740876 1884506444 1347643724 1349732684 1953713219)
             :extends (resolving-backend)
             :fields ((restorers :accessor restorers 
                                 :initform (make-hash-table :size 100))))
 
+
 (defun register-code (code name &optional (errorp t))
   (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp)
        (error "Code ~A is already defined for ~A." code name)
@@ -20,6 +20,8 @@
              name))
   code)
 
+
+
 ;;  Type code constants
 (defvar +referrer-code+ (register-code 1 'referrer nil))
 (defvar +unicode-string-code+ (register-code 3 'unicode-string nil))
@@ -64,10 +66,6 @@
 (defvar +float-double-nan-code+ (register-code 33 'float-double-nan nil))
 (defvar +unicode-base-string-code+ (register-code 34 'unicode-base-string nil))
 (defvar +simple-base-string-code+ (register-code 35 'simple-base-string nil))
-(defvar +proper-list-code+ (register-code 36 'proper-list))
-(defvar +circular-list-code+  (register-code 37 'circular-list))
-(defvar +dotted-list-code+  (register-code 38 'dotted-list))
-
 
 
 ;; setups for type code mapping
@@ -279,49 +277,26 @@
 
 
 ;; Lists
-(defun dump-proper-list (list length stream)
-  (output-type-code +proper-list-code+ stream)
+(defun dump-list (list length last stream)
+  (declare (optimize speed (safety 1) (debug 0))
+           (type cons list))
+  (output-type-code +cons-code+ stream)
   (store-object length stream)
-  (dolist (x list)
-    (store-object x stream)))
-
-
+  (loop repeat length 
+        for x on list do
+        (store-object (car x) stream))
+  (store-object last stream))
 
-
-(defun restore-proper-list (stream)
-  (let ((fixes ()))
-    (let ((ret (loop for count below (restore-object stream)
-                     for elt = (restore-object stream)
-                     if (and *check-for-circs* (referrer-p elt))
-                       do (push (cons count elt) fixes)
-                     collect elt)))
-      ;; This requires a bit of fiddling
-      (when *check-for-circs*
-        (dolist (referrer fixes)
-          (let ((ref (cdr referrer))
-                (pos (car referrer)))
-            (push (delay (setf (nth pos ret)
-                               (referred-value ref *restored-values*)))
-                  *need-to-fix*))))
-      ret)))
-
-(defun dump-dotted-list (list stream)
-  (output-type-code +dotted-list-code+ stream)
-  (store-object (count-conses list) stream)
-  (labels ((rec (list)
-             (cond ((atom (cdr list)) ;; last cons cell
-                    (store-object (car list) stream)
-                    (store-object (cdr list) stream))
-                   (t (store-object (car list) stream)
-                      (rec (cdr list))))))
-    (rec list)))
-
-(defun restore-dotted-list (stream)
-  (let* ((ret ())
-         (tail ret)
-         (conses (restore-object stream)))
+(defun restore-list (stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let* ((conses (restore-object stream))
+         (ret ())
+         (tail ret))
     (dotimes (x conses)
       (let ((obj (restore-object stream)))
+        ;; we can't use setting here since we wan't to
+        ;; be fairly efficient when adding objects to the
+        ;; end of the list.
         (when (and *check-for-circs* (referrer-p obj))
           (let ((x x))
             (push (delay (setf (nth x ret)
@@ -332,37 +307,21 @@
                   tail (cdr tail))
             (setf ret (list obj)
                   tail (last ret)))))
-    (setf (cdr tail) (restore-object stream))
+    (let ((last1 (restore-object stream)))
+      ;; and check for the last possible circularity
+      (if (and *check-for-circs* (referrer-p last1))
+          (push (delay (setf (cdr tail)
+                             (referred-value last1 *restored-values*)))
+                *need-to-fix*)
+          (setf (cdr tail) last1)))
     ret))
 
-(defun dump-circular-list (list stream)
-  (output-type-code +circular-list-code+ stream)
-  (store-object (car list) stream)
-  (store-object (cdr list) stream))
-
 (defstore-cl-store (list cons stream)
-  (multiple-value-bind (length errorp)
-      (proper-list-length list)
-    (cond (errorp (dump-dotted-list list stream))
-          (length (dump-proper-list list length stream))
-          (t (dump-circular-list list stream)))))
-
-(defrestore-cl-store (proper-list stream)
-  (restore-proper-list stream))
-
-(defrestore-cl-store (dotted-list stream)
-  (restore-dotted-list stream))
-
-(defrestore-cl-store (circular-list stream)
-  (resolving-object (ret (cons nil nil))
-    (setting (car ret) (restore-object stream))
-    (setting (cdr ret) (restore-object stream))))
+  (multiple-value-bind (length last) (safe-length list)
+    (dump-list list length last stream)))
 
-;; kept for backwards compatibility
 (defrestore-cl-store (cons stream)
-  (resolving-object (ret (cons nil nil))
-    (setting (car ret) (restore-object stream))
-    (setting (cdr ret) (restore-object stream))))
+  (restore-list stream))
 
 
 ;; pathnames
@@ -513,7 +472,6 @@
   (find-class (restore-object stream)))
 
 
-
 ;; Arrays, vectors and strings.
 (defstore-cl-store (obj array stream)
   (declare (optimize speed (safety 1) (debug 0)))
@@ -524,7 +482,8 @@
     (t (store-array obj stream))))
 
 (defun store-array (obj stream)
-  (declare (optimize speed (safety 1) (debug 0)))
+  (declare (optimize speed (safety 0) (debug 0))
+           (type array obj))
   (output-type-code +array-code+ stream)
   (if (and (= (array-rank obj) 1)
            (array-has-fill-pointer-p obj))


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.24 cl-store/tests.lisp:1.25
--- cl-store/tests.lisp:1.24	Thu Sep  1 13:59:30 2005
+++ cl-store/tests.lisp	Fri Sep  9 16:59:17 2005
@@ -231,6 +231,7 @@
           (equalp (cl-store::external-symbols (find-package :foo))
                   (make-array 1 :initial-element (find-symbol "BAR" "FOO"))))))
 
+
 ; unfortunately it's difficult to portably test the internal symbols
 ; in a package so we just assume that it's OK.
 (deftest package.2 
@@ -286,7 +287,6 @@
          9)))
   t)
 
-
 ;; classes
 (deftest standard-class.1 (progn (store (find-class 'foo) *test-file*) 
                                  (restore *test-file*)
@@ -302,7 +302,7 @@
                                  (restore *test-file*)
                                  t)
   t)
-  
+
 
 
 ;; conditions
@@ -550,6 +550,18 @@
                            (eq ret (third ret)))))
          t)
 
+;; large circular lists
+(deftest large.1 (let ((list (make-list 100000)))
+                   (setf (cdr (last list)) list)
+                   (store list *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (eq (nthcdr 100000 ret) ret)))
+         t)
+
+;; large dotted lists
+(deftestit large.2 (let ((list (make-list 100000)))
+                     (setf (cdr (last list)) 'foo)
+                     list))
 
 
 


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.18 cl-store/utils.lisp:1.19
--- cl-store/utils.lisp:1.18	Thu Sep  1 12:24:55 2005
+++ cl-store/utils.lisp	Fri Sep  9 16:59:17 2005
@@ -147,19 +147,20 @@
   "Concatenate all symbol names into one big symbol"
   (values (intern (apply #'mkstr syms))))
 
-
-(defun count-conses (list)
-  "Somewhat like length but will work on dotted lists.
-Circular lists will cause this to hang."
-  (declare (optimize speed)
-           (type list list))
-  (loop for x on list
-        if (not (listp (cdr x)))
-            do (return (1+ ret))
-        else sum 1 into ret
-        finally (return ret)))
-
-(defun proper-list-length (list)
-  (ignore-errors (list-length list)))
+;; Taken straight from swank.lisp --- public domain
+;; and then slightly modified
+(defun safe-length (list)
+  "Similar to `list-length', but avoid errors on improper lists.
+Return two values: the length of the list and the last cdr.
+Modified to work on circular lists."
+  (do ((n 0 (+ n 2))                    ;Counter.
+       (fast list (cddr fast))          ;Fast pointer: leaps by 2.
+       (slow list (cdr slow)))          ;Slow pointer: leaps by 1.
+      (nil)
+    (cond ((null fast) (return (values n nil)))
+          ((not (consp fast)) (return (values n fast)))
+          ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
+          ((and (eq fast slow) (> n 0)) (return (values (/ n 2) list)))
+          ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
 
 ;; EOF