Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5345

Modified Files: image.lisp Log Message: Added support for movitz-read'ing ratios.

Date: Thu Jul 29 09:18:47 2004 Author: ffjeld

Index: movitz/image.lisp diff -u movitz/image.lisp:1.56 movitz/image.lisp:1.57 --- movitz/image.lisp:1.56 Wed Jul 28 18:59:13 2004 +++ movitz/image.lisp Thu Jul 29 09:18:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.56 2004/07/29 01:59:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.57 2004/07/29 16:18:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -1426,61 +1426,75 @@ (declare (special *movitz-reader-clean-map*)) ,@body))

-(defun movitz-read (expr) +(defun movitz-read (expr &optional re-read) "Map native lisp data to movitz-objects. Makes sure that when two EXPR are EQ, ~@ the Movitz objects are also EQ, under the same image." (declare (optimize (debug 3) (speed 0))) (with-movitz-read-context () (when (typep expr 'movitz-object) (return-from movitz-read expr)) - (or - (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) - (setf (image-lisp-to-movitz-object *image* expr) - (etypecase expr - (null *movitz-nil*) - ((member t) (movitz-read 'muerte.cl:t)) - (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 (gethash expr (image-cons-constants *image*)) - (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)) - (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)))))))) + (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)) + (setf (image-lisp-to-movitz-object *image* expr) + (etypecase expr + (null *movitz-nil*) + ((member t) (movitz-read 'muerte.cl:t)) + (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 (gethash expr (image-cons-constants *image*)) + (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)) + (ratio + (let ((slot-descriptions (gethash 'muerte.cl::ratio + (image-struct-slot-descriptions *image*) + nil))) + (unless slot-descriptions + (error "Don't know how to movitz-read ratios (yet)." expr)) + (let ((movitz-object (make-instance 'movitz-struct + :class (muerte::movitz-find-class 'muerte.cl::ratio) + :length (length slot-descriptions)))) + (setf (image-lisp-to-movitz-object *image* expr) movitz-object) + (setf (slot-value movitz-object 'slot-values) + (list (movitz-read (numerator expr)) + (movitz-read (denominator expr)))) + movitz-object))) + (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))))))))

;;;