[cl-prevalence-cvs] CVS update: cl-prevalence/src/serialization.lisp

[Sven Van Caekenberghe]

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv28019/src

Modified Files:
	serialization.lisp 
Log Message:
added support for unprintable symbols in serialization

Date: Mon Jan 24 02:04:16 2005
Author: scaekenberghe

Index: cl-prevalence/src/serialization.lisp
diff -u cl-prevalence/src/serialization.lisp:1.8 cl-prevalence/src/serialization.lisp:1.9
--- cl-prevalence/src/serialization.lisp:1.8	Sat Jan 22 11:23:54 2005
+++ cl-prevalence/src/serialization.lisp	Mon Jan 24 02:04:15 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: serialization.lisp,v 1.8 2005/01/22 19:23:54 scaekenberghe Exp $
+;;;; $Id: serialization.lisp,v 1.9 2005/01/24 10:04:15 scaekenberghe Exp $
 ;;;;
 ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS
 ;;;;
@@ -91,28 +91,36 @@
   (setf (gethash object (get-hashtable serialization-state))
         (incf (get-counter serialization-state))))
 
+;; when printing symbols we always add the package and treat the symbol as internal
+;; so that the serialization is independent of future change in export status 
+;; we handling symbols in the common-lisp and keyword package more efficiently
+;; some hacking to handle unprintable symbols is involved
+
 (defconstant +cl-package+ (find-package :cl))
 
 (defconstant +keyword-package+ (find-package :keyword))
 
 (defun print-symbol-xml (symbol stream)
   (let ((package (symbol-package symbol))
-	(name (symbol-name 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)))
-    (s-xml:print-string-xml name 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 (symbol-name symbol)))
+	(name (prin1-to-string symbol)))
     (cond ((eq package +cl-package+) (write-string "CL:" stream))
 	  ((eq package +keyword-package+) (write-char #\: stream))
-	  (t (write-string (package-name package) stream)
+	  (t (s-xml:print-string-xml (package-name package) stream)
 	     (write-string "::" stream)))
-    ;; this is *NOT* correct for unprintable symbols !!
-    (write-string name 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