[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-serv16792

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

Date: Tue Jan 25 05:49:51 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.45 movitz/losp/muerte/inspect.lisp:1.46
--- movitz/losp/muerte/inspect.lisp:1.45	Tue Dec 21 06:27:09 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jan 25 05:49:51 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -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.45 2004/12/21 14:27:09 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.46 2005/01/25 13:49:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -41,11 +41,21 @@
 (defun stack-frame-funobj (stack frame)
   (stack-frame-ref stack frame -1))
 
+(defun stack-location (stack index)
+  (if (eq nil stack)
+      index
+    (+ (object-location stack) 2 index)))
+
 (defun stack-frame-uplink (stack frame)
   (if (eq 0 (stack-frame-funobj stack frame))
       (dit-frame-casf stack frame)
     (stack-frame-ref stack frame 0)))
 
+(defun stack-vector-designator (stack)
+  (etypecase stack
+    (null (%run-time-context-slot 'stack-vector))
+    (vector stack)))
+
 (define-compiler-macro current-stack-frame ()
   `(with-inline-assembly (:returns :eax)
      (:leal ((:ebp ,(truncate movitz::+movitz-fixnum-factor+ 4)))
@@ -176,23 +186,21 @@
   (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))))))
+    (when (and (= (memref l 0 :type :unsigned-byte16)
+		  #.(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."