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

Contents of /src/hemlock/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Mon Oct 30 15:45:04 2000 UTC (13 years, 5 months ago) by pw
Branch: MAIN
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 chiles 1.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 pw 1.8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/debug.lisp,v 1.8 2000/10/30 15:45:04 pw Exp $")
9 chiles 1.1 ;;;
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 chiles 1.3 ;;;; DEFINE-DEBUGGER-COMMAND.
23 chiles 1.1
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 chiles 1.3
42     ;;;; Frame changing commands.
43    
44 chiles 1.1 (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 chiles 1.3
68     ;;;; In and Out commands.
69    
70 chiles 1.1 (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 chiles 1.3
90     ;;;; Information commands.
91    
92 chiles 1.1 (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 chiles 1.4 "Executes the debugger's BACKTRACE command."
103 chiles 1.1 :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 chiles 1.2
130    
131 chiles 1.3
132     ;;;; Source editing.
133 chiles 1.2
134 chiles 1.3 ;;; "Debug Edit Source" -- Command.
135 chiles 1.2 ;;;
136 chiles 1.3 ;;; 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 chiles 1.2 ;;; 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 ram 1.6 (defvar *in-debug-edit-source* nil)
146 chiles 1.2
147     (defcommand "Debug Edit Source" (p)
148 chiles 1.4 "Given the \"Current Eval Server\"'s current debugger frame, place the user
149 chiles 1.2 at the location's source in the editor."
150 chiles 1.4 "Given the \"Current Eval Server\"'s current debugger frame, place the user
151 chiles 1.2 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 ram 1.6 (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 chiles 1.2
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 pw 1.8 ;;
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 chiles 1.2 ;;
243 chiles 1.4 ;; Walk down to the form. Change to buffer in case we get an error
244     ;; while finding the form.
245 chiles 1.2 (change-to-buffer buffer)
246 chiles 1.4 (mark-to-debug-source-path point path)))))
247 chiles 1.2 (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 ram 1.6 (loud-message "Can't edit source.")
260     (when *in-debug-edit-source*
261     (throw 'blow-debug-edit-source nil)))
262 chiles 1.4
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 ram 1.5 (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 chiles 1.4 ;;;
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 chiles 1.3 (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 chiles 1.4 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 chiles 1.3 "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 chiles 1.4 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 chiles 1.3 (declare (ignore p))
504 chiles 1.4 (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 chiles 1.3
553     ;;;; Miscellaneous commands.
554 chiles 1.1
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