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