[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Fri Jul 23 15:36:46 UTC 2004
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))))))))
More information about the Movitz-cvs
mailing list