[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	inspect.lisp 
Log Message:
Added %find-code-vector.

Date: Tue Dec 21 15:27:09 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.44 movitz/losp/muerte/inspect.lisp:1.45
--- movitz/losp/muerte/inspect.lisp:1.44	Tue Nov 23 17:03:35 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Dec 21 15:27:09 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.44 2004/11/23 16:03:35 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.45 2004/12/21 14:27:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -163,6 +163,37 @@
        (when (member :catch types)
 	 (format t "~&catch:   ~Z: ~S" tag tag))))))
 
+(define-compiler-macro %location-object (&environment env location tag)
+  (assert (movitz:movitz-constantp tag env))
+  `(with-inline-assembly (:returns :eax)
+     (:compile-form (:result-mode :eax) ,location)
+     (:addl ,tag :eax)))
+
+(defun %find-code-vector (location &optional (stop-location (if (< location #x2000)
+								0
+							      (- location #x2000))))
+  "Find the code-vector that holds a location by searching for a code-vector object header."
+  (do ((l (logand location -2) (- l 2)))
+      ((< l stop-location)
+       (error "Unable to find code-vector for location ~S." location))
+    (multiple-value-bind (upper30 lower2)
+	(memref l 0 :type :signed-byte30+2)
+      (when (and (= 2 lower2)
+		 (= #.(movitz:basic-vector-type-tag :code))
+		 ;; If the vector has a fill-pointer, it should be equal to the length.
+		 (multiple-value-bind (len len-tag)
+		     (memref l 4 :type :signed-byte30+2)
+		   (and (= 0 len-tag)
+			(typecase len
+			  ((integer 0 #x3fff)
+			   (= len (memref l 2 :type :unsigned-byte14)))
+			  (positive-fixnum t)
+			  (t nil)))))
+	(let ((code-vector (%location-object l 6)))
+	  (check-type code-vector code-vector)
+	  (assert (location-in-object-p code-vector location))
+	  (return code-vector))))))
+
 (defun %shallow-copy-object (object word-count)
   "Copy any object with size word-count."
   (check-type word-count (integer 2 *))
@@ -373,9 +404,10 @@
     (do ((frame start-frame))
 	((eq 0 frame))
       (let ((uplink (stack-frame-uplink nil frame)))
-	(setf (stack-frame-ref copy 0 (- frame start-frame) :lisp)
-	  (if (eql 0 uplink)
-	      0
-	    (- uplink start-frame)))
+	(unless (= 0 uplink)
+	  (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp)
+	    (- uplink start-frame))
+	  
+	  )
 	(setf frame uplink)))
     copy))