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

Modified Files: ChangeLog circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp Log Message: Changelog 2005-03-24 Date: Thu Mar 24 09:25:17 2005 Author: sross

Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.28 cl-store/ChangeLog:1.29 --- cl-store/ChangeLog:1.28 Wed Mar 23 13:58:43 2005 +++ cl-store/ChangeLog Thu Mar 24 09:25:16 2005 @@ -1,3 +1,12 @@ +2005-03-24 Sean Ross sross@common-lisp.net + * backends.lisp, circularities.lisp, tests.lisp: + Added test gensym.2 which crashed in previous + versions (pre 0.5.7). Symbols are now tested + for equality when storing. + int-sym-or-char-p renamed to int-or-char-p. + * plumbing.lisp: Added error to the superclasses + of restore-error and store-error. + 2005-03-23 Sean Ross sross@common-lisp.net * backends.lisp: Fix up for type specifications for the old-magic-numbers and stream-type slots

Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.18 cl-store/circularities.lisp:1.19 --- cl-store/circularities.lisp:1.18 Wed Mar 23 13:58:43 2005 +++ cl-store/circularities.lisp Thu Mar 24 09:25:17 2005 @@ -116,7 +116,7 @@ (deftype not-circ () "Type grouping integer, characters and symbols, which we don't bother to check if they have been stored before" - '(or integer character symbol)) + '(or integer character))

(defun needs-checkp (obj) "Do we need to check if this object has been stored before?" @@ -131,9 +131,10 @@

(defun get-ref (obj) (if (needs-checkp obj) - (aif (seen obj) - it - (update-seen obj)) + (multiple-value-bind (val win) (seen obj) + (if (or val win) + val + (update-seen obj))) nil))

(defmethod backend-store-object ((backend resolving-backend) (obj t) (place t)) @@ -179,7 +180,7 @@ (cond ((referrerp backend reader) (incf *restore-counter*) (new-val (internal-restore-object backend reader place))) - ((not (int-sym-or-char-p backend reader)) + ((not (int-or-char-p backend reader)) (handle-normal backend reader place)) (t (new-val (internal-restore-object backend reader place))))))

@@ -189,18 +190,25 @@ (handle-restore place backend) (call-next-method)))

-(defgeneric int-sym-or-char-p (backend fn) +; This used to be called int-sym-or-char-p +; but was renamed to handle eq symbols (gensym's mainly). +; The basic concept is that we don't bother +; checking for circularities with integers or +; characters since these aren't gauraunteed to be eq +; even if they are the same object. +; (notes for eq in CLHS). +(defgeneric int-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)))) + "Is function FN registered to restore an integer or character in BACKEND." + (member fn '(integer character))))

(defun new-val (val) "Tries to get a referred value to reduce unnecessary cirularity fixing." (if (referrer-p val) - (aif (referred-value val *restored-values*) - it - val) + (multiple-value-bind (new-val win) (referred-value val *restored-values*) + (if (or new-val win) + new-val + val)) val))

;; EOF

Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.26 cl-store/cl-store.asd:1.27 --- cl-store/cl-store.asd:1.26 Wed Mar 23 13:58:43 2005 +++ cl-store/cl-store.asd Thu Mar 24 09:25: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.5.4" + :version "0.5.8" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT"

Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.25 cl-store/default-backend.lisp:1.26 --- cl-store/default-backend.lisp:1.25 Wed Mar 23 13:58:43 2005 +++ cl-store/default-backend.lisp Thu Mar 24 09:25:17 2005 @@ -103,8 +103,8 @@ ;; so we we have a little optimization for it

;; We need this for circularity stuff. -(defmethod int-sym-or-char-p ((backend cl-store) (type symbol)) - (find type '(integer character 32-bit-integer symbol))) +(defmethod int-or-char-p ((backend cl-store) (type symbol)) + (find type '(integer character 32-bit-integer)))

(defstore-cl-store (obj integer stream) (if (typep obj 'sb32) @@ -545,8 +545,8 @@ (store-object (mapcar (if *store-used-packages* #'identity #'package-name) (package-use-list obj)) stream) - (store-object (package-shadowing-symbols obj) stream) (store-object (internal-symbols obj) stream) + (store-object (package-shadowing-symbols obj) stream) (store-object (external-symbols obj) stream))

(defun remove-remaining (times stream) @@ -578,14 +578,14 @@ acc))

(defun restore-package (package-name stream &key force) - (when force + (when (and force (find-package package-name)) (delete-package package-name)) (let ((package (make-package package-name :nicknames (restore-object stream) :use (restore-object stream)))) - (shadow (restore-object stream) package) (loop for symbol across (restore-object stream) do (import symbol package)) + (shadow (restore-object stream) package) (loop for symbol across (restore-object stream) do (export symbol package)) package))

Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.20 cl-store/package.lisp:1.21 --- cl-store/package.lisp:1.20 Fri Feb 18 09:15:49 2005 +++ cl-store/package.lisp Thu Mar 24 09:25:17 2005 @@ -13,7 +13,7 @@ #:restore #:backend-store #:store-backend-code #:store-object #:backend-store-object #:get-class-details #:get-array-values #:restore #:backend-restore #:cl-store #:referrerp - #:check-magic-number #:get-next-reader #:int-sym-or-char-p + #:check-magic-number #:get-next-reader #:int-or-char-p #:restore-object #:backend-restore-object #:serializable-slots #:defstore-cl-store #:defrestore-cl-store #:register-code #:output-type-code #:store-referrer #:resolving-object

Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.13 cl-store/plumbing.lisp:1.14 --- cl-store/plumbing.lisp:1.13 Wed Mar 23 13:58:43 2005 +++ cl-store/plumbing.lisp Thu Mar 24 09:25:17 2005 @@ -45,11 +45,11 @@ (:report cl-store-report) (:documentation "Root cl-store condition"))

-(define-condition store-error (cl-store-error) +(define-condition store-error (error cl-store-error) () (:documentation "Error thrown when storing an object fails."))

-(define-condition restore-error (cl-store-error) +(define-condition restore-error (error cl-store-error) () (:documentation "Error thrown when restoring an object fails."))

Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.18 cl-store/tests.lisp:1.19 --- cl-store/tests.lisp:1.18 Wed Mar 23 13:58:43 2005 +++ cl-store/tests.lisp Thu Mar 24 09:25:17 2005 @@ -166,6 +166,13 @@ (mismatch "Foobar" (symbol-name new))))) (nil 6))

+; This failed in cl-store < 0.5.5 +(deftest gensym.2 (let ((x (gensym))) + (store (list x x) *test-file*) + (let ((new (restore *test-file*))) + (eq (car new) (cadr new)))) + t) +

;; cons

@@ -205,16 +212,17 @@ (:export bar))

(defun package-restores () - (store (find-package :foo) *test-file*) - (delete-package :foo) - (restore *test-file*) - (list (package-name (find-package :foo)) - (mapcar #'package-name (package-use-list :foo)) - (package-nicknames :foo) - (equalp (remove-duplicates (package-shadowing-symbols :foo)) - (list (find-symbol "FORMAT" "FOO"))) - (equalp (cl-store::external-symbols (find-package :foo)) - (make-array 1 :initial-element (find-symbol "BAR" "FOO"))))) + (let (( *nuke-existing-packages* t)) + (store (find-package :foo) *test-file*) + (delete-package :foo) + (restore *test-file*) + (list (package-name (find-package :foo)) + (mapcar #'package-name (package-use-list :foo)) + (package-nicknames :foo) + (equalp (remove-duplicates (package-shadowing-symbols :foo)) + (list (find-symbol "FORMAT" "FOO"))) + (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.