Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv23541
Modified Files:
ChangeLog circularities.lisp cl-store.asd default-backend.lisp
package.lisp plumbing.lisp
Log Message:
See ChangeLog 2004-09-27
Date: Mon Sep 27 13:24:18 2004
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.7 cl-store/ChangeLog:1.8
--- cl-store/ChangeLog:1.7 Sun Sep 5 16:56:06 2004
+++ cl-store/ChangeLog Mon Sep 27 13:24:18 2004
@@ -1,3 +1,8 @@
+2004-09-27 Sean Ross <sdr(a)jhb.ucs.co.za>
+ * plumbing.lisp: Slightly nicer error handling (I think).
+ All conditions caught in store and restore are resignalled
+ and rethrown as a store or restore error respectively.
+
2004-09-01 Sean Ross <sdr(a)jhb.ucs.co.za>
* sbcl/custom.lisp, sbcl/custom-xml.lisp: Custom structure storing.
* cmucl/custom.lisp, cmucl/custom-xml.lisp: Custom structure storing.
Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.6 cl-store/circularities.lisp:1.7
--- cl-store/circularities.lisp:1.6 Mon Aug 30 17:10:20 2004
+++ cl-store/circularities.lisp Mon Sep 27 13:24:18 2004
@@ -116,7 +116,7 @@
(defvar *stored-values*)
-(defmethod backend-store ((obj t) (place t) (backend resolving-backend))
+(defmethod backend-store ((obj t) (place stream) (backend resolving-backend))
"Store OBJ into PLACE. Does the setup for counters and seen values."
(let ((*stored-counter* 0)
(*stored-values* (make-hash-table :test #'eq)))
@@ -185,10 +185,10 @@
(*restored-values* (make-hash-table)))
(check-stream-element-type place backend)
(check-magic-number place backend)
- (let ((obj (backend-restore-object place backend)))
+ (prog1
+ (backend-restore-object place backend)
(dolist (fn *need-to-fix*)
- (funcall (the function fn)))
- obj)))
+ (funcall (the function fn))))))
(defmethod backend-restore-object ((place t) (backend resolving-backend))
"Retrieve a object from PLACE, does housekeeping for circularity fixing."
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.7 cl-store/cl-store.asd:1.8
--- cl-store/cl-store.asd:1.7 Sun Sep 5 16:56:06 2004
+++ cl-store/cl-store.asd Mon Sep 27 13:24:18 2004
@@ -39,7 +39,7 @@
:name "CL-STORE"
:author "Sean Ross <sdr(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>"
- :version "0.2.2"
+ :version "0.2.3"
: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.5 cl-store/default-backend.lisp:1.6
--- cl-store/default-backend.lisp:1.5 Sun Sep 5 16:56:06 2004
+++ cl-store/default-backend.lisp Mon Sep 27 13:24:18 2004
@@ -3,11 +3,13 @@
;; The cl-store backend.
-;; cater for unicode characters in symbol names
-;; Outstanding objects.
-;; functions, methods
+;; functions
;; closures (once done add initform, and default-initargs)
-
+;; funcallable instances (methods and generic functions)
+;; add variable *store-methods-with-classes*
+;; some sort of optimization for bignums
+;; cater for unicode characters in symbol names
+;; Other MOP classes.
(in-package :cl-store)
@@ -44,6 +46,7 @@
(defconstant +array-code+ (register-code 19 'array))
(defconstant +simple-vector-code+ (register-code 20 'simple-vector))
(defconstant +package-code+ (register-code 21 'package))
+(defconstant +function-code+ (register-code 22 'function))
;; setups for type code mapping
(defun output-type-code (code stream)
Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.9 cl-store/package.lisp:1.10
--- cl-store/package.lisp:1.9 Mon Aug 30 17:10:20 2004
+++ cl-store/package.lisp Mon Sep 27 13:24:18 2004
@@ -18,6 +18,7 @@
#:*store-class-slots*
#:*nuke-existing-classes*
#:*store-class-superclasses*
+ #:cl-store-error
#:store-error
#:restore-error
#:store
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.1 cl-store/plumbing.lisp:1.2
--- cl-store/plumbing.lisp:1.1 Tue Aug 17 13:12:43 2004
+++ cl-store/plumbing.lisp Mon Sep 27 13:24:18 2004
@@ -21,22 +21,29 @@
;; conditions
-;; Should these be the only errors that are thrown
-;; from store and restore?
-(define-condition store-error ()
- ((format-string :accessor format-string :initarg :format-string :initform "Unknown")
+;; From 0.2.3 all conditions which are signalled from
+;; store or restore will be rethrown as store-error and
+;; restore-error respectively. The original condition
+;; is still signalled.
+(define-condition cl-store-error (condition)
+ ((caused-by :accessor caused-by :initarg :caused-by
+ :initform nil)
+ (format-string :accessor format-string :initarg :format-string
+ :initform "Unknown")
(format-args :accessor format-args :initarg :format-args :initform nil))
(:report (lambda (condition stream)
- (apply #'format stream (format-string condition)
- (format-args condition))))
+ (aif (caused-by condition)
+ (format stream "~A" it)
+ (apply #'format stream (format-string condition)
+ (format-args condition)))))
+ (:documentation "Root cl-store condition"))
+
+(define-condition store-error (cl-store-error)
+ ()
(:documentation "Error thrown when storing an object fails."))
-(define-condition restore-error ()
- ((format-string :accessor format-string :initarg :format-string :initform "Unknown")
- (format-args :accessor format-args :initarg :format-args :initform nil))
- (:report (lambda (condition stream)
- (apply #'format stream (format-string condition)
- (format-args condition))))
+(define-condition restore-error (cl-store-error)
+ ()
(:documentation "Error thrown when restoring an object fails."))
(defun store-error (format-string &rest args)
@@ -46,6 +53,8 @@
(error 'restore-error :format-string format-string :format-args args))
+
+
;; entry points
(defun store-to-file (obj place backend)
(let* ((backend-type (stream-type backend))
@@ -54,33 +63,36 @@
(integer '(unsigned-byte 8)))))
(with-open-file (s place :element-type element-type
:direction :output :if-exists :supersede)
- (store obj s backend))))
+ (backend-store obj s backend))))
(defgeneric store (obj place &optional backend)
(:documentation "Entry Point for storing objects.")
- (:method ((obj t) (place stream) &optional (backend *default-backend*))
+ (:method ((obj t) (place t) &optional (backend *default-backend*))
"Store OBJ into Stream PLACE using backend BACKEND."
(let ((*current-backend* backend))
- (backend-store obj place backend)))
- (:method ((obj t) (place string) &optional (backend *default-backend*))
- "Store OBJ into file designator PLACE using backend BACKEND."
- (store-to-file obj place backend))
- (:method ((obj t) (place pathname) &optional (backend *default-backend*))
- "Store OBJ into file designator PLACE using backend BACKEND."
- (store-to-file obj place backend)))
-
+ (handler-case (backend-store obj place backend)
+ (condition (c)
+ (signal c)
+ (error (make-condition 'store-error
+ :caused-by c)))))))
(defgeneric backend-store (obj place backend)
(:argument-precedence-order backend place obj)
- (:documentation "Method wrapped by store, override this method for
-custom behaviour (see circularities.lisp).")
- (:method ((obj t) (place t) (backend t))
+ (:method ((obj t) (place stream) (backend t))
"The default. Checks the streams element-type, stores the backend code
and calls store-object."
(check-stream-element-type place backend)
(store-backend-code place backend)
(store-object obj place backend)
- obj))
+ obj)
+ (:method ((obj t) (place string) (backend t))
+ "Store OBJ into file designator PLACE."
+ (store-to-file obj place backend))
+ (:method ((obj t) (place pathname) (backend t))
+ "Store OBJ into file designator PLACE."
+ (store-to-file obj place backend))
+ (:documentation "Method wrapped by store, override this method for
+ custom behaviour (see circularities.lisp)."))
@@ -131,7 +143,10 @@
(:method (place &optional (backend *default-backend*))
"Entry point for restoring objects (setfable)."
(let ((*current-backend* backend))
- (backend-restore place backend))))
+ (handler-case (backend-restore place backend)
+ (condition (c) (signal c)
+ (error (make-condition 'restore-error
+ :caused-by c)))))))
(defgeneric backend-restore (place backend)
(:argument-precedence-order backend place)
