From scaekenberghe at common-lisp.net Thu Jan 5 14:28:44 2006 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Thu, 5 Jan 2006 15:28:44 +0100 Subject: [cl-prevalence-devel] Re: Kpax win32 patch In-Reply-To: <9238e8de0512260537g17d07a00y@mail.gmail.com> References: <9238e8de0512230653ub5a2880g@mail.gmail.com> <9238e8de0512241111j1a386a5fl@mail.gmail.com> <9238e8de0512260537g17d07a00y@mail.gmail.com> Message-ID: Marko, Thx for reporting this problem. I 'fixed' it by no longer loading debug-prevalence by default. The s-xml::echo-xml function (used here for pretty printing xml) is no longer loaded by default. Compilation/loading using LispWorks and SBCL is now OK. Sven On 26 Dec 2005, at 14:37, Marko Koci? wrote: > Another thing, since you are the author of both cl-prevalence and s- > xml. > I got cvs of s-xml from > :pserver:anonymous at common-lisp.net:/project/s-xml/cvsroot > and CVS of cl-prevalence from > :pserver:anonymous at common-lisp.net:/project/cl-prevalence/cvsroot > > When I try to load cl-prevalence I got: > ;; Compiling file C:\dev\cvstree\cl-prevalence\src\debug- > prevalence.lisp ... > *** - READ from > # #P"C:\\dev\\cvstree\\cl-prevalence\\src\\debug-prevalence.lisp" @19> > : # has no external symbol with name "ECHO-XML" > The following restarts are available: > RETRY :R1 Retry performing # #x19ECFD2D> on # x19ECEFDD>. > ACCEPT :R2 Continue, treating # #x19ECFD2D> on # #x19ECEFDD> as having been successful. > ABORT :R3 ABORT > Break 1 CL-PREVALENCE[2]> > > I'm using clisp on windows. > > thanks, > Marko From bab at entricom.com Thu Jan 5 19:18:38 2006 From: bab at entricom.com (Bruce Butterfield) Date: Thu, 05 Jan 2006 11:18:38 -0800 Subject: [cl-prevalence-devel] Re: Kpax win32 patch In-Reply-To: References: <9238e8de0512230653ub5a2880g@mail.gmail.com> <9238e8de0512241111j1a386a5fl@mail.gmail.com> <9238e8de0512260537g17d07a00y@mail.gmail.com> Message-ID: <43BD710E.6030502@entricom.com> Sven Van Caekenberghe wrote: > Marko, > > Thx for reporting this problem. > I 'fixed' it by no longer loading debug-prevalence by default. > The s-xml::echo-xml function (used here for pretty printing xml) is no > longer loaded by default. > Compilation/loading using LispWorks and SBCL is now OK. > FWIW, here are patches to CVS head for threaded SBCL and an update to #'totally-destroy so it includes a wildcard pathname (SBCL isn't happy with unnamed paths): =================================================================== RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/prevalence.lisp,v retrieving revision 1.7 diff -u -r1.7 prevalence.lisp --- src/prevalence.lisp 4 Oct 2004 14:25:13 -0000 1.7 +++ src/prevalence.lisp 5 Jan 2006 19:14:33 -0000 @@ -169,7 +169,7 @@ "Totally destroy system from permanent storage by deleting any files used by the system, remove all root objects" (close-open-streams system :abort abort) (when (probe-file (get-directory system)) - (dolist (pathname (directory (merge-pathnames (make-pathname :type (get-file-extension system)) + (dolist (pathname (directory (merge-pathnames (make-pathname :name :wild :type (get-file-extension system)) (get-directory system)))) (delete-file pathname))) (clrhash (get-root-objects system))) Index: src/sysdeps.lisp =================================================================== RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/sysdeps.lisp,v retrieving revision 1.1 diff -u -r1.1 sysdeps.lisp --- src/sysdeps.lisp 28 Jun 2004 11:54:49 -0000 1.1 +++ src/sysdeps.lisp 5 Jan 2006 19:14:34 -0000 @@ -65,15 +65,16 @@ #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments) #+allegro (apply #'mp:process-run-function name function arguments) #+openmcl (apply #'ccl:process-run-function name function arguments) - #+sbcl (apply function arguments) - #-(or openmcl lispworks sbcl allegro) (error "not yet ported")) + #+sb-thread (apply #'sb-thread:make-thread function :name name arguments) + #-(or openmcl lispworks sb-thread allegro) (error "not yet ported")) (defun make-process-lock (name) "Create a named process lock object" #+lispworks (mp:make-lock :name name) #+openmcl (ccl:make-lock name) #+allegro (mp:make-process-lock :name name) - #-(or lispworks openmcl allegro) (error "not yet ported")) + #+sb-thread (sb-thread:make-mutex :name name) + #-(or lispworks openmcl allegro sb-thread) (error "not yet ported")) (defmacro with-process-lock ((lock) &body body) "Execute body wih the process lock grabbed, wait otherwise" @@ -83,7 +84,8 @@ #+lispworks `(mp:with-lock (,lock) , at body) #+openmcl `(ccl:with-lock-grabbed (,lock) , at body) #+allegro `(mp:with-process-lock (,lock) , at body) - #-(or lispworks openmcl allegro) (error "not yet ported")) + #+sb-thread `(sb-thread:with-recursive-lock (,lock) , at body) + #-(or lispworks openmcl allegro sb-thread) (error "not yet ported")) #+sbcl (defvar *server-processes* nil) From scaekenberghe at common-lisp.net Mon Jan 9 19:24:39 2006 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 9 Jan 2006 20:24:39 +0100 Subject: [cl-prevalence-devel] S-SYSDEPS Message-ID: From now on, the local sydeps.lisp file is replace by a dependency on the more general S-SYSDEPS package ( http://homepage.mac.com/svc/s- sysdeps/ ). Only in CVS HEAD for now, if there are no objections, I will release this soon to the tarballs. Sven From scaekenberghe at common-lisp.net Mon Jan 9 19:09:05 2006 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 9 Jan 2006 20:09:05 +0100 Subject: [cl-prevalence-devel] Re: Kpax win32 patch In-Reply-To: <43BD710E.6030502@entricom.com> References: <9238e8de0512230653ub5a2880g@mail.gmail.com> <9238e8de0512241111j1a386a5fl@mail.gmail.com> <9238e8de0512260537g17d07a00y@mail.gmail.com> <43BD710E.6030502@entricom.com> Message-ID: <159A3DD3-8C46-42B5-8310-DE8D2CA5FD5C@common-lisp.net> Thanks Bruce, I applied your patched (to S-SYSDEPS). Sven On 05 Jan 2006, at 20:18, Bruce Butterfield wrote: > Sven Van Caekenberghe wrote: >> Marko, >> Thx for reporting this problem. >> I 'fixed' it by no longer loading debug-prevalence by default. >> The s-xml::echo-xml function (used here for pretty printing xml) >> is no longer loaded by default. >> Compilation/loading using LispWorks and SBCL is now OK. > > FWIW, here are patches to CVS head for threaded SBCL and an update > to #'totally-destroy so it includes a wildcard pathname (SBCL isn't > happy with unnamed paths): > > > =================================================================== > RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/ > prevalence.lisp,v > retrieving revision 1.7 > diff -u -r1.7 prevalence.lisp > --- src/prevalence.lisp 4 Oct 2004 14:25:13 -0000 1.7 > +++ src/prevalence.lisp 5 Jan 2006 19:14:33 -0000 > @@ -169,7 +169,7 @@ > "Totally destroy system from permanent storage by deleting any > files used by the system, remove all root objects" > (close-open-streams system :abort abort) > (when (probe-file (get-directory system)) > - (dolist (pathname (directory (merge-pathnames (make- > pathname :type (get-file-extension system)) > + (dolist (pathname (directory (merge-pathnames (make- > pathname :name :wild :type (get-file-extension system)) > (get-directory > system)))) > (delete-file pathname))) > (clrhash (get-root-objects system))) > Index: src/sysdeps.lisp > =================================================================== > RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/ > sysdeps.lisp,v > retrieving revision 1.1 > diff -u -r1.1 sysdeps.lisp > --- src/sysdeps.lisp 28 Jun 2004 11:54:49 -0000 1.1 > +++ src/sysdeps.lisp 5 Jan 2006 19:14:34 -0000 > @@ -65,15 +65,16 @@ > #+lispworks (apply #'mp:process-run-function name '(:priority 3) > function arguments) > #+allegro (apply #'mp:process-run-function name function arguments) > #+openmcl (apply #'ccl:process-run-function name function > arguments) > - #+sbcl (apply function arguments) > - #-(or openmcl lispworks sbcl allegro) (error "not yet ported")) > + #+sb-thread (apply #'sb-thread:make-thread function :name name > arguments) > + #-(or openmcl lispworks sb-thread allegro) (error "not yet > ported")) > > (defun make-process-lock (name) > "Create a named process lock object" > #+lispworks (mp:make-lock :name name) > #+openmcl (ccl:make-lock name) > #+allegro (mp:make-process-lock :name name) > - #-(or lispworks openmcl allegro) (error "not yet ported")) > + #+sb-thread (sb-thread:make-mutex :name name) > + #-(or lispworks openmcl allegro sb-thread) (error "not yet > ported")) > > (defmacro with-process-lock ((lock) &body body) > "Execute body wih the process lock grabbed, wait otherwise" > @@ -83,7 +84,8 @@ > #+lispworks `(mp:with-lock (,lock) , at body) > #+openmcl `(ccl:with-lock-grabbed (,lock) , at body) > #+allegro `(mp:with-process-lock (,lock) , at body) > - #-(or lispworks openmcl allegro) (error "not yet ported")) > + #+sb-thread `(sb-thread:with-recursive-lock (,lock) , at body) > + #-(or lispworks openmcl allegro sb-thread) (error "not yet > ported")) > > #+sbcl > (defvar *server-processes* nil) From henrik at evahjelte.com Fri Jan 27 11:29:05 2006 From: henrik at evahjelte.com (Henrik Hjelte) Date: Fri, 27 Jan 2006 12:29:05 +0100 Subject: [cl-prevalence-devel] Patch for serializing improper lists Message-ID: <1138361345.9481.27.camel@localhost.localdomain> I have made some changes in s-serialization that allows improper-lists, for example cons-pairs and circular lists. They used to fail with a type-error. I have made the changes inside the method for sequences rather than an another method specialised on lists. That way a proper list is output as a sequence (which is prettier), and an improper list is output as a list of cons-pairs. Circular lists are handled by first making a fresh cons in the hash-table of deserialized objects, and then replacing its cdr with a reference to the first cons in the circular list, which is also stored in the hash-table. Some new simple tests have also been added. The source files are attached, and a diff against the latest version in CVS. I have only tested this on x86 SBCL, but it should work on all implementations. Best wishes, Henrik Hjelte -------------- next part -------------- A non-text attachment was scrubbed... Name: improperlists.patch Type: text/x-patch Size: 19957 bytes Desc: not available URL: -------------- next part -------------- ;;;; -*- mode: Lisp -*- ;;;; ;;;; $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 ;;;; ;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-serialization) ;;; Public API (defgeneric serializable-slots (object) (:documentation "Return a list of slot names that need serialization")) (defun serialize-xml (object stream &optional (serialization-state (make-serialization-state))) "Write a serialized version of object to stream using XML, optionally reusing a serialization-state" (reset serialization-state) (serialize-xml-internal object stream serialization-state)) (defun serialize-sexp (object stream &optional (serialization-state (make-serialization-state))) "Write a serialized version of object to stream using s-expressions, optionally reusing a serialization-state" (reset serialization-state) (serialize-sexp-internal object stream serialization-state)) (defgeneric serialize-xml-internal (object stream serialization-state) (:documentation "Write a serialized version of object to stream using XML")) (defgeneric serialize-sexp-internal (object stream serialization-state) (:documentation "Write a serialized version of object to stream using s-expressions")) (defun deserialize-xml (stream &optional (serialization-state (make-serialization-state))) "Read and return an XML serialized version of a lisp object from stream, optionally reusing a serialization state" (reset serialization-state) (let ((*deserialized-objects* (get-hashtable serialization-state))) (declare (special *deserialized-objects*)) (car (s-xml:start-parse-xml stream (get-xml-parser-state serialization-state))))) (defun deserialize-sexp (stream &optional (serialization-state (make-serialization-state))) "Read and return an s-expression serialized version of a lisp object from stream, optionally reusing a serialization state" (reset serialization-state) (let ((sexp (read stream nil :eof))) (if (eq sexp :eof) nil (deserialize-sexp-internal sexp (get-hashtable serialization-state))))) (defun make-serialization-state () "Create a reusable serialization state to pass as optional argument to [de]serialize-xml" (make-instance 'serialization-state)) (defgeneric reset-known-slots (serialization-state &optional class) (:documentation "Clear the caching of known slots for class, or for all classes if class is nil")) ;;; Implementation ;; State and Support (defclass serialization-state () ((xml-parser-state :initform nil) (counter :accessor get-counter :initform 0) (hashtable :reader get-hashtable :initform (make-hash-table :test 'eq :size 1024 :rehash-size 2.0)) (known-slots :initform (make-hash-table)))) (defmethod get-xml-parser-state ((serialization-state serialization-state)) (with-slots (xml-parser-state) serialization-state (or xml-parser-state (setf xml-parser-state (make-instance 's-xml:xml-parser-state :new-element-hook #'deserialize-xml-new-element :finish-element-hook #'deserialize-xml-finish-element :text-hook #'deserialize-xml-text))))) (defmethod reset ((serialization-state serialization-state)) (with-slots (hashtable counter) serialization-state (clrhash hashtable) (setf counter 0))) (defmethod reset-known-slots ((serialization-state serialization-state) &optional class) (with-slots (known-slots) serialization-state (if class (remhash (if (symbolp class) class (class-name class)) known-slots) (clrhash known-slots)))) (defmethod known-object-id ((serialization-state serialization-state) object) (gethash object (get-hashtable serialization-state))) (defmethod set-known-object ((serialization-state serialization-state) object) (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 (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)))))) (defmethod serializable-slots ((object structure-object)) #+openmcl (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%)) (slots (if sd (ccl::sd-slots sd)))) (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) #+cmu (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) #+sbcl (mapcar #'sb-pcl:slot-definition-name (sb-pcl:class-slots (class-of object))) #+lispworks (structure:structure-class-slot-names (class-of object)) #+allegro (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))) #+sbcl (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object))) #-(or openmcl cmu lispworks allegro sbcl) (error "not yet implemented")) (defmethod serializable-slots ((object standard-object)) #+openmcl (mapcar #'ccl:slot-definition-name (#-openmcl-native-threads ccl:class-instance-slots #+openmcl-native-threads ccl:class-slots (class-of object))) #+cmu (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) #+sbcl (mapcar #'sb-pcl:slot-definition-name (sb-pcl:class-slots (class-of object))) #+lispworks (mapcar #'hcl:slot-definition-name (hcl:class-slots (class-of object))) #+allegro (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))) #+sbcl (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object))) #-(or openmcl cmu lispworks allegro sbcl) (error "not yet implemented")) (defmethod get-serializable-slots ((serialization-state serialization-state) object) (with-slots (known-slots) serialization-state (let* ((class (class-name (class-of object))) (slots (gethash class known-slots))) (when (not slots) (setf slots (serializable-slots object)) (setf (gethash class known-slots) slots)) slots))) ;; Serializers (defmethod serialize-xml-internal ((object integer) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (prin1 object stream) (write-string "" stream)) (defmethod serialize-xml-internal ((object ratio) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (prin1 object stream) (write-string "" stream)) (defmethod serialize-xml-internal ((object float) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (prin1 object stream) (write-string "" stream)) (defmethod serialize-xml-internal ((object complex) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (prin1 object stream) (write-string "" stream)) (defmethod serialize-sexp-internal ((object number) stream serialize-sexp-internal) (declare (ignore serialize-sexp-internal)) (prin1 object stream)) (defmethod serialize-xml-internal ((object null) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream)) (defmethod serialize-xml-internal ((object (eql 't)) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream)) (defmethod serialize-xml-internal ((object string) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (s-xml:print-string-xml object stream) (write-string "" stream)) (defmethod serialize-xml-internal ((object character) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (s-xml:print-string-xml (princ-to-string object) stream) (write-string "" stream)) (defmethod serialize-xml-internal ((object symbol) stream serialization-state) (declare (ignore serialization-state)) (write-string "" stream) (print-symbol-xml object stream) (write-string "" stream)) (defmethod serialize-sexp-internal ((object null) stream serialization-state) (declare (ignore serialization-state)) (write-string "NIL" stream)) (defmethod serialize-sexp-internal ((object (eql 't)) stream serialization-state) (declare (ignore serialization-state)) (write-string "T" stream)) (defmethod serialize-sexp-internal ((object string) stream serialization-state) (declare (ignore serialization-state)) (prin1 object stream)) (defmethod serialize-sexp-internal ((object character) stream serialization-state) (declare (ignore serialization-state)) (prin1 object stream)) (defmethod serialize-sexp-internal ((object symbol) stream serialization-state) (declare (ignore serialization-state)) (print-symbol object stream)) (defun sequence-type-and-length(sequence) (if (listp sequence) (handler-case (let ((length (list-length sequence))) (if length (values :proper-list length) (values :circular-list nil))) (type-error () (values :dotted-list nil))) (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 "" stream) (map nil #'(lambda (element) (serialize-xml-internal element stream serialization-state)) object) (write-string "" stream))) (improper-list () (let ((id (set-known-object serialization-state object))) (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 "" stream)))) (let ((id (known-object-id serialization-state object))) (if id (progn (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) (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) (let ((id (known-object-id serialization-state object))) (if id (progn (write-string "" stream)) (progn (setf id (set-known-object serialization-state object)) (write-string "" stream) (maphash #'(lambda (key value) (write-string "" stream) (serialize-xml-internal key stream serialization-state) (write-string "" stream) (serialize-xml-internal value stream serialization-state) (princ "" stream)) object) (write-string "" 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))))) (defmethod serialize-xml-internal ((object structure-object) stream serialization-state) (let ((id (known-object-id serialization-state object))) (if id (progn (write-string "" stream)) (progn (setf id (set-known-object serialization-state object)) (write-string "" stream) (mapc #'(lambda (slot) (write-string "" stream) (serialize-xml-internal (slot-value object slot) stream serialization-state) (write-string "" stream)) (get-serializable-slots serialization-state object)) (write-string "" 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))))) (defmethod serialize-xml-internal ((object standard-object) stream serialization-state) (let ((id (known-object-id serialization-state object))) (if id (progn (write-string "" stream)) (progn (setf id (set-known-object serialization-state object)) (write-string "

" 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))))) ;;; Deserialize CLOS instances and Lisp primitives from the XML representation (defun get-attribute-value (name attributes) (cdr (assoc name attributes :test #'eq))) (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))))) '()) (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)) (defun deserialize-xml-text (string seed) (declare (ignore seed)) string) (defun deserialize-sexp-internal (sexp deserialized-objects) (if (atom sexp) sexp (ecase (first sexp) (:sequence (destructuring-bind (id &key class size elements) (rest sexp) (let ((sequence (make-sequence class size))) (setf (gethash id deserialized-objects) sequence) (map-into sequence #'(lambda (x) (deserialize-sexp-internal x deserialized-objects)) elements)))) (:hash-table (destructuring-bind (id &key test size rehash-size rehash-threshold entries) (rest sexp) (let ((hash-table (make-hash-table :size size :test test :rehash-size rehash-size :rehash-threshold rehash-threshold))) (setf (gethash id deserialized-objects) hash-table) (dolist (entry entries) (setf (gethash (deserialize-sexp-internal (first entry) deserialized-objects) hash-table) (deserialize-sexp-internal (rest entry) deserialized-objects))) hash-table))) (:object (destructuring-bind (id &key class slots) (rest sexp) (let ((object (make-instance class))) (setf (gethash id deserialized-objects) object) (dolist (slot slots) (when (slot-exists-p object (first slot)) (setf (slot-value object (first slot)) (deserialize-sexp-internal (rest slot) deserialized-objects)))) object))) (:struct (destructuring-bind (id &key class slots) (rest sexp) (let ((object (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) (symbol-package class))))) (setf (gethash id deserialized-objects) object) (dolist (slot slots) (when (slot-exists-p object (first slot)) (setf (slot-value object (first slot)) (deserialize-sexp-internal (rest slot) deserialized-objects)))) object))) (:cons (destructuring-bind (id cons-car cons-cdr) (rest sexp) (let ((conspair (cons nil nil))) (setf (gethash id deserialized-objects) conspair) (rplaca conspair (deserialize-sexp-internal cons-car deserialized-objects)) (rplacd conspair (deserialize-sexp-internal cons-cdr deserialized-objects))))) (:ref (gethash (rest sexp) deserialized-objects))))) ;;;; eof -------------- next part -------------- ;;;; -*- mode: Lisp -*- ;;;; ;;;; $Id: test-serialization.lisp,v 1.4 2005/01/24 10:04:18 scaekenberghe Exp $ ;;;; ;;;; Testing XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; ;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-serialization) (defun serialize-and-deserialize-xml (object) (with-input-from-string (in (with-output-to-string (out) (serialize-xml object out))) (deserialize-xml in))) (defun serialize-and-deserialize-sexp (object) (with-input-from-string (in (with-output-to-string (out) (serialize-sexp object out))) (deserialize-sexp in))) ;; primitives (assert (null (serialize-and-deserialize-xml nil))) (assert (null (serialize-and-deserialize-sexp nil))) (assert (eq (serialize-and-deserialize-xml t) t)) (assert (eq (serialize-and-deserialize-sexp t) t)) (assert (= (serialize-and-deserialize-xml 100) 100)) (assert (= (serialize-and-deserialize-sexp 100) 100)) (assert (= (serialize-and-deserialize-xml (/ 3)) (/ 3))) (assert (= (serialize-and-deserialize-sexp (/ 3)) (/ 3))) (assert (= (serialize-and-deserialize-xml pi) pi)) (assert (= (serialize-and-deserialize-sexp pi) pi)) (assert (= (serialize-and-deserialize-xml (complex 1.5 2.5)) (complex 1.5 2.5))) (assert (= (serialize-and-deserialize-sexp (complex 1.5 2.5)) (complex 1.5 2.5))) (assert (eq (serialize-and-deserialize-xml 'foo) 'foo)) (assert (eq (serialize-and-deserialize-sexp 'foo) 'foo)) (assert (eq (serialize-and-deserialize-xml :foo) :foo)) (assert (eq (serialize-and-deserialize-sexp :foo) :foo)) (assert (eq (serialize-and-deserialize-xml 'room) 'room)) (assert (eq (serialize-and-deserialize-sexp 'room) 'room)) (assert (eq (serialize-and-deserialize-xml '|Unprintable|) '|Unprintable|)) (assert (eq (serialize-and-deserialize-sexp '|Unprintable|) '|Unprintable|)) (assert (equal (serialize-and-deserialize-xml "Hello") "Hello")) (assert (equal (serialize-and-deserialize-sexp "Hello") "Hello")) (assert (equal (serialize-and-deserialize-xml "") "")) (assert (equal (serialize-and-deserialize-sexp "") "")) (assert (equal (serialize-and-deserialize-xml #\A) #\A)) (assert (equal (serialize-and-deserialize-sexp #\A) #\A)) (assert (equal (serialize-and-deserialize-xml #\<) #\<)) (assert (equal (serialize-and-deserialize-sexp #\<) #\<)) (assert (equal (serialize-and-deserialize-xml "Hello & !") "Hello & !")) (assert (equal (serialize-and-deserialize-sexp "Hello & !") "Hello & !")) ;; simple sequences (assert (reduce #'(lambda (x &optional (y t)) (and x y)) (map 'list #'eql (serialize-and-deserialize-xml (list 1 2 3)) (list 1 2 3)))) (assert (reduce #'(lambda (x &optional (y t)) (and x y)) (map 'list #'eql (serialize-and-deserialize-sexp (list 1 2 3)) (list 1 2 3)))) (assert (equal (serialize-and-deserialize-xml (list 1 2 3)) (list 1 2 3))) (assert (equal (serialize-and-deserialize-sexp (list 1 2 3)) (list 1 2 3))) (assert (equal (serialize-and-deserialize-xml (cons 'hi 2)) (cons 'hi 2))) (assert (equal (serialize-and-deserialize-sexp (cons 'hi 2)) (cons 'hi 2))) (defun circular-list (&rest elements) (let ((cycle (copy-list elements))) (nconc cycle cycle))) (assert (equal (third (serialize-and-deserialize-sexp (circular-list 'a 'b))) 'a)) (assert (equal (third (serialize-and-deserialize-xml (circular-list 'a 'b))) 'a)) ;; simple objects (defclass foobar () ((foo :accessor get-foo :initarg :foo) (bar :accessor get-bar :initarg :bar))) (defparameter *foobar* (make-instance 'foobar :foo 100 :bar "Bar")) (assert (let ((foobar (serialize-and-deserialize-xml *foobar*))) (and (equal (get-foo foobar) (get-foo *foobar*)) (equal (get-bar foobar) (get-bar *foobar*)) (eq (class-of foobar) (class-of *foobar*))))) (assert (let ((foobar (serialize-and-deserialize-sexp *foobar*))) (and (equal (get-foo foobar) (get-foo *foobar*)) (equal (get-bar foobar) (get-bar *foobar*)) (eq (class-of foobar) (class-of *foobar*))))) ;; standard structs (defstruct foobaz foo baz) (defparameter *foobaz* (make-foobaz :foo 100 :baz "Baz")) (assert (let ((foobaz (serialize-and-deserialize-xml *foobaz*))) (and (foobaz-p foobaz) (equal (foobaz-foo foobaz) (foobaz-foo *foobaz*)) (equal (foobaz-baz foobaz) (foobaz-baz *foobaz*))))) (assert (let ((foobaz (serialize-and-deserialize-sexp *foobaz*))) (and (foobaz-p foobaz) (equal (foobaz-foo foobaz) (foobaz-foo *foobaz*)) (equal (foobaz-baz foobaz) (foobaz-baz *foobaz*))))) ;;; hash-tables (defparameter *hashtable* (let ((hashtable (make-hash-table :test 'equal))) (map nil #'(lambda (feature) (setf (gethash (symbol-name feature) hashtable) feature)) *features*) hashtable)) (let (h2) (setf h2 (serialize-and-deserialize-xml *hashtable*)) (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2)) (let (h2) (setf h2 (serialize-and-deserialize-sexp *hashtable*)) (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2)) ;;; eof From scaekenberghe at common-lisp.net Tue Jan 31 12:59:55 2006 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 31 Jan 2006 13:59:55 +0100 Subject: [cl-prevalence-devel] Patch for serializing improper lists In-Reply-To: <1138361345.9481.27.camel@localhost.localdomain> References: <1138361345.9481.27.camel@localhost.localdomain> Message-ID: Hi Henrik, On 27 Jan 2006, at 12:29, Henrik Hjelte wrote: > I have made some changes in s-serialization that allows improper- > lists, > for example cons-pairs and circular lists. They used to fail with a > type-error. > > I have made the changes inside the method for sequences rather than an > another method specialised on lists. That way a proper list is > output as > a sequence (which is prettier), and an improper list is output as a > list > of cons-pairs. > > Circular lists are handled by first making a fresh cons in the > hash-table of deserialized objects, and then replacing its cdr with a > reference to the first cons in the circular list, which is also stored > in the hash-table. > > Some new simple tests have also been added. > > The source files are attached, and a diff against the latest > version in > CVS. > > I have only tested this on x86 SBCL, but it should work on all > implementations. Your code looks very good; as far as I can see, it works well (I tested on LWM). I applied your changes and checked them in against cvs head. Thanks a lot for your contributions, Sven -- Sven Van Caekenberghe - http://homepage.mac.com/svc Beta Nine - software engineering - http://www.beta9.be "Lisp isn't a language, it's a building material." - Alan Kay