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

Contents of /src/hemlock/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5