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

Modified Files:
	inspect.lisp 
Log Message:
Improved copy-control-stack: Take a parameter absolutep which means to
make the stack-frame uplink pointers array indexes rather than locations.

Date: Fri Jul 23 08:36:46 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.30 movitz/losp/muerte/inspect.lisp:1.31
--- movitz/losp/muerte/inspect.lisp:1.30	Wed Jul 21 18:08:18 2004
+++ movitz/losp/muerte/inspect.lisp	Fri Jul 23 08:36:46 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.30 2004/07/22 01:08:18 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.31 2004/07/23 15:36:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -340,8 +340,9 @@
 	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))
 
 
-(defun copy-control-stack (&optional (stack (%run-time-context-slot 'stack-vector))
-				     (frame (current-stack-frame)))
+(defun copy-control-stack (&key (absolutep)
+				(stack (%run-time-context-slot 'stack-vector))
+				(frame (current-stack-frame)))
   (assert (location-in-object-p stack frame))
   (let* ((stack-start-location (+ 2 (object-location stack)))
 	 (frame-index (- frame stack-start-location))
@@ -357,7 +358,10 @@
 	 (t (let ((uplink-index (- uplink-frame stack-start-location frame-index)))
 	      (assert (< -1 uplink-index (length copy)) ()
 		"Uplink-index outside copy: ~S, i: ~S" uplink-index i)
-	      (let ((x  (+ uplink-index copy-start-location)))
-		(assert (location-in-object-p copy x))
-		(setf (svref%unsafe copy i) x)
-		(setf i uplink-index)))))))))
+	      (setf (svref%unsafe copy i)
+		(if absolutep
+		    uplink-index
+		  (let ((x (+ uplink-index copy-start-location)))
+		    (assert (location-in-object-p copy x))
+		    (setf (svref%unsafe copy i) x))))
+	      (setf i uplink-index))))))))