[movitz-cvs] CVS update: movitz/image.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	image.lisp 
Log Message:
Improved movitz-print so it's more symmetric with movitz-read.

Date: Mon Feb  2 08:04:49 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.3 movitz/image.lisp:1.4
--- movitz/image.lisp:1.3	Mon Jan 19 06:23:41 2004
+++ movitz/image.lisp	Mon Feb  2 08:04:49 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.3 2004/01/19 11:23:41 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.4 2004/02/02 13:04:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1262,6 +1262,9 @@
   (setf (gethash movitz-object (image-inverse-read-map-hash image)) lisp-object
 	(gethash lisp-object (image-read-map-hash image)) movitz-object))
 
+(defmethod image-movitz-to-lisp-object ((image symbolic-image) movitz-object)
+  (gethash movitz-object (image-inverse-read-map-hash image)))
+
 (defmacro with-movitz-read-context (options &body body)
   (declare (ignore options))
   `(let ((*movitz-reader-clean-map* (if (boundp '*movitz-reader-clean-map*)
@@ -1292,7 +1295,7 @@
 	 (integer (make-movitz-fixnum expr))
 	 (character (make-movitz-character expr))
 	 (vector (make-movitz-vector (length expr)
-				  :initial-contents (map 'vector #'movitz-read expr)))
+				     :initial-contents (map 'vector #'movitz-read expr)))
 	 (cons
 	  (image-read-intern-constant *image* expr)
 	  #+ignore (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#)))
@@ -1387,25 +1390,17 @@
 ;;; "Printer"
 
 (defun movitz-print (expr)
+  "Find the host lisp object equivalent to the Movitz object expr."
   (etypecase expr
     (integer expr)
     (symbol expr)
     (cons (mapcar #'movitz-print expr))
     ((or movitz-nil movitz-constant-block) nil)
-    (movitz-symbol
-     (intern (movitz-print (movitz-symbol-name expr))))
-    (movitz-string
-     (map 'string #'identity
-	  (movitz-vector-symbolic-data expr)))
     (movitz-fixnum
      (movitz-fixnum-value expr))
-    (movitz-vector
-     (map 'vector #'movitz-print (movitz-vector-symbolic-data expr)))
-    (movitz-cons
-     (cons (movitz-print (movitz-car expr))
-	   (movitz-print (movitz-cdr expr))))))
-
-;;;
+    (movitz-heap-object
+     (or (image-movitz-to-lisp-object *image* expr)
+	 (error "Unknown Movitz object: ~S" expr)))))
 
 (defmethod make-toplevel-funobj ((*image* symbolic-image))
   (let ((toplevel-code (loop for (funobj) in (image-load-time-funobjs *image*)