[cl-prevalence-devel] [PATCH] Use WITH-STANDARD-IO-SYNTAX
Maciej Katafiasz
mathrick at gmail.com
Thu Feb 21 11:43:38 UTC 2008
Hi,
the patch below adds WITH-STANDARD-IO-SYNTAX to all places where
reading and writing is done, which fixes the breakage when XML is
(de)serialised across images with different READTABLE-CASE. I did a
quick test on data that used to break before, and it seems to work
fine.
Cheers,
Maciej
? doc
Index: src/serialization.lisp
===================================================================
RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp,v
retrieving revision 1.11
diff -u -u -r1.11 serialization.lisp
--- src/serialization.lisp 16 Mar 2007 15:37:18 -0000 1.11
+++ src/serialization.lisp 21 Feb 2008 11:31:19 -0000
@@ -101,26 +101,28 @@
(defconstant +keyword-package+ (find-package :keyword))
(defun print-symbol-xml (symbol stream)
- (let ((package (symbol-package symbol))
- (name (prin1-to-string symbol)))
- (cond ((eq package +cl-package+) (write-string "CL:" stream))
- ((eq package +keyword-package+) (write-char #\: stream))
- (t (s-xml:print-string-xml (package-name package) stream)
- (write-string "::" stream)))
- (if (char= (char name (1- (length name))) #\|)
- (s-xml:print-string-xml name stream :start (position #\| name))
- (s-xml:print-string-xml name stream :start (1+ (or (position
#\: name :from-end t) -1))))))
+ (with-standard-io-syntax
+ (let ((package (symbol-package symbol))
+ (name (prin1-to-string symbol)))
+ (cond ((eq package +cl-package+) (write-string "CL:" stream))
+ ((eq package +keyword-package+) (write-char #\: stream))
+ (t (s-xml:print-string-xml (package-name package) stream)
+ (write-string "::" stream)))
+ (if (char= (char name (1- (length name))) #\|)
+ (s-xml:print-string-xml name stream :start (position #\| name))
+ (s-xml:print-string-xml name stream :start (1+ (or
(position #\: name :from-end t) -1)))))))
(defun print-symbol (symbol stream)
- (let ((package (symbol-package symbol))
- (name (prin1-to-string symbol)))
- (cond ((eq package +cl-package+) (write-string "CL:" stream))
- ((eq package +keyword-package+) (write-char #\: stream))
- (t (s-xml:print-string-xml (package-name package) stream)
- (write-string "::" stream)))
- (if (char= (char name (1- (length name))) #\|)
- (write-string name stream :start (position #\| name))
- (write-string name stream :start (1+ (or (position #\: name
:from-end t) -1))))))
+ (with-standard-io-syntax
+ (let ((package (symbol-package symbol))
+ (name (prin1-to-string symbol)))
+ (cond ((eq package +cl-package+) (write-string "CL:" stream))
+ ((eq package +keyword-package+) (write-char #\: stream))
+ (t (s-xml:print-string-xml (package-name package) stream)
+ (write-string "::" stream)))
+ (if (char= (char name (1- (length name))) #\|)
+ (write-string name stream :start (position #\| name))
+ (write-string name stream :start (1+ (or (position #\: name
:from-end t) -1)))))))
(defmethod serializable-slots ((object structure-object))
#+openmcl
@@ -234,15 +236,18 @@
(defmethod serialize-sexp-internal ((object string) stream
serialization-state)
(declare (ignore serialization-state))
- (prin1 object stream))
+ (with-standard-io-syntax
+ (prin1 object stream)))
(defmethod serialize-sexp-internal ((object character) stream
serialization-state)
(declare (ignore serialization-state))
- (prin1 object stream))
+ (with-standard-io-syntax
+ (prin1 object stream)))
(defmethod serialize-sexp-internal ((object symbol) stream
serialization-state)
(declare (ignore serialization-state))
- (print-symbol object stream))
+ (with-standard-io-syntax
+ (print-symbol object stream)))
(defun sequence-type-and-length(sequence)
(if (listp sequence)
@@ -256,226 +261,234 @@
(values :proper-sequence (length sequence))))
(defmethod serialize-xml-internal ((object sequence) stream
serialization-state)
- (flet ((proper-sequence (length)
- (let ((id (set-known-object serialization-state object)))
- (write-string "<SEQUENCE ID=\"" stream)
- (prin1 id stream)
- (write-string "\" CLASS=\"" stream)
- (print-symbol-xml (etypecase object (list 'list) (vector
'vector)) stream)
- (write-string "\" SIZE=\"" stream)
- (prin1 length stream)
- (write-string "\">" stream)
- (map nil
- #'(lambda (element)
- (serialize-xml-internal element stream
serialization-state))
- object)
- (write-string "</SEQUENCE>" stream)))
- (improper-list ()
- (let ((id (set-known-object serialization-state object)))
- (write-string "<CONS ID=\"" stream)
- (prin1 id stream)
- (write-string "\">" stream)
- (serialize-xml-internal (car object) stream serialization-state)
- (write-char #\Space stream)
- (serialize-xml-internal (cdr object) stream serialization-state)
- (write-string "</CONS>" stream))))
+ (with-standard-io-syntax
+ (flet ((proper-sequence (length)
+ (let ((id (set-known-object serialization-state object)))
+ (write-string "<SEQUENCE ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\" CLASS=\"" stream)
+ (print-symbol-xml (etypecase object (list 'list)
(vector 'vector)) stream)
+ (write-string "\" SIZE=\"" stream)
+ (prin1 length stream)
+ (write-string "\">" stream)
+ (map nil
+ #'(lambda (element)
+ (serialize-xml-internal element stream
serialization-state))
+ object)
+ (write-string "</SEQUENCE>" stream)))
+ (improper-list ()
+ (let ((id (set-known-object serialization-state object)))
+ (write-string "<CONS ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\">" stream)
+ (serialize-xml-internal (car object) stream
serialization-state)
+ (write-char #\Space stream)
+ (serialize-xml-internal (cdr object) stream
serialization-state)
+ (write-string "</CONS>" stream))))
+ (let ((id (known-object-id serialization-state object)))
+ (if id
+ (progn
+ (write-string "<REF ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\"/>" stream))
+ (multiple-value-bind (seq-type length)
(sequence-type-and-length object)
+ (ecase seq-type
+ ((:proper-sequence :proper-list) (proper-sequence length))
+ ((:dotted-list :circular-list) (improper-list)))))))))
+
+(defmethod serialize-sexp-internal ((object sequence) stream
serialization-state)
+ (with-standard-io-syntax
+ (flet ((proper-sequence (length)
+ (let ((id (set-known-object serialization-state object)))
+ (write-string "(:SEQUENCE " stream)
+ (prin1 id stream)
+ (write-string " :CLASS " stream)
+ (print-symbol (etypecase object (list 'list) (vector
'vector)) stream)
+ (write-string " :SIZE " stream)
+ (prin1 length stream)
+ (unless (zerop length)
+ (write-string " :ELEMENTS (" stream)
+ (map nil
+ #'(lambda (element)
+ (write-string " " stream)
+ (serialize-sexp-internal element stream
serialization-state))
+ object))
+ (write-string " ) )" stream)))
+ (improper-list ()
+ (let ((id (set-known-object serialization-state object)))
+ (write-string "(:CONS " stream)
+ (prin1 id stream)
+ (write-char #\Space stream)
+ (serialize-sexp-internal (car object) stream
serialization-state)
+ (write-char #\Space stream)
+ (serialize-sexp-internal (cdr object) stream
serialization-state)
+ (write-string " ) " stream))))
+ (let ((id (known-object-id serialization-state object)))
+ (if id
+ (progn
+ (write-string "(:REF . " stream)
+ (prin1 id stream)
+ (write-string ")" stream))
+ (multiple-value-bind (seq-type length)
(sequence-type-and-length object)
+ (ecase seq-type
+ ((:proper-sequence :proper-list) (proper-sequence length))
+ ((:dotted-list :circular-list) (improper-list)))))))))
+
+(defmethod serialize-xml-internal ((object hash-table) stream
serialization-state)
+ (with-standard-io-syntax
(let ((id (known-object-id serialization-state object)))
(if id
(progn
(write-string "<REF ID=\"" stream)
(prin1 id stream)
- (write-string "\"/>" stream))
- (multiple-value-bind (seq-type length)
(sequence-type-and-length object)
- (ecase seq-type
- ((:proper-sequence :proper-list) (proper-sequence length))
- ((:dotted-list :circular-list) (improper-list))))))))
+ (write-string "\"/>" stream))
+ (progn
+ (setf id (set-known-object serialization-state object))
+ (write-string "<HASH-TABLE ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\" TEST=\"" stream)
+ (print-symbol-xml (hash-table-test object) stream)
+ (write-string "\" SIZE=\"" stream)
+ (prin1 (hash-table-size object) stream)
+ (write-string "\">" stream)
+ (maphash #'(lambda (key value)
+ (write-string "<ENTRY><KEY>" stream)
+ (serialize-xml-internal key stream
serialization-state)
+ (write-string "</KEY><VALUE>" stream)
+ (serialize-xml-internal value stream
serialization-state)
+ (princ "</VALUE></ENTRY>" stream))
+ object)
+ (write-string "</HASH-TABLE>" stream))))))
-(defmethod serialize-sexp-internal ((object sequence) stream
serialization-state)
- (flet ((proper-sequence (length)
- (let ((id (set-known-object serialization-state object)))
- (write-string "(:SEQUENCE " stream)
- (prin1 id stream)
- (write-string " :CLASS " stream)
- (print-symbol (etypecase object (list 'list) (vector
'vector)) stream)
- (write-string " :SIZE " stream)
- (prin1 length stream)
- (unless (zerop length)
- (write-string " :ELEMENTS (" stream)
- (map nil
- #'(lambda (element)
- (write-string " " stream)
- (serialize-sexp-internal element stream
serialization-state))
- object))
- (write-string " ) )" stream)))
- (improper-list ()
- (let ((id (set-known-object serialization-state object)))
- (write-string "(:CONS " stream)
- (prin1 id stream)
- (write-char #\Space stream)
- (serialize-sexp-internal (car object) stream serialization-state)
- (write-char #\Space stream)
- (serialize-sexp-internal (cdr object) stream serialization-state)
- (write-string " ) " stream))))
+(defmethod serialize-sexp-internal ((object hash-table) stream
serialization-state)
+ (with-standard-io-syntax
(let ((id (known-object-id serialization-state object)))
(if id
(progn
(write-string "(:REF . " stream)
(prin1 id stream)
(write-string ")" stream))
- (multiple-value-bind (seq-type length)
(sequence-type-and-length object)
- (ecase seq-type
- ((:proper-sequence :proper-list) (proper-sequence length))
- ((:dotted-list :circular-list) (improper-list))))))))
-
-(defmethod serialize-xml-internal ((object hash-table) stream
serialization-state)
- (let ((id (known-object-id serialization-state object)))
- (if id
- (progn
- (write-string "<REF ID=\"" stream)
- (prin1 id stream)
- (write-string "\"/>" stream))
- (progn
- (setf id (set-known-object serialization-state object))
- (write-string "<HASH-TABLE ID=\"" stream)
- (prin1 id stream)
- (write-string "\" TEST=\"" stream)
- (print-symbol-xml (hash-table-test object) stream)
- (write-string "\" SIZE=\"" stream)
- (prin1 (hash-table-size object) stream)
- (write-string "\">" stream)
- (maphash #'(lambda (key value)
- (write-string "<ENTRY><KEY>" stream)
- (serialize-xml-internal key stream serialization-state)
- (write-string "</KEY><VALUE>" stream)
- (serialize-xml-internal value stream
serialization-state)
- (princ "</VALUE></ENTRY>" stream))
- object)
- (write-string "</HASH-TABLE>" stream)))))
-
-(defmethod serialize-sexp-internal ((object hash-table) stream
serialization-state)
- (let ((id (known-object-id serialization-state object)))
- (if id
- (progn
- (write-string "(:REF . " stream)
- (prin1 id stream)
- (write-string ")" stream))
- (let ((count (hash-table-count object)))
- (setf id (set-known-object serialization-state object))
- (write-string "(:HASH-TABLE " stream)
- (prin1 id stream)
- (write-string " :TEST " stream)
- (print-symbol (hash-table-test object) stream)
- (write-string " :SIZE " stream)
- (prin1 (hash-table-size object) stream)
- (write-string " :REHASH-SIZE " stream)
- (prin1 (hash-table-rehash-size object) stream)
- (write-string " :REHASH-THRESHOLD " stream)
- (prin1 (hash-table-rehash-threshold object) stream)
- (unless (zerop count)
- (write-string " :ENTRIES (" stream)
- (maphash #'(lambda (key value)
- (write-string " (" stream)
- (serialize-sexp-internal key stream
serialization-state)
- (write-string " . " stream)
- (serialize-sexp-internal value stream
serialization-state)
- (princ ")" stream))
- object)
- (write-string " )" stream))
- (write-string " )" stream)))))
+ (let ((count (hash-table-count object)))
+ (setf id (set-known-object serialization-state object))
+ (write-string "(:HASH-TABLE " stream)
+ (prin1 id stream)
+ (write-string " :TEST " stream)
+ (print-symbol (hash-table-test object) stream)
+ (write-string " :SIZE " stream)
+ (prin1 (hash-table-size object) stream)
+ (write-string " :REHASH-SIZE " stream)
+ (prin1 (hash-table-rehash-size object) stream)
+ (write-string " :REHASH-THRESHOLD " stream)
+ (prin1 (hash-table-rehash-threshold object) stream)
+ (unless (zerop count)
+ (write-string " :ENTRIES (" stream)
+ (maphash #'(lambda (key value)
+ (write-string " (" stream)
+ (serialize-sexp-internal key stream
serialization-state)
+ (write-string " . " stream)
+ (serialize-sexp-internal value stream
serialization-state)
+ (princ ")" stream))
+ object)
+ (write-string " )" stream))
+ (write-string " )" stream))))))
(defmethod serialize-xml-internal ((object structure-object) stream
serialization-state)
- (let ((id (known-object-id serialization-state object)))
- (if id
- (progn
- (write-string "<REF ID=\"" stream)
- (prin1 id stream)
- (write-string "\"/>" stream))
- (progn
- (setf id (set-known-object serialization-state object))
- (write-string "<STRUCT ID=\"" stream)
- (prin1 id stream)
- (write-string "\" CLASS=\"" stream)
- (print-symbol-xml (class-name (class-of object)) stream)
- (write-string "\">" stream)
- (mapc #'(lambda (slot)
- (write-string "<SLOT NAME=\"" stream)
- (print-symbol-xml slot stream)
- (write-string "\">" stream)
- (serialize-xml-internal (slot-value object slot) stream
serialization-state)
- (write-string "</SLOT>" stream))
- (get-serializable-slots serialization-state object))
- (write-string "</STRUCT>" stream)))))
+ (with-standard-io-syntax
+ (let ((id (known-object-id serialization-state object)))
+ (if id
+ (progn
+ (write-string "<REF ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\"/>" stream))
+ (progn
+ (setf id (set-known-object serialization-state object))
+ (write-string "<STRUCT ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\" CLASS=\"" stream)
+ (print-symbol-xml (class-name (class-of object)) stream)
+ (write-string "\">" stream)
+ (mapc #'(lambda (slot)
+ (write-string "<SLOT NAME=\"" stream)
+ (print-symbol-xml slot stream)
+ (write-string "\">" stream)
+ (serialize-xml-internal (slot-value object
slot) stream serialization-state)
+ (write-string "</SLOT>" stream))
+ (get-serializable-slots serialization-state object))
+ (write-string "</STRUCT>" stream))))))
(defmethod serialize-sexp-internal ((object structure-object) stream
serialization-state)
- (let ((id (known-object-id serialization-state object)))
- (if id
- (progn
- (write-string "(:REF . " stream)
- (prin1 id stream)
- (write-string ")" stream))
- (let ((serializable-slots (get-serializable-slots
serialization-state object)))
- (setf id (set-known-object serialization-state object))
- (write-string "(:STRUCT " stream)
- (prin1 id stream)
- (write-string " :CLASS " stream)
- (print-symbol (class-name (class-of object)) stream)
- (when serializable-slots
- (write-string " :SLOTS (" stream)
- (mapc #'(lambda (slot)
- (write-string " (" stream)
- (print-symbol slot stream)
- (write-string " . " stream)
- (serialize-sexp-internal (slot-value object slot)
stream serialization-state)
- (write-string ")" stream))
- serializable-slots))
- (write-string " ) )" stream)))))
+ (with-standard-io-syntax
+ (let ((id (known-object-id serialization-state object)))
+ (if id
+ (progn
+ (write-string "(:REF . " stream)
+ (prin1 id stream)
+ (write-string ")" stream))
+ (let ((serializable-slots (get-serializable-slots
serialization-state object)))
+ (setf id (set-known-object serialization-state object))
+ (write-string "(:STRUCT " stream)
+ (prin1 id stream)
+ (write-string " :CLASS " stream)
+ (print-symbol (class-name (class-of object)) stream)
+ (when serializable-slots
+ (write-string " :SLOTS (" stream)
+ (mapc #'(lambda (slot)
+ (write-string " (" stream)
+ (print-symbol slot stream)
+ (write-string " . " stream)
+ (serialize-sexp-internal (slot-value object
slot) stream serialization-state)
+ (write-string ")" stream))
+ serializable-slots))
+ (write-string " ) )" stream))))))
(defmethod serialize-xml-internal ((object standard-object) stream
serialization-state)
- (let ((id (known-object-id serialization-state object)))
- (if id
- (progn
- (write-string "<REF ID=\"" stream)
- (prin1 id stream)
- (write-string "\"/>" stream))
- (progn
- (setf id (set-known-object serialization-state object))
- (write-string "<OBJECT ID=\"" stream)
- (prin1 id stream)
- (write-string "\" CLASS=\"" stream)
- (print-symbol-xml (class-name (class-of object)) stream)
- (princ "\">" stream)
- (loop :for slot :in (get-serializable-slots serialization-state object)
- :do (when (slot-boundp object slot)
- (write-string "<SLOT NAME=\"" stream)
- (print-symbol-xml slot stream)
- (write-string "\">" stream)
- (serialize-xml-internal (slot-value object slot)
stream serialization-state)
- (write-string "</SLOT>" stream)))
- (write-string "</OBJECT>" stream)))))
+ (with-standard-io-syntax
+ (let ((id (known-object-id serialization-state object)))
+ (if id
+ (progn
+ (write-string "<REF ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\"/>" stream))
+ (progn
+ (setf id (set-known-object serialization-state object))
+ (write-string "<OBJECT ID=\"" stream)
+ (prin1 id stream)
+ (write-string "\" CLASS=\"" stream)
+ (print-symbol-xml (class-name (class-of object)) stream)
+ (princ "\">" stream)
+ (loop :for slot :in (get-serializable-slots
serialization-state object)
+ :do (when (slot-boundp object slot)
+ (write-string "<SLOT NAME=\"" stream)
+ (print-symbol-xml slot stream)
+ (write-string "\">" stream)
+ (serialize-xml-internal (slot-value object slot)
stream serialization-state)
+ (write-string "</SLOT>" stream)))
+ (write-string "</OBJECT>" stream))))))
(defmethod serialize-sexp-internal ((object standard-object) stream
serialization-state)
- (let ((id (known-object-id serialization-state object)))
- (if id
- (progn
- (write-string "(:REF . " stream)
- (prin1 id stream)
- (write-string ")" stream))
- (let ((serializable-slots (get-serializable-slots
serialization-state object)))
- (setf id (set-known-object serialization-state object))
- (write-string "(:OBJECT " stream)
- (prin1 id stream)
- (write-string " :CLASS " stream)
- (print-symbol (class-name (class-of object)) stream)
- (when serializable-slots
- (princ " :SLOTS (" stream)
- (loop :for slot :in serializable-slots
- :do (when (slot-boundp object slot)
- (write-string " (" stream)
- (print-symbol slot stream)
- (write-string " . " stream)
- (serialize-sexp-internal (slot-value object
slot) stream serialization-state)
- (write-string ")" stream))))
- (write-string " ) )" stream)))))
+ (with-standard-io-syntax
+ (let ((id (known-object-id serialization-state object)))
+ (if id
+ (progn
+ (write-string "(:REF . " stream)
+ (prin1 id stream)
+ (write-string ")" stream))
+ (let ((serializable-slots (get-serializable-slots
serialization-state object)))
+ (setf id (set-known-object serialization-state object))
+ (write-string "(:OBJECT " stream)
+ (prin1 id stream)
+ (write-string " :CLASS " stream)
+ (print-symbol (class-name (class-of object)) stream)
+ (when serializable-slots
+ (princ " :SLOTS (" stream)
+ (loop :for slot :in serializable-slots
+ :do (when (slot-boundp object slot)
+ (write-string " (" stream)
+ (print-symbol slot stream)
+ (write-string " . " stream)
+ (serialize-sexp-internal (slot-value object
slot) stream serialization-state)
+ (write-string ")" stream))))
+ (write-string " ) )" stream))))))
;;; Deserialize CLOS instances and Lisp primitives from the XML representation
@@ -484,68 +497,70 @@
(defun deserialize-xml-new-element (name attributes seed)
(declare (ignore seed) (special *deserialized-objects*))
- (case name
- (:sequence (let ((id (parse-integer (get-attribute-value :id attributes)))
- (class (read-from-string (get-attribute-value
:class attributes)))
- (size (parse-integer (get-attribute-value :size
attributes))))
- (setf (gethash id *deserialized-objects*)
- (make-sequence class size))))
- (:object (let ((id (parse-integer (get-attribute-value :id attributes)))
- (class (read-from-string (get-attribute-value
:class attributes))))
- (setf (gethash id *deserialized-objects*)
- (make-instance class))))
- (:cons (setf (gethash (parse-integer (get-attribute-value :id attributes))
- *deserialized-objects*)
- (cons nil nil)))
- (:struct (let ((id (parse-integer (get-attribute-value :id attributes)))
- (class (read-from-string (get-attribute-value
:class attributes))))
- (setf (gethash id *deserialized-objects*)
- (funcall (intern (concatenate 'string "MAKE-" (symbol-name
class)) (symbol-package class))))))
- (:hash-table (let ((id (parse-integer (get-attribute-value :id
attributes)))
- (test (read-from-string (get-attribute-value
:test attributes)))
- (size (parse-integer (get-attribute-value
:size attributes))))
- (setf (gethash id *deserialized-objects*)
- (make-hash-table :test test :size size)))))
+ (with-standard-io-syntax
+ (case name
+ (:sequence (let ((id (parse-integer (get-attribute-value :id
attributes)))
+ (class (read-from-string (get-attribute-value
:class attributes)))
+ (size (parse-integer (get-attribute-value
:size attributes))))
+ (setf (gethash id *deserialized-objects*)
+ (make-sequence class size))))
+ (:object (let ((id (parse-integer (get-attribute-value :id attributes)))
+ (class (read-from-string (get-attribute-value
:class attributes))))
+ (setf (gethash id *deserialized-objects*)
+ (make-instance class))))
+ (:cons (setf (gethash (parse-integer (get-attribute-value :id
attributes))
+ *deserialized-objects*)
+ (cons nil nil)))
+ (:struct (let ((id (parse-integer (get-attribute-value :id attributes)))
+ (class (read-from-string (get-attribute-value
:class attributes))))
+ (setf (gethash id *deserialized-objects*)
+ (funcall (intern (concatenate 'string "MAKE-"
(symbol-name class)) (symbol-package class))))))
+ (:hash-table (let ((id (parse-integer (get-attribute-value :id
attributes)))
+ (test (read-from-string (get-attribute-value
:test attributes)))
+ (size (parse-integer (get-attribute-value
:size attributes))))
+ (setf (gethash id *deserialized-objects*)
+ (make-hash-table :test test :size size))))))
'())
(defun deserialize-xml-finish-element (name attributes parent-seed seed)
(declare (special *deserialized-objects*))
- (cons (case name
- (:int (parse-integer seed))
- ((:float :ratio :complex :symbol) (read-from-string seed))
- (:null nil)
- (:true t)
- (:string (or seed ""))
- (:character (char seed 0))
- (:key (car seed))
- (:value (car seed))
- (:entry (nreverse seed))
- (:slot (let ((name (read-from-string (get-attribute-value :name
attributes))))
- (cons name (car seed))))
- (:sequence (let* ((id (parse-integer (get-attribute-value
:id attributes)))
- (sequence (gethash id *deserialized-objects*)))
- (map-into sequence #'identity (nreverse seed))))
- (:cons (let* ((id (parse-integer (get-attribute-value :id
attributes)))
- (cons-pair (gethash id *deserialized-objects*)))
- (rplaca cons-pair (second seed))
- (rplacd cons-pair (first seed))))
- (:object (let* ((id (parse-integer (get-attribute-value :id
attributes)))
- (object (gethash id *deserialized-objects*)))
- (dolist (pair seed object)
- (when (slot-exists-p object (car pair))
- (setf (slot-value object (car pair)) (cdr pair))))))
- (:struct (let* ((id (parse-integer (get-attribute-value :id
attributes)))
- (object (gethash id *deserialized-objects*)))
- (dolist (pair seed object)
- (when (slot-exists-p object (car pair))
- (setf (slot-value object (car pair)) (cdr pair))))))
- (:hash-table (let* ((id (parse-integer (get-attribute-value
:id attributes)))
- (hash-table (gethash id
*deserialized-objects*)))
- (dolist (pair seed hash-table)
- (setf (gethash (car pair) hash-table)
(cadr pair)))))
- (:ref (let ((id (parse-integer (get-attribute-value :id
attributes))))
- (gethash id *deserialized-objects*))))
- parent-seed))
+ (with-standard-io-syntax
+ (cons (case name
+ (:int (parse-integer seed))
+ ((:float :ratio :complex :symbol) (read-from-string seed))
+ (:null nil)
+ (:true t)
+ (:string (or seed ""))
+ (:character (char seed 0))
+ (:key (car seed))
+ (:value (car seed))
+ (:entry (nreverse seed))
+ (:slot (let ((name (read-from-string (get-attribute-value
:name attributes))))
+ (cons name (car seed))))
+ (:sequence (let* ((id (parse-integer (get-attribute-value
:id attributes)))
+ (sequence (gethash id *deserialized-objects*)))
+ (map-into sequence #'identity (nreverse seed))))
+ (:cons (let* ((id (parse-integer (get-attribute-value :id
attributes)))
+ (cons-pair (gethash id *deserialized-objects*)))
+ (rplaca cons-pair (second seed))
+ (rplacd cons-pair (first seed))))
+ (:object (let* ((id (parse-integer (get-attribute-value
:id attributes)))
+ (object (gethash id *deserialized-objects*)))
+ (dolist (pair seed object)
+ (when (slot-exists-p object (car pair))
+ (setf (slot-value object (car pair)) (cdr
pair))))))
+ (:struct (let* ((id (parse-integer (get-attribute-value
:id attributes)))
+ (object (gethash id *deserialized-objects*)))
+ (dolist (pair seed object)
+ (when (slot-exists-p object (car pair))
+ (setf (slot-value object (car pair)) (cdr
pair))))))
+ (:hash-table (let* ((id (parse-integer
(get-attribute-value :id attributes)))
+ (hash-table (gethash id
*deserialized-objects*)))
+ (dolist (pair seed hash-table)
+ (setf (gethash (car pair) hash-table)
(cadr pair)))))
+ (:ref (let ((id (parse-integer (get-attribute-value :id
attributes))))
+ (gethash id *deserialized-objects*))))
+ parent-seed)))
(defun deserialize-xml-text (string seed)
(declare (ignore seed))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: cl-prevalence-standard-io.diff
Type: text/x-patch
Size: 31919 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cl-prevalence-devel/attachments/20080221/c18616dd/attachment.bin>
More information about the Cl-prevalence-devel
mailing list