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

Modified Files:
	inspect.lisp 
Log Message:
Wrote function copy-control-stack, which does that.

Date: Tue Jul 20 16:53:00 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.26 movitz/losp/muerte/inspect.lisp:1.27
--- movitz/losp/muerte/inspect.lisp:1.26	Tue Jul 20 05:37:59 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 20 16:53:00 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.26 2004/07/20 12:37:59 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.27 2004/07/20 23:53:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -105,8 +105,8 @@
     (<= bottom pointer top)))
 
 (defun stack-ref (pointer offset index type)
-  (assert (stack-ref-p pointer) (pointer)
-    "Stack pointer not in range: #x~X" pointer)
+  #+ignore (assert (stack-ref-p pointer) (pointer)
+	     "Stack pointer not in range: #x~X" pointer)
   (memref-int pointer offset index type))
 
 (defun current-dynamic-context ()
@@ -336,3 +336,25 @@
 	      #.(movitz::movitz-type-word-size :movitz-struct)
 	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))
 
+
+(defun copy-control-stack (&optional (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))
+	 (copy (subseq stack frame-index))
+	 (copy-start-location (+ 2 (object-location copy)))
+	 (cc (subseq copy 0)))
+    (do ((i 0)) (nil)
+      (let ((uplink-frame (svref%unsafe copy i)))
+	(cond
+	 ((= 0 uplink-frame)
+	  (setf (svref%unsafe copy i) 0)
+	  (return (values copy cc)))
+	 (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)))))))))