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

Modified Files: README backends.lisp circularities.lisp cl-store.asd default-backend.lisp plumbing.lisp tests.lisp xml-backend.lisp Log Message: Added structure definition support for CMUCL Date: Fri Nov 26 15:35:37 2004 Author: sross

Index: cl-store/README diff -u cl-store/README:1.12 cl-store/README:1.13 --- cl-store/README:1.12 Wed Nov 24 14:27:03 2004 +++ cl-store/README Fri Nov 26 15:35:36 2004 @@ -1,7 +1,7 @@ README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ -Version: 0.4 +Version: 0.4.1

0. About. CL-STORE is an portable serialization package which

Index: cl-store/backends.lisp diff -u cl-store/backends.lisp:1.5 cl-store/backends.lisp:1.6 --- cl-store/backends.lisp:1.5 Wed Nov 24 14:27:03 2004 +++ cl-store/backends.lisp Fri Nov 26 15:35:36 2004 @@ -104,8 +104,8 @@ (assert (symbolp name)) (let ((class-name (symbolicate name '-backend))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (prog2 - ,(get-class-form class-name fields extends) + (prog2 + ,(get-class-form class-name fields extends) (register-backend ',name ',class-name ,magic-number ,stream-type ',old-magic-numbers) ,(get-store-macro name class-name)

Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.12 cl-store/circularities.lisp:1.13 --- cl-store/circularities.lisp:1.12 Wed Nov 24 14:27:03 2004 +++ cl-store/circularities.lisp Fri Nov 26 15:35:36 2004 @@ -198,9 +198,9 @@ (defun handle-restore (place backend) (multiple-value-bind (reader sym) (find-function-for-type place backend) (declare (type function reader) (type symbol sym)) - (cond ((eq sym 'values-object) + (cond ((eql sym 'values-object) (handle-values reader place)) - ((eq sym 'referrer) + ((eql sym 'referrer) (incf *restore-counter*) (new-val (call-it reader place))) ((not (int-sym-or-char-p sym backend))

Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.14 cl-store/cl-store.asd:1.15 --- cl-store/cl-store.asd:1.14 Wed Nov 24 14:27:03 2004 +++ cl-store/cl-store.asd Fri Nov 26 15:35:36 2004 @@ -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" + :version "0.4.1" :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.13 cl-store/default-backend.lisp:1.14 --- cl-store/default-backend.lisp:1.13 Wed Nov 24 14:27:03 2004 +++ cl-store/default-backend.lisp Fri Nov 26 15:35:36 2004 @@ -511,10 +511,20 @@ ;; or signal a store-error. (defun parse-name (name) (let ((name (subseq name 21))) + (declare (type simple-string name)) (if (search name "SB!" :end1 3) (replace name "SB-" :end1 3) name)))

+#+sbcl +(defvar *sbcl-readtable* (copy-readtable *readtable*)) +#+sbcl +(set-macro-character ## #'(lambda (c s) + (declare (ignore c s)) + (store-error "Invalid character in function name.")) + nil + *sbcl-readtable*) + (defstore-cl-store (obj function stream) (output-type-code +function-code+ stream) (multiple-value-bind (l cp name) (function-lambda-expression obj) @@ -524,10 +534,12 @@ ;; Try to deal with sbcl's naming convention ;; of built in functions #+sbcl - ((and name (stringp name) (search "top level local call " - (the simple-string name))) - (let ((new-name (parse-name name))) - (when (not (string= new-name "")) + ((and name (stringp name) + (search "top level local call " + (the simple-string name))) + (let ((new-name (parse-name name)) + (*readtable* *sbcl-readtable*)) + (unless (string= new-name "") (handler-case (store-object (read-from-string new-name) stream) (error (c) (declare (ignore c))

Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.7 cl-store/plumbing.lisp:1.8 --- cl-store/plumbing.lisp:1.7 Wed Nov 24 14:27:03 2004 +++ cl-store/plumbing.lisp Fri Nov 26 15:35:36 2004 @@ -71,7 +71,8 @@ (:documentation "Entry Point for storing objects.") (:method ((obj t) (place t) &optional (backend *default-backend*)) "Store OBJ into Stream PLACE using backend BACKEND." - (let ((*current-backend* backend)) + (let ((*current-backend* backend) + (*read-eval* nil)) (handler-bind ((error (lambda (c) (signal (make-condition 'store-error :caused-by c))))) @@ -131,7 +132,8 @@ overridden, use backend-restore instead") (:method (place &optional (backend *default-backend*)) "Entry point for restoring objects (setfable)." - (let ((*current-backend* backend)) + (let ((*current-backend* backend) + (*read-eval* nil)) (handler-bind ((error (lambda (c) (signal (make-condition 'restore-error :caused-by c)))))

Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.11 cl-store/tests.lisp:1.12 --- cl-store/tests.lisp:1.11 Wed Nov 24 14:27:03 2004 +++ cl-store/tests.lisp Fri Nov 26 15:35:36 2004 @@ -508,10 +508,10 @@ (declare (ignore dep)) (print-unreadable-object (obj st :type t) (format st "~A" (f-x obj)))))) - (y 0 :type integer) (z "" :type simple-string)) + (y 0 :type integer) (z nil :type simple-string))

-#+sbcl +#+(or sbcl cmu) (deftest struct-class.1 (let* ((obj (fooo "Z" 2 3)) (string (format nil "~A" obj)))

Index: cl-store/xml-backend.lisp diff -u cl-store/xml-backend.lisp:1.7 cl-store/xml-backend.lisp:1.8 --- cl-store/xml-backend.lisp:1.7 Wed Nov 10 11:43:16 2004 +++ cl-store/xml-backend.lisp Fri Nov 26 15:35:36 2004 @@ -163,7 +163,7 @@ (princ-xml "CHARACTER" (char-code obj) stream))

(defrestore-xml (character place) - (code-char (read-from-string (first-child place)))) + (code-char (parse-integer (first-child place))))