[movitz-cvs] CVS update: movitz/image.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Jul 29 16:18:47 UTC 2004
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*))
, at 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))))))))
;;;
More information about the Movitz-cvs
mailing list