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

Contents of /src/hemlock/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon May 31 20:26:29 1993 UTC (20 years, 10 months ago) by ram
Branch: MAIN
Changes since 1.4: +8 -6 lines
In delete-breakpoints-buffer-hook, if no wire (server died), then don't do
anything.
1 ;;; -*- Mode: Lisp; Package: ED; Log: hemlock.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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/debug.lisp,v 1.5 1993/05/31 20:26:29 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This contains commands for sending debugger commands to slaves in the
15 ;;; debugger.
16 ;;;
17 ;;; Written by Bill Chiles.
18 ;;;
19
20 (in-package "HEMLOCK")
21
22
23
24 ;;;; DEFINE-DEBUGGER-COMMAND.
25
26 (defmacro define-debugger-command (name doc cmd &key uses-argument)
27 `(defcommand ,(concatenate 'simple-string "Debug " name) (p)
28 ,doc ,doc
29 ,@(if uses-argument
30 nil
31 '((declare (ignore p))))
32 (let* ((server-info (get-current-eval-server t))
33 (wire (server-info-wire server-info)))
34 (wire:remote wire
35 (ts-stream-accept-input
36 (ts-data-stream (server-info-slave-info server-info))
37 ,(if uses-argument
38 `(list ,cmd p)
39 cmd)))
40 (wire:wire-force-output wire))))
41
42
43
44 ;;;; Frame changing commands.
45
46 (define-debugger-command "Up"
47 "Moves the \"Current Eval Server\" up one debugger frame."
48 :up)
49
50 (define-debugger-command "Down"
51 "Moves the \"Current Eval Server\" down one debugger frame."
52 :down)
53
54 (define-debugger-command "Top"
55 "Moves the \"Current Eval Server\" to the top of the debugging stack."
56 :top)
57
58 (define-debugger-command "Bottom"
59 "Moves the \"Current Eval Server\" to the bottom of the debugging stack."
60 :bottom)
61
62 (define-debugger-command "Frame"
63 "Moves the \"Current Eval Server\" to the absolute debugger frame number
64 indicated by the prefix argument."
65 :frame
66 :uses-argument t)
67
68
69
70 ;;;; In and Out commands.
71
72 (define-debugger-command "Quit"
73 "In the \"Current Eval Server\", throws to top level out of the debugger."
74 :quit)
75
76 (define-debugger-command "Go"
77 "In the \"Current Eval Server\", tries the CONTINUE restart."
78 :go)
79
80 (define-debugger-command "Abort"
81 "In the \"Current Eval Server\", execute the previous ABORT restart."
82 :abort)
83
84 (define-debugger-command "Restart"
85 "In the \"Current Eval Server\", executes the restart indicated by the
86 prefix argument."
87 :restart
88 :uses-argument t)
89
90
91
92 ;;;; Information commands.
93
94 (define-debugger-command "Help"
95 "In the \"Current Eval Server\", prints the debugger's help text."
96 :help)
97
98 (define-debugger-command "Error"
99 "In the \"Current Eval Server\", print the error condition and restart cases
100 upon entering the debugger."
101 :error)
102
103 (define-debugger-command "Backtrace"
104 "Executes the debugger's BACKTRACE command."
105 :backtrace)
106
107 (define-debugger-command "Print"
108 "In the \"Current Eval Server\", prints a representation of the debugger's
109 current frame."
110 :print)
111
112 (define-debugger-command "Verbose Print"
113 "In the \"Current Eval Server\", prints a representation of the debugger's
114 current frame without elipsis."
115 :vprint)
116
117 (define-debugger-command "List Locals"
118 "In the \"Current Eval Server\", prints the local variables for the debugger's
119 current frame."
120 :list-locals)
121
122 (define-debugger-command "Source"
123 "In the \"Current Eval Server\", prints the source form for the debugger's
124 current frame."
125 :source)
126
127 (define-debugger-command "Verbose Source"
128 "In the \"Current Eval Server\", prints the source form for the debugger's
129 current frame with surrounding forms for context."
130 :vsource)
131
132
133
134 ;;;; Source editing.
135
136 ;;; "Debug Edit Source" -- Command.
137 ;;;
138 ;;; The :edit-source command in the slave debugger initiates a synchronous RPC
139 ;;; into the editor via the wire in *terminal-io*, a typescript stream. This
140 ;;; routine takes the necessary values, a file and source-path, and changes the
141 ;;; editor's state to display that location.
142 ;;;
143 ;;; This command has to wait on SERVE-EVENT until some special is set by the
144 ;;; RPC routine saying it is okay to return to the editor's top level.
145 ;;;
146 (defvar *debug-editor-source-data* nil)
147
148 (defcommand "Debug Edit Source" (p)
149 "Given the \"Current Eval Server\"'s current debugger frame, place the user
150 at the location's source in the editor."
151 "Given the \"Current Eval Server\"'s current debugger frame, place the user
152 at the location's source in the editor."
153 (declare (ignore p))
154 (let* ((server-info (get-current-eval-server t))
155 (wire (server-info-wire server-info)))
156 ;;
157 ;; Tell the slave to tell the editor some source info.
158 (wire:remote wire
159 (ts-stream-accept-input
160 (ts-data-stream (server-info-slave-info server-info))
161 :edit-source))
162 (wire:wire-force-output wire)
163 ;;
164 ;; Wait for the source info.
165 (let ((*debug-editor-source-data* nil))
166 (loop
167 (system:serve-event)
168 (when *debug-editor-source-data* (return))))))
169
170 ;;; EDIT-SOURCE-LOCATION -- Internal Interface.
171 ;;;
172 ;;; The slave calls this in the editor when the debugger gets an :edit-source
173 ;;; command. This receives the information necessary to take the user in
174 ;;; Hemlock to the source location, and does it.
175 ;;;
176 (defun edit-source-location (name source-created-date tlf-offset
177 local-tlf-offset char-offset form-number)
178 (let ((pn (pathname name)))
179 (unless (probe-file pn)
180 (editor-error "Source file no longer exists: ~A." name))
181 (multiple-value-bind (buffer newp) (find-file-buffer pn)
182 (let ((date (buffer-write-date buffer))
183 (point (buffer-point buffer)))
184 (when newp (push-buffer-mark (copy-mark point) nil))
185 (buffer-start point)
186 ;;
187 ;; Get to the top-level form in the buffer.
188 (cond ((buffer-modified buffer)
189 (loud-message "Buffer has been modified. Using form offset ~
190 instead of character position.")
191 (dotimes (i local-tlf-offset)
192 (pre-command-parse-check point)
193 (form-offset point 1)))
194 ((not date)
195 (loud-message "Cannot compare write dates. Assuming source ~
196 has not been modified -- ~A."
197 name)
198 (character-offset point char-offset))
199 ((= source-created-date date)
200 (character-offset point char-offset))
201 (t
202 (loud-message "File has been modified since reading the source. ~
203 Using form offset instead of character position.")
204 (dotimes (i local-tlf-offset)
205 (pre-command-parse-check point)
206 (form-offset point 1))))
207 ;;
208 ;; Read our form, get form-number translations, get the source-path,
209 ;; and make it usable.
210 (let ((path (nreverse
211 (butlast
212 (cdr
213 (svref (di:form-number-translations
214 (with-input-from-region
215 (s (region point (buffer-end-mark buffer)))
216 (read s))
217 tlf-offset)
218 form-number))))))
219 ;;
220 ;; Walk down to the form. Change to buffer in case we get an error
221 ;; while finding the form.
222 (change-to-buffer buffer)
223 (mark-to-debug-source-path point path)))))
224 (setf *debug-editor-source-data* t)
225 ;;
226 ;; While Hemlock was setting up the source edit, the user could have typed
227 ;; while looking at a buffer no longer current when the commands execute.
228 (clear-editor-input *editor-input*))
229
230 ;;; CANNOT-EDIT-SOURCE-LOCATION -- Interface.
231 ;;;
232 ;;; The slave calls this when the debugger command "EDIT-SOURCE" runs, and the
233 ;;; slave cannot give the editor source information.
234 ;;;
235 (defun cannot-edit-source-location ()
236 (throw 'editor-top-level nil))
237
238
239
240 ;;;; Breakpoints.
241
242 ;;;
243 ;;; Breakpoint information for editor management.
244 ;;;
245
246 ;;; This holds all the stuff we might want to know about a breakpoint in some
247 ;;; slave.
248 ;;;
249 (defstruct (breakpoint-info (:print-function print-breakpoint-info)
250 (:constructor make-breakpoint-info
251 (slave buffer remote-object name)))
252 (slave nil :type server-info)
253 (buffer nil :type buffer)
254 (remote-object nil :type wire:remote-object)
255 (name nil :type simple-string))
256 ;;;
257 (defun print-breakpoint-info (obj str n)
258 (declare (ignore n))
259 (format str "#<Breakpoint-Info for ~S>" (breakpoint-info-name obj)))
260
261 (defvar *breakpoints* nil)
262
263 (macrolet ((frob (name accessor)
264 `(defun ,name (key)
265 (let ((res nil))
266 (dolist (bpt-info *breakpoints* res)
267 (when (eq (,accessor bpt-info) key)
268 (push bpt-info res)))))))
269 (frob slave-breakpoints breakpoint-info-slave)
270 (frob buffer-breakpoints breakpoint-info-buffer))
271
272 (defun delete-breakpoints-buffer-hook (buffer)
273 (let ((server-info (value current-eval-server)))
274 (when server-info
275 (let ((bpts (buffer-breakpoints buffer))
276 (wire (server-info-wire server-info)))
277 (dolist (b bpts)
278 (setf *breakpoints* (delete b *breakpoints*))
279 (when wire
280 (wire:remote wire
281 (di:delete-breakpoint (breakpoint-info-remote-object b))))
282 (when wire
283 (wire:wire-force-output wire)))))))
284 ;;;
285 (add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook)
286
287 ;;;
288 ;;; Setting breakpoints.
289 ;;;
290
291 ;;; "Debug Breakpoint" uses this to prompt for :function-end and
292 ;;; :function-start breakpoints.
293 ;;;
294 (defvar *function-breakpoint-strings*
295 (make-string-table :initial-contents
296 '(("Start" . :function-start) ("End" . :function-end))))
297 ;;;
298 ;;; Maybe this should use the wire level directly and hold onto remote-objects
299 ;;; identifying the breakpoints. Then we could write commands to show where
300 ;;; the breakpoints were and to individually deactivate or delete them. As it
301 ;;; is now we probably have to delete all for a given function. What about
302 ;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a
303 ;;; nice set such as something to simply print all locals at a certain
304 ;;; location.
305 ;;;
306 (defcommand "Debug Breakpoint" (p)
307 "This tries to set a breakpoint in the \"Current Eval Server\" at the
308 location designated by the current point. If there is no known code
309 location at the point, then this moves the point to the closest location
310 before the point. With an argument, this sets a breakpoint at the start
311 or end of the function, prompting the user for which one to use."
312 "This tries to set a breakpoint in the \"Current Eval Server\" at the
313 location designated by the current point. If there is no known code
314 location at the point, then this moves the point to the closest location
315 before the point. With an argument, this sets a breakpoint at the start
316 or end of the function, prompting the user for which one to use."
317 (let ((point (current-point)))
318 (pre-command-parse-check point)
319 (let ((name (find-defun-for-breakpoint point)))
320 (if p
321 (multiple-value-bind (str place)
322 (prompt-for-keyword
323 (list *function-breakpoint-strings*)
324 :prompt "Set breakpoint at function: "
325 :default :start :default-string "Start")
326 (declare (ignore str))
327 (set-breakpoint-in-slave (get-current-eval-server t) name place))
328 (let* ((path (find-path-for-breakpoint point))
329 (server-info (get-current-eval-server t))
330 (res (set-breakpoint-in-slave server-info name path)))
331 (cond ((not res)
332 (message "No code locations correspond with point."))
333 ((wire:remote-object-p res)
334 (push (make-breakpoint-info server-info (current-buffer)
335 res name)
336 *breakpoints*)
337 (message "Breakpoint set."))
338 (t
339 (resolve-ambiguous-breakpoint-location server-info
340 name res))))))))
341
342 ;;; FIND-PATH-FOR-BREAKPOINT -- Internal.
343 ;;;
344 ;;; This walks up from point to the beginning of its containing DEFUN to return
345 ;;; the pseudo source-path (no form-number, no top-level form offset, and in
346 ;;; descent order from start of the DEFUN).
347 ;;;
348 (defun find-path-for-breakpoint (point)
349 (with-mark ((m point)
350 (end point))
351 (let ((path nil))
352 (top-level-offset end -1)
353 (with-mark ((containing-form m))
354 (loop
355 (when (mark= m end) (return))
356 (backward-up-list containing-form)
357 (do ((count 0 (1+ count)))
358 ((mark= m containing-form)
359 ;; Count includes moving from the first form inside the
360 ;; containing-form paren to the outside of the containing-form
361 ;; paren -- one too many.
362 (push (1- count) path))
363 (form-offset m -1))))
364 path)))
365
366 ;;; SET-BREAKPOINT-IN-SLAVE -- Internal.
367 ;;;
368 ;;; This tells the slave to set a breakpoint for name. Path is a modified
369 ;;; source-path (with no form-number or top-level-form offset) or a symbol
370 ;;; (:function-start or :function-end). If the server dies while evaluating
371 ;;; form, then this signals an editor-error.
372 ;;;
373 (defun set-breakpoint-in-slave (server-info name path)
374 (when (server-info-notes server-info)
375 (editor-error "Server ~S is currently busy. See \"List Operations\"."
376 (server-info-name server-info)))
377 (multiple-value-bind (res error)
378 (wire:remote-value (server-info-wire server-info)
379 (di:set-breakpoint-for-editor (value current-package)
380 name path))
381 (when error (editor-error "The server died before finishing."))
382 res))
383
384 ;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal.
385 ;;;
386 ;;; This helps the user select an ambiguous code location for "Debug
387 ;;; Breakpoint".
388 ;;;
389 (defun resolve-ambiguous-breakpoint-location (server-info name locs)
390 (declare (list locs))
391 (let ((point (current-point))
392 (loc-num (length locs))
393 (count 1)
394 (cur-loc locs))
395 (flet ((show-loc ()
396 (top-level-offset point -1)
397 (mark-to-debug-source-path point (cdar cur-loc))))
398 (show-loc)
399 (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num)
400 :help "Pick a location to set a breakpoint."
401 :change-window nil)
402 (#\space "Move point to next possible location."
403 (setf cur-loc (cdr cur-loc))
404 (cond (cur-loc
405 (incf count))
406 (t
407 (setf cur-loc locs)
408 (setf count 1)))
409 (show-loc)
410 (reprompt))
411 (:confirm "Choose the current location."
412 (let ((res (wire:remote-value (server-info-wire server-info)
413 (di:set-location-breakpoint-for-editor (caar cur-loc)))))
414 (unless (wire:remote-object-p res)
415 (editor-error "Couldn't set breakpoint from location?"))
416 (push (make-breakpoint-info server-info (current-buffer) res name)
417 *breakpoints*))
418 (message "Breakpoint set."))))))
419
420 ;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal.
421 ;;;
422 ;;; This takes a mark at the beginning of a top-level form and modified debugger
423 ;;; source-path. Path has no form number or top-level-form offset element, and
424 ;;; it has been reversed to actually be usable.
425 ;;;
426 (defun mark-to-debug-source-path (mark path)
427 (let ((quote-or-function nil))
428 (pre-command-parse-check mark)
429 (dolist (n path)
430 (when quote-or-function
431 (editor-error
432 "Apparently settled on the symbol QUOTE or FUNCTION via their ~
433 read macros, which is odd, but furthermore there seems to be ~
434 more source-path left."))
435 (unless (form-offset mark 1)
436 ;; Want to use the following and delete the next FORM-OFFSET -1.
437 ;; (scan-direction-valid mark t (or :open-paren :prefix))
438 (editor-error
439 "Ran out of text in buffer with more source-path remaining."))
440 (form-offset mark -1)
441 (ecase (next-character mark)
442 (#\(
443 (mark-after mark)
444 (form-offset mark n))
445 (#\'
446 (case n
447 (0 (setf quote-or-function t))
448 (1 (mark-after mark))
449 (t (editor-error "Next form is QUOTE, but source-path index ~
450 is other than zero or one."))))
451 (#\#
452 (case (next-character (mark-after mark))
453 (#\'
454 (case n
455 (0 (setf quote-or-function t))
456 (1 (mark-after mark))
457 (t (editor-error "Next form is FUNCTION, but source-path ~
458 index is other than zero or one."))))
459 (t (editor-error
460 "Can only parse ' and #' read macros."))))))
461 ;; Get to the beginning of the form.
462 (form-offset mark 1)
463 (form-offset mark -1)))
464
465 ;;;
466 ;;; Deleting breakpoints.
467 ;;;
468
469 (defhvar "Delete Breakpoints Confirm"
470 "This determines whether \"Debug Delete Breakpoints\" should ask for
471 confirmation before deleting breakpoints."
472 :value t)
473
474 (defcommand "Debug Delete Breakpoints" (p)
475 "This deletes all breakpoints for the named DEFUN containing the point.
476 This affects the \"Current Eval Server\"."
477 "This deletes all breakpoints for the named DEFUN containing the point.
478 This affects the \"Current Eval Server\"."
479 (declare (ignore p))
480 (let* ((server-info (get-current-eval-server t))
481 (wire (server-info-wire server-info))
482 (name (find-defun-for-breakpoint (current-point)))
483 (bpts (slave-breakpoints server-info)))
484 (cond ((not bpts)
485 (message "No breakpoints recorded for ~A." name))
486 ((or (not (value delete-breakpoints-confirm))
487 (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name)
488 :default t
489 :default-string "Y"))
490 (dolist (b bpts)
491 (when (string= name (breakpoint-info-name b))
492 (setf *breakpoints* (delete b *breakpoints*))
493 (wire:remote wire
494 (di:delete-breakpoint-for-editor
495 (breakpoint-info-remote-object b)))))
496 (wire:wire-force-output wire)))))
497
498 ;;;
499 ;;; Breakpoint utilities.
500 ;;;
501
502 ;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal.
503 ;;;
504 ;;; This returns as a string the name of the DEFUN containing point. It
505 ;;; signals any errors necessary to ensure "we are in good form".
506 ;;;
507 (defun find-defun-for-breakpoint (point)
508 (with-mark ((m1 point)
509 (m2 point))
510 (unless (top-level-offset m2 -1)
511 (editor-error "Must be inside a DEFUN."))
512 ;;
513 ;; Check for DEFUN.
514 (mark-after (move-mark m1 m2))
515 (unless (find-attribute m1 :whitespace #'zerop)
516 (editor-error "Must be inside a DEFUN."))
517 (word-offset (move-mark m2 m1) 1)
518 (unless (string-equal (region-to-string (region m1 m2)) "defun")
519 (editor-error "Must be inside a DEFUN."))
520 ;;
521 ;; Find name.
522 (unless (find-attribute m2 :whitespace #'zerop)
523 (editor-error "Function unnamed?"))
524 (form-offset (move-mark m1 m2) 1)
525 (region-to-string (region m2 m1))))
526
527
528
529 ;;;; Miscellaneous commands.
530
531 (define-debugger-command "Flush Errors"
532 "In the \"Current Eval Server\", toggles whether the debugger ignores errors
533 or recursively enters itself."
534 :flush)

  ViewVC Help
Powered by ViewVC 1.1.5