/[cmucl]/src/code/debug.lisp
ViewVC logotype

Contents of /src/code/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.72 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.71: +90 -90 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/debug.lisp,v 1.72 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; CMU Common Lisp Debugger. This includes a basic command-line oriented
13 ;;; debugger interface as well as support for Hemlock to deliver debugger
14 ;;; commands to a slave Lisp.
15 ;;;
16 ;;; Written by Bill Chiles.
17 ;;;
18
19 (in-package "DEBUG")
20
21 (intl:textdomain "cmucl")
22
23 (export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
24 *debug-print-level* *debug-print-length* *debug-prompt*
25 *default-print-frame-call-verbosity*
26 *debug-readtable* *help-line-scroll-count* *stack-top-hint*
27
28 *auto-eval-in-frame* var arg
29 *only-block-start-locations* *print-location-kind*
30
31 do-debug-command))
32
33 (in-package "LISP")
34 (export '(invoke-debugger *debugger-hook* step))
35
36 (in-package "DEBUG")
37
38 ;;;
39 ;;; Used to communicate to debug-loop that we are at a step breakpoint.
40 ;;;
41 (define-condition step-condition (simple-condition) ())
42
43
44 ;;;; Variables, parameters, and constants.
45
46 (defparameter *debug-print-level* 3
47 "*PRINT-LEVEL* is bound to this value when debug prints a function call. If
48 null, use *PRINT-LEVEL*")
49
50 (defparameter *debug-print-length* 5
51 "*PRINT-LENGTH* is bound to this value when debug prints a function call. If
52 null, use *PRINT-LENGTH*.")
53
54 (defparameter *default-print-frame-call-verbosity* 1
55 "default value for the verbose argument to print-frame-call. If set to >= 2, source will be printed for all frames")
56
57 (defvar *in-the-debugger* nil
58 "This is T while in the debugger.")
59
60 (defvar *debug-command-level* 0
61 "Pushes and pops/exits inside the debugger change this.")
62
63 (defvar *stack-top-hint* nil
64 "If this is bound before the debugger is invoked, it is used as the stack
65 top by the debugger.")
66 (defvar *stack-top* nil)
67 (defvar *real-stack-top* nil)
68
69 (defvar *current-frame* nil)
70
71 ;;; DEBUG-PROMPT -- Internal.
72 ;;;
73 ;;; This is the default for *debug-prompt*.
74 ;;;
75 (defun debug-prompt ()
76 (let ((*standard-output* *debug-io*))
77 (terpri)
78 (prin1 (di:frame-number *current-frame*))
79 (dotimes (i *debug-command-level*) (princ "]"))
80 (princ " ")
81 (force-output)))
82
83 (defparameter *debug-prompt* #'debug-prompt
84 "This is a function of no arguments that prints the debugger prompt
85 on *debug-io*.")
86
87 (defconstant debug-help-string
88 "
89 The prompt is right square brackets, the number indicating how many
90 recursive command loops you are in.
91 Debug commands do not affect * and friends, but evaluation in the debug loop
92 do affect these variables.
93 Any command may be uniquely abbreviated.
94
95 Getting in and out of DEBUG:
96 Q throws to top level.
97 GO calls CONTINUE which tries to proceed with the restart 'continue.
98 RESTART invokes restart numbered as shown (prompt if not given).
99 ERROR prints the error condition and restart cases.
100 FLUSH toggles *flush-debug-errors*, which is initially t.
101
102 The name of any restart, or its number, is a valid command, and is the same
103 as using RESTART to invoke that restart.
104
105 Changing frames:
106 U up frame D down frame T top frame B bottom frame
107
108 F n goes to frame n.
109
110 Inspecting frames:
111 BACKTRACE [n] shows n frames going down the stack.
112 L [prefix] lists locals starting with the given prefix in current function.
113 P displays current function call.
114 PP verbose display of current function, with source.
115 SOURCE [n] displays frame's source form with n levels of enclosing forms.
116 VSOURCE [n] displays frame's source form without any ellipsis.
117 DESCRIBE describe the current function.
118
119 Breakpoints and steps:
120 LIST-LOCATIONS [{function | :c}] list the locations for breakpoints.
121 Specify :c for the current frame. Abbreviation: LL
122 LIST-BREAKPOINTS list the active breakpoints.
123 Abbreviations: LB, LBP
124 DELETE-BREAKPOINT [n] remove breakpoint n or all breakpoints.
125 Abbreviations: DEL, DBP
126 BREAKPOINT {n | :end | :start} [:break form] [:function function]
127 [{:print form}*] [:condition form] set a breakpoint.
128 Abbreviations: BR, BP
129 STEP [n] step to the next location or step n times.
130
131 Actions on frames:
132 DEBUG-RETURN expression
133 returns expression's values from the current frame, exiting the debugger.
134 Abbreviations: R
135
136 Variables:
137 (DEBUG:VAR name [id]) Returns variable's value if possible. If multiple
138 variables with the same name exist, use id to select
139 one
140 (DEBUG:ARG n) Returns the n'th argument's value if possible.
141 Argument zero is the first argument.
142
143 See the CMU Common Lisp User's Manual for more information.
144 ")
145
146
147 ;;;; Breakpoint state:
148
149 (defvar *only-block-start-locations* nil
150 "When true, the LIST-LOCATIONS command only displays block start locations.
151 Otherwise, all locations are displayed.")
152
153 (defvar *print-location-kind* nil
154 "If true, list the code location type in the LIST-LOCATIONS command.")
155
156 ;;; A list of the types of code-locations that should not be stepped to and
157 ;;; should not be listed when listing breakpoints.
158 ;;;
159 (defvar *bad-code-location-types* '(:call-site :internal-error))
160 (declaim (type list *bad-code-location-types*))
161
162 ;;; Code locations of the possible breakpoints
163 ;;;
164 (defvar *possible-breakpoints*)
165 (declaim (type list *possible-breakpoints*))
166
167 ;;; A list of the made and active breakpoints, each is a breakpoint-info
168 ;;; structure.
169 ;;;
170 (defvar *breakpoints* nil)
171 (declaim (type list *breakpoints*))
172
173 ;;; A list of breakpoint-info structures of the made and active step
174 ;;; breakpoints.
175 ;;;
176 (defvar *step-breakpoints* nil)
177 (declaim (type list *step-breakpoints*))
178
179 ;;; Number of times left to step.
180 ;;;
181 (defvar *number-of-steps* 1)
182 (declaim (type integer *number-of-steps*))
183
184 ;;; Used when listing and setting breakpoints.
185 ;;;
186 (defvar *default-breakpoint-debug-function* nil)
187 (declaim (type (or list di:debug-function) *default-breakpoint-debug-function*))
188
189
190 ;;;; Code location utilities:
191
192 ;;; FIRST-CODE-LOCATION -- Internal.
193 ;;;
194 ;;; Returns the first code-location in the passed debug block
195 ;;;
196 (defun first-code-location (debug-block)
197 (let ((found nil)
198 (first-code-location nil))
199 (di:do-debug-block-locations (code-location debug-block)
200 (unless found
201 (setf first-code-location code-location)
202 (setf found t)))
203 first-code-location))
204
205 ;;; NEXT-CODE-LOCATIONS -- Internal.
206 ;;;
207 ;;; Returns a list of the next code-locations following the one passed. One of
208 ;;; the *bad-code-location-types* will not be returned.
209 ;;;
210 (defun next-code-locations (code-location)
211 (let ((debug-block (di:code-location-debug-block code-location))
212 (block-code-locations nil))
213 (di:do-debug-block-locations (block-code-location debug-block)
214 (unless (member (di:code-location-kind block-code-location)
215 *bad-code-location-types*)
216 (push block-code-location block-code-locations)))
217 (setf block-code-locations (nreverse block-code-locations))
218 (let* ((code-loc-list (rest (member code-location block-code-locations
219 :test #'di:code-location=)))
220 (next-list (cond (code-loc-list
221 (list (first code-loc-list)))
222 ((map 'list #'first-code-location
223 (di:debug-block-successors debug-block)))
224 (t nil))))
225 (when (and (= (length next-list) 1)
226 (di:code-location= (first next-list) code-location))
227 (setf next-list (next-code-locations (first next-list))))
228 next-list)))
229
230 ;;; POSSIBLE-BREAKPOINTS -- Internal.
231 ;;;
232 ;;; Returns a list of code-locations of the possible breakpoints of the
233 ;;; debug-function passed.
234 ;;;
235 (defun possible-breakpoints (debug-function)
236 (let ((possible-breakpoints nil))
237 (di:do-debug-function-blocks (debug-block debug-function)
238 (unless (di:debug-block-elsewhere-p debug-block)
239 (if *only-block-start-locations*
240 (push (first-code-location debug-block) possible-breakpoints)
241 (di:do-debug-block-locations (code-location debug-block)
242 (when (not (member (di:code-location-kind code-location)
243 *bad-code-location-types*))
244 (push code-location possible-breakpoints))))))
245 (nreverse possible-breakpoints)))
246
247 ;;; LOCATION-IN-LIST -- Internal.
248 ;;;
249 ;;; Searches the info-list for the item passed (code-location, debug-function,
250 ;;; or breakpoint-info). If the item passed is a debug function then kind will
251 ;;; be compared if it was specified. The kind if also compared if a
252 ;;; breakpoint-info is passed since it's in the breakpoint. The info structure
253 ;;; is returned if found.
254 ;;;
255 (defun location-in-list (place info-list &optional (kind nil))
256 (when (breakpoint-info-p place)
257 (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
258 (setf place (breakpoint-info-place place)))
259 (cond ((di:code-location-p place)
260 (find place info-list
261 :key #'breakpoint-info-place
262 :test #'(lambda (x y) (and (di:code-location-p y)
263 (di:code-location= x y)))))
264 (t
265 (find place info-list
266 :test #'(lambda (x-debug-function y-info)
267 (let ((y-place (breakpoint-info-place y-info))
268 (y-breakpoint (breakpoint-info-breakpoint
269 y-info)))
270 (and (di:debug-function-p y-place)
271 (eq x-debug-function y-place)
272 (or (not kind)
273 (eq kind (di:breakpoint-kind
274 y-breakpoint))))))))))
275
276
277 ;;; MAYBE-BLOCK-START-LOCATION -- Internal.
278 ;;;
279 ;;; If Loc is an unknown location, then try to find the block start location.
280 ;;; Used by source printing to some information instead of none for the user.
281 ;;;
282 (defun maybe-block-start-location (loc)
283 (if (di:code-location-unknown-p loc)
284 (let* ((block (di:code-location-debug-block loc))
285 (start (di:do-debug-block-locations (loc block)
286 (return loc))))
287 (cond ((and (not (di:debug-block-elsewhere-p block))
288 start)
289 (format t (intl:gettext "~%Unknown location: using block start.~%"))
290 start)
291 (t
292 loc)))
293 loc))
294
295
296 ;;;; The BREAKPOINT-INFO structure:
297
298 ;;; Hold info about made breakpoints
299 ;;;
300 (defstruct breakpoint-info
301 ;;
302 ;; Where we are going to stop.
303 (place (required-argument) :type (or di:code-location di:debug-function))
304 ;;
305 ;; The breakpoint returned by di:make-breakpoint.
306 (breakpoint (required-argument) :type di:breakpoint)
307 ;;
308 ;; Function returned from di:preprocess-for-eval. If result is non-nil,
309 ;; drop into the debugger.
310 (break #'identity :type function)
311 ;;
312 ;; Function returned from di:preprocess-for-eval. If result is non-nil,
313 ;; eval (each) print and print results.
314 (condition #'identity :type function)
315 ;;
316 ;; List of functions from di:preprocess-for-eval to evaluate, results are
317 ;; conditionally printed. Car of each element is the function, cdr is the
318 ;; form it goes with.
319 (print nil :type list)
320 ;;
321 ;; The number used when listing the possible breakpoints within a function.
322 ;; Could also be a symbol such as start or end.
323 (code-location-number (required-argument) :type (or symbol integer))
324 ;;
325 ;; The number used when listing the breakpoints active and to delete
326 ;; breakpoints.
327 (breakpoint-number (required-argument) :type integer))
328
329
330 ;;; CREATE-BREAKPOINT-INFO -- Internal.
331 ;;;
332 ;;; Returns a new breakpoint-info structure with the info passed.
333 ;;;
334 (defun create-breakpoint-info (place breakpoint code-location-number
335 &key (break #'identity)
336 (condition #'identity) (print nil))
337 (setf *breakpoints*
338 (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
339 (let ((breakpoint-number
340 (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
341 ((or (> i (length *breakpoints*))
342 (not (= i (breakpoint-info-breakpoint-number
343 (first breakpoints)))))
344
345 i))))
346 (make-breakpoint-info :place place :breakpoint breakpoint
347 :code-location-number code-location-number
348 :breakpoint-number breakpoint-number
349 :break break :condition condition :print print)))
350
351 ;;; PRINT-BREAKPOINT-INFO -- Internal.
352 ;;;
353 ;;; Prints the breakpoint info for the breakpoint-info structure passed.
354 ;;;
355 (defun print-breakpoint-info (breakpoint-info)
356 (let ((place (breakpoint-info-place breakpoint-info))
357 (bp-number (breakpoint-info-breakpoint-number breakpoint-info))
358 (loc-number (breakpoint-info-code-location-number breakpoint-info)))
359 (case (di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
360 (:code-location
361 (print-code-location-source-form place 0)
362 (format t (intl:gettext "~&~S: ~S in ~S")
363 bp-number loc-number (di:debug-function-name
364 (di:code-location-debug-function place))))
365 (:function-start
366 (format t (intl:gettext "~&~S: FUNCTION-START in ~S") bp-number
367 (di:debug-function-name place)))
368 (:function-end
369 (format t (intl:gettext "~&~S: FUNCTION-END in ~S") bp-number
370 (di:debug-function-name place))))))
371
372
373
374 ;;;; Main-hook-function for steps and breakpoints
375
376 ;;; MAIN-HOOK-FUNCTION -- Internal.
377 ;;;
378 ;;; Must be passed as the hook function. Keeps track of where step
379 ;;; breakpoints are.
380 ;;;
381 (defun main-hook-function (current-frame breakpoint &optional return-vals
382 function-end-cookie)
383 (setf *default-breakpoint-debug-function*
384 (di:frame-debug-function current-frame))
385 (dolist (step-info *step-breakpoints*)
386 (di:delete-breakpoint (breakpoint-info-breakpoint step-info))
387 (let ((bp-info (location-in-list step-info *breakpoints*)))
388 (when bp-info
389 (di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
390 (let ((*stack-top-hint* current-frame)
391 (step-hit-info
392 (location-in-list (di:breakpoint-what breakpoint)
393 *step-breakpoints* (di:breakpoint-kind breakpoint)))
394 (bp-hit-info
395 (location-in-list (di:breakpoint-what breakpoint)
396 *breakpoints* (di:breakpoint-kind breakpoint)))
397 (break)
398 (condition)
399 (string ""))
400 (setf *step-breakpoints* nil)
401 (labels ((build-string (str)
402 (setf string (concatenate 'string string str)))
403 (print-common-info ()
404 (build-string
405 (with-output-to-string (*standard-output*)
406 (when function-end-cookie
407 (format t (intl:gettext "~%Return values: ~S") return-vals))
408 (when condition
409 (when (breakpoint-info-print bp-hit-info)
410 (format t "~%")
411 (print-frame-call current-frame))
412 (dolist (print (breakpoint-info-print bp-hit-info))
413 (format t "~& ~S = ~S" (rest print)
414 (funcall (first print) current-frame))))))))
415 (when bp-hit-info
416 (setf break (funcall (breakpoint-info-break bp-hit-info)
417 current-frame))
418 (setf condition (funcall (breakpoint-info-condition bp-hit-info)
419 current-frame)))
420 (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
421 (build-string (format nil (intl:gettext "~&*Step (to a breakpoint)*")))
422 (print-common-info)
423 (break string))
424 ((and bp-hit-info step-hit-info break)
425 (build-string (format nil (intl:gettext "~&*Step (to a breakpoint)*")))
426 (print-common-info)
427 (break string))
428 ((and bp-hit-info step-hit-info)
429 (print-common-info)
430 (format t "~A" string)
431 (decf *number-of-steps*)
432 (set-step-breakpoint current-frame))
433 ((and step-hit-info (= 1 *number-of-steps*))
434 (build-string (intl:gettext "*Step*"))
435 (break (make-condition 'step-condition :format-control string)))
436 (step-hit-info
437 (decf *number-of-steps*)
438 (set-step-breakpoint current-frame))
439 (bp-hit-info
440 (when break
441 (build-string (format nil (intl:gettext "~&*Breakpoint hit*"))))
442 (print-common-info)
443 (if break
444 (break string)
445 (format t "~A" string)))
446 (t
447 (break (intl:gettext "Error in main-hook-function: unknown breakpoint")))))))
448
449
450
451 ;;; SET-STEP-BREAKPOINT -- Internal.
452 ;;;
453 ;;; Sets breakpoints at the next possible code-locations. After calling
454 ;;; this either (continue) if in the debugger or just let program flow
455 ;;; return if in a hook function.
456 (defun set-step-breakpoint (frame)
457 (cond
458 ((di:debug-block-elsewhere-p (di:code-location-debug-block
459 (di:frame-code-location frame)))
460 (format t (intl:gettext "Cannot step, in elsewhere code~%")))
461 (t
462 (let* ((code-location (di:frame-code-location frame))
463 (next-code-locations (next-code-locations code-location)))
464 (cond
465 (next-code-locations
466 (dolist (code-location next-code-locations)
467 (let ((bp-info (location-in-list code-location *breakpoints*)))
468 (when bp-info
469 (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info))))
470 (let ((bp (di:make-breakpoint #'main-hook-function code-location
471 :kind :code-location)))
472 (di:activate-breakpoint bp)
473 (push (create-breakpoint-info code-location bp 0)
474 *step-breakpoints*))))
475 (t
476 (let* ((debug-function (di:frame-debug-function *current-frame*))
477 (bp (di:make-breakpoint #'main-hook-function debug-function
478 :kind :function-end)))
479 (di:activate-breakpoint bp)
480 (push (create-breakpoint-info debug-function bp 0)
481 *step-breakpoints*))))))))
482
483 ;;; STEP-INTERNAL -- Internal.
484 ;;;
485 (defun step-internal (function form)
486 (when (eval:interpreted-function-p function)
487 ;; The stepper currently only supports compiled functions So we
488 ;; try to compile the passed-in function, bailing out if it fails.
489 (handler-case
490 (setq function (compile nil function))
491 (error (c)
492 (error (intl:gettext "Currently only compiled code can be stepped.~%~
493 Trying to compile the passed form resulted in ~
494 the following error:~% ~A") c))))
495 (let ((*print-length* *debug-print-length*)
496 (*print-level* *debug-print-level*))
497 (format *debug-io* (intl:gettext "~2&Stepping the form~% ~S~%") form)
498 (format *debug-io* (intl:gettext "~&using the debugger. Type HELP for help.~2%")))
499 (let* ((debug-function (di:function-debug-function function))
500 (bp (di:make-breakpoint #'main-hook-function debug-function
501 :kind :function-start)))
502 (di:activate-breakpoint bp)
503 (push (create-breakpoint-info debug-function bp 0)
504 *step-breakpoints*))
505 (funcall function))
506
507 ;;; STEP -- Public.
508 ;;;
509 (defmacro step (form)
510 "STEP implements a debugging paradigm wherein the programmer is allowed
511 to step through the evaluation of a form. We use the debugger's stepping
512 facility to step through an anonymous function containing only form.
513
514 Currently the stepping facility only supports stepping compiled code,
515 so step will try to compile the resultant anonymous function. If this
516 fails, e.g. because it closes over a non-null lexical environment, an
517 error is signalled."
518 `(step-internal #'(lambda () ,form) ',form))
519
520
521 ;;;; Backtrace:
522
523 ;;; BACKTRACE -- Public.
524 ;;;
525 (defun backtrace (&optional (count most-positive-fixnum)
526 (*standard-output* *debug-io*))
527 "Show a listing of the call stack going down from the current frame. In the
528 debugger, the current frame is indicated by the prompt. Count is how many
529 frames to show."
530 (let ((*print-length* (or *debug-print-length* *print-length*))
531 (*print-level* (or *debug-print-level* *print-level*)))
532 (fresh-line *standard-output*)
533 (do ((frame (if *in-the-debugger* *current-frame* (di:top-frame))
534 (di:frame-down frame))
535 (count count (1- count)))
536 ((or (null frame) (zerop count)))
537 (print-frame-call frame :number t))
538 (fresh-line *standard-output*)
539 (values)))
540
541
542 ;;;; Frame printing:
543
544 (eval-when (compile eval)
545
546 ;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal.
547 ;;;
548 ;;; This is a convenient way to express what to do for each type of lambda-list
549 ;;; element.
550 ;;;
551 (defmacro lambda-list-element-dispatch (element &key required optional rest
552 keyword deleted)
553 `(etypecase ,element
554 (di:debug-variable
555 ,@required)
556 (cons
557 (ecase (car ,element)
558 (:optional ,@optional)
559 (:rest ,@rest)
560 (:keyword ,@keyword)))
561 (symbol
562 (assert (eq ,element :deleted))
563 ,@deleted)))
564
565 (defmacro lambda-var-dispatch (variable location deleted valid other)
566 (let ((var (gensym)))
567 `(let ((,var ,variable))
568 (cond ((eq ,var :deleted) ,deleted)
569 ((eq (di:debug-variable-validity ,var ,location) :valid) ,valid)
570 (t ,other)))))
571
572 ) ;EVAL-WHEN
573
574
575 ;;; This is used in constructing arg lists for debugger printing when the arg
576 ;;; list is unavailable, some arg is unavailable or unused, etc.
577 ;;;
578 (defstruct (unprintable-object
579 (:constructor make-unprintable-object (string))
580 (:print-function (lambda (x s d)
581 (declare (ignore d))
582 (format s "#<~A>"
583 (unprintable-object-string x)))))
584 string)
585
586
587 ;;; PRINT-FRAME-CALL-1 -- Internal.
588 ;;;
589 ;;; This prints frame with verbosity level 1. If we hit a rest-arg,
590 ;;; then print as many of the values as possible,
591 ;;; punting the loop over lambda-list variables since any other arguments
592 ;;; will be in the rest-arg's list of values.
593 ;;;
594 (defun print-frame-call-1 (frame)
595 (let* ((d-fun (di:frame-debug-function frame))
596 (loc (di:frame-code-location frame))
597 (results (list (di:debug-function-name d-fun))))
598 (handler-case
599 (dolist (ele (di:debug-function-lambda-list d-fun))
600 (lambda-list-element-dispatch ele
601 :required ((push (frame-call-arg ele loc frame) results))
602 :optional ((push (frame-call-arg (second ele) loc frame) results))
603 :keyword ((push (second ele) results)
604 (push (frame-call-arg (third ele) loc frame) results))
605 :deleted ((push (frame-call-arg ele loc frame) results))
606 :rest ((lambda-var-dispatch (second ele) loc
607 nil
608 (progn
609 (setf results
610 (append (reverse (di:debug-variable-value
611 (second ele) frame))
612 results))
613 (return))
614 (push (make-unprintable-object (intl:gettext "unavaliable-rest-arg"))
615 results)))))
616 (di:lambda-list-unavailable
617 ()
618 (push (make-unprintable-object (intl:gettext "lambda-list-unavailable")) results)))
619 (prin1 (mapcar #'ensure-printable-object (nreverse results)))
620 (when (di:debug-function-kind d-fun)
621 (write-char #\[)
622 (prin1 (di:debug-function-kind d-fun))
623 (write-char #\]))))
624
625 (defun ensure-printable-object (object)
626 (handler-case
627 (with-open-stream (out (make-broadcast-stream))
628 (prin1 object out)
629 object)
630 (error (cond)
631 (declare (ignore cond))
632 (make-unprintable-object
633 (format nil (intl:gettext "error printing object {~X}")
634 (kernel:get-lisp-obj-address object))))))
635
636 (defun frame-call-arg (var location frame)
637 (lambda-var-dispatch var location
638 (make-unprintable-object (intl:gettext "unused-arg"))
639 (di:debug-variable-value var frame)
640 (make-unprintable-object (intl:gettext "unavailable-arg"))))
641
642
643 ;;; PRINT-FRAME-CALL -- Interface
644 ;;;
645 ;;; This prints a representation of the function call causing frame to exist.
646 ;;; Verbosity indicates the level of information to output; zero indicates just
647 ;;; printing the debug-function's name, and one indicates displaying call-like,
648 ;;; one-liner format with argument values.
649 ;;;
650 (defun print-frame-call (frame &key
651 ((:print-length *print-length*)
652 (or *debug-print-length* *print-length*))
653 ((:print-level *print-level*)
654 (or *debug-print-level* *print-level*))
655 (verbosity *default-print-frame-call-verbosity*)
656 (number nil))
657 (cond
658 ((zerop verbosity)
659 (when number
660 (format t "~&~S: " (di:frame-number frame)))
661 (format t "~S" frame))
662 (t
663 (when number
664 (format t "~&~S: " (di:frame-number frame)))
665 (print-frame-call-1 frame)))
666 (when (>= verbosity 2)
667 (let ((loc (di:frame-code-location frame)))
668 (handler-case
669 (progn
670 (di:code-location-debug-block loc)
671 (format t (intl:gettext "~%Source: "))
672 (print-code-location-source-form loc 0))
673 (di:debug-condition (ignore) ignore)
674 (error (cond) (format t (intl:gettext "Error finding source: ~A") cond))))))
675
676 ;;; SAFE-CONDITION-MESSAGE -- Internal
677 ;;;
678 ;;; Safely print condition to a string, handling any errors during
679 ;;; printing.
680 ;;;
681 (defun safe-condition-message (condition)
682 (handler-case
683 (princ-to-string condition)
684 (error (cond)
685 ;; Beware of recursive errors in printing, so only use the condition
686 ;; if it is printable itself:
687 (format nil (intl:gettext "Unable to display error condition~@[: ~A~]")
688 (ignore-errors (princ-to-string cond))))))
689
690
691 ;;;; Invoke-debugger.
692
693 (defvar *debugger-hook* nil
694 "This is either nil or a function of two arguments, a condition and the value
695 of *debugger-hook*. This function can either handle the condition or return
696 which causes the standard debugger to execute. The system passes the value
697 of this variable to the function because it binds *debugger-hook* to nil
698 around the invocation.")
699
700 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
701 ;;;
702 (defvar *debug-restarts*)
703 (defvar *debug-condition*)
704
705 ;;; INVOKE-TTY-DEBUGGER -- Internal
706 ;;;
707 ;;; Print condition and invoke the TTY debugger.
708 ;;;
709 (defun invoke-tty-debugger (condition)
710 (format *error-output* (intl:gettext "~2&~A~% [Condition of type ~S]~2&")
711 (safe-condition-message *debug-condition*)
712 (type-of *debug-condition*))
713 (unless (typep condition 'step-condition)
714 (show-restarts *debug-restarts* *error-output*))
715 (internal-debug))
716
717 ;;; REAL-INVOKE-DEBUGGER -- Internal
718 ;;;
719 ;;; This function really invokes the current standard debugger.
720 ;;; This is overwritten by e.g. the Motif Interface code. It is a
721 ;;; function and not a special variable hook, because users are
722 ;;; supposed to use *debugger-hook*, and this is supposed to be the
723 ;;; safe fall-back, which should be fairly secure against
724 ;;; accidental mishaps.
725 ;;;
726 (defun real-invoke-debugger (condition)
727 (invoke-tty-debugger condition))
728
729 ;;; INVOKE-DEBUGGER -- Public.
730 ;;;
731 (defun invoke-debugger (condition)
732 "The CMU Common Lisp debugger. Type h for help."
733 (when *debugger-hook*
734 (let ((hook *debugger-hook*)
735 (*debugger-hook* nil))
736 (funcall hook condition hook)))
737 (unix:unix-sigsetmask 0)
738 (let* ((*debug-condition* condition)
739 (*debug-restarts* (compute-restarts condition))
740 (*standard-input* *debug-io*) ;in case of setq
741 (*standard-output* *debug-io*) ;'' '' '' ''
742 (*error-output* *debug-io*)
743 ;; Rebind some printer control variables.
744 (kernel:*current-level* 0)
745 (*print-readably* nil)
746 (*read-eval* t)
747 ;; XXX: Fixme: What external format do we really want to use
748 ;; in the debugger? This is problem if we have a badly
749 ;; formed string that the current external format can't
750 ;; handle.
751 #+unicode
752 (*default-external-format* :iso8859-1))
753 (real-invoke-debugger condition)))
754
755 ;;; SHOW-RESTARTS -- Internal.
756 ;;;
757 (defun show-restarts (restarts &optional (s *error-output*))
758 (when restarts
759 (format s (intl:gettext "~&Restarts:~%"))
760 (let ((count 0)
761 (names-used '(nil))
762 (max-name-len 0))
763 (dolist (restart restarts)
764 (let ((name (restart-name restart)))
765 (when name
766 (let ((len (length (princ-to-string name))))
767 (when (> len max-name-len)
768 (setf max-name-len len))))))
769 (unless (zerop max-name-len)
770 (incf max-name-len 3))
771 (dolist (restart restarts)
772 (let ((name (restart-name restart)))
773 (cond ((member name names-used)
774 (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
775 (t
776 (format s "~& ~2D: [~VA] ~A~%"
777 count (- max-name-len 3) name restart)
778 (push name names-used))))
779 (incf count)))))
780
781 ;;; INTERNAL-DEBUG -- Internal Interface.
782 ;;;
783 ;;; This calls DEBUG-LOOP, performing some simple initializations before doing
784 ;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger.
785 ;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
786 ;;; prompt as quickly as possible with as little risk as possible for stepping
787 ;;; on whatever is causing recursive errors.
788 ;;;
789 (defun internal-debug ()
790 (let ((*in-the-debugger* t)
791 (*read-suppress* nil))
792 (unless (typep *debug-condition* 'step-condition)
793 (clear-input *debug-io*)
794 (format *debug-io* (intl:gettext "~2&Debug (type H for help)~2%")))
795 #-mp (debug-loop)
796 #+mp (mp:without-scheduling (debug-loop))))
797
798
799
800 ;;;; Debug-loop.
801
802 (defvar *flush-debug-errors* t
803 "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
804 executing in the debugger. The 'flush' command toggles this.")
805
806 (defvar *debug-readtable* nil
807 "When non-NIL, becomes the system *READTABLE* in the debugger
808 read-eval-print loop")
809
810 (defvar *debug-print-current-frame* t
811 "When non-NIL, print the current frame when entering the debugger.")
812
813 (defun maybe-handle-dead-input-stream (condition)
814 ;; Scenario: "xon <remote-box> cmucl -edit"
815 ;; Then close the display with the window manager or shutdown the
816 ;; local computer. The remote lisp goes into infinite error loop.
817 (labels ((real-stream (stream)
818 ;; Using etypecase here causes an infloop in SLIME:
819 ;; SLIME's slime-input-streams are not fd-streams
820 (etypecase stream
821 (system:fd-stream
822 (values stream (system:fd-stream-fd stream)))
823 (synonym-stream
824 (real-stream (symbol-value (synonym-stream-symbol stream))))
825 (two-way-stream
826 (real-stream (two-way-stream-input-stream stream))))))
827
828 (when (typep condition 'stream-error)
829 (let* ((stream-with-error (stream-error-stream condition))
830 (real-stream-with-error (real-stream stream-with-error))
831 (real-debug-io (real-stream *debug-io*)))
832 (when (and (eq real-stream-with-error real-debug-io)
833 (not (unix:unix-isatty (system:fd-stream-fd real-debug-io))))
834 ;; Probably running on a remote processor and lost the connection.
835 (ext:quit))))))
836
837 (defun debug-loop ()
838 (let* ((*debug-command-level* (1+ *debug-command-level*))
839 (*real-stack-top* (di:top-frame))
840 (*stack-top* (or *stack-top-hint* *real-stack-top*))
841 (*stack-top-hint* nil)
842 (*current-frame* *stack-top*)
843 (*readtable* (or *debug-readtable* *readtable*)))
844 (handler-bind ((di:debug-condition #'(lambda (condition)
845 (princ condition *debug-io*)
846 (throw 'debug-loop-catcher nil))))
847 (when *debug-print-current-frame*
848 (fresh-line)
849 (print-frame-call *current-frame* :verbosity 2))
850 (loop
851 (catch 'debug-loop-catcher
852 (handler-bind ((error #'(lambda (condition)
853 (maybe-handle-dead-input-stream condition)
854 (when *flush-debug-errors*
855 (clear-input *debug-io*)
856 (princ condition)
857 (format t (intl:gettext "~&Error flushed ..."))
858 (throw 'debug-loop-catcher nil)))))
859 ;; Must bind level for restart function created by
860 ;; WITH-SIMPLE-RESTART.
861 (let ((level *debug-command-level*)
862 (restart-commands (make-restart-commands)))
863 (with-simple-restart (abort (intl:gettext "Return to debug level ~D.") level)
864 (funcall *debug-prompt*)
865 (let ((input (ext:get-stream-command *debug-io*)))
866 (cond (input
867 (let ((cmd-fun (debug-command-p
868 (ext:stream-command-name input)
869 restart-commands)))
870 (cond
871 ((not cmd-fun)
872 (error (intl:gettext "Unknown stream-command -- ~S.") input))
873 ((consp cmd-fun)
874 (error (intl:gettext "Ambiguous debugger command: ~S.") cmd-fun))
875 (t
876 (apply cmd-fun (ext:stream-command-args input))))))
877 (t
878 (let* ((exp (read))
879 (cmd-fun (debug-command-p exp restart-commands)))
880 (cond ((not cmd-fun)
881 (debug-eval-print exp))
882 ((consp cmd-fun)
883 (format t (intl:gettext "~&Your command, ~S, is ambiguous:~%")
884 exp)
885 (dolist (ele cmd-fun)
886 (format t " ~A~%" ele)))
887 (t
888 (funcall cmd-fun)))))))))))))))
889
890 (defvar *auto-eval-in-frame* t
891 "When set (the default), evaluations in the debugger's command loop occur
892 relative to the current frame's environment without the need of debugger
893 forms that explicitly control this kind of evaluation.")
894
895 (defun debug-eval-print (exp)
896 (when (and (fboundp 'lisp::commandp) (funcall 'lisp::commandp exp))
897 (return-from debug-eval-print
898 (funcall 'lisp::invoke-command-interactive exp)))
899 (setq +++ ++ ++ + + - - exp)
900 (let* ((values (multiple-value-list
901 (if (and (fboundp 'compile) *auto-eval-in-frame*)
902 (di:eval-in-frame *current-frame* -)
903 (eval -))))
904 (*standard-output* *debug-io*))
905 (fresh-line)
906 (if values (prin1 (car values)))
907 (dolist (x (cdr values))
908 (fresh-line)
909 (prin1 x))
910 (setq /// // // / / values)
911 (setq *** ** ** * * (car values))
912 ;; Make sure nobody passes back an unbound marker.
913 (unless (boundp '*)
914 (setq * nil)
915 (fresh-line)
916 (princ (intl:gettext "Setting * to NIL -- was unbound marker.")))))
917
918
919
920 ;;;; Debug loop functions.
921
922 ;;; These commands are function, not really commands, so users can get their
923 ;;; hands on the values returned.
924 ;;;
925
926 (eval-when (eval compile)
927
928 (defmacro define-var-operation (ref-or-set &optional value-var)
929 `(let* ((temp (etypecase name
930 (symbol (di:debug-function-symbol-variables
931 (di:frame-debug-function *current-frame*)
932 name))
933 (simple-string (di:ambiguous-debug-variables
934 (di:frame-debug-function *current-frame*)
935 name))))
936 (location (di:frame-code-location *current-frame*))
937 ;; Let's only deal with valid variables.
938 (vars (remove-if-not #'(lambda (v)
939 (eq (di:debug-variable-validity v location)
940 :valid))
941 temp)))
942 (declare (list vars))
943 (cond ((null vars)
944 (error (intl:gettext "No known valid variables match ~S.") name))
945 ((= (length vars) 1)
946 ,(ecase ref-or-set
947 (:ref
948 '(di:debug-variable-value (car vars) *current-frame*))
949 (:set
950 `(setf (di:debug-variable-value (car vars) *current-frame*)
951 ,value-var))))
952 (t
953 ;; Since we have more than one, first see if we have any
954 ;; variables that exactly match the specification.
955 (let* ((name (etypecase name
956 (symbol (symbol-name name))
957 (simple-string name)))
958 (exact (remove-if-not #'(lambda (v)
959 (string= (di:debug-variable-name v)
960 name))
961 vars))
962 (vars (or exact vars)))
963 (declare (simple-string name)
964 (list exact vars))
965 (cond
966 ;; Check now for only having one variable.
967 ((= (length vars) 1)
968 ,(ecase ref-or-set
969 (:ref
970 '(di:debug-variable-value (car vars) *current-frame*))
971 (:set
972 `(setf (di:debug-variable-value (car vars) *current-frame*)
973 ,value-var))))
974 ;; If there weren't any exact matches, flame about ambiguity
975 ;; unless all the variables have the same name.
976 ((and (not exact)
977 (find-if-not
978 #'(lambda (v)
979 (string= (di:debug-variable-name v)
980 (di:debug-variable-name (car vars))))
981 (cdr vars)))
982 (error (intl:gettext "Specification ambiguous:~%~{ ~A~%~}")
983 (mapcar #'di:debug-variable-name
984 (delete-duplicates
985 vars :test #'string=
986 :key #'di:debug-variable-name))))
987 ;; All names are the same, so see if the user ID'ed one of them.
988 (id-supplied
989 (let ((v (find id vars :key #'di:debug-variable-id)))
990 (unless v
991 (error (intl:gettext "Invalid variable ID, ~D, should have been one of ~S.")
992 id (mapcar #'di:debug-variable-id vars)))
993 ,(ecase ref-or-set
994 (:ref
995 '(di:debug-variable-value v *current-frame*))
996 (:set
997 `(setf (di:debug-variable-value v *current-frame*)
998 ,value-var)))))
999 (t
1000 (error (intl:gettext "Specify variable ID to disambiguate ~S. Use one of ~S.")
1001 name (mapcar #'di:debug-variable-id vars)))))))))
1002
1003 ) ;EVAL-WHEN
1004
1005 ;;; VAR -- Public.
1006 ;;;
1007 (defun var (name &optional (id 0 id-supplied))
1008 "Returns a variable's value if possible. Name is a simple-string or symbol.
1009 If it is a simple-string, it is an initial substring of the variable's name.
1010 If name is a symbol, it has the same name and package as the variable whose
1011 value this function returns. If the symbol is uninterned, then the variable
1012 has the same name as the symbol, but it has no package.
1013
1014 If name is the initial substring of variables with different names, then
1015 this return no values after displaying the ambiguous names. If name
1016 determines multiple variables with the same name, then you must use the
1017 optional id argument to specify which one you want. If you left id
1018 unspecified, then this returns no values after displaying the distinguishing
1019 id values.
1020
1021 The result of this function is limited to the availability of variable
1022 information. This is SETF'able."
1023 (define-var-operation :ref))
1024 ;;;
1025 (defun (setf var) (value name &optional (id 0 id-supplied))
1026 (define-var-operation :set value))
1027
1028
1029
1030 ;;; ARG -- Public.
1031 ;;;
1032 (defun arg (n)
1033 "Returns the n'th argument's value if possible. Argument zero is the first
1034 argument in a frame's default printed representation. Count keyword/value
1035 pairs as separate arguments."
1036 (multiple-value-bind
1037 (var lambda-var-p)
1038 (nth-arg n (handler-case (di:debug-function-lambda-list
1039 (di:frame-debug-function *current-frame*))
1040 (di:lambda-list-unavailable ()
1041 (error (intl:gettext "No argument values are available.")))))
1042 (if lambda-var-p
1043 (lambda-var-dispatch var (di:frame-code-location *current-frame*)
1044 (error (intl:gettext "Unused arguments have no values."))
1045 (di:debug-variable-value var *current-frame*)
1046 (error (intl:gettext "Invalid argument value.")))
1047 var)))
1048
1049 ;;; NTH-ARG -- Internal.
1050 ;;;
1051 ;;; This returns the n'th arg as the user sees it from args, the result of
1052 ;;; DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a potential debug-variable
1053 ;;; from the lambda-list, then the second value is t. If this returns a
1054 ;;; keyword symbol or a value from a rest arg, then the second value is nil.
1055 ;;;
1056 (defun nth-arg (count args)
1057 (let ((n count))
1058 (dolist (ele args (error (intl:gettext "Argument specification out of range -- ~S.") n))
1059 (lambda-list-element-dispatch ele
1060 :required ((if (zerop n) (return (values ele t))))
1061 :optional ((if (zerop n) (return (values (second ele) t))))
1062 :keyword ((cond ((zerop n)
1063 (return (values (second ele) nil)))
1064 ((zerop (decf n))
1065 (return (values (third ele) t)))))
1066 :deleted ((if (zerop n) (return (values ele t))))
1067 :rest ((let ((var (second ele)))
1068 (lambda-var-dispatch var
1069 (di:frame-code-location *current-frame*)
1070 (error (intl:gettext "Unused rest-arg before n'th argument."))
1071 (dolist (value
1072 (di:debug-variable-value var *current-frame*)
1073 (error (intl:gettext "Argument specification out of range -- ~S.")
1074 n))
1075 (if (zerop n)
1076 (return-from nth-arg (values value nil))
1077 (decf n)))
1078 (error (intl:gettext "Invalid rest-arg before n'th argument."))))))
1079 (decf n))))
1080
1081
1082
1083 ;;;; Debug loop command definition:
1084
1085 (defvar *debug-commands* nil)
1086
1087 ;;; DEF-DEBUG-COMMAND -- Internal.
1088 ;;;
1089 ;;; Interface to *debug-commands*. No required arguments in args are
1090 ;;; permitted.
1091 ;;;
1092 (defmacro def-debug-command (name args &rest body)
1093 (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
1094 `(progn
1095 (when (assoc ,name *debug-commands* :test #'string=)
1096 (setf *debug-commands*
1097 (remove ,name *debug-commands* :key #'car :test #'string=)))
1098 (defun ,fun-name ,args
1099 (unless *in-the-debugger*
1100 (error (intl:gettext "Invoking debugger command while outside the debugger.")))
1101 ,@body)
1102 (push (cons ,name #',fun-name) *debug-commands*)
1103 ',fun-name)))
1104
1105 ;;; DEF-DEBUG-COMMAND-ALIAS -- Internal.
1106 ;;;
1107 (defun def-debug-command-alias (new-name existing-name)
1108 (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
1109 (unless pair (error (intl:gettext "Unknown debug command name -- ~S") existing-name))
1110 (push (cons new-name (cdr pair)) *debug-commands*))
1111 new-name)
1112
1113 ;;; DEBUG-COMMAND-P -- Internal.
1114 ;;;
1115 ;;; This takes a symbol and uses its name to find a debugger command, using
1116 ;;; initial substring matching. It returns the command function if form
1117 ;;; identifies only one command, but if form is ambiguous, this returns a list
1118 ;;; of the command names. If there are no matches, this returns nil. Whenever
1119 ;;; the loop that looks for a set of possibilities encounters an exact name
1120 ;;; match, we return that command function immediately.
1121 ;;;
1122 (defun debug-command-p (form &optional other-commands)
1123 (if (or (symbolp form) (integerp form))
1124 (let* ((name
1125 (if (symbolp form)
1126 (symbol-name form)
1127 (format nil "~d" form)))
1128 (len (length name))
1129 (res nil))
1130 (declare (simple-string name)
1131 (fixnum len)
1132 (list res))
1133 ;;
1134 ;; Find matching commands, punting if exact match.
1135 (flet ((match-command (ele)
1136 (let* ((str (car ele))
1137 (str-len (length str)))
1138 (declare (simple-string str)
1139 (fixnum str-len))
1140 (cond ((< str-len len))
1141 ((= str-len len)
1142 (when (string= name str :end1 len :end2 len)
1143 (return-from debug-command-p (cdr ele))))
1144 ((string= name str :end1 len :end2 len)
1145 (push ele res))))))
1146 (mapc #'match-command *debug-commands*)
1147 (mapc #'match-command other-commands))
1148 ;;
1149 ;; Return the right value.
1150 (cond ((not res) nil)
1151 ((= (length res) 1)
1152 (cdar res))
1153 (t ;Just return the names.
1154 (do ((cmds res (cdr cmds)))
1155 ((not cmds) res)
1156 (setf (car cmds) (caar cmds))))))))
1157
1158
1159 ;;;
1160 ;;; Returns a list of debug commands (in the same format as *debug-commands*)
1161 ;;; that invoke each active restart.
1162 ;;;
1163 ;;; Two commands are made for each restart: one for the number, and one for
1164 ;;; the restart name (unless it's been shadowed by an earlier restart of the
1165 ;;; same name, or it is nil).
1166 ;;;
1167 (defun make-restart-commands (&optional (restarts *debug-restarts*))
1168 (let ((commands)
1169 (num 0)) ; better be the same as show-restarts!
1170 (dolist (restart restarts)
1171 (let ((name (string (restart-name restart))))
1172 ;;
1173 ;; Use %Invoke-Restart-Interactively because the dynamic
1174 ;; environment when the debugger invokes the restart can be
1175 ;; different from the dynamic environment when the debugger
1176 ;; computes active restarts. If this is the case,
1177 ;; Invoke-Restart-Interactively might find that the restart
1178 ;; being invoked is not currently active and signal a
1179 ;; Control-Error.
1180 (let ((restart-fun
1181 (lambda ()
1182 (conditions::%invoke-restart-interactively restart))))
1183 (push (cons (format nil "~d" num) restart-fun) commands)
1184 (unless (or (null (restart-name restart))
1185 (find name commands :key #'car :test #'string=))
1186 (push (cons name restart-fun) commands))))
1187 (incf num))
1188 commands))
1189
1190
1191 ;;;
1192 ;;; Frame changing commands.
1193 ;;;
1194
1195 (def-debug-command "UP" ()
1196 (let ((next (di:frame-up *current-frame*)))
1197 (cond (next
1198 (setf *current-frame* next)
1199 (print-frame-call next))
1200 (t
1201 (format t (intl:gettext "~&Top of stack."))))))
1202
1203 (def-debug-command "DOWN" ()
1204 (let ((next (di:frame-down *current-frame*)))
1205 (cond (next
1206 (setf *current-frame* next)
1207 (print-frame-call next))
1208 (t
1209 (format t (intl:gettext "~&Bottom of stack."))))))
1210
1211 (def-debug-command-alias "D" "DOWN")
1212
1213 (def-debug-command "TOP" ()
1214 (do ((prev *current-frame* lead)
1215 (lead (di:frame-up *current-frame*) (di:frame-up lead)))
1216 ((null lead)
1217 (setf *current-frame* prev)
1218 (print-frame-call prev))))
1219
1220 (def-debug-command "BOTTOM" ()
1221 (do ((prev *current-frame* lead)
1222 (lead (di:frame-down *current-frame*) (di:frame-down lead)))
1223 ((null lead)
1224 (setf *current-frame* prev)
1225 (print-frame-call prev))))
1226
1227
1228 (def-debug-command-alias "B" "BOTTOM")
1229
1230 (def-debug-command "FRAME" (&optional
1231 (n (read-prompting-maybe (intl:gettext "Frame number: "))))
1232 (let ((current (di:frame-number *current-frame*)))
1233 (cond ((= n current)
1234 (princ (intl:gettext "You are here.")))
1235 ((> n current)
1236 (print-frame-call
1237 (setf *current-frame*
1238 (do ((prev *current-frame* lead)
1239 (lead (di:frame-down *current-frame*)
1240 (di:frame-down lead)))
1241 ((null lead)
1242 (princ (intl:gettext "Bottom of stack encountered."))
1243 prev)
1244 (when (= n (di:frame-number prev))
1245 (return prev))))))
1246 (t
1247 (print-frame-call
1248 (setf *current-frame*
1249 (do ((prev *current-frame* lead)
1250 (lead (di:frame-up *current-frame*)
1251 (di:frame-up lead)))
1252 ((null lead)
1253 (princ (intl:gettext "Top of stack encountered."))
1254 prev)
1255 (when (= n (di:frame-number prev))
1256 (return prev)))))))))
1257
1258 (def-debug-command-alias "F" "FRAME")
1259
1260 ;; debug-return, equivalent to return-from-frame in some other lisps,
1261 ;; allows us to return an arbitrary value from any frame
1262 (def-debug-command "DEBUG-RETURN" (&optional
1263 (return (read-prompting-maybe
1264 (intl:gettext "debug-return: "))))
1265 (unless (di:return-from-frame *current-frame* return)
1266 ;; the "unless" here is for aesthetical purposes only. If all goes
1267 ;; well with return-from-frame, the code after it will never get
1268 ;; reached anyway.
1269 (format t (intl:gettext "~@<can't find a tag for this frame ~
1270 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1271 and recompiling)~:@>"))))
1272
1273 (def-debug-command-alias "R" "DEBUG-RETURN")
1274
1275
1276 ;;;
1277 ;;; In and Out commands.
1278 ;;;
1279
1280 (def-debug-command "QUIT" ()
1281 (throw 'lisp::top-level-catcher nil))
1282
1283 (def-debug-command "GO" ()
1284 (continue *debug-condition*)
1285 (error (intl:gettext "No restart named continue.")))
1286
1287 (def-debug-command "RESTART" ()
1288 (let ((num (read-if-available :prompt)))
1289 (when (eq num :prompt)
1290 (show-restarts *debug-restarts*)
1291 (write-string (intl:gettext "Restart: "))
1292 (force-output)
1293 (setf num (read *standard-input*)))
1294 (let ((restart (typecase num
1295 (unsigned-byte
1296 (nth num *debug-restarts*))
1297 (symbol
1298 (find num *debug-restarts* :key #'restart-name
1299 :test #'(lambda (sym1 sym2)
1300 (string= (symbol-name sym1)
1301 (symbol-name sym2)))))
1302 (t
1303 (format t (intl:gettext "~S is invalid as a restart name.~%") num)
1304 (return-from restart-debug-command nil)))))
1305 (if restart
1306 (invoke-restart-interactively restart)
1307 (princ (intl:gettext "No such restart."))))))
1308
1309
1310 ;;;
1311 ;;; Information commands.
1312 ;;;
1313
1314 (defvar *help-line-scroll-count* 20
1315 "This controls how many lines the debugger's help command prints before
1316 printing a prompting line to continue with output.")
1317
1318 (def-debug-command "HELP" ()
1319 (let* ((translated (intl:dgettext "cmucl" debug-help-string))
1320 (end -1)
1321 (len (length translated))
1322 (len-1 (1- len)))
1323 (loop
1324 (let ((start (1+ end))
1325 (count *help-line-scroll-count*))
1326 (loop
1327 (setf end (position #\newline translated :start (1+ end)))
1328 (cond ((or (not end) (= end len-1))
1329 (setf end len)
1330 (return))
1331 ((or (zerop (decf count)) (= end len))
1332 (return))))
1333 (write-string translated *standard-output*
1334 :start start :end end))
1335 (when (= end len) (return))
1336 (format t (intl:gettext "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: "))
1337 (force-output)
1338 (let ((res (read-line)))
1339 (when (or (string= res "q") (string= res "Q"))
1340 (return))))))
1341
1342 (def-debug-command-alias "?" "HELP")
1343
1344 (def-debug-command "ERROR" ()
1345 (format t "~A~%" (safe-condition-message *debug-condition*))
1346 (show-restarts *debug-restarts*))
1347
1348 (def-debug-command "BACKTRACE" ()
1349 (backtrace (read-if-available most-positive-fixnum)))
1350
1351 (def-debug-command "PRINT" ()
1352 (print-frame-call *current-frame*))
1353
1354 (def-debug-command-alias "P" "PRINT")
1355
1356 (def-debug-command "VPRINT" ()
1357 (print-frame-call *current-frame* :print-level nil :print-length nil
1358 :verbosity (read-if-available 2)))
1359
1360 (def-debug-command-alias "PP" "VPRINT")
1361
1362 (def-debug-command "LIST-LOCALS" ()
1363 (let ((d-fun (di:frame-debug-function *current-frame*)))
1364 (if (di:debug-variable-info-available d-fun)
1365 (let ((*print-level* (or *debug-print-level* *print-level*))
1366 (*print-length* (or *debug-print-length* *print-length*))
1367 (*standard-output* *debug-io*)
1368 (location (di:frame-code-location *current-frame*))
1369 (prefix (read-if-available nil))
1370 (any-p nil)
1371 (any-valid-p nil))
1372 (dolist (v (di:ambiguous-debug-variables
1373 d-fun
1374 (if prefix (string prefix) "")))
1375 (setf any-p t)
1376 (when (eq (di:debug-variable-validity v location) :valid)
1377 (setf any-valid-p t)
1378 (format t "~S~:[#~D~;~*~] = ~S~%"
1379 (di:debug-variable-symbol v)
1380 (zerop (di:debug-variable-id v))
1381 (di:debug-variable-id v)
1382 (di:debug-variable-value v *current-frame*))))
1383
1384 (cond
1385 ((not any-p)
1386 (format t (intl:gettext "No local variables ~@[starting with ~A ~]~
1387 in function.")
1388 prefix))
1389 ((not any-valid-p)
1390 (format t (intl:gettext "All variables ~@[starting with ~A ~]currently ~
1391 have invalid values.")
1392 prefix))))
1393 (write-line (intl:gettext "No variable information available.")))))
1394
1395 (def-debug-command-alias "L" "LIST-LOCALS")
1396
1397 (def-debug-command "SOURCE" ()
1398 (fresh-line)
1399 (print-code-location-source-form (di:frame-code-location *current-frame*)
1400 (read-if-available 0)))
1401
1402 (def-debug-command "VSOURCE" ()
1403 (fresh-line)
1404 (print-code-location-source-form (di:frame-code-location *current-frame*)
1405 (read-if-available 0)
1406 t))
1407
1408
1409 ;;;; Source location printing:
1410
1411 ;;; We cache a stream to the last valid file debug source so that we won't have
1412 ;;; to repeatedly open the file.
1413 ;;;
1414 (defvar *cached-debug-source* nil)
1415 (declaim (type (or di:debug-source null) *cached-debug-source*))
1416 (defvar *cached-source-stream* nil)
1417 (declaim (type (or stream null) *cached-source-stream*))
1418
1419 ;;; To suppress the read-time evaluation #. macro during source read
1420 ;;; the *readtable* is modified. The *readtable* is cached to avoid
1421 ;;; copying it each time, and invalidated when the
1422 ;;; *cached-debug-source* has changed.
1423 (defvar *cached-readtable* nil)
1424 (declaim (type (or readtable null) *cached-readtable*))
1425
1426 (pushnew #'(lambda ()
1427 (setq *cached-debug-source* nil *cached-source-stream* nil
1428 *cached-readtable* nil))
1429 ext:*before-save-initializations*)
1430
1431
1432 ;;; We also cache the last top-level form that we printed a source for so that
1433 ;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
1434 ;;;
1435 (defvar *cached-top-level-form-offset* nil)
1436 (declaim (type (or kernel:index null) *cached-top-level-form-offset*))
1437 (defvar *cached-top-level-form*)
1438 (defvar *cached-form-number-translations*)
1439
1440
1441 ;;; GET-TOP-LEVEL-FORM -- Internal
1442 ;;;
1443 ;;; Given a code location, return the associated form-number translations
1444 ;;; and the actual top-level form. We check our cache --- if there is a miss,
1445 ;;; we dispatch on the kind of the debug source.
1446 ;;;
1447 (defun get-top-level-form (location)
1448 (let ((d-source (di:code-location-debug-source location)))
1449 (if (and (eq d-source *cached-debug-source*)
1450 (eql (di:code-location-top-level-form-offset location)
1451 *cached-top-level-form-offset*))
1452 (values *cached-form-number-translations* *cached-top-level-form*)
1453 (let* ((offset (di:code-location-top-level-form-offset location))
1454 (res
1455 (ecase (di:debug-source-from d-source)
1456 (:file (get-file-top-level-form location))
1457 ((:lisp :stream)
1458 (svref (di:debug-source-name d-source) offset)))))
1459 (setq *cached-top-level-form-offset* offset)
1460 (values (setq *cached-form-number-translations*
1461 (di:form-number-translations res offset))
1462 (setq *cached-top-level-form* res))))))
1463
1464
1465 ;;; GET-FILE-TOP-LEVEL-FORM -- Internal.
1466 ;;;
1467 ;;; Locates the source file (if it still exists) and grabs the top-level form.
1468 ;;; If the file is modified, we use the top-level-form offset instead of the
1469 ;;; recorded character offset.
1470 ;;;
1471 (defun get-file-top-level-form (location)
1472 (let* ((d-source (di:code-location-debug-source location))
1473 (tlf-offset (di:code-location-top-level-form-offset location))
1474 (local-tlf-offset (- tlf-offset
1475 (di:debug-source-root-number d-source)))
1476 (char-offset
1477 (aref (or (di:debug-source-start-positions d-source)
1478 (error (intl:gettext "No start positions map.")))
1479 local-tlf-offset))
1480 (name (di:debug-source-name d-source)))
1481 (unless (eq d-source *cached-debug-source*)
1482 (unless (and *cached-source-stream*
1483 (equal (pathname *cached-source-stream*)
1484 (pathname name)))
1485 (setq *cached-readtable* nil)
1486 (when *cached-source-stream* (close *cached-source-stream*))
1487 (setq *cached-source-stream*
1488 (open name :if-does-not-exist nil
1489 :external-format (or (c::debug-source-info d-source) :default)))
1490 (unless *cached-source-stream*
1491 (error (intl:gettext "Source file no longer exists:~% ~A.") (namestring name)))
1492 (format t (intl:gettext "~%; File: ~A~%") (namestring name)))
1493
1494 (setq *cached-debug-source*
1495 (if (= (di:debug-source-created d-source) (file-write-date name))
1496 d-source nil)))
1497
1498 (cond
1499 ((eq *cached-debug-source* d-source)
1500 (file-position *cached-source-stream* char-offset))
1501 (t
1502 (format t (intl:gettext "~%; File has been modified since compilation:~%; ~A~@
1503 ; Using form offset instead of character position.~%")
1504 (namestring name))
1505 (file-position *cached-source-stream* 0)
1506 (let ((*read-suppress* t))
1507 (dotimes (i local-tlf-offset)
1508 (read *cached-source-stream*)))))
1509 (unless *cached-readtable*
1510 (setq *cached-readtable* (copy-readtable))
1511 (set-dispatch-macro-character
1512 #\# #\.
1513 #'(lambda (stream sub-char &rest rest)
1514 (declare (ignore rest sub-char))
1515 (let ((token (read stream t nil t)))
1516 (format nil "#.~s" token)))
1517 *cached-readtable*))
1518 (let ((*readtable* *cached-readtable*))
1519 (read *cached-source-stream*))))
1520
1521
1522 ;;; PRINT-CODE-LOCATION-SOURCE-FORM -- Internal.
1523 ;;;
1524 (defun print-code-location-source-form (location context &optional verbose)
1525 (let* ((location (maybe-block-start-location location))
1526 (*print-level* (if verbose
1527 nil
1528 (or *debug-print-level* *print-level*)))
1529 (*print-length* (if verbose
1530 nil
1531 (or *debug-print-length* *print-length*)))
1532 (form-num (di:code-location-form-number location)))
1533 (multiple-value-bind (translations form)
1534 (get-top-level-form location)
1535 (unless (< form-num (length translations))
1536 (error (intl:gettext "Source path no longer exists.")))
1537 (prin1 (di:source-path-context form
1538 (svref translations form-num)
1539 context)))))
1540
1541
1542 ;;;
1543 ;;; Breakpoint and step commands.
1544 ;;;
1545
1546 ;;; Steps to the next code-location
1547 (def-debug-command "STEP" ()
1548 (setf *number-of-steps* (read-if-available 1))
1549 (set-step-breakpoint *current-frame*)
1550 (continue *debug-condition*)
1551 (error (intl:gettext "Couldn't continue.")))
1552
1553 ;;; Lists possible breakpoint locations, which are active, and where go will
1554 ;;; continue. Sets *possible-breakpoints* to the code-locations which can then
1555 ;;; be used by sbreakpoint. Takes a function as an optional argument.
1556 (def-debug-command "LIST-LOCATIONS" ()
1557 (let ((df (read-if-available *default-breakpoint-debug-function*)))
1558 (cond ((consp df)
1559 (setf df (di:function-debug-function (eval df)))
1560 (setf *default-breakpoint-debug-function* df))
1561 ((or (eq ':c df)
1562 (not *default-breakpoint-debug-function*))
1563 (setf df (di:frame-debug-function *current-frame*))
1564 (setf *default-breakpoint-debug-function* df)))
1565 (setf *possible-breakpoints* (possible-breakpoints df)))
1566 (let ((continue-at (di:frame-code-location *current-frame*)))
1567 (let ((active (location-in-list *default-breakpoint-debug-function*
1568 *breakpoints* :function-start))
1569 (here (di:code-location=
1570 (di:debug-function-start-location
1571 *default-breakpoint-debug-function*) continue-at)))
1572 (when (or active here)
1573 (format t (intl:gettext "::FUNCTION-START "))
1574 (when active (format t (intl:gettext " *Active*")))
1575 (when here (format t (intl:gettext " *Continue here*")))))
1576
1577 (let ((prev-location nil)
1578 (prev-num 0)
1579 (this-num 0))
1580 (flet ((flush ()
1581 (when prev-location
1582 (let ((this-num (1- this-num)))
1583 (if (= prev-num this-num)
1584 (format t "~&~D: " prev-num)
1585 (format t "~&~D-~D: " prev-num this-num)))
1586 (print-code-location-source-form prev-location 0)
1587 (when *print-location-kind*
1588 (format t "~S " (di:code-location-kind prev-location)))
1589 (when (location-in-list prev-location *breakpoints*)
1590 (format t (intl:gettext " *Active*")))
1591 (when (di:code-location= prev-location continue-at)
1592 (format t (intl:gettext " *Continue here*"))))))
1593
1594 (dolist (code-location *possible-breakpoints*)
1595 (when (or *print-location-kind*
1596 (location-in-list code-location *breakpoints*)
1597 (di:code-location= code-location continue-at)
1598 (not prev-location)
1599 (not (eq (di:code-location-debug-source code-location)
1600 (di:code-location-debug-source prev-location)))
1601 (not (eq (di:code-location-top-level-form-offset
1602 code-location)
1603 (di:code-location-top-level-form-offset
1604 prev-location)))
1605 (not (eq (di:code-location-form-number code-location)
1606 (di:code-location-form-number prev-location))))
1607 (flush)
1608 (setq prev-location code-location prev-num this-num))
1609
1610 (incf this-num))))
1611
1612 (when (location-in-list *default-breakpoint-debug-function* *breakpoints*
1613 :function-end)
1614 (format t (intl:gettext "~&::FUNCTION-END *Active* ")))))
1615
1616 (def-debug-command-alias "LL" "LIST-LOCATIONS")
1617
1618 ;;; set breakpoint at # given
1619 (def-debug-command "BREAKPOINT" ()
1620 (let ((index (read-prompting-maybe (intl:gettext "Location number, :start, or :end: ")))
1621 (break t)
1622 (condition t)
1623 (print nil)
1624 (print-functions nil)
1625 (function nil)
1626 (bp)
1627 (place *default-breakpoint-debug-function*))
1628 (flet ((get-command-line ()
1629 (let ((command-line nil)
1630 (unique '(nil)))
1631 (loop
1632 (let ((next-input (read-if-available unique)))
1633 (when (eq next-input unique) (return))
1634 (push next-input command-line)))
1635 (nreverse command-line)))
1636 (set-vars-from-command-line (command-line)
1637 (do ((arg (pop command-line) (pop command-line)))
1638 ((not arg))
1639 (ecase arg
1640 (:condition (setf condition (pop command-line)))
1641 (:print (push (pop command-line) print))
1642 (:break (setf break (pop command-line)))
1643 (:function
1644 (setf function (eval (pop command-line)))
1645 (setf *default-breakpoint-debug-function*
1646 (di:function-debug-function function))
1647 (setf place *default-breakpoint-debug-function*)
1648 (setf *possible-breakpoints*
1649 (possible-breakpoints
1650 *default-breakpoint-debug-function*))))))
1651 (setup-function-start ()
1652 (let ((code-loc (di:debug-function-start-location place)))
1653 (setf bp (di:make-breakpoint #'main-hook-function place
1654 :kind :function-start))
1655 (setf break (di:preprocess-for-eval break code-loc))
1656 (setf condition (di:preprocess-for-eval condition code-loc))
1657 (dolist (form print)
1658 (push (cons (di:preprocess-for-eval form code-loc) form)
1659 print-functions))))
1660 (setup-function-end ()
1661 (setf bp
1662 (di:make-breakpoint #'main-hook-function place
1663 :kind :function-end))
1664 (setf break
1665 (coerce `(lambda (dummy)
1666 (declare (ignore dummy)) ,break)
1667 'function))
1668 (setf condition (coerce `(lambda (dummy)
1669 (declare (ignore dummy)) ,condition)
1670 'function))
1671 (dolist (form print)
1672 (push (cons
1673 (coerce `(lambda (dummy)
1674 (declare (ignore dummy)) ,form) 'function)
1675 form)
1676 print-functions)))
1677 (setup-code-location ()
1678 (setf place (nth index *possible-breakpoints*))
1679 (setf bp (di:make-breakpoint #'main-hook-function place
1680 :kind :code-location))
1681 (dolist (form print)
1682 (push (cons
1683 (di:preprocess-for-eval form place)
1684 form)
1685 print-functions))
1686 (setf break (di:preprocess-for-eval break place))
1687 (setf condition (di:preprocess-for-eval condition place))))
1688 (set-vars-from-command-line (get-command-line))
1689 (cond
1690 ((or (eq index :start) (eq index :s))
1691 (setup-function-start))
1692 ((or (eq index :end) (eq index :e))
1693 (setup-function-end))
1694 (t
1695 (setup-code-location)))
1696 (di:activate-breakpoint bp)
1697 (let* ((new-bp-info (create-breakpoint-info place bp index
1698 :break break
1699 :print print-functions
1700 :condition condition))
1701 (old-bp-info (location-in-list new-bp-info *breakpoints*)))
1702 (when old-bp-info
1703 (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
1704 (setf *breakpoints* (remove old-bp-info *breakpoints*))
1705 (format t (intl:gettext "Note: previous breakpoint removed.~%")))
1706 (push new-bp-info *breakpoints*))
1707 (print-breakpoint-info (first *breakpoints*))
1708 (format t (intl:gettext "~&Added.")))))
1709
1710 (def-debug-command-alias "BP" "BREAKPOINT")
1711
1712 ;;; list all breakpoints set
1713 (def-debug-command "LIST-BREAKPOINTS" ()
1714 (setf *breakpoints*
1715 (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
1716 (dolist (info *breakpoints*)
1717 (print-breakpoint-info info)))
1718
1719 (def-debug-command-alias "LB" "LIST-BREAKPOINTS")
1720 (def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
1721
1722 ;;; remove breakpoint n or all if none given
1723 (def-debug-command "DELETE-BREAKPOINT" ()
1724 (let* ((index (read-if-available nil))
1725 (bp-info
1726 (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
1727 (cond (bp-info
1728 (di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
1729 (setf *breakpoints* (remove bp-info *breakpoints*))
1730 (format t (intl:gettext "Breakpoint ~S removed.~%") index))
1731 (index (format t (intl:gettext "Breakpoint doesn't exist.")))
1732 (t
1733 (dolist (ele *breakpoints*)
1734 (di:delete-breakpoint (breakpoint-info-breakpoint ele)))
1735 (setf *breakpoints* nil)
1736 (format t (intl:gettext "All breakpoints deleted.~%"))))))
1737
1738 (def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
1739
1740
1741 ;;;
1742 ;;; Miscellaneous commands.
1743 ;;;
1744
1745 (def-debug-command "FLUSH-ERRORS" ()
1746 (if (setf *flush-debug-errors* (not *flush-debug-errors*))
1747 (write-line (intl:gettext "Errors now flushed."))
1748 (write-line (intl:gettext "Errors now create nested debug levels."))))
1749
1750
1751 (def-debug-command "DESCRIBE" ()
1752 (let* ((curloc (di:frame-code-location *current-frame*))
1753 (debug-fun (di:code-location-debug-function curloc))
1754 (function (di:debug-function-function debug-fun)))
1755 (if function
1756 (describe function)
1757 (format t (intl:gettext "Can't figure out the function for this frame.")))))
1758
1759
1760 ;;;
1761 ;;; Editor commands.
1762 ;;;
1763
1764 (def-debug-command "EDIT-SOURCE" ()
1765 (unless (ed::ts-stream-p *terminal-io*)
1766 (error (intl:gettext "The debugger's EDIT-SOURCE command only works in slave Lisps ~
1767 connected to a Hemlock editor.")))
1768 (let* ((wire (ed::ts-stream-wire *terminal-io*))
1769 (location (maybe-block-start-location
1770 (di:frame-code-location *current-frame*)))
1771 (d-source (di:code-location-debug-source location))
1772 (name (di:debug-source-name d-source)))
1773 (ecase (di:debug-source-from d-source)
1774 (:file
1775 (let* ((tlf-offset (di:code-location-top-level-form-offset location))
1776 (local-tlf-offset (- tlf-offset
1777 (di:debug-source-root-number d-source)))
1778 (char-offset (aref (or (di:debug-source-start-positions d-source)
1779 (error (intl:gettext "No start positions map.")))
1780 local-tlf-offset)))
1781 (wire:remote wire
1782 (ed::edit-source-location (namestring name)
1783 (di:debug-source-created d-source)
1784 tlf-offset local-tlf-offset char-offset
1785 (di:code-location-form-number location)))
1786 (wire:wire-force-output wire)))
1787 ((:lisp :stream)
1788 (wire:remote wire
1789 (ed::cannot-edit-source-location))
1790 (wire:wire-force-output wire)))))
1791
1792
1793
1794 ;;;; Debug loop command utilities.
1795
1796 (defun read-prompting-maybe (prompt &optional (in *standard-input*)
1797 (out *standard-output*))
1798 (unless (ext:listen-skip-whitespace in)
1799 (princ prompt out)
1800 (force-output out))
1801 (read in))
1802
1803 (defun read-if-available (default &optional (stream *standard-input*))
1804 (if (ext:listen-skip-whitespace stream)
1805 (read stream)
1806 default))

  ViewVC Help
Powered by ViewVC 1.1.5