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@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@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@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@jhb.ucs.co.za" :maintainer "Sean Ross sdr@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)))