[cl-store-cvs] CVS update: cl-store/README cl-store/backends.lisp cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/xml-backend.lisp
Sean Ross
sross at common-lisp.net
Fri Nov 26 14:35:51 UTC 2004
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 at jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr at 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))))
More information about the Cl-store-cvs
mailing list