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

Modified Files:
	inspect.lisp 
Log Message:
Improved copy-current-control-stack.

Date: Mon Feb 28 18:00:09 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.48 movitz/losp/muerte/inspect.lisp:1.49
--- movitz/losp/muerte/inspect.lisp:1.48	Fri Feb 25 08:59:31 2005
+++ movitz/losp/muerte/inspect.lisp	Mon Feb 28 18:00:05 2005
@@ -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.48 2005/02/25 07:59:31 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.49 2005/02/28 17:00:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -93,8 +93,8 @@
     (let ((pos (+ frame index)))
       (assert (< -1 pos (length stack))
 	  () "Index ~S, pos ~S, len ~S" index pos (length stack))
-      (memref stack 2 :index pos :type type)))
-   (t (memref frame 0 :index index :type type))))
+      (memref stack (+ 2 (* 4 pos)) :type type)))
+   (t (memref frame (* 4 index) :type type))))
 
 (defun (setf stack-frame-ref) (value stack frame index &optional (type ':lisp))
   (cond
@@ -428,11 +428,29 @@
 	(stack-frame-ref nil start-frame i :unsigned-byte32)))
     (do ((frame start-frame))
 	((eq 0 frame))
-      (let ((uplink (stack-frame-uplink nil frame)))
+      (let ((uplink (stack-frame-uplink nil frame))
+	    (copy-frame (- frame start-frame)))
 	(unless (= 0 uplink)
-	  (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp)
+	  (setf (stack-frame-ref copy copy-frame 0 :lisp)
 	    (- uplink start-frame))
-	  
-	  )
+	  (unless (= 0 copy-frame)	; first frame has only uplink.
+	    ;; Now, make any raw stack-pointers into relative indexes.
+	    ;; XXX TODO: The dynamic-env list.
+	    (case (stack-frame-funobj copy copy-frame)
+	      (0 (let ((ebp (dit-frame-ref nil frame :ebp)))
+		   (setf (dit-frame-ref copy copy-frame :ebp)
+		     (etypecase ebp
+		       (fixnum (- ebp start-frame))
+		       (null nil))))
+		 (let ((ac (dit-frame-ref copy copy-frame
+					  :atomically-continuation
+					  :location)))
+		   (when (and (/= 0 ac)
+			      (= 0 (ldb (byte 2 0)
+					(dit-frame-ref copy copy-frame
+						       :atomically-continuation
+						       :unsigned-byte8))))
+		     (setf (dit-frame-ref copy copy-frame :atomically-continuation)
+		       (- ac start-frame))))))))
 	(setf frame uplink)))
     copy))