[movitz-cvs] CVS movitz

[ffjeld]

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv32704

Modified Files:
	image.lisp 
Log Message:
Minor tweaks.


--- /project/movitz/cvsroot/movitz/image.lisp	2008/02/24 12:13:06	1.116
+++ /project/movitz/cvsroot/movitz/image.lisp	2008/03/15 20:45:21	1.117
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.116 2008/02/24 12:13:06 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.117 2008/03/15 20:45:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -894,14 +894,13 @@
 	  (unless (typep (movitz-env-named-function (car cf) nil)
 			 'movitz-funobj)
 	    (warn "Function ~S is called (in ~S) but not defined." (car cf) (cdr cf))))
-	(maphash #'(lambda (symbol function-value)
-		     (let ((movitz-symbol (movitz-read symbol)))
-		       (if (typep function-value 'movitz-object)
-			   ;; (warn "SETTING ~A's funval to ~A"
-			 ;; movitz-symbol function-value)
-			   (setf (movitz-symbol-function-value movitz-symbol)
-			     function-value)
-			 #+ignore (warn "fv: ~W" (movitz-macro-expander-function function-value)))))
+	(maphash (lambda (symbol function-value)
+		   (let ((movitz-symbol (movitz-read symbol)))
+		     (etypecase function-value
+		       (movitz-funobj
+			(setf (movitz-symbol-function-value movitz-symbol) function-value))
+		       (movitz-macro
+			#+ignore (warn "fv: ~S ~S ~S" symbol function-value (movitz-env-get symbol :macro-expansion))))))
 		 (movitz-environment-function-cells (image-global-environment *image*)))
 	(let ((run-time-context (image-run-time-context *image*)))
 	  ;; pull in functions in run-time-context
@@ -1169,12 +1168,18 @@
 				  name symbol)
 		   name)))
 	     (ensure-package (package-name lisp-package &optional context)
-	       (assert (not (member (package-name lisp-package)
-				    #+allegro '(excl common-lisp sys aclmop)
-				    #-allegro '(common-lisp)
-				    :test #'string=)) ()
-		 "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz."
-		 lisp-package context)
+	       (restart-case (assert (not (member (package-name lisp-package)
+						  '(common-lisp movitz
+						    #+allegro excl
+						    #+allegro sys
+						    #+allegro aclmop
+						    #+sbcl sb-ext)
+						  :test #'string=)) ()
+						  "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz."
+						  lisp-package context)
+		 (use-muerte ()
+		   :report "Substitute the muerte pacakge."
+		   (return-from ensure-package (ensure-package :muerte (find-package :muerte)))))
 	       (setf (gethash lisp-package lisp-to-movitz-package)
 		 (or (gethash package-name packages-hash nil)
 		     (let* ((nicks (mapcar #'movitz-package-name (package-nicknames lisp-package)))
@@ -1460,8 +1465,10 @@
 	      (length (movitz-funobj-const-list funobj))
 	      (movitz-funobj-const-list funobj)
 	      (loop with pc = 0
-		 for (data . instruction) in (asm:disassemble-proglist code :symtab (movitz-funobj-symtab funobj)
-									    :collect-data t)
+		 for (data . instruction) in (let ((asm-x86:*cpu-mode* :32-bit))
+					       (asm:disassemble-proglist code
+									 :symtab (movitz-funobj-symtab funobj)
+									 :collect-data t))
 		 when (assoc pc entry-points)
 		 collect (list pc nil
 			       (format nil "  => Entry-point for ~D arguments <=" (cdr (assoc pc entry-points)))