Permalink
Browse files

Backtrace and frame/eval improvements

  • Loading branch information...
1 parent 14add2c commit a8e47da3f7ca087c85445888b0c201d7b3f736ce Geo Carncross committed Apr 30, 2008
Showing with 95 additions and 16 deletions.
  1. +4 −0 ChangeLog
  2. +91 −16 swank-ecl.lisp
View
@@ -1,3 +1,7 @@
+2008-04-29 Geo Carncross <geocar@gmail.com>
+
+ * swank-ecl.lisp: Backtrace and frame/eval improvements
+
2008-04-24 Tobias C. Rittweiler <tcr@freebits.de>
* swank-backend.lisp: Clarified docstrings of interface functions
View
@@ -207,7 +207,8 @@
;;; Debugging
(import
- '(si::*ihs-top*
+ '(si::*break-env*
+ si::*ihs-top*
si::*ihs-current*
si::*ihs-base*
si::*frs-base*
@@ -216,11 +217,15 @@
si::*tpl-level*
si::frs-top
si::ihs-top
+ si::ihs-fun
+ si::ihs-env
si::sch-frs-base
si::set-break-env
si::set-current-ihs
si::tpl-commands))
+(defvar *backtrace* '())
+
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let* ((*tpl-commands* si::tpl-commands)
@@ -229,27 +234,97 @@
(*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
(*frs-top* (frs-top))
(*read-suppress* nil)
- (*tpl-level* (1+ *tpl-level*)))
+ (*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
+ collect (list (si::ihs-fun (1+ ihs))
+ (si::ihs-env ihs)
+ nil))))
+ (loop for f from *frs-base* until *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (nreverse *backtrace*))
(set-break-env)
(set-current-ihs)
- (funcall debugger-loop-fn)))
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
-;; (defimplementation call-with-debugger-hook (hook fun)
-;; (let ((*debugger-hook* hook))
-;; (funcall fun)))
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
+ (funcall fun)))
-(defun nth-frame (n)
- (cond ((>= n *ihs-top* ) nil)
- (t (- *ihs-top* n))))
-
(defimplementation compute-backtrace (start end)
- (loop for i from start below end
- for f = (nth-frame i)
- while f
- collect f))
+ (when (numberp end)
+ (setf end (min end (length *backtrace*))))
+ (subseq *backtrace* start end))
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun function-position (fun)
+ (multiple-value-bind (file position)
+ (si::bc-file fun)
+ (and file (make-location `(:file ,file) `(:position ,position)))))
+
+(defun frame-function (frame)
+ (let* ((x (first frame))
+ fun position)
+ (etypecase x
+ (symbol (and (fboundp x)
+ (setf fun (fdefinition x)
+ position (function-position fun))))
+ (function (setf fun x position (function-position x))))
+ (values fun position)))
+
+(defun frame-decode-env (frame)
+ (let ((functions '())
+ (blocks '())
+ (variables '()))
+ (dolist (record (second frame))
+ (let* ((record0 (car record))
+ (record1 (cdr record)))
+ (cond ((symbolp record0)
+ (setq variables (acons record0 record1 variables)))
+ ((not (fixnump record0))
+ (push record1 functions))
+ ((symbolp record1)
+ (push record1 blocks))
+ (t
+ ))))
+ (values functions blocks variables)))
(defimplementation print-frame (frame stream)
- (format stream "~A" (si::ihs-fname frame)))
+ (format stream "~A" (first frame)))
+
+(defimplementation frame-source-location-for-emacs (frame-number)
+ (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+ (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ with i = 0
+ collect (list :name name :id (prog1 i (incf i)) :value value)))
+
+(defimplementation frame-var-value (frame-number var-id)
+ (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ var-id))
+
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-fun (elt *backtrace* frame-number))))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (si:eval-with-env form env)))
;;;; Inspector
@@ -312,7 +387,7 @@
(or
(typecase obj
(function
- (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj))
+ (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
(if (and file pos)
(make-location
`(:file ,(namestring file))

0 comments on commit a8e47da

Please sign in to comment.