;;;
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Spice Lisp Debugger.
;;;
;;; Written by Steve Handerson
;;;
;;; **********************************************************************
(defparameter *debug-print-level* 3
"*Print-level* is bound to this value when debug prints a function call.")
(defparameter *debug-print-length* 5
"*Print-length* is bound to this value when debug prints a function call.")
(defvar *debug-current-frame* nil
"Where the debugger stashes the currently examined frame.")
(defvar *debug-command-level* 0
"Pushes and pops/exits inside the debugger change this.")
(Defun debug-prompt ()
"The default contents of *debug-prompt*."
(terpri)
(let ((level (stack-level (frame-stack *debug-current-frame*))))
(cond ((not (zerop level))
(prin1 level)
(princ ":")))
(prin1 (frame-number *debug-current-frame*))
(dotimes (i *debug-command-level*) (princ "]"))
(princ " ")))
(defparameter *debug-prompt* #'debug-prompt
"A lambda of no args that prints the debugger prompt on *standard-output*.")
(defconstant debug-help-string
"
Prompt is <stack-level>':'<frame-number>(<command-level>*']').
Frames look like calls, with * meaning an open frame, C signifying catch.
Expressions get evaluated in the frame's lexical environment and setting *, etc.
Symbolic commands do not affect * and friends.
H prints this text. Q returns () from last call to debug.
PUSH rebinds things in another command level. Good for debug-hide/show.
POP goes to the next higher debug level. Pops past break loops (uses throw).
FLUSH causes errors to be flushed. FLUSH NIL lets them break.
$G throws to top level.
To change the current frame:
U up frame D down frame T top frame B bottom frame
F go to numbered frame (prompts if not given).
S search for a specified function (prompts),
an optional number of times (does not prompt).
R searches up the stack, optional times.
To examine the current frame:
? prints all kinds of groovy things.
L lists locals in current function. *Print-level* & *print-length* are
P displays current function call. bound to *Debug-print-level* &
PP '' '' '' '' *Debug-print-length* during the
G grinds it. L, & P commands.
Functions/macros for your enjoyment:
(DEBUG-RETURN expression [frame]) returns with values from an active frame.
(DEBUG-SPECIAL symbol [frame]) the special's value in the frame's context.
(DEBUG-EVAL exp [frame]) evaluates in the frame's lexical environment.
(DEBUG-LOCAL n [frame]) shows the nth local variable.
(DEBUG-ARG n [frame]) '' '' '' supplied argument.
(DEBUG-PC [frame]) '' '' next pc to be executed (use w/DISASSEMBLE).
(DEBUG-HIDE/DEBUG-SHOW <what> <which-ones>) hides/reveals un/interesting frames.
(DEBUG-SHOW-ALL) makes all frames visible. Use with push.
(DEBUG-HIDE-STUFF) makes the default stuff hidden.
")
;;;
;;; Some debugger functions
;;;
(defun inside-debugger-p ()
(and (boundp '*debug-current-frame*)
(debug-frame-p *debug-current-frame*)))
(Defmacro debug-return (expression &optional
(number (frame-number
*debug-current-frame*)))
`(frame-return (multiple-value-list ,expression)
(stack-frame-n (Frame-stack *debug-current-frame*) ,number)))
(Defun debug-special (symbol &optional (number (frame-number
*debug-current-frame*)))
(frame-special symbol (stack-frame-n (frame-stack
*debug-current-frame*)
number)))
(Defun debug-eval (exp &optional (number (frame-number
*debug-current-frame*)))
(let ((%venv% (debug-special '%venv% number)))
(%eval exp)))
(defun debug-local (n &optional (number (frame-number
*debug-current-frame*)))
(frame-local n (stack-frame-n (frame-stack
*debug-current-frame*)
number)))
(defun debug-print-locals (frame)
(let ((*print-level* *debug-print-level*)
(*print-length* *debug-print-length*))
(dotimes (i (frame-local-count frame))
(print i) (princ ":")
(prin1 (frame-local i frame)))))
(defun debug-arg (n &optional (number (frame-number
*debug-current-frame*)))
(frame-arg n (stack-frame-n (frame-stack
*debug-current-frame*)
number)))
(defun debug-pc (&optional (number (frame-number
*debug-current-frame*)))
(let ((*debug-top-of-stack*
#'(lambda () (princ "Pc cannot be determined - top of stack.")
(throw 'debug-loop-catcher nil))))
(frame-pc (stack-frame-n (frame-stack *debug-current-frame*) number))))
(Defun debug-show-all ()
(setq *debug-filter*
(make-debug-filter :debug-hidden-functions nil
:debug-hidden-packages nil
:debug-hidden-function-types nil
:debug-hidden-frame-types nil))
T)
(defun debug-hide-stuff ()
(setq *debug-filter*
(make-debug-filter))
T)
(Defun debug-describe-frame (frame)
(let ((fun (frame-function frame)))
(princ "Current Function:")
(describe (debug-function-name fun))
(if (not (zerop (debug-function-local-count fun)))
(format *standard-output*
"There are ~D local variables."
(debug-function-local-count fun)))
(format *standard-output*
"~%Function is ~:[interpreted~;compiled~]."
(compiled-function-p fun))
(format *standard-output*
"~%Function was called for ~a."
(frame-pointer-values-type frame))))
;;; Backtrace
;;; Backtrace prints a history of calls on the stack. It comes in two flavors.
;;; one works inside Debug, and the other works anywhere else. The effect is
;;; the same as far as the user can tell.
(DEfun backtrace (&optional (frames most-positive-fixnum))
(let ((*print-length* *Debug-print-length*)
(*print-level* *Debug-print-level*))
(cond ((inside-debugger-p)
(let ((*debug-bottom-of-stack*
#'(lambda ()
(return-from backtrace (values)))))
(do ((frame *debug-current-frame*
(frame-previous frame)))
((zerop frames) (values))
(decf frames)
(frame-pointer-print-prefix
(frame-pointer frame)
(frame-next-pointer frame))
(prin1 (frame-call frame)))))
;; Current and next are as usual. The guess is either the previous
;;open or active call frame, for when current-frame is a call frame,
;;or the previous catch frame, for when it's a catch frame.
(T (PROG (next-frame current-frame guess-for-previous tmp)
(setq guess-for-previous (%primitive active-catch-frame))
(setq guess-for-previous
(if (null guess-for-previous) 0
(%sp-make-fixnum guess-for-previous)))
(setq current-frame
(%sp-make-fixnum (%primitive active-call-frame)))
LOOP
(setq next-frame current-frame)
(cond ((< (setq tmp (guess-previous-frame-pointer current-frame))
guess-for-previous)
(shiftf current-frame guess-for-previous tmp))
(t (setq current-frame tmp)))
(if (or (zerop current-frame)
(zerop frames))
(return (values)))
(cond ((frame-pointer-interesting-p current-frame next-frame)
(decf frames)
(frame-pointer-print-prefix current-frame next-frame)
(prin1 (frame-pointer-call current-frame next-frame))))
(go LOOP)
)))))
;;;
;;; Error handling
;;;
(defmacro with-debug-handler-bindings (&body body)
(list 'let '((*debug-bottom-of-stack*
#'(lambda ()
(princ "Bottom of stack.")
(throw 'debug-loop-catcher nil)))
(*debug-top-of-stack*
#'(lambda ()
(princ "Top of stack.")
(throw 'debug-loop-catcher nil)))
(*debug-no-such-frame*
#'(lambda (number)
(format t "Frame number, ~A, out of bounds" number)
(throw 'debug-loop-catcher nil)))
(*debug-unbound-special*
#'(lambda (symbol)
(format t "Unbound special - ~A" symbol)
(throw 'debug-loop-catcher nil)))
(*debug-unbound-lexical*
#'(lambda (symbol)
(format t "Unbound symbol - ~A" symbol)
(throw 'debug-loop-catcher nil)))
(*debug-no-such-arg*
#'(lambda (number frame)
(format t "No argument ~A in frame ~A." number frame)
(throw 'debug-loop-catcher nil)))
(*debug-no-such-local*
#'(lambda (number frame)
(format t "No local ~A in frame ~A." number frame)
(throw 'debug-loop-catcher nil)))
(*debug-return-from-top-level*
#'(lambda ()
(princ "Return from top level?")
(throw 'debug-loop-catcher nil)))
(*debug-frame-not-active*
#'(lambda (frame)
(format t "Frame ~A not active." frame)
(throw 'debug-loop-catcher nil))))
`(condition-bind ((nil #'break-condition-handler))
,@body)))
(defun debug-function-search (thing times)
(let ((*debug-bottom-of-stack*
#'(lambda () (throw 'debug-search-catcher nil)))
(searchee (if (symbolp thing) (symbol-function thing) thing)))
(do ((i 1 (1+ i))
(frame (catch 'debug-search-catcher
(frame-search searchee *debug-current-frame*))
(catch 'debug-search-catcher
(frame-search searchee frame))))
((cond ((null frame)
(format T "~:[Only~R occurence~:P~;No occurences.~]." (= 1 i)
(1- i))
(throw 'debug-loop-catcher nil))
(t (= i times)))
frame))))
(defun debug-function-reverse-search (thing times)
(let ((*debug-top-of-stack*
#'(lambda () (throw 'debug-search-catcher nil)))
(searchee (if (symbolp thing) (symbol-function thing) thing)))
(do ((i 1 (1+ i))
(frame (catch 'debug-search-catcher
(frame-reverse-search searchee *debug-current-frame*))
(catch 'debug-search-catcher
(frame-reverse-search searchee frame))))
((cond ((null frame)
(format T "~:[Only ~R occurence~:P~;No occurences.~]." (= 1 i)
(1- i))
(throw 'debug-loop-catcher nil))
(t (= i times)))
frame))))
(defun debug-print-frame (frame &optional
(*print-length* *debug-print-length*)
(*print-level* *debug-print-level*))
(frame-pointer-print-prefix (frame-pointer frame) (frame-next-pointer frame))
(prin1 (frame-call frame)))
(defun debug-pprint-frame (frame)
(frame-pointer-print-prefix (frame-pointer frame) (frame-next-pointer frame))
(pprint (frame-call frame)))
;;; DEBUG
(defun command-loop (prompt do-command)
"Read-eval-print loop function with commands. The first argument is a
lambda of no args, evaluated before each read. The second takes the read
in expression as its argument. It may throw an expression (like the one it
got, for instance) to 'command-loop-eval, and it will get evaluated and
assigned to +, etc. * and friends do not get pushed unless you either throw
or use command-loop-return-values."
(prog (this-exp)
LOOP
(funcall prompt)
(setq this-exp
(catch 'command-loop-eval
(funcall do-command (read))
(go loop)))
(shiftf +++ ++ + - this-exp)
(command-loop-return-values
(multiple-value-list (eval -)))
(go LOOP)))
(proclaim '(special %temp%))
(defun command-loop-return-values (multiple-value-list)
"Companion to command-loop. Prints the list as values, and sets /, //, *..."
(dolist (x multiple-value-list)
(print x))
(setq /// // // / / multiple-value-list)
(Setq %temp% (car multiple-value-list))
;; Make sure nobody passes back an unbound marker.
(unless (boundp '%temp%)
(setq %temp% nil)
(cerror "Go on, but set * to NIL."
"Eval returned an unbound marker."))
(setq *** ** ** * * %temp%))
(defun listen-skip-whitespace (&optional (stream *standard-input*))
"See listen. Any whitespace in the input stream will be flushed."
(do ((char (Read-char-no-hang stream nil nil nil)
(Read-char-no-hang stream nil nil nil)))
((null char) nil)
(cond ((not (whitespace-char-p char))
(unread-char char stream)
(return T)))))
(defun read-prompting-maybe (prompt &optional (in *standard-input*)
(out *standard-output*))
(if (not (listen-skip-whitespace in))
(princ prompt out))
(read in))
(Defun read-if-available (default &optional (stream *standard-input*))
(if (listen-skip-whitespace stream)
(read stream) default))
;;; Debug is the main loop for the Debug debugger. It is styled after a break
;;; loop, but many symbols are interpreted as commands when they are typed at
;;; top level.
;;;
;;; Debug sees if inside the debugger, + parses the stack.
;;; calls debug-loop on the parsed stack, which does the binding.
;;; Push calls debug-loop on the current stack, current frame.
;;;
(defun debug ()
"The Spice Lisp debugger. Inside the debugger, type the symbol H for help."
(terpri ) (princ "Debug (type H for help)" ) (terpri )
(let* ((stack (if (inside-debugger-p)
(parse-stack (frame-stack *debug-current-frame*))
(parse-stack)))
(*debug-current-frame*
(stack-frame-n stack 0)))
(catch 'debug-catcher
(with-debug-handler-bindings
(debug-loop)))))
(defun debug-loop ()
(prog ((*standard-input* *terminal-io*) ;in case of setq
(*standard-output* *terminal-io*) ;'' '' '' ''
(*print-level* *print-level*) ;Ditto
(*print-length* *print-length*)
(*error-output* *terminal-io*) ;make sure he sees em
(*debug-filter* (copy-debug-filter *debug-filter*))
(*debug-command-level* (1+ *debug-command-level*))
)
(debug-print-frame *debug-current-frame*)
LOOP
(if (catch
'break-loop-catcher
(catch
'debug-loop-catcher
(command-loop
*debug-prompt*
#'(lambda (exp)
(cond ((member exp '(U D S R T B P F)) ;Frame-changing.
(setq *debug-current-frame*
(case exp
(U (frame-next *debug-current-frame*))
(D (frame-previous *debug-current-frame*))
((T) (stack-frame-n
(frame-stack *debug-current-frame*) 0))
(B (stack-bottom-frame (frame-stack
*debug-current-frame*)))
(S (debug-function-search
(read-prompting-maybe "Function name/object: ")
(read-if-available 1)))
(R (debug-function-reverse-search
(read-prompting-maybe "Function name/object: ")
(read-if-available 1)))
(P *debug-current-frame*) ;Just print.
(F (stack-frame-n
(frame-stack *debug-current-frame*)
(eval (read-prompting-maybe "Go to frame: "))))))
(debug-print-frame *debug-current-frame*))
(T ;Informational.
(case exp
($g (throw 'top-level-catcher nil))
(PUSH (debug-loop))
(FLUSH (if (read-if-available T)
(condition-psetq nil
#'break-condition-handler)
(condition-psetq nil
#'default-condition-handler)))
(H (princ debug-help-string))
(PP (debug-print-frame *debug-current-frame* nil nil))
(G (debug-pprint-frame *debug-current-frame*))
(L (debug-print-locals *debug-current-frame*))
(? (debug-describe-frame *debug-current-frame*))
(pop (throw 'debug-loop-catcher T))
(q (throw 'debug-catcher nil))
(t (command-loop-return-values
(multiple-value-list (debug-eval exp))))
)))))))
(throw 'debug-loop-catcher nil))
(go loop)))