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

Contents of /src/hemlock/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Wed Nov 15 11:59:23 2000 UTC (13 years, 5 months ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.8: +2 -6 lines
Rework previous fix to edit-source-location to use *read-suppress*
instead of mucking with dispatch macro characters.
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.9 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/debug.lisp,v 1.9 2000/11/15 11:59:23 pw Rel $")
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 pw 1.9 (let ((*read-suppress* t))
231 pw 1.8 (read s)))
232     tlf-offset))
233     ;; Don't signal error on index overrun.It may be due
234     ;; to read-time eval getting form editing blind to
235     ;; editor
236     (index (min form-number (1- (length vector))))
237     (path (nreverse (butlast (cdr (svref vector index))))))
238 chiles 1.2 ;;
239 chiles 1.4 ;; Walk down to the form. Change to buffer in case we get an error
240     ;; while finding the form.
241 chiles 1.2 (change-to-buffer buffer)
242 chiles 1.4 (mark-to-debug-source-path point path)))))
243 chiles 1.2 (setf *debug-editor-source-data* t)
244     ;;
245     ;; While Hemlock was setting up the source edit, the user could have typed
246     ;; while looking at a buffer no longer current when the commands execute.
247     (clear-editor-input *editor-input*))
248    
249     ;;; CANNOT-EDIT-SOURCE-LOCATION -- Interface.
250     ;;;
251     ;;; The slave calls this when the debugger command "EDIT-SOURCE" runs, and the
252     ;;; slave cannot give the editor source information.
253     ;;;
254     (defun cannot-edit-source-location ()
255 ram 1.6 (loud-message "Can't edit source.")
256     (when *in-debug-edit-source*
257     (throw 'blow-debug-edit-source nil)))
258 chiles 1.4
259    
260     ;;;; Breakpoints.
261    
262     ;;;
263     ;;; Breakpoint information for editor management.
264     ;;;
265    
266     ;;; This holds all the stuff we might want to know about a breakpoint in some
267     ;;; slave.
268     ;;;
269     (defstruct (breakpoint-info (:print-function print-breakpoint-info)
270     (:constructor make-breakpoint-info
271     (slave buffer remote-object name)))
272     (slave nil :type server-info)
273     (buffer nil :type buffer)
274     (remote-object nil :type wire:remote-object)
275     (name nil :type simple-string))
276     ;;;
277     (defun print-breakpoint-info (obj str n)
278     (declare (ignore n))
279     (format str "#<Breakpoint-Info for ~S>" (breakpoint-info-name obj)))
280    
281     (defvar *breakpoints* nil)
282    
283     (macrolet ((frob (name accessor)
284     `(defun ,name (key)
285     (let ((res nil))
286     (dolist (bpt-info *breakpoints* res)
287     (when (eq (,accessor bpt-info) key)
288     (push bpt-info res)))))))
289     (frob slave-breakpoints breakpoint-info-slave)
290     (frob buffer-breakpoints breakpoint-info-buffer))
291    
292     (defun delete-breakpoints-buffer-hook (buffer)
293     (let ((server-info (value current-eval-server)))
294     (when server-info
295     (let ((bpts (buffer-breakpoints buffer))
296     (wire (server-info-wire server-info)))
297 ram 1.5 (dolist (b bpts)
298     (setf *breakpoints* (delete b *breakpoints*))
299     (when wire
300     (wire:remote wire
301     (di:delete-breakpoint (breakpoint-info-remote-object b))))
302     (when wire
303     (wire:wire-force-output wire)))))))
304 chiles 1.4 ;;;
305     (add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook)
306    
307     ;;;
308     ;;; Setting breakpoints.
309     ;;;
310    
311     ;;; "Debug Breakpoint" uses this to prompt for :function-end and
312     ;;; :function-start breakpoints.
313     ;;;
314     (defvar *function-breakpoint-strings*
315     (make-string-table :initial-contents
316     '(("Start" . :function-start) ("End" . :function-end))))
317     ;;;
318     ;;; Maybe this should use the wire level directly and hold onto remote-objects
319     ;;; identifying the breakpoints. Then we could write commands to show where
320     ;;; the breakpoints were and to individually deactivate or delete them. As it
321     ;;; is now we probably have to delete all for a given function. What about
322     ;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a
323     ;;; nice set such as something to simply print all locals at a certain
324     ;;; location.
325     ;;;
326 chiles 1.3 (defcommand "Debug Breakpoint" (p)
327     "This tries to set a breakpoint in the \"Current Eval Server\" at the
328     location designated by the current point. If there is no known code
329     location at the point, then this moves the point to the closest location
330 chiles 1.4 before the point. With an argument, this sets a breakpoint at the start
331     or end of the function, prompting the user for which one to use."
332 chiles 1.3 "This tries to set a breakpoint in the \"Current Eval Server\" at the
333     location designated by the current point. If there is no known code
334     location at the point, then this moves the point to the closest location
335 chiles 1.4 before the point. With an argument, this sets a breakpoint at the start
336     or end of the function, prompting the user for which one to use."
337     (let ((point (current-point)))
338     (pre-command-parse-check point)
339     (let ((name (find-defun-for-breakpoint point)))
340     (if p
341     (multiple-value-bind (str place)
342     (prompt-for-keyword
343     (list *function-breakpoint-strings*)
344     :prompt "Set breakpoint at function: "
345     :default :start :default-string "Start")
346     (declare (ignore str))
347     (set-breakpoint-in-slave (get-current-eval-server t) name place))
348     (let* ((path (find-path-for-breakpoint point))
349     (server-info (get-current-eval-server t))
350     (res (set-breakpoint-in-slave server-info name path)))
351     (cond ((not res)
352     (message "No code locations correspond with point."))
353     ((wire:remote-object-p res)
354     (push (make-breakpoint-info server-info (current-buffer)
355     res name)
356     *breakpoints*)
357     (message "Breakpoint set."))
358     (t
359     (resolve-ambiguous-breakpoint-location server-info
360     name res))))))))
361    
362     ;;; FIND-PATH-FOR-BREAKPOINT -- Internal.
363     ;;;
364     ;;; This walks up from point to the beginning of its containing DEFUN to return
365     ;;; the pseudo source-path (no form-number, no top-level form offset, and in
366     ;;; descent order from start of the DEFUN).
367     ;;;
368     (defun find-path-for-breakpoint (point)
369     (with-mark ((m point)
370     (end point))
371     (let ((path nil))
372     (top-level-offset end -1)
373     (with-mark ((containing-form m))
374     (loop
375     (when (mark= m end) (return))
376     (backward-up-list containing-form)
377     (do ((count 0 (1+ count)))
378     ((mark= m containing-form)
379     ;; Count includes moving from the first form inside the
380     ;; containing-form paren to the outside of the containing-form
381     ;; paren -- one too many.
382     (push (1- count) path))
383     (form-offset m -1))))
384     path)))
385    
386     ;;; SET-BREAKPOINT-IN-SLAVE -- Internal.
387     ;;;
388     ;;; This tells the slave to set a breakpoint for name. Path is a modified
389     ;;; source-path (with no form-number or top-level-form offset) or a symbol
390     ;;; (:function-start or :function-end). If the server dies while evaluating
391     ;;; form, then this signals an editor-error.
392     ;;;
393     (defun set-breakpoint-in-slave (server-info name path)
394     (when (server-info-notes server-info)
395     (editor-error "Server ~S is currently busy. See \"List Operations\"."
396     (server-info-name server-info)))
397     (multiple-value-bind (res error)
398     (wire:remote-value (server-info-wire server-info)
399     (di:set-breakpoint-for-editor (value current-package)
400     name path))
401     (when error (editor-error "The server died before finishing."))
402     res))
403    
404     ;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal.
405     ;;;
406     ;;; This helps the user select an ambiguous code location for "Debug
407     ;;; Breakpoint".
408     ;;;
409     (defun resolve-ambiguous-breakpoint-location (server-info name locs)
410     (declare (list locs))
411     (let ((point (current-point))
412     (loc-num (length locs))
413     (count 1)
414     (cur-loc locs))
415     (flet ((show-loc ()
416     (top-level-offset point -1)
417     (mark-to-debug-source-path point (cdar cur-loc))))
418     (show-loc)
419     (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num)
420     :help "Pick a location to set a breakpoint."
421     :change-window nil)
422     (#\space "Move point to next possible location."
423     (setf cur-loc (cdr cur-loc))
424     (cond (cur-loc
425     (incf count))
426     (t
427     (setf cur-loc locs)
428     (setf count 1)))
429     (show-loc)
430     (reprompt))
431     (:confirm "Choose the current location."
432     (let ((res (wire:remote-value (server-info-wire server-info)
433     (di:set-location-breakpoint-for-editor (caar cur-loc)))))
434     (unless (wire:remote-object-p res)
435     (editor-error "Couldn't set breakpoint from location?"))
436     (push (make-breakpoint-info server-info (current-buffer) res name)
437     *breakpoints*))
438     (message "Breakpoint set."))))))
439    
440     ;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal.
441     ;;;
442     ;;; This takes a mark at the beginning of a top-level form and modified debugger
443     ;;; source-path. Path has no form number or top-level-form offset element, and
444     ;;; it has been reversed to actually be usable.
445     ;;;
446     (defun mark-to-debug-source-path (mark path)
447     (let ((quote-or-function nil))
448     (pre-command-parse-check mark)
449     (dolist (n path)
450     (when quote-or-function
451     (editor-error
452     "Apparently settled on the symbol QUOTE or FUNCTION via their ~
453     read macros, which is odd, but furthermore there seems to be ~
454     more source-path left."))
455     (unless (form-offset mark 1)
456     ;; Want to use the following and delete the next FORM-OFFSET -1.
457     ;; (scan-direction-valid mark t (or :open-paren :prefix))
458     (editor-error
459     "Ran out of text in buffer with more source-path remaining."))
460     (form-offset mark -1)
461     (ecase (next-character mark)
462     (#\(
463     (mark-after mark)
464     (form-offset mark n))
465     (#\'
466     (case n
467     (0 (setf quote-or-function t))
468     (1 (mark-after mark))
469     (t (editor-error "Next form is QUOTE, but source-path index ~
470     is other than zero or one."))))
471     (#\#
472     (case (next-character (mark-after mark))
473     (#\'
474     (case n
475     (0 (setf quote-or-function t))
476     (1 (mark-after mark))
477     (t (editor-error "Next form is FUNCTION, but source-path ~
478     index is other than zero or one."))))
479     (t (editor-error
480     "Can only parse ' and #' read macros."))))))
481     ;; Get to the beginning of the form.
482     (form-offset mark 1)
483     (form-offset mark -1)))
484    
485     ;;;
486     ;;; Deleting breakpoints.
487     ;;;
488    
489     (defhvar "Delete Breakpoints Confirm"
490     "This determines whether \"Debug Delete Breakpoints\" should ask for
491     confirmation before deleting breakpoints."
492     :value t)
493    
494     (defcommand "Debug Delete Breakpoints" (p)
495     "This deletes all breakpoints for the named DEFUN containing the point.
496     This affects the \"Current Eval Server\"."
497     "This deletes all breakpoints for the named DEFUN containing the point.
498     This affects the \"Current Eval Server\"."
499 chiles 1.3 (declare (ignore p))
500 chiles 1.4 (let* ((server-info (get-current-eval-server t))
501     (wire (server-info-wire server-info))
502     (name (find-defun-for-breakpoint (current-point)))
503     (bpts (slave-breakpoints server-info)))
504     (cond ((not bpts)
505     (message "No breakpoints recorded for ~A." name))
506     ((or (not (value delete-breakpoints-confirm))
507     (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name)
508     :default t
509     :default-string "Y"))
510     (dolist (b bpts)
511     (when (string= name (breakpoint-info-name b))
512     (setf *breakpoints* (delete b *breakpoints*))
513     (wire:remote wire
514     (di:delete-breakpoint-for-editor
515     (breakpoint-info-remote-object b)))))
516     (wire:wire-force-output wire)))))
517    
518     ;;;
519     ;;; Breakpoint utilities.
520     ;;;
521    
522     ;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal.
523     ;;;
524     ;;; This returns as a string the name of the DEFUN containing point. It
525     ;;; signals any errors necessary to ensure "we are in good form".
526     ;;;
527     (defun find-defun-for-breakpoint (point)
528     (with-mark ((m1 point)
529     (m2 point))
530     (unless (top-level-offset m2 -1)
531     (editor-error "Must be inside a DEFUN."))
532     ;;
533     ;; Check for DEFUN.
534     (mark-after (move-mark m1 m2))
535     (unless (find-attribute m1 :whitespace #'zerop)
536     (editor-error "Must be inside a DEFUN."))
537     (word-offset (move-mark m2 m1) 1)
538     (unless (string-equal (region-to-string (region m1 m2)) "defun")
539     (editor-error "Must be inside a DEFUN."))
540     ;;
541     ;; Find name.
542     (unless (find-attribute m2 :whitespace #'zerop)
543     (editor-error "Function unnamed?"))
544     (form-offset (move-mark m1 m2) 1)
545     (region-to-string (region m2 m1))))
546    
547    
548 chiles 1.3
549     ;;;; Miscellaneous commands.
550 chiles 1.1
551     (define-debugger-command "Flush Errors"
552     "In the \"Current Eval Server\", toggles whether the debugger ignores errors
553     or recursively enters itself."
554     :flush)

  ViewVC Help
Powered by ViewVC 1.1.5