cl-prevalence-devel

Download

cl-prevalence-devel@common-lisp.net

February 2008

2 participants
1 discussions

[cl-prevalence-devel] [PATCH] Use WITH-STANDARD-IO-SYNTAX
by Maciej Katafiasz 21 Feb '08

21 Feb '08

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))

2 1