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(a)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."