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