Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv2524
Modified Files:
ChangeLog backends.lisp cl-store.asd default-backend.lisp
package.lisp plumbing.lisp utils.lisp
Log Message:
Changelog 2005-11-30
Date: Wed Nov 30 10:49:56 2005
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.37 cl-store/ChangeLog:1.38
--- cl-store/ChangeLog:1.37 Thu Oct 6 09:49:45 2005
+++ cl-store/ChangeLog Wed Nov 30 10:49:56 2005
@@ -1,3 +1,12 @@
+2005-11-30 Sean Ross <sross(a)common-lisp.net>
+ * package.lisp: Added imports for MCL (from Gary King)
+ * backends.lisp: Changed definition of the defstore-? and
+ defrestore-? macros to work with lispworks dspecs.
+ * default-backend.lisp: Fixed the *sbcl-readtable* to copy
+ the default readtable.
+ * plumbing.lisp: Changed cl-store-error to extend directly from error
+ and removed error from restore-error and store-error's precedence list.
+
2005-10-06 Sean Ross <sross(a)common-lisp.net>
* backends.lisp: Fixed type definition for
compatible-magic-numbers from integer to list.
@@ -7,7 +16,8 @@
* sbcl/custom.lisp: sb-kernel:instance is no
longer a class (since 0.9.5.3 or so). Fixed
definition of *sbcl-struct-inherits* to work
- with or without this class. Reported by Rafał Strzaliński.
+ with or without this class.
+ Reported by Rafał Strzaliński.
2005-09-20 Sean Ross <sross(a)common-lisp.net>
* default-backend.lisp: Changed storing and restoring
Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.12 cl-store/backends.lisp:1.13
--- cl-store/backends.lisp:1.12 Thu Oct 6 09:49:46 2005
+++ cl-store/backends.lisp Wed Nov 30 10:49:56 2005
@@ -43,6 +43,23 @@
(symbol (find-backend designator t))
(backend designator)))
+
+#+lispworks
+(defun get-store-macro (name)
+ "Return the defstore-? macro which will be used by a custom backend"
+ (let ((macro-name (symbolicate 'defstore- name)))
+ `(defmacro ,macro-name ((var type stream &optional qualifier)
+ &body body)
+ (with-gensyms (gbackend)
+ `(dspec:def (,',macro-name (,var ,type ,stream))
+ (defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
+ ((,gbackend ,',name) (,var ,type) ,stream)
+ ,(format nil "Definition for storing an object of type ~A with ~
+ backend ~A" type ',name)
+ (declare (ignorable ,gbackend))
+ ,@body))))))
+
+#-lispworks
(defun get-store-macro (name)
"Return the defstore-? macro which will be used by a custom backend"
(let ((macro-name (symbolicate 'defstore- name)))
@@ -50,12 +67,25 @@
&body body)
(with-gensyms (gbackend)
`(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
- ((,gbackend ,',name) (,var ,type) ,stream)
- ,(format nil "Definition for storing an object of type ~A with ~
+ ((,gbackend ,',name) (,var ,type) ,stream)
+ ,(format nil "Definition for storing an object of type ~A with ~
backend ~A" type ',name)
- (declare (ignorable ,gbackend))
- ,@body)))))
+ (declare (ignorable ,gbackend))
+ ,@body)))))
+
+#+lispworks
+(defun get-restore-macro (name)
+ "Return the defrestore-? macro which will be used by a custom backend"
+ (let ((macro-name (symbolicate 'defrestore- name)))
+ `(defmacro ,macro-name ((type place &optional qualifier) &body body)
+ (with-gensyms (gbackend gtype)
+ `(dspec:def (,',macro-name (,type ,place))
+ (defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
+ ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
+ (declare (ignorable ,gbackend ,gtype))
+ ,@body))))))
+#-lispworks
(defun get-restore-macro (name)
"Return the defrestore-? macro which will be used by a custom backend"
(let ((macro-name (symbolicate 'defrestore- name)))
@@ -66,6 +96,7 @@
(declare (ignorable ,gbackend ,gtype))
,@body)))))
+
(defun register-backend (name class magic-number stream-type old-magic-numbers
compatible-magic-numbers)
(declare (type symbol name))
@@ -87,6 +118,23 @@
(:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)."
name))))
+
+#+lispworks
+(defun get-dspec-alias-and-parser (name)
+ (let ((store-name (symbolicate 'defstore- name))
+ (restore-name (symbolicate 'defrestore- name)))
+ `( (dspec:define-dspec-alias ,store-name (arglist)
+ `(method cl-store::internal-store-object ,arglist))
+ (dspec:define-form-parser ,store-name (arglist)
+ `(,,store-name ,arglist))
+
+ (dspec:define-dspec-alias ,restore-name (arglist)
+ `(method cl-store::internal-restore-object ,arglist))
+
+ (dspec:define-form-parser ,restore-name (arglist)
+ `(,,restore-name ,arglist)))))
+
+
(defmacro defbackend (name &key (stream-type ''(unsigned-byte 8))
(magic-number nil) fields (extends '(backend))
(old-magic-numbers nil) (compatible-magic-numbers nil))
@@ -98,6 +146,7 @@
(assert (symbolp name))
`(eval-when (:load-toplevel :execute)
(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+lispworks ,@(get-dspec-alias-and-parser name)
,(get-class-form name fields extends)
,(get-store-macro name)
,(get-restore-macro name))
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.34 cl-store/cl-store.asd:1.35
--- cl-store/cl-store.asd:1.34 Thu Oct 6 09:53:04 2005
+++ cl-store/cl-store.asd Wed Nov 30 10:49:56 2005
@@ -40,19 +40,20 @@
:name "CL-STORE"
:author "Sean Ross <sdr(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>"
- :version "0.6.4"
+ :version "0.6.8"
:description "Serialization package"
:long-description "Portable CL Package to serialize data"
:licence "MIT"
+ :serial t
:components ((:file "package")
#+(and clisp (not mop))
- (:non-required-file "mop" :depends-on ("package"))
- (:file "utils" :depends-on ("package"))
- (:file "backends" :depends-on ("utils"))
- (:file "plumbing" :depends-on ("backends"))
- (:file "circularities" :depends-on ("plumbing"))
- (:file "default-backend" :depends-on ("circularities"))
- (:non-required-file "custom" :depends-on ("default-backend"))))
+ (:non-required-file "mop")
+ (:file "utils")
+ (:file "backends")
+ (:file "plumbing")
+ (:file "circularities")
+ (:file "default-backend")
+ (:non-required-file "custom")))
(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store))))
(provide 'cl-store))
Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.32 cl-store/default-backend.lisp:1.33
--- cl-store/default-backend.lisp:1.32 Tue Oct 4 10:10:26 2005
+++ cl-store/default-backend.lisp Wed Nov 30 10:49:56 2005
@@ -13,6 +13,7 @@
: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)
@@ -245,7 +246,6 @@
(/ (the integer (restore-object stream))
(the integer (restore-object stream))))
-
;; chars
(defstore-cl-store (obj character stream)
(output-type-code +character-code+ stream)
@@ -689,7 +689,7 @@
name)))
#+sbcl
-(defvar *sbcl-readtable* (copy-readtable *readtable*))
+(defvar *sbcl-readtable* (copy-readtable nil))
#+sbcl
(set-macro-character #\# #'(lambda (c s)
(declare (ignore c s))
@@ -710,9 +710,10 @@
(*readtable* *sbcl-readtable*))
(unless (string= new-name "")
(handler-case (read-from-string new-name)
- (error (c) (declare (ignore c))
- (store-error "Unable to determine function name for ~A."
- obj))))))
+ (error (c)
+ (declare (ignore c))
+ (store-error "Unable to determine function name for ~A."
+ obj))))))
(t (store-error "Unable to determine function name for ~A."
obj)))))
Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.22 cl-store/package.lisp:1.23
--- cl-store/package.lisp:1.22 Thu Sep 1 12:24:55 2005
+++ cl-store/package.lisp Wed Nov 30 10:49:56 2005
@@ -1,6 +1,8 @@
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;; See the file LICENCE for licence information.
-(in-package :cl-store.system)
+
+;(in-package :cl-store.system)
+
(defpackage #:cl-store
(:use #:cl)
(:export #:backend #:magic-number #:stream-type
@@ -93,6 +95,24 @@
#:class-direct-superclasses
#:class-slots
#:ensure-class)
+
+ #+digitool (:import-from #:ccl
+ #:generic-function-name
+ #:slot-definition-name
+ #:slot-definition-allocation
+ #:compute-slots
+ #:slot-definition
+ #:slot-definition-initform
+ #:slot-definition-initargs
+ #:slot-definition-name
+ #:slot-definition-readers
+ #:slot-definition-type
+ #:slot-definition-writers
+ #:class-direct-default-initargs
+ #:class-direct-slots
+ #:class-direct-superclasses
+ #:class-slots
+ #:ensure-class)
#+(and clisp (not mop)) (:import-from #:clos
#:slot-value
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.18 cl-store/plumbing.lisp:1.19
--- cl-store/plumbing.lisp:1.18 Tue Oct 4 10:10:26 2005
+++ cl-store/plumbing.lisp Wed Nov 30 10:49:56 2005
@@ -34,7 +34,7 @@
(apply #'format stream (format-string condition)
(format-args condition))))
-(define-condition cl-store-error (condition)
+(define-condition cl-store-error (error)
((caused-by :accessor caused-by :initarg :caused-by
:initform nil)
(format-string :accessor format-string :initarg :format-string
@@ -43,11 +43,11 @@
(:report cl-store-report)
(:documentation "Root cl-store condition"))
-(define-condition store-error (error cl-store-error)
+(define-condition store-error (cl-store-error)
()
(:documentation "Error thrown when storing an object fails."))
-(define-condition restore-error (error cl-store-error)
+(define-condition restore-error (cl-store-error)
()
(:documentation "Error thrown when restoring an object fails."))
@@ -76,8 +76,7 @@
(*current-backend* backend)
(*read-eval* nil))
(handler-bind ((error (lambda (c)
- (signal (make-condition 'store-error
- :caused-by c)))))
+ (signal 'store-error :caused-by c))))
(backend-store backend place obj)))))
@@ -141,8 +140,7 @@
(*current-backend* backend)
(*read-eval* nil))
(handler-bind ((error (lambda (c)
- (signal (make-condition 'restore-error
- :caused-by c)))))
+ (signal 'restore-error :caused-by c))))
(backend-restore backend place)))))
Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.19 cl-store/utils.lisp:1.20
--- cl-store/utils.lisp:1.19 Fri Sep 9 16:59:17 2005
+++ cl-store/utils.lisp Wed Nov 30 10:49:56 2005
@@ -125,16 +125,6 @@
(logior (ash -1 32) ret)
ret))))
-
-(defun store-string-code (string stream)
- "Write length of STRING then STRING into stream"
- (declare (simple-string string) (stream stream))
- (format stream "~S" string))
-
-(defun retrieve-string-code (stream)
- "Retrieve a String written by store-string-code from STREAM"
- (read stream))
-
(defun kwd (name)
(values (intern (string-upcase name) :keyword)))
