[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/plumbing.lisp cl-store/tests.lisp
Sean Ross
sross at common-lisp.net
Wed Feb 16 12:40:27 UTC 2005
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 at 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 at 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 at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at 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 ()
More information about the Cl-store-cvs
mailing list