Permalink
Browse files

(frame-var-value): New backend function.

  • Loading branch information...
1 parent fe294da commit 2b0dd286ccb88a15d8129663984e99b4c8cfe767 Helmut Eller committed Jun 25, 2004
Showing with 59 additions and 29 deletions.
  1. +8 −4 swank-allegro.lisp
  2. +11 −5 swank-backend.lisp
  3. +4 −1 swank-clisp.lisp
  4. +21 −10 swank-cmucl.lisp
  5. +15 −9 swank-lispworks.lisp
View
@@ -55,9 +55,12 @@
(princ-to-string c))
(defimplementation condition-references (c)
- (declare (ignore))
+ (declare (ignore c))
'())
+(defimplementation call-with-syntax-hooks (fn)
+ (funcall fn))
+
;;;; Unix signals
(defimplementation call-without-interrupts (fn)
@@ -77,9 +80,6 @@
(defimplementation default-directory ()
(excl:chdir))
-(defimplementation call-with-syntax-hooks (fn)
- (funcall fn))
-
;;;; Misc
(defimplementation arglist (symbol)
@@ -147,6 +147,10 @@
:id 0
:value (debugger:frame-var-value frame i)))))
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (debugger:frame-var-value frame var)))
+
(defimplementation frame-catch-tags (index)
(declare (ignore index))
nil)
View
@@ -347,11 +347,16 @@ within the dynamic contour of a function defined by
DEFINE-DEBUGGER-HOOK.")
(definterface frame-locals (frame-number)
- "Return a list of XXX local variable designators define me
+ "Return a list of XXX local variable designators define me
for a debugger stack frame. The results are undefined unless
this is called within the dynamic contour of a function defined
by DEFINE-DEBUGGER-HOOK.")
+(definterface frame-var-value (frame var)
+ "Return the value of VAR in FRAME.
+FRAME is the number of the frame in the backtrace.
+VAR is the number of the variable in the frame.")
+
(definterface disassemble-frame (frame-number)
"Disassemble the code for the FRAME-NUMBER.
The output should be written to standard output.
@@ -510,13 +515,14 @@ themselves, that is, their dispatch functions, are left alone.")
;;;; Inspector
-(defstruct (unbound-slot-filler
- (:print-object
- (lambda (obj stream)
- (print-unreadable-object (obj stream :type t)))))
+(defstruct (unbound-slot-filler (:print-function print-unbound-slot))
"The definition of an object which serves as a placeholder in
an unbound slot for inspection purposes.")
+(defun print-unbound-slot (o stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (o stream :type t)))
+
(definterface inspected-parts (object)
"Return a short description and a list of (LABEL . VALUE) pairs."
(values (format nil "~S is an atom." object) '()))
View
@@ -25,7 +25,7 @@
(in-package :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (use-package "SOCKET")
+ ;;(use-package "SOCKET")
(use-package "GRAY"))
(eval-when (:compile-toplevel :execute)
@@ -198,6 +198,9 @@ Return NIL if the symbol is unbound."
(frame-do-genv frame (svref frame-env 3))
(frame-do-denv frame (svref frame-env 4)))))
+(defimplementation frame-var-value (frame var)
+ (getf (nth var (frame-locals frame)) :value))
+
;; Interpreter-Variablen-Environment has the shape
;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
View
@@ -1,5 +1,7 @@
;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
;;;
+;;; License: Public Domain
+;;;
;;;; Introduction
;;;
;;; This is the CMUCL implementation of the `swank-backend' package.
@@ -521,7 +523,7 @@ constant pool."
"Return FUNCTION's callers. The result is a list of code-objects."
(let ((referrers '()))
(declare (inline map-caller-code-components))
- (ext:gc :full t)
+ ;;(ext:gc :full t)
(map-caller-code-components function spaces
(lambda (code) (push code referrers)))
referrers))
@@ -1466,19 +1468,28 @@ A utility for debugging DEBUG-FUNCTION-ARGLIST."
(defimplementation eval-in-frame (form index)
(di:eval-in-frame (nth-frame index) form))
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))
+
+(defun debug-var-value (var frame location)
+ (ecase (di:debug-variable-validity var location)
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) ':<not-available>)))
+
(defimplementation frame-locals (index)
(let* ((frame (nth-frame index))
- (location (di:frame-code-location frame))
- (debug-function (di:frame-debug-function frame))
- (debug-variables (di::debug-function-debug-variables debug-function)))
- (loop for v across debug-variables collect
+ (loc (di:frame-code-location frame))
+ (vars (frame-debug-vars frame)))
+ (loop for v across vars collect
(list :name (di:debug-variable-symbol v)
:id (di:debug-variable-id v)
- :value (ecase (di:debug-variable-validity v location)
- (:valid
- (di:debug-variable-value v frame))
- ((:invalid :unknown)
- ':not-available))))))
+ :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame (di:frame-code-location frame))))
(defimplementation frame-catch-tags (index)
(mapcar #'car (di:frame-catches (nth-frame index))))
View
@@ -239,18 +239,24 @@ Return NIL if the symbol is unbound."
(frame-actual-args frame)))
(t (princ frame stream))))
+(defun frame-vars (frame)
+ (first (dbg::frame-locals-format-list frame #'list 75 0)))
+
(defimplementation frame-locals (n)
(let ((frame (nth-frame n)))
(if (dbg::call-frame-p frame)
- (destructuring-bind (vars with)
- (dbg::frame-locals-format-list frame #'list 75 0)
- (declare (ignore with))
- (mapcar (lambda (var)
- (destructuring-bind (name value symbol location) var
- (declare (ignore name location))
- (list :name symbol :id 0
- :value value)))
- vars)))))
+ (mapcar (lambda (var)
+ (destructuring-bind (name value symbol location) var
+ (declare (ignore name location))
+ (list :name symbol :id 0
+ :value value)))
+ (frame-vars frame)))))
+
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
+ (declare (ignore _n _s _l))
+ value)))
(defimplementation frame-catch-tags (index)
(declare (ignore index))

0 comments on commit 2b0dd28

Please sign in to comment.