[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Fri Jul 18 13:15:40 UTC 2008
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv3039
Modified Files:
image.lisp
Log Message:
Have dump-image be more resilient against cyclic structures.
--- /project/movitz/cvsroot/movitz/image.lisp 2008/07/09 19:54:56 1.125
+++ /project/movitz/cvsroot/movitz/image.lisp 2008/07/18 13:15:40 1.126
@@ -9,7 +9,7 @@
;;;; Created at: Sun Oct 22 00:22:43 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: image.lisp,v 1.125 2008/07/09 19:54:56 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.126 2008/07/18 13:15:40 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1645,79 +1645,83 @@
(with-movitz-read-context ()
(when (typep expr 'movitz-object)
(return-from movitz-read expr))
- (or (and (not re-read)
- (let ((old-object (image-lisp-to-movitz-object *image* expr)))
- (when (and old-object (not (gethash old-object *movitz-reader-clean-map*)))
- (update-movitz-object old-object expr)
- (setf (gethash old-object *movitz-reader-clean-map*) t))
- old-object))
+ (or (unless re-read
+ (let ((old-object (image-lisp-to-movitz-object *image* expr)))
+ (when (and old-object
+ (not (gethash old-object *movitz-reader-clean-map*)))
+ (setf (gethash old-object *movitz-reader-clean-map*) t)
+ (update-movitz-object old-object expr))
+ old-object))
(setf (image-lisp-to-movitz-object *image* expr)
- (etypecase expr
- (null *movitz-nil*)
- ((member t) (movitz-read 'muerte.cl:t))
- ((eql unbound) (make-instance 'movitz-unbound-value))
- (symbol (intern-movitz-symbol expr))
- (integer (make-movitz-integer expr))
- (character (make-movitz-character expr))
- (string (or (gethash expr (image-string-constants *image*))
- (setf (gethash expr (image-string-constants *image*))
- (make-movitz-string expr))))
- (vector (make-movitz-vector (length expr)
- :element-type (array-element-type expr)
- :initial-contents expr))
- (cons
- (or (let ((old-cons (gethash expr (image-cons-constants *image*))))
- (when old-cons
- (update-movitz-object old-cons expr)
- old-cons))
- (setf (gethash expr (image-cons-constants *image*))
- (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#)))
- (multiple-value-bind (unfolded-expr cdr-index)
- (unfold-circular-list expr)
- (let ((result (movitz-read unfolded-expr)))
- (setf (movitz-last-cdr result)
- (movitz-nthcdr cdr-index result))
- result))
- (make-movitz-cons (movitz-read (car expr))
- (movitz-read (cdr expr)))))))
- (hash-table
- (make-movitz-hash-table expr))
- (pathname
- (make-instance 'movitz-struct
- :class (muerte::movitz-find-class 'muerte::pathname)
- :length 1
- :slot-values (list (movitz-read (namestring expr)))))
- (complex
- (make-instance 'movitz-struct
- :class (muerte::movitz-find-class 'muerte::complex)
- :length 2
- :slot-values (list (movitz-read (realpart expr))
- (movitz-read (imagpart expr)))))
- (ratio
- (make-instance 'movitz-ratio
- :value expr))
- (structure-object
- (let ((slot-descriptions (gethash (type-of expr)
- (image-struct-slot-descriptions *image*)
- nil)))
- (unless slot-descriptions
- (error "Don't know how to movitz-read struct: ~S" expr))
- (let ((movitz-object (make-instance 'movitz-struct
- :class (muerte::movitz-find-class (type-of expr))
- :length (length slot-descriptions))))
- (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
- (setf (slot-value movitz-object 'slot-values)
- (mapcar #'(lambda (slot)
- (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
- slot-descriptions))
- movitz-object)))
- (float ; XXX
- (movitz-read (rationalize expr)))
- (class
- (muerte::movitz-find-class (translate-program (class-name expr)
- :cl :muerte.cl)))
- (array ; XXX
- (movitz-read nil)))))))
+ (etypecase expr
+ (null *movitz-nil*)
+ ((member t) (movitz-read 'muerte.cl:t))
+ ((eql unbound) (make-instance 'movitz-unbound-value))
+ (symbol (intern-movitz-symbol expr))
+ (integer (make-movitz-integer expr))
+ (character (make-movitz-character expr))
+ (string (or (gethash expr (image-string-constants *image*))
+ (setf (gethash expr (image-string-constants *image*))
+ (make-movitz-string expr))))
+ (vector (make-movitz-vector (length expr)
+ :element-type (array-element-type expr)
+ :initial-contents expr))
+ (cons
+ (or (let ((old-cons (gethash expr (image-cons-constants *image*))))
+ (when old-cons
+ (update-movitz-object old-cons expr)
+ old-cons))
+ (setf (gethash expr (image-cons-constants *image*))
+ (if (eq '#0=#:error
+ (ignore-errors
+ (when (not (list-length expr))
+ '#0#)))
+ (multiple-value-bind (unfolded-expr cdr-index)
+ (unfold-circular-list expr)
+ (let ((result (movitz-read unfolded-expr)))
+ (setf (movitz-last-cdr result)
+ (movitz-nthcdr cdr-index result))
+ result))
+ (make-movitz-cons (movitz-read (car expr))
+ (movitz-read (cdr expr)))))))
+ (hash-table
+ (make-movitz-hash-table expr))
+ (pathname
+ (make-instance 'movitz-struct
+ :class (muerte::movitz-find-class 'muerte::pathname)
+ :length 1
+ :slot-values (list (movitz-read (namestring expr)))))
+ (complex
+ (make-instance 'movitz-struct
+ :class (muerte::movitz-find-class 'muerte::complex)
+ :length 2
+ :slot-values (list (movitz-read (realpart expr))
+ (movitz-read (imagpart expr)))))
+ (ratio
+ (make-instance 'movitz-ratio
+ :value expr))
+ (structure-object
+ (let ((slot-descriptions (gethash (type-of expr)
+ (image-struct-slot-descriptions *image*)
+ nil)))
+ (unless slot-descriptions
+ (error "Don't know how to movitz-read struct: ~S" expr))
+ (let ((movitz-object (make-instance 'movitz-struct
+ :class (muerte::movitz-find-class (type-of expr))
+ :length (length slot-descriptions))))
+ (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
+ (setf (slot-value movitz-object 'slot-values)
+ (mapcar #'(lambda (slot)
+ (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
+ slot-descriptions))
+ movitz-object)))
+ (float ; XXX
+ (movitz-read (rationalize expr)))
+ (class
+ (muerte::movitz-find-class (translate-program (class-name expr)
+ :cl :muerte.cl)))
+ (array ; XXX
+ (movitz-read nil)))))))
;;;
More information about the Movitz-cvs
mailing list