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

Modified Files: ChangeLog cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp Log Message: Changelog 2005-02-16 Date: Wed Feb 16 13:40:24 2005 Author: sross

Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.21 cl-store/ChangeLog:1.22 --- cl-store/ChangeLog:1.21 Mon Feb 14 10:02:33 2005 +++ cl-store/ChangeLog Wed Feb 16 13:40:24 2005 @@ -1,3 +1,8 @@ +2005-02-16 Sean Ross sross@common-lisp.net + * default-backend.lisp, package.lisp, plumbing.lisp: Patch + from Thomas Stenhaug which adds more comprehensive package + storing. + 2005-02-14 Sean Ross sross@common-lisp.net * default-backend.lisp: Applied patch from Thomas Stenhaug to default null superclasses of a restored class to

Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.20 cl-store/cl-store.asd:1.21 --- cl-store/cl-store.asd:1.20 Mon Feb 14 10:02:34 2005 +++ cl-store/cl-store.asd Wed Feb 16 13:40:24 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.4.14" + :version "0.4.15" :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.19 cl-store/default-backend.lisp:1.20 --- cl-store/default-backend.lisp:1.19 Mon Feb 14 10:02:34 2005 +++ cl-store/default-backend.lisp Wed Feb 16 13:40:24 2005 @@ -21,7 +21,6 @@

;; Type code constants (defvar +referrer-code+ (register-code 1 'referrer nil)) -;(defvar +values-code+ (register-code 2 'values-object nil)) (defvar +unicode-string-code+ (register-code 3 'unicode-string nil)) (defvar +integer-code+ (register-code 4 'integer nil)) (defvar +simple-string-code+ (register-code 5 'simple-string nil)) @@ -42,14 +41,12 @@ (defvar +simple-vector-code+ (register-code 20 'simple-vector nil)) (defvar +package-code+ (register-code 21 'package nil))

-;; Used by lispworks (defvar +positive-infinity-code+ (register-code 22 'positive-infinity nil)) (defvar +negative-infinity-code+ (register-code 23 'negative-infinity nil))

;; new storing for 32 bit ints (defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))

-;; More for lispworks (defvar +float-nan-code+ (register-code 25 'nan-float nil))

(defvar +function-code+ (register-code 26 'function nil)) @@ -187,10 +184,10 @@

(defrestore-cl-store (float stream) (float (* (get-float-type (read-byte stream)) - (* (restore-object stream) - (expt (restore-object stream) - (restore-object stream))) - (restore-object stream)))) + (* (the integer (restore-object stream)) + (expt (the integer (restore-object stream)) + (the integer (restore-object stream)))) + (the integer (restore-object stream)))))

(defun handle-special-float (code name) (aif (rassoc code *special-floats*) @@ -534,15 +531,55 @@ (setf (schar res x) (code-char (funcall reader stream)))) res))

-;; packages +;; packages (from Thomas Stenhaug) (defstore-cl-store (obj package stream) - (output-type-code +package-code+ stream) - (store-object (package-name obj) stream)) + (output-type-code +package-code+ stream) + (store-object (package-name obj) stream) + (store-object (package-nicknames obj) stream) + (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 (external-symbols obj) stream))

(defrestore-cl-store (package stream) - (find-package (restore-object stream))) - - + (let* ((package-name (restore-object stream)) + (existing-package (find-package package-name))) + (cond ((or (not existing-package) + (and existing-package *nuke-existing-packages*)) + (restore-package package-name stream :force *nuke-existing-packages*)) + (t (dotimes (x 5) ; remove remaining objects from the stream + (restore-object stream)) + existing-package)))) + +(defun internal-symbols (package) + (let ((acc (make-array 100 :adjustable t :fill-pointer 0)) + (used (package-use-list package))) + (do-symbols (symbol package) + (unless (find (symbol-package symbol) used) + (vector-push-extend symbol acc))) + acc)) + +(defun external-symbols (package) + (let ((acc (make-array 100 :adjustable t :fill-pointer 0))) + (do-external-symbols (symbol package) + (vector-push-extend symbol acc)) + acc)) + +(defun restore-package (package-name stream &key force) + (when force + (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)) + (loop for symbol across (restore-object stream) do + (export symbol package)) + package)) + ;; Function storing hack. ;; This just stores the function name if we can find it ;; or signal a store-error.

Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.17 cl-store/package.lisp:1.18 --- cl-store/package.lisp:1.17 Fri Feb 11 13:00:31 2005 +++ cl-store/package.lisp Wed Feb 16 13:40:24 2005 @@ -21,7 +21,8 @@ #:float-type #:get-float-type #:make-referrer #:setting-hash #:multiple-value-store #:*postfix-setters* #:caused-by #:store-32-bit #:read-32-bit #:*check-for-circs* - #:*store-hash-size* #:*restore-hash-size*) + #:*store-hash-size* #:*restore-hash-size* + #:*store-used-packages* #:*nuke-existing-packages*)

#+sbcl (:import-from #:sb-mop #:generic-function-name

Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.10 cl-store/plumbing.lisp:1.11 --- cl-store/plumbing.lisp:1.10 Fri Feb 11 13:00:31 2005 +++ cl-store/plumbing.lisp Wed Feb 16 13:40:24 2005 @@ -6,6 +6,11 @@

(in-package :cl-store)

+(defvar *store-used-packages* nil + "If non-nil will serialize each used package otherwise will +only store the package name") +(defvar *nuke-existing-packages* nil + "Whether or not to overwrite existing packages on restoration.") (defvar *nuke-existing-classes* nil "Do we overwrite existing class definitions on restoration.") (defvar *store-class-superclasses* nil

Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.14 cl-store/tests.lisp:1.15 --- cl-store/tests.lisp:1.14 Fri Feb 11 13:00:31 2005 +++ cl-store/tests.lisp Wed Feb 16 13:40:24 2005 @@ -191,7 +191,29 @@ ;; packages (deftestit package.1 (find-package :cl-store))

+(defpackage foo + (:nicknames foobar) + (:use :cl) + (:shadow cl:format) + (: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"))))) + +; unfortunately it's difficult to portably test the internal symbols +; in a package so we just have to assume that it's OK. +(deftest package.2 + (package-restores) + ("FOO" ("COMMON-LISP") ("FOOBAR") t t))

;; objects (defclass foo ()