Mercurial > hg > xemacs-beta
comparison lisp/edebug/edebug.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | b82b59fe008d |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:376386a54a3c |
---|---|
1 ;;; edebug.el --- a source-level debugger for Emacs Lisp | |
2 | |
3 ;; Copyright (C) 1988,'89,'90,'91,'92,'93,'94,'95 Free Software Foundation, Inc | |
4 | |
5 ;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> | |
6 ;; Keywords: lisp, tools, maint | |
7 | |
8 ;; LCD Archive Entry: | |
9 ;; edebug|Daniel LaLiberte|liberte@cs.uiuc.edu | |
10 ;; |A source level debugger for Emacs Lisp. | |
11 ;; |$Date: 1996/12/18 03:33:28 $|$Revision: 1.1.1.1 $|~/modes/edebug.el| | |
12 | |
13 ;; This file is part of GNU Emacs. | |
14 | |
15 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
16 ;; it under the terms of the GNU General Public License as published by | |
17 ;; the Free Software Foundation; either version 2, or (at your option) | |
18 ;; any later version. | |
19 | |
20 ;; GNU Emacs is distributed in the hope that it will be useful, | |
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
23 ;; GNU General Public License for more details. | |
24 | |
25 ;; You should have received a copy of the GNU General Public License | |
26 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
27 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
28 | |
29 ;;;; Commentary: | |
30 | |
31 ;;; This minor mode allows programmers to step through Emacs Lisp | |
32 ;;; source code while executing functions. You can also set | |
33 ;;; breakpoints, trace (stopping at each expression), evaluate | |
34 ;;; expressions as if outside Edebug, reevaluate and display a list of | |
35 ;;; expressions, trap errors normally caught by debug, and display a | |
36 ;;; debug style backtrace. | |
37 | |
38 ;;;; Installation | |
39 ;;; ============= | |
40 | |
41 ;;; Put edebug.el in some directory in your load-path and | |
42 ;;; byte-compile it. Also read the beginning of edebug-epoch.el, | |
43 ;;; cl-specs.el, and edebug-cl-read.el if they apply to you. | |
44 | |
45 ;;; Unless you are using Emacs 19 which is already set up to use Edebug, | |
46 ;;; put the following forms in your .emacs file. | |
47 ;;; (define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form) | |
48 ;;; (autoload 'edebug-eval-top-level-form "edebug") | |
49 | |
50 ;;; If you wish to change the default edebug global command prefix, change: | |
51 ;;; (setq edebug-global-prefix "\C-xX") | |
52 | |
53 ;;; Other options, are described in the manual. | |
54 | |
55 ;;; In previous versions of Edebug, users were directed to set | |
56 ;;; `debugger' to `edebug-debug'. This is no longer necessary | |
57 ;;; since Edebug automatically sets it whenever Edebug is active. | |
58 | |
59 ;;;; Minimal Instructions | |
60 ;;; ===================== | |
61 | |
62 ;;; First evaluate a defun with C-xx, then run the function. Step | |
63 ;;; through the code with SPC, mark breakpoints with b, go until a | |
64 ;;; breakpoint is reached with g, and quit execution with q. Use the | |
65 ;;; "?" command in edebug to describe other commands. See edebug.tex | |
66 ;;; or the Emacs 19 Lisp Reference Manual for more instructions. | |
67 | |
68 ;;; Send me your enhancements, ideas, bugs, or fixes. | |
69 ;;; For bugs, you can call edebug-submit-bug-report if you have reporter.el. | |
70 ;;; There is an edebug mailing list if you want to keep up | |
71 ;;; with the latest developments. Requests to: edebug-request@cs.uiuc.edu | |
72 | |
73 ;;; Daniel LaLiberte 217-398-4114 | |
74 ;;; University of Illinois, Urbana-Champaign | |
75 ;;; Department of Computer Science | |
76 ;;; 1304 W Springfield | |
77 ;;; Urbana, IL 61801 | |
78 | |
79 ;;; uiucdcs!liberte | |
80 ;;; liberte@cs.uiuc.edu | |
81 | |
82 ;;; =============================== | |
83 ;;; For the early revision history, see edebug-history. | |
84 | |
85 (defconst edebug-version | |
86 (let ((raw-version "$Revision: 1.1.1.1 $")) | |
87 (substring raw-version (string-match "[0-9.]*" raw-version) | |
88 (match-end 0)))) | |
89 | |
90 (require 'backquote) | |
91 | |
92 ;; Emacs 18 doesnt have defalias. | |
93 (eval-and-compile | |
94 (or (fboundp 'defalias) (fset 'defalias 'fset))) | |
95 | |
96 | |
97 ;;;; Bug reporting | |
98 ;;; ============== | |
99 | |
100 (defconst edebug-maintainer-address "liberte@cs.uiuc.edu") | |
101 | |
102 (defun edebug-submit-bug-report () | |
103 "Submit, via mail, a bug report on edebug." | |
104 (interactive) | |
105 (require 'reporter) | |
106 (and (y-or-n-p "Do you really want to submit a report on edebug? ") | |
107 (reporter-submit-bug-report | |
108 edebug-maintainer-address | |
109 (concat "edebug.el " edebug-version) | |
110 (list 'edebug-setup-hook | |
111 'edebug-all-defs | |
112 'edebug-all-forms | |
113 'edebug-eval-macro-args | |
114 'edebug-stop-before-symbols | |
115 'edebug-save-windows | |
116 'edebug-save-displayed-buffer-points | |
117 'edebug-initial-mode | |
118 'edebug-trace | |
119 'edebug-test-coverage | |
120 'edebug-continue-kbd-macro | |
121 'edebug-print-length | |
122 'edebug-print-level | |
123 'edebug-print-circle | |
124 )))) | |
125 | |
126 | |
127 ;;;; Options | |
128 ;;; =============================== | |
129 | |
130 (defvar edebug-setup-hook nil | |
131 "*Functions to call before edebug is used. | |
132 Each time it is set to a new value, Edebug will call those functions | |
133 once and then `edebug-setup-hook' is reset to nil. You could use this | |
134 to load up Edebug specifications associated with a package you are | |
135 using but only when you also use Edebug.") | |
136 | |
137 (defvar edebug-all-defs nil | |
138 "*If non-nil, evaluation of any defining forms will instrument for Edebug. | |
139 This applies to `eval-defun', `eval-region', `eval-buffer', and | |
140 `eval-current-buffer'. `eval-region' is also called by | |
141 `eval-last-sexp', and `eval-print-last-sexp'. | |
142 | |
143 You can use the command `edebug-all-defs' to toggle the value of this | |
144 variable. You may wish to make it local to each buffer with | |
145 \(make-local-variable 'edebug-all-defs) in your | |
146 `emacs-lisp-mode-hook'.") | |
147 | |
148 (defvar edebug-all-forms nil | |
149 "*Non-nil evaluation of all forms will instrument for Edebug. | |
150 This doesn't apply to loading or evaluations in the minibuffer. | |
151 Use the command `edebug-all-forms' to toggle the value of this option.") | |
152 | |
153 (defvar edebug-eval-macro-args nil | |
154 "*Non-nil means all macro call arguments may be evaluated. | |
155 If this variable is nil, the default, Edebug will *not* wrap | |
156 macro call arguments as if they will be evaluated. | |
157 For each macro, a `edebug-form-spec' overrides this option. | |
158 So to specify exceptions for macros that have some arguments evaluated | |
159 and some not, you should specify an `edebug-form-spec'. | |
160 | |
161 This option is going away soon.") | |
162 | |
163 (defvar edebug-stop-before-symbols nil | |
164 "*Non-nil causes Edebug to stop before symbols as well as after. | |
165 In any case, a breakpoint or interrupt may stop before a symbol. | |
166 | |
167 This option is going away soon.") | |
168 | |
169 (defvar edebug-save-windows t | |
170 "*If non-nil, Edebug saves and restores the window configuration. | |
171 That takes some time, so if your program does not care what happens to | |
172 the window configurations, it is better to set this variable to nil. | |
173 | |
174 If the value is a list, only the listed windows are saved and | |
175 restored. | |
176 | |
177 `edebug-toggle-save-windows' may be used to change this variable.") | |
178 | |
179 (defvar edebug-save-displayed-buffer-points nil | |
180 "*If non-nil, save and restore point in all displayed buffers. | |
181 | |
182 Saving and restoring point in other buffers is necessary if you are | |
183 debugging code that changes the point of a buffer which is displayed | |
184 in a non-selected window. If Edebug or the user then selects the | |
185 window, the buffer's point will be changed to the window's point. | |
186 | |
187 Saving and restoring point in all buffers is expensive, since it | |
188 requires selecting each window twice, so enable this only if you need | |
189 it.") | |
190 | |
191 (defvar edebug-initial-mode 'step | |
192 "*Initial execution mode for Edebug, if non-nil. If this variable | |
193 is non-@code{nil}, it specifies the initial execution mode for Edebug | |
194 when it is first activated. Possible values are step, next, go, | |
195 Go-nonstop, trace, Trace-fast, continue, and Continue-fast.") | |
196 | |
197 (defvar edebug-trace nil | |
198 "*Non-nil means display a trace of function entry and exit. | |
199 Tracing output is displayed in a buffer named `*edebug-trace*', one | |
200 function entry or exit per line, indented by the recursion level. | |
201 | |
202 You can customize by replacing functions `edebug-print-trace-before' | |
203 and `edebug-print-trace-after'.") | |
204 | |
205 (defvar edebug-test-coverage nil | |
206 "*If non-nil, Edebug tests coverage of all expressions debugged. | |
207 This is done by comparing the result of each expression | |
208 with the previous result. Coverage is considered OK if two different | |
209 results are found. | |
210 | |
211 Use `edebug-display-freq-count' to display the frequency count and | |
212 coverage information for a definition.") | |
213 | |
214 (defvar edebug-continue-kbd-macro nil | |
215 "*If non-nil, continue defining or executing any keyboard macro. | |
216 Use this with caution since it is not debugged.") | |
217 | |
218 | |
219 (defvar edebug-print-length 50 | |
220 "*Default value of `print-length' to use while printing results in Edebug.") | |
221 (defvar edebug-print-level 50 | |
222 "*Default value of `print-level' to use while printing results in Edebug.") | |
223 (defvar edebug-print-circle t | |
224 "*Default value of `print-circle' to use while printing results in Edebug.") | |
225 | |
226 (defvar edebug-unwrap-results nil | |
227 "*Non-nil if Edebug should unwrap results of expressions. | |
228 This is useful when debugging macros where the results of expressions | |
229 are instrumented expressions. But don't do this when results might be | |
230 circular or an infinite loop will result.") | |
231 | |
232 (defvar edebug-on-error t | |
233 "*Value bound to `debug-on-error' while Edebug is active. | |
234 | |
235 If `debug-on-error' is non-nil, that value is still used. | |
236 | |
237 If the value is a list of signal names, Edebug will stop when any of | |
238 these errors are signaled from Lisp code whether or not the signal is | |
239 handled by a `condition-case'. This option is useful for debugging | |
240 signals that *are* handled since they would otherwise be missed. | |
241 After execution is resumed, the error is signaled again.") | |
242 | |
243 (defvar edebug-on-quit t | |
244 "*Value bound to `debug-on-quit' while Edebug is active.") | |
245 | |
246 (defvar edebug-global-break-condition nil | |
247 "*If non-nil, an expression to test for at every stop point. | |
248 If the result is non-nil, then break. Errors are ignored.") | |
249 | |
250 | |
251 ;;;; Form spec utilities. | |
252 ;;; =============================== | |
253 | |
254 ;;;###autoload | |
255 (defmacro def-edebug-spec (symbol spec) | |
256 "Set the edebug-form-spec property of SYMBOL according to SPEC. | |
257 Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol | |
258 \(naming a function), or a list." | |
259 (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec))))) | |
260 | |
261 (defmacro def-edebug-form-spec (symbol spec-form) | |
262 "For compatibility with old version. Use `def-edebug-spec' instead." | |
263 (message "Obsolete: use def-edebug-spec instead.") | |
264 (def-edebug-spec symbol (eval spec-form))) | |
265 | |
266 (defun get-edebug-spec (symbol) | |
267 ;; Get the spec of symbol resolving all indirection. | |
268 (let ((edebug-form-spec (get symbol 'edebug-form-spec)) | |
269 indirect) | |
270 (while (and (symbolp edebug-form-spec) | |
271 (setq indirect (get edebug-form-spec 'edebug-form-spec))) | |
272 ;; (edebug-trace "indirection: %s" edebug-form-spec) | |
273 (setq edebug-form-spec indirect)) | |
274 edebug-form-spec | |
275 )) | |
276 | |
277 | |
278 ;;;; Utilities | |
279 ;;; =============================== | |
280 | |
281 ;; Define edebug-gensym - from old cl.el | |
282 (defvar edebug-gensym-index 0 | |
283 "Integer used by `edebug-gensym' to produce new names.") | |
284 | |
285 (defun edebug-gensym (&optional prefix) | |
286 "Generate a fresh uninterned symbol. | |
287 There is an optional argument, PREFIX. PREFIX is the | |
288 string that begins the new name. Most people take just the default, | |
289 except when debugging needs suggest otherwise." | |
290 (if (null prefix) | |
291 (setq prefix "G")) | |
292 (let ((newsymbol nil) | |
293 (newname "")) | |
294 (while (not newsymbol) | |
295 (setq newname (concat prefix (int-to-string edebug-gensym-index))) | |
296 (setq edebug-gensym-index (+ edebug-gensym-index 1)) | |
297 (if (not (intern-soft newname)) | |
298 (setq newsymbol (make-symbol newname)))) | |
299 newsymbol)) | |
300 | |
301 ;; Only used by CL-like code. | |
302 (defun edebug-keywordp (object) | |
303 "Return t if OBJECT is a keyword. | |
304 A keyword is a symbol that starts with `:'." | |
305 (and (symbolp object) | |
306 (= ?: (aref (symbol-name object) 0)))) | |
307 | |
308 (defun edebug-lambda-list-keywordp (object) | |
309 "Return t if OBJECT is a lambda list keyword. | |
310 A lambda list keyword is a symbol that starts with `&'." | |
311 (and (symbolp object) | |
312 (= ?& (aref (symbol-name object) 0)))) | |
313 | |
314 | |
315 (defun edebug-last-sexp () | |
316 ;; Return the last sexp before point in current buffer. | |
317 ;; Assumes Emacs Lisp syntax is active. | |
318 (car | |
319 (read-from-string | |
320 (buffer-substring | |
321 (save-excursion | |
322 (forward-sexp -1) | |
323 (point)) | |
324 (point))))) | |
325 | |
326 (defun edebug-window-list () | |
327 "Return a list of windows, in order of `next-window'." | |
328 ;; This doesnt work for epoch. | |
329 (let* ((first-window (selected-window)) | |
330 (window-list (list first-window)) | |
331 (next (next-window first-window))) | |
332 (while (not (eq next first-window)) | |
333 (setq window-list (cons next window-list)) | |
334 (setq next (next-window next))) | |
335 (nreverse window-list))) | |
336 | |
337 (defun edebug-window-live-p (window) | |
338 "Return non-nil if WINDOW is visible." | |
339 (let* ((first-window (selected-window)) | |
340 (next (next-window first-window t))) | |
341 (while (not (or (eq next window) | |
342 (eq next first-window))) | |
343 (setq next (next-window next t))) | |
344 (eq next window))) | |
345 | |
346 ;; Not used. | |
347 '(defun edebug-two-window-p () | |
348 "Return t if there are two windows." | |
349 (and (not (one-window-p)) | |
350 (eq (selected-window) | |
351 (next-window (next-window (selected-window)))))) | |
352 | |
353 (defsubst edebug-lookup-function (object) | |
354 (while (and (symbolp object) (fboundp object)) | |
355 (setq object (symbol-function object))) | |
356 object) | |
357 | |
358 (defun edebug-macrop (object) | |
359 "Return the macro named by OBJECT, or nil if it is not a macro." | |
360 (setq object (edebug-lookup-function object)) | |
361 (if (and (listp object) | |
362 (eq 'macro (car object)) | |
363 (edebug-functionp (cdr object))) | |
364 object)) | |
365 | |
366 (defun edebug-functionp (object) | |
367 "Returns the function named by OBJECT, or nil if it is not a function." | |
368 (setq object (edebug-lookup-function object)) | |
369 (if (or (subrp object) | |
370 (byte-code-function-p object) | |
371 (and (listp object) | |
372 (eq (car object) 'lambda) | |
373 (listp (car (cdr object))))) | |
374 object)) | |
375 | |
376 (defun edebug-sort-alist (alist function) | |
377 ;; Return the ALIST sorted with comparison function FUNCTION. | |
378 ;; This uses 'sort so the sorting is destructive. | |
379 (sort alist (function | |
380 (lambda (e1 e2) | |
381 (funcall function (car e1) (car e2)))))) | |
382 | |
383 ;;(def-edebug-spec edebug-save-restriction t) | |
384 | |
385 ;; Not used. If it is used, def-edebug-spec must be defined before use. | |
386 '(defmacro edebug-save-restriction (&rest body) | |
387 "Evaluate BODY while saving the current buffers restriction. | |
388 BODY may change buffer outside of current restriction, unlike | |
389 save-restriction. BODY may change the current buffer, | |
390 and the restriction will be restored to the original buffer, | |
391 and the current buffer remains current. | |
392 Return the result of the last expression in BODY." | |
393 (` (let ((edebug:s-r-beg (point-min-marker)) | |
394 (edebug:s-r-end (point-max-marker))) | |
395 (unwind-protect | |
396 (progn (,@ body)) | |
397 (save-excursion | |
398 (set-buffer (marker-buffer edebug:s-r-beg)) | |
399 (narrow-to-region edebug:s-r-beg edebug:s-r-end)))))) | |
400 | |
401 ;;;; Display | |
402 ;;; ============ | |
403 | |
404 (defconst edebug-trace-buffer "*edebug-trace*" | |
405 "Name of the buffer to put trace info in.") | |
406 | |
407 (defun edebug-pop-to-buffer (buffer &optional window) | |
408 ;; Like pop-to-buffer, but select window where BUFFER was last shown. | |
409 ;; Select WINDOW if it provided and it still exists. Otherwise, | |
410 ;; if buffer is currently shown in several windows, choose one. | |
411 ;; Otherwise, find a new window, possibly splitting one. | |
412 (setq window (if (and (windowp window) (edebug-window-live-p window) | |
413 (eq (window-buffer window) buffer)) | |
414 window | |
415 (if (eq (window-buffer (selected-window)) buffer) | |
416 (selected-window) | |
417 (edebug-get-buffer-window buffer)))) | |
418 (if window | |
419 (select-window window) | |
420 (if (one-window-p) | |
421 (split-window)) | |
422 ;; (message "next window: %s" (next-window)) (sit-for 1) | |
423 (if (eq (get-buffer-window edebug-trace-buffer) (next-window)) | |
424 ;; Dont select trace window | |
425 nil | |
426 (select-window (next-window)))) | |
427 (set-window-buffer (selected-window) buffer) | |
428 (set-window-hscroll (selected-window) 0);; should this be?? | |
429 ;; Selecting the window does not set the buffer until command loop. | |
430 ;;(set-buffer buffer) | |
431 ) | |
432 | |
433 | |
434 (defun edebug-get-displayed-buffer-points () | |
435 ;; Return a list of buffer point pairs, for all displayed buffers. | |
436 (save-excursion | |
437 (let* ((first-window (selected-window)) | |
438 (next (next-window first-window)) | |
439 (buffer-point-list nil) | |
440 buffer) | |
441 (while (not (eq next first-window)) | |
442 (set-buffer (setq buffer (window-buffer next))) | |
443 (setq buffer-point-list | |
444 (cons (cons buffer (point)) buffer-point-list)) | |
445 (setq next (next-window next))) | |
446 buffer-point-list))) | |
447 | |
448 | |
449 (defun edebug-set-buffer-points (buffer-points) | |
450 ;; Restore the buffer-points created by edebug-get-displayed-buffer-points. | |
451 (let ((current-buffer (current-buffer))) | |
452 (mapcar (function (lambda (buf-point) | |
453 (if (buffer-name (car buf-point)) ; still exists | |
454 (progn | |
455 (set-buffer (car buf-point)) | |
456 (goto-char (cdr buf-point)))))) | |
457 buffer-points) | |
458 (set-buffer current-buffer))) | |
459 | |
460 (defun edebug-current-windows (which-windows) | |
461 ;; Get either a full window configuration or some window information. | |
462 (if (listp which-windows) | |
463 (mapcar (function (lambda (window) | |
464 (if (edebug-window-live-p window) | |
465 (list window | |
466 (window-buffer window) | |
467 (window-point window) | |
468 (window-start window) | |
469 (window-hscroll window))))) | |
470 which-windows) | |
471 (current-window-configuration))) | |
472 | |
473 (defun edebug-set-windows (window-info) | |
474 ;; Set either a full window configuration or some window information. | |
475 (if (listp window-info) | |
476 (mapcar (function | |
477 (lambda (one-window-info) | |
478 (if one-window-info | |
479 (apply (function | |
480 (lambda (window buffer point start hscroll) | |
481 (if (edebug-window-live-p window) | |
482 (progn | |
483 (set-window-buffer window buffer) | |
484 (set-window-point window point) | |
485 (set-window-start window start) | |
486 (set-window-hscroll window hscroll))))) | |
487 one-window-info)))) | |
488 window-info) | |
489 (set-window-configuration window-info))) | |
490 | |
491 (defalias 'edebug-get-buffer-window 'get-buffer-window) | |
492 (defalias 'edebug-sit-for 'sit-for) | |
493 (defalias 'edebug-input-pending-p 'input-pending-p) | |
494 | |
495 | |
496 ;;;; Redefine read and eval functions | |
497 ;;; ================================= | |
498 ;;; read is redefined to maybe instrument forms. | |
499 ;;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. | |
500 | |
501 ;;; Use the Lisp version of eval-region. | |
502 (require 'eval-reg "eval-reg") | |
503 | |
504 ;; Save the original read function | |
505 (or (fboundp 'edebug-original-read) | |
506 (defalias 'edebug-original-read (symbol-function 'read))) | |
507 | |
508 (defun edebug-read (&optional stream) | |
509 "Read one Lisp expression as text from STREAM, return as Lisp object. | |
510 If STREAM is nil, use the value of `standard-input' (which see). | |
511 STREAM or the value of `standard-input' may be: | |
512 a buffer (read from point and advance it) | |
513 a marker (read from where it points and advance it) | |
514 a function (call it with no arguments for each character, | |
515 call it with a char as argument to push a char back) | |
516 a string (takes text from string, starting at the beginning) | |
517 t (read text line using minibuffer and use it). | |
518 | |
519 This version, from Edebug, maybe instruments the expression. But the | |
520 STREAM must be the current buffer to do so. Whether it instuments is | |
521 also dependent on the values of `edebug-all-defs' and | |
522 `edebug-all-forms'." | |
523 (or stream (setq stream standard-input)) | |
524 (if (eq stream (current-buffer)) | |
525 (edebug-read-and-maybe-wrap-form) | |
526 (edebug-original-read stream))) | |
527 | |
528 (or (fboundp 'edebug-original-eval-defun) | |
529 (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) | |
530 | |
531 (defun edebug-eval-defun (edebug-it) | |
532 "Evaluate the top-level form containing point, or after point. | |
533 | |
534 This version, from Edebug, has the following differences: With a | |
535 prefix argument instrument the code for Edebug. If `edebug-all-defs' is | |
536 non-nil, then the code is instrumented *unless* there is a prefix | |
537 argument. If instrumenting, it prints: `Edebug: FUNCTIONNAME'. | |
538 Otherwise, it prints in the minibuffer." | |
539 (interactive "P") | |
540 (let ((edebugging (not (eq (not edebug-it) (not edebug-all-defs)))) | |
541 (edebug-result)) | |
542 (setq edebug-result | |
543 (eval | |
544 (let ((edebug-all-forms edebugging) | |
545 (edebug-all-defs (eq edebug-all-defs (not edebug-it)))) | |
546 (edebug-read-top-level-form)))) | |
547 (if (not edebugging) | |
548 (princ edebug-result) | |
549 edebug-result))) | |
550 | |
551 | |
552 ;;;###autoload | |
553 (defalias 'edebug-defun 'edebug-eval-top-level-form) | |
554 | |
555 ;;;###autoload | |
556 (defun edebug-eval-top-level-form () | |
557 "Evaluate a top level form, such as a defun or defmacro. | |
558 This is like `eval-defun', but the code is always instrumented for Edebug. | |
559 Print its name in the minibuffer and leave point where it is, | |
560 or if an error occurs, leave point after it with mark at the original point." | |
561 (interactive) | |
562 (eval | |
563 ;; Bind edebug-all-forms only while reading, not while evaling | |
564 ;; but this causes problems while edebugging edebug. | |
565 (let ((edebug-all-forms t) | |
566 (edebug-all-defs t)) | |
567 (edebug-read-top-level-form)))) | |
568 | |
569 | |
570 (defun edebug-read-top-level-form () | |
571 (let ((starting-point (point))) | |
572 (end-of-defun) | |
573 (beginning-of-defun) | |
574 (prog1 | |
575 (edebug-read-and-maybe-wrap-form) | |
576 ;; Recover point, but only if no error occurred. | |
577 (goto-char starting-point)))) | |
578 | |
579 | |
580 ;; Compatibility with old versions. | |
581 (defalias 'edebug-all-defuns 'edebug-all-defs) | |
582 | |
583 (defun edebug-all-defs () | |
584 "Toggle edebugging of all definitions." | |
585 (interactive) | |
586 (setq edebug-all-defs (not edebug-all-defs)) | |
587 (message "Edebugging all definitions is %s." | |
588 (if edebug-all-defs "on" "off"))) | |
589 | |
590 | |
591 (defun edebug-all-forms () | |
592 "Toggle edebugging of all forms." | |
593 (interactive) | |
594 (setq edebug-all-forms (not edebug-all-forms)) | |
595 (message "Edebugging all forms is %s." | |
596 (if edebug-all-forms "on" "off"))) | |
597 | |
598 | |
599 (defun edebug-install-read-eval-functions () | |
600 (interactive) | |
601 ;; Don't install if already installed. | |
602 (if (eq (symbol-function 'read) 'edebug-read) nil | |
603 (elisp-eval-region-install) | |
604 (defalias 'read 'edebug-read) | |
605 (defalias 'eval-defun 'edebug-eval-defun))) | |
606 | |
607 (defun edebug-uninstall-read-eval-functions () | |
608 (interactive) | |
609 (elisp-eval-region-uninstall) | |
610 (defalias 'read (symbol-function 'edebug-original-read)) | |
611 (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun))) | |
612 | |
613 | |
614 ;;;; Edebug internal data | |
615 ;;; =============================== | |
616 | |
617 ;;; The internal data that is needed for edebugging is kept in the | |
618 ;;; buffer-local variable `edebug-form-data'. | |
619 | |
620 ;; XEmacs change? | |
621 (defconst edebug-form-data nil) | |
622 (make-variable-buffer-local 'edebug-form-data) | |
623 | |
624 ;; A list of entries associating symbols with buffer regions. | |
625 ;; This is an automatic buffer local variable. Each entry looks like: | |
626 ;; @code{(@var{symbol} @var{begin-marker} @var{end-marker}). The markers | |
627 ;; are at the beginning and end of an entry level form and @var{symbol} is | |
628 ;; a symbol that holds all edebug related information for the form on its | |
629 ;; property list. | |
630 | |
631 ;; In the future, the symbol will be irrelevant and edebug data will | |
632 ;; be stored in the definitions themselves rather than in the property | |
633 ;; list of a symbol. | |
634 | |
635 (defun edebug-make-form-data-entry (symbol begin end) | |
636 (list symbol begin end)) | |
637 | |
638 (defsubst edebug-form-data-name (entry) | |
639 (car entry)) | |
640 | |
641 (defsubst edebug-form-data-begin (entry) | |
642 (nth 1 entry)) | |
643 | |
644 (defsubst edebug-form-data-end (entry) | |
645 (nth 2 entry)) | |
646 | |
647 (defsubst edebug-set-form-data-entry (entry name begin end) | |
648 (setcar entry name);; in case name is changed | |
649 (set-marker (nth 1 entry) begin) | |
650 (set-marker (nth 2 entry) end)) | |
651 | |
652 (defun edebug-get-form-data-entry (pnt &optional end-point) | |
653 ;; Find the edebug form data entry which is closest to PNT. | |
654 ;; If END-POINT is supplied, match must be exact. | |
655 ;; Return `nil' if none found. | |
656 (let ((rest edebug-form-data) | |
657 closest-entry | |
658 (closest-dist 999999)) ;; need maxint here | |
659 (while (and rest (< 0 closest-dist)) | |
660 (let* ((entry (car rest)) | |
661 (begin (edebug-form-data-begin entry)) | |
662 (dist (- pnt begin))) | |
663 (setq rest (cdr rest)) | |
664 (if (and (<= 0 dist) | |
665 (< dist closest-dist) | |
666 (or (not end-point) | |
667 (= end-point (edebug-form-data-end entry))) | |
668 (<= pnt (edebug-form-data-end entry))) | |
669 (setq closest-dist dist | |
670 closest-entry entry)))) | |
671 closest-entry)) | |
672 | |
673 ;; Also need to find all contained entries, | |
674 ;; and find an entry given a symbol, which should be just assq. | |
675 | |
676 (defun edebug-form-data-symbol () | |
677 ;; Return the edebug data symbol of the form where point is in. | |
678 ;; If point is not inside a edebuggable form, cause error. | |
679 (or (edebug-form-data-name (edebug-get-form-data-entry (point))) | |
680 (error "Not inside instrumented form"))) | |
681 | |
682 (defun edebug-make-top-form-data-entry (new-entry) | |
683 ;; Make NEW-ENTRY the first element in the `edebug-form-data' list. | |
684 (edebug-clear-form-data-entry new-entry) | |
685 (setq edebug-form-data (cons new-entry edebug-form-data))) | |
686 | |
687 (defun edebug-clear-form-data-entry (entry) | |
688 ;; If non-nil, clear ENTRY out of the form data. | |
689 ;; Maybe clear the markers and delete the symbol's edebug property? | |
690 (if entry | |
691 (progn | |
692 ;; Instead of this, we could just find all contained forms. | |
693 ;; (put (car entry) 'edebug nil) ; | |
694 ;; (mapcar 'edebug-clear-form-data-entry ; dangerous | |
695 ;; (get (car entry) 'edebug-dependents)) | |
696 ;; (set-marker (nth 1 entry) nil) | |
697 ;; (set-marker (nth 2 entry) nil) | |
698 (setq edebug-form-data (delq entry edebug-form-data))))) | |
699 | |
700 | |
701 ;;;; Parser utilities | |
702 ;;; =============================== | |
703 | |
704 | |
705 (defun edebug-syntax-error (&rest args) | |
706 ;; Signal an invalid-read-syntax with ARGS. | |
707 (signal 'invalid-read-syntax args)) | |
708 | |
709 | |
710 (defconst edebug-read-syntax-table | |
711 ;; Lookup table for significant characters indicating the class of the | |
712 ;; token that follows. This is not a \"real\" syntax table. | |
713 (let ((table (make-vector 256 'symbol)) | |
714 (i 0)) | |
715 (while (< i ?!) | |
716 (aset table i 'space) | |
717 (setq i (1+ i))) | |
718 (aset table ?\( 'lparen) | |
719 (aset table ?\) 'rparen) | |
720 (aset table ?\' 'quote) | |
721 (aset table ?\" 'string) | |
722 (aset table ?\? 'char) | |
723 (aset table ?\[ 'lbracket) | |
724 (aset table ?\] 'rbracket) | |
725 (aset table ?\. 'dot) | |
726 (aset table ?\# 'hash) | |
727 ;; We treat numbers as symbols, because of confusion with -, -1, and 1-. | |
728 ;; We dont care about any other chars since they wont be seen. | |
729 table)) | |
730 | |
731 (defun edebug-next-token-class () | |
732 ;; Move to the next token and return its class. We only care about | |
733 ;; lparen, rparen, dot, quote, string, char, vector, or symbol. | |
734 (edebug-skip-whitespace) | |
735 (aref edebug-read-syntax-table (following-char))) | |
736 | |
737 | |
738 (defun edebug-skip-whitespace () | |
739 ;; Leave point before the next token, skipping white space and comments. | |
740 (skip-chars-forward " \t\r\n\f") | |
741 (while (= (following-char) ?\;) | |
742 ;; \r is counted as a comment terminator to support selective display. | |
743 (skip-chars-forward "^\n\r") ; skip the comment | |
744 (skip-chars-forward " \t\r\n\f"))) | |
745 | |
746 | |
747 ;; Mostly obsolete reader; still used in one case. | |
748 | |
749 (defun edebug-read-sexp () | |
750 ;; Read one sexp from the current buffer starting at point. | |
751 ;; Leave point immediately after it. A sexp can be a list or atom. | |
752 ;; An atom is a symbol (or number), character, string, or vector. | |
753 ;; This works for reading anything legitimate, but it | |
754 ;; is gummed up by parser inconsistencies (bugs?) | |
755 (let ((class (edebug-next-token-class))) | |
756 (cond | |
757 ;; read goes one too far if a (possibly quoted) string or symbol | |
758 ;; is immediately followed by non-whitespace. | |
759 ((eq class 'symbol) (prog1 | |
760 (edebug-original-read (current-buffer)) | |
761 (if (not (eq (aref edebug-read-syntax-table | |
762 (preceding-char)) 'symbol)) | |
763 (forward-char -1)))) | |
764 ((eq class 'string) (prog1 | |
765 (edebug-original-read (current-buffer)) | |
766 (if (/= (preceding-char) ?\") | |
767 (forward-char -1)))) | |
768 ((eq class 'quote) (forward-char 1) | |
769 (list 'quote (edebug-read-sexp))) | |
770 (t ; anything else, just read it. | |
771 (edebug-original-read (current-buffer)))))) | |
772 | |
773 | |
774 ;;;; Offsets for reader | |
775 ;;; ============================== | |
776 | |
777 ;; Define a structure to represent offset positions of expressions. | |
778 ;; Each offset structure looks like: (before . after) for constituents, | |
779 ;; or for structures that have elements: (before <subexpressions> . after) | |
780 ;; where the <subexpressions> are the offset structures for subexpressions | |
781 ;; including the head of a list. | |
782 (defconst edebug-offsets nil) | |
783 | |
784 ;; Stack of offset structures in reverse order of the nesting. | |
785 ;; This is used to get back to previous levels. | |
786 (defconst edebug-offsets-stack nil) | |
787 (defconst edebug-current-offset nil) ; Top of the stack, for convenience. | |
788 | |
789 ;; We must store whether we just read a list with a dotted form that | |
790 ;; is itself a list. This structure will be condensed, so the offsets | |
791 ;; must also be condensed. | |
792 (defconst edebug-read-dotted-list nil) | |
793 | |
794 (defsubst edebug-initialize-offsets () | |
795 ;; Reinitialize offset recording. | |
796 (setq edebug-current-offset nil)) | |
797 | |
798 (defun edebug-store-before-offset (point) | |
799 ;; Add a new offset pair with POINT as the before offset. | |
800 (let ((new-offset (list point))) | |
801 (if edebug-current-offset | |
802 (setcdr edebug-current-offset | |
803 (cons new-offset (cdr edebug-current-offset))) | |
804 ;; Otherwise, we are at the top level, so initialize. | |
805 (setq edebug-offsets new-offset | |
806 edebug-offsets-stack nil | |
807 edebug-read-dotted-list nil)) | |
808 ;; Cons the new offset to the front of the stack. | |
809 (setq edebug-offsets-stack (cons new-offset edebug-offsets-stack) | |
810 edebug-current-offset new-offset) | |
811 )) | |
812 | |
813 (defun edebug-store-after-offset (point) | |
814 ;; Finalize the current offset struct by reversing it and | |
815 ;; store POINT as the after offset. | |
816 (if (not edebug-read-dotted-list) | |
817 ;; Just reverse the offsets of all subexpressions. | |
818 (setcdr edebug-current-offset (nreverse (cdr edebug-current-offset))) | |
819 | |
820 ;; We just read a list after a dot, which will be abbreviated out. | |
821 (setq edebug-read-dotted-list nil) | |
822 ;; Drop the corresponding offset pair. | |
823 ;; That is, nconc the reverse of the rest of the offsets | |
824 ;; with the cdr of last offset. | |
825 (setcdr edebug-current-offset | |
826 (nconc (nreverse (cdr (cdr edebug-current-offset))) | |
827 (cdr (car (cdr edebug-current-offset)))))) | |
828 | |
829 ;; Now append the point using nconc. | |
830 (setq edebug-current-offset (nconc edebug-current-offset point)) | |
831 ;; Pop the stack. | |
832 (setq edebug-offsets-stack (cdr edebug-offsets-stack) | |
833 edebug-current-offset (car edebug-offsets-stack))) | |
834 | |
835 (defun edebug-ignore-offset () | |
836 ;; Ignore the last created offset pair. | |
837 (setcdr edebug-current-offset (cdr (cdr edebug-current-offset)))) | |
838 | |
839 (def-edebug-spec edebug-storing-offsets (form body)) | |
840 (put 'edebug-storing-offsets 'lisp-indent-hook 1) | |
841 | |
842 (defmacro edebug-storing-offsets (point &rest body) | |
843 (` (unwind-protect | |
844 (progn | |
845 (edebug-store-before-offset (, point)) | |
846 (,@ body)) | |
847 (edebug-store-after-offset (point))))) | |
848 | |
849 | |
850 ;;;; Reader for Emacs Lisp. | |
851 ;;; ========================================== | |
852 ;; Uses edebug-next-token-class (and edebug-skip-whitespace) above. | |
853 | |
854 (defconst edebug-read-alist | |
855 '((symbol . edebug-read-symbol) | |
856 (lparen . edebug-read-list) | |
857 (string . edebug-read-string) | |
858 (quote . edebug-read-quote) | |
859 (lbracket . edebug-read-vector) | |
860 (hash . edebug-read-function) | |
861 )) | |
862 | |
863 (defun edebug-read-storing-offsets (stream) | |
864 (let ((class (edebug-next-token-class)) | |
865 func | |
866 edebug-read-dotted-list) ; see edebug-store-after-offset | |
867 (edebug-storing-offsets (point) | |
868 (if (setq func (assq class edebug-read-alist)) | |
869 (funcall (cdr func) stream) | |
870 ;; anything else, just read it. | |
871 (edebug-original-read stream)) | |
872 ))) | |
873 | |
874 (defun edebug-read-symbol (stream) | |
875 (prog1 | |
876 (edebug-original-read stream) | |
877 ;; loses for escaped chars | |
878 (if (not (eq (aref edebug-read-syntax-table | |
879 (preceding-char)) 'symbol)) | |
880 (forward-char -1)))) | |
881 | |
882 (defun edebug-read-string (stream) | |
883 (prog1 | |
884 (edebug-original-read stream) | |
885 (if (/= (preceding-char) ?\") | |
886 (forward-char -1)))) | |
887 | |
888 (defun edebug-read-quote (stream) | |
889 ;; Turn 'thing into (quote thing) | |
890 (forward-char 1) | |
891 (list | |
892 (edebug-storing-offsets (point) 'quote) | |
893 (edebug-read-storing-offsets stream))) | |
894 | |
895 (defun edebug-read-function (stream) | |
896 ;; Turn #'thing into (function thing) | |
897 (forward-char 1) | |
898 (if (/= ?\' (following-char)) (edebug-syntax-error "Bad char")) | |
899 (forward-char 1) | |
900 (list | |
901 (edebug-storing-offsets (point) | |
902 (if (featurep 'cl) 'function* 'function)) | |
903 (edebug-read-storing-offsets stream))) | |
904 | |
905 (defun edebug-read-list (stream) | |
906 (forward-char 1) ; skip \( | |
907 (prog1 | |
908 (let ((elements)) | |
909 (while (not (memq (edebug-next-token-class) '(rparen dot))) | |
910 (setq elements (cons (edebug-read-storing-offsets stream) elements))) | |
911 (setq elements (nreverse elements)) | |
912 (if (eq 'dot (edebug-next-token-class)) | |
913 (let (dotted-form) | |
914 (forward-char 1) ; skip \. | |
915 (setq dotted-form (edebug-read-storing-offsets stream)) | |
916 elements (nconc elements dotted-form) | |
917 (if (not (eq (edebug-next-token-class) 'rparen)) | |
918 (edebug-syntax-error "Expected `)'")) | |
919 (setq edebug-read-dotted-list (listp dotted-form)) | |
920 )) | |
921 elements) | |
922 (forward-char 1) ; skip \) | |
923 )) | |
924 | |
925 (defun edebug-read-vector (stream) | |
926 (forward-char 1) ; skip \[ | |
927 (prog1 | |
928 (let ((elements)) | |
929 (while (not (eq 'rbracket (edebug-next-token-class))) | |
930 (setq elements (cons (edebug-read-storing-offsets stream) elements))) | |
931 (apply 'vector (nreverse elements))) | |
932 (forward-char 1) ; skip \] | |
933 )) | |
934 | |
935 | |
936 | |
937 ;;;; Cursors for traversal of list and vector elements with offsets. | |
938 ;;;==================================================================== | |
939 | |
940 (defvar edebug-dotted-spec nil) | |
941 | |
942 (defun edebug-new-cursor (expressions offsets) | |
943 ;; Return a new cursor for EXPRESSIONS with OFFSETS. | |
944 (if (vectorp expressions) | |
945 (setq expressions (append expressions nil))) | |
946 (cons expressions offsets)) | |
947 | |
948 (defsubst edebug-set-cursor (cursor expressions offsets) | |
949 ;; Set the CURSOR's EXPRESSIONS and OFFSETS to the given. | |
950 ;; Return the cursor. | |
951 (setcar cursor expressions) | |
952 (setcdr cursor offsets) | |
953 cursor) | |
954 | |
955 '(defun edebug-copy-cursor (cursor) | |
956 ;; Copy the cursor using the same object and offsets. | |
957 (cons (car cursor) (cdr cursor))) | |
958 | |
959 (defsubst edebug-cursor-expressions (cursor) | |
960 (car cursor)) | |
961 (defsubst edebug-cursor-offsets (cursor) | |
962 (cdr cursor)) | |
963 | |
964 (defsubst edebug-empty-cursor (cursor) | |
965 ;; Return non-nil if CURSOR is empty - meaning no more elements. | |
966 (null (car cursor))) | |
967 | |
968 (defsubst edebug-top-element (cursor) | |
969 ;; Return the top element at the cursor. | |
970 ;; Assumes not empty. | |
971 (car (car cursor))) | |
972 | |
973 (defun edebug-top-element-required (cursor &rest error) | |
974 ;; Check if a dotted form is required. | |
975 (if edebug-dotted-spec (edebug-no-match cursor "Dot expected.")) | |
976 ;; Check if there is at least one more argument. | |
977 (if (edebug-empty-cursor cursor) (apply 'edebug-no-match cursor error)) | |
978 ;; Return that top element. | |
979 (edebug-top-element cursor)) | |
980 | |
981 (defsubst edebug-top-offset (cursor) | |
982 ;; Return the top offset pair corresponding to the top element. | |
983 (car (cdr cursor))) | |
984 | |
985 (defun edebug-move-cursor (cursor) | |
986 ;; Advance and return the cursor to the next element and offset. | |
987 ;; throw no-match if empty before moving. | |
988 ;; This is a violation of the cursor encapsulation, but | |
989 ;; there is plenty of that going on while matching. | |
990 ;; The following test should always fail. | |
991 (if (edebug-empty-cursor cursor) | |
992 (edebug-no-match cursor "Not enough arguments.")) | |
993 (setcar cursor (cdr (car cursor))) | |
994 (setcdr cursor (cdr (cdr cursor))) | |
995 cursor) | |
996 | |
997 | |
998 (defun edebug-before-offset (cursor) | |
999 ;; Return the before offset of the cursor. | |
1000 ;; If there is nothing left in the offsets, | |
1001 ;; return one less than the offset itself, | |
1002 ;; which is the after offset for a list. | |
1003 (let ((offset (edebug-cursor-offsets cursor))) | |
1004 (if (consp offset) | |
1005 (car (car offset)) | |
1006 (1- offset)))) | |
1007 | |
1008 (defun edebug-after-offset (cursor) | |
1009 ;; Return the after offset of the cursor object. | |
1010 (let ((offset (edebug-top-offset cursor))) | |
1011 (while (consp offset) | |
1012 (setq offset (cdr offset))) | |
1013 offset)) | |
1014 | |
1015 ;;;; The Parser | |
1016 ;;; =============================== | |
1017 | |
1018 ;;; The top level function for parsing forms is | |
1019 ;;; edebug-read-and-maybe-wrap-form; it calls all the rest. It checks the | |
1020 ;;; syntax a bit and leaves point at any error it finds, but otherwise | |
1021 ;;; should appear to work like eval-defun. | |
1022 | |
1023 ;;; The basic plan is to surround each expression with a call to | |
1024 ;;; the edebug debugger together with indexes into a table of positions of | |
1025 ;;; all expressions. Thus an expression "exp" becomes: | |
1026 | |
1027 ;;; (edebug-after (edebug-before 1) 2 exp) | |
1028 | |
1029 ;;; When this is evaluated, first point is moved to the beginning of | |
1030 ;;; exp at offset 1 of the current function. The expression is | |
1031 ;;; evaluated, which may cause more edebug calls, and then point is | |
1032 ;;; moved to offset 2 after the end of exp. | |
1033 | |
1034 ;;; The highest level expressions of the function are wrapped in a call to | |
1035 ;;; edebug-enter, which supplies the function name and the actual | |
1036 ;;; arguments to the function. See functions edebug-enter, edebug-before, | |
1037 ;;; and edebug-after for more details. | |
1038 | |
1039 ;; Dynamically bound vars, left unbound, but globally declared. | |
1040 ;; This is to quiet the byte compiler. | |
1041 | |
1042 ;; Window data of the highest definition being wrapped. | |
1043 ;; This data is shared by all embedded definitions. | |
1044 (defvar edebug-top-window-data) | |
1045 | |
1046 (defvar edebug-&optional) | |
1047 (defvar edebug-&rest) | |
1048 (defvar edebug-gate nil) ;; whether no-match forces an error. | |
1049 | |
1050 (defconst edebug-def-name nil) ; name of definition, used by interactive-form | |
1051 (defconst edebug-old-def-name nil) ; previous name of containing definition. | |
1052 | |
1053 (defconst edebug-error-point nil) | |
1054 (defconst edebug-best-error nil) | |
1055 | |
1056 | |
1057 (defun edebug-read-and-maybe-wrap-form () | |
1058 ;; Read a form and wrap it with edebug calls, if the conditions are right. | |
1059 ;; Here we just catch any no-match not caught below and signal an error. | |
1060 | |
1061 ;; Run the setup hook. | |
1062 (run-hooks 'edebug-setup-hook) | |
1063 (setq edebug-setup-hook nil) | |
1064 | |
1065 (let (result | |
1066 edebug-top-window-data | |
1067 edebug-def-name;; make sure it is locally nil | |
1068 ;; I dont like these here!! | |
1069 edebug-&optional | |
1070 edebug-&rest | |
1071 edebug-gate | |
1072 edebug-best-error | |
1073 edebug-error-point | |
1074 no-match | |
1075 ;; Do this once here instead of several times. | |
1076 (max-lisp-eval-depth (+ 800 max-lisp-eval-depth)) | |
1077 (max-specpdl-size (+ 2000 max-specpdl-size))) | |
1078 (setq no-match | |
1079 (catch 'no-match | |
1080 (setq result (edebug-read-and-maybe-wrap-form1)) | |
1081 nil)) | |
1082 (if no-match | |
1083 (apply 'edebug-syntax-error no-match)) | |
1084 result)) | |
1085 | |
1086 | |
1087 (defun edebug-read-and-maybe-wrap-form1 () | |
1088 (let (spec | |
1089 def-kind | |
1090 defining-form-p | |
1091 def-name | |
1092 ;; These offset things dont belong here, but to support recursive | |
1093 ;; calls to edebug-read, they need to be here. | |
1094 edebug-offsets | |
1095 edebug-offsets-stack | |
1096 edebug-current-offset ; reset to nil | |
1097 ) | |
1098 (save-excursion | |
1099 (if (and (eq 'lparen (edebug-next-token-class)) | |
1100 (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) | |
1101 ;; Find out if this is a defining form from first symbol | |
1102 (setq def-kind (edebug-original-read (current-buffer)) | |
1103 spec (and (symbolp def-kind) (get-edebug-spec def-kind)) | |
1104 defining-form-p (and (listp spec) | |
1105 (eq '&define (car spec))) | |
1106 ;; This is incorrect in general!! But OK most of the time. | |
1107 def-name (if (and defining-form-p | |
1108 (eq 'name (car (cdr spec))) | |
1109 (eq 'symbol (edebug-next-token-class))) | |
1110 (edebug-original-read (current-buffer)))))) | |
1111 ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) | |
1112 (cond | |
1113 (defining-form-p | |
1114 (if (or edebug-all-defs edebug-all-forms) | |
1115 ;; If it is a defining form and we are edebugging defs, | |
1116 ;; then let edebug-list-form start it. | |
1117 (let ((cursor (edebug-new-cursor | |
1118 (list (edebug-read-storing-offsets (current-buffer))) | |
1119 (list edebug-offsets)))) | |
1120 (car | |
1121 (edebug-make-form-wrapper | |
1122 cursor | |
1123 (edebug-before-offset cursor) | |
1124 (1- (edebug-after-offset cursor)) | |
1125 (list (cons (symbol-name def-kind) (cdr spec)))))) | |
1126 | |
1127 ;; Not edebugging this form, so reset the symbol's edebug | |
1128 ;; property to be just a marker at the definition's source code. | |
1129 ;; This only works for defs with simple names. | |
1130 (put def-name 'edebug (point-marker)) | |
1131 ;; Also nil out dependent defs. | |
1132 '(mapcar (function | |
1133 (lambda (def) | |
1134 (put def-name 'edebug nil))) | |
1135 (get def-name 'edebug-dependents)) | |
1136 (edebug-read-sexp))) | |
1137 | |
1138 ;; If all forms are being edebugged, explicitly wrap it. | |
1139 (edebug-all-forms | |
1140 (let ((cursor (edebug-new-cursor | |
1141 (list (edebug-read-storing-offsets (current-buffer))) | |
1142 (list edebug-offsets)))) | |
1143 (edebug-make-form-wrapper | |
1144 cursor | |
1145 (edebug-before-offset cursor) | |
1146 (edebug-after-offset cursor) | |
1147 nil))) | |
1148 | |
1149 ;; Not a defining form, and not edebugging. | |
1150 (t (edebug-read-sexp))) | |
1151 )) | |
1152 | |
1153 | |
1154 (defvar edebug-def-args) ; args of defining form. | |
1155 (defvar edebug-def-interactive) ; is it an emacs interactive function? | |
1156 (defvar edebug-inside-func) ;; whether code is inside function context. | |
1157 ;; Currently def-form sets this to nil; def-body sets it to t. | |
1158 | |
1159 (defun edebug-interactive-p-name () | |
1160 ;; Return a unique symbol for the variable used to store the | |
1161 ;; status of interactive-p for this function. | |
1162 (intern (format "edebug-%s-interactive-p" edebug-def-name))) | |
1163 | |
1164 | |
1165 (defun edebug-wrap-def-body (forms) | |
1166 "Wrap the FORMS of a definition body." | |
1167 (if edebug-def-interactive | |
1168 (` (let (((, (edebug-interactive-p-name)) | |
1169 (interactive-p))) | |
1170 (, (edebug-make-enter-wrapper forms)))) | |
1171 (edebug-make-enter-wrapper forms))) | |
1172 | |
1173 | |
1174 (defun edebug-make-enter-wrapper (forms) | |
1175 ;; Generate the enter wrapper for some forms of a definition. | |
1176 ;; This is not to be used for the body of other forms, e.g. `while', | |
1177 ;; since it wraps the list of forms with a call to `edebug-enter'. | |
1178 ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. | |
1179 ;; Do this after parsing since that may find a name. | |
1180 (setq edebug-def-name | |
1181 (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) | |
1182 (` (edebug-enter | |
1183 (quote (, edebug-def-name)) | |
1184 (, (if edebug-inside-func | |
1185 (` (list (,@ | |
1186 ;; Doesnt work with more than one def-body!! | |
1187 ;; But the list will just be reversed. | |
1188 (nreverse edebug-def-args)))) | |
1189 'nil)) | |
1190 (function (lambda () (,@ forms))) | |
1191 ))) | |
1192 | |
1193 | |
1194 (defvar edebug-form-begin-marker) ; the mark for def being instrumented | |
1195 | |
1196 (defvar edebug-offset-index) ; the next available offset index. | |
1197 (defvar edebug-offset-list) ; the list of offset positions. | |
1198 | |
1199 (defun edebug-inc-offset (offset) | |
1200 ;; modifies edebug-offset-index and edebug-offset-list | |
1201 ;; accesses edebug-func-marc and buffer point | |
1202 (prog1 | |
1203 edebug-offset-index | |
1204 (setq edebug-offset-list (cons (- offset edebug-form-begin-marker) | |
1205 edebug-offset-list) | |
1206 edebug-offset-index (1+ edebug-offset-index)))) | |
1207 | |
1208 | |
1209 (defun edebug-make-before-and-after-form (before-index form after-index) | |
1210 ;; Return the edebug form for the current function at offset BEFORE-INDEX | |
1211 ;; given FORM. Looks like: | |
1212 ;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM) | |
1213 ;; Also increment the offset index for subsequent use. | |
1214 ;; if (not edebug-stop-before-symbols) and form is a symbol, | |
1215 ;; then dont call edebug-before. | |
1216 (list 'edebug-after | |
1217 (list 'edebug-before before-index) | |
1218 after-index form)) | |
1219 | |
1220 (defun edebug-make-after-form (form after-index) | |
1221 ;; Like edebug-make-before-and-after-form, but only after. | |
1222 (list 'edebug-after 0 after-index form)) | |
1223 | |
1224 | |
1225 (defun edebug-unwrap (sexp) | |
1226 "Return the unwrapped SEXP or return it as is if it is not wrapped. | |
1227 The SEXP might be the result of wrapping a body, which is a list of | |
1228 expressions; a `progn' form will be returned enclosing these forms." | |
1229 (if (consp sexp) | |
1230 (cond | |
1231 ((eq 'edebug-after (car sexp)) | |
1232 (nth 3 sexp)) | |
1233 ((eq 'edebug-enter (car sexp)) | |
1234 (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp))))) | |
1235 (if (> (length forms) 1) | |
1236 (cons 'progn forms) ;; could return (values forms) instead. | |
1237 (car forms)))) | |
1238 (t sexp);; otherwise it is not wrapped, so just return it. | |
1239 ) | |
1240 sexp)) | |
1241 | |
1242 (defun edebug-unwrap* (sexp) | |
1243 "Return the sexp recursively unwrapped." | |
1244 (let ((new-sexp (edebug-unwrap sexp))) | |
1245 (while (not (eq sexp new-sexp)) | |
1246 (setq sexp new-sexp | |
1247 new-sexp (edebug-unwrap sexp))) | |
1248 (if (consp new-sexp) | |
1249 (mapcar 'edebug-unwrap* new-sexp) | |
1250 new-sexp))) | |
1251 | |
1252 | |
1253 (defun edebug-defining-form (cursor form-begin form-end speclist) | |
1254 ;; Process the defining form, starting outside the form. | |
1255 ;; The speclist is a generated list spec that looks like: | |
1256 ;; (("def-symbol" defining-form-spec-sans-&define)) | |
1257 ;; Skip the first offset. | |
1258 (edebug-set-cursor cursor (edebug-cursor-expressions cursor) | |
1259 (cdr (edebug-cursor-offsets cursor))) | |
1260 (edebug-make-form-wrapper | |
1261 cursor | |
1262 form-begin (1- form-end) | |
1263 speclist)) | |
1264 | |
1265 (defun edebug-make-form-wrapper (cursor form-begin form-end | |
1266 &optional speclist) | |
1267 ;; Wrap a form, usually a defining form, but any evaluated one. | |
1268 ;; If speclist is non-nil, this is being called by edebug-defining-form. | |
1269 ;; Otherwise it is being called from edebug-read-and-maybe-wrap-form1. | |
1270 ;; This is a hack, but I havent figured out a simpler way yet. | |
1271 (let* ((form-data-entry (edebug-get-form-data-entry form-begin form-end)) | |
1272 ;; Set this marker before parsing. | |
1273 (edebug-form-begin-marker | |
1274 (if form-data-entry | |
1275 (edebug-form-data-begin form-data-entry) | |
1276 ;; Buffer must be current-buffer for this to work: | |
1277 (set-marker (make-marker) form-begin)))) | |
1278 | |
1279 (let (edebug-offset-list | |
1280 (edebug-offset-index 0) | |
1281 result | |
1282 ;; For definitions. | |
1283 ;; (edebug-containing-def-name edebug-def-name) | |
1284 ;; Get name from form-data, if any. | |
1285 (edebug-old-def-name (edebug-form-data-name form-data-entry)) | |
1286 edebug-def-name | |
1287 edebug-def-args | |
1288 edebug-def-interactive | |
1289 edebug-inside-func;; whether wrapped code executes inside a function. | |
1290 ) | |
1291 | |
1292 (setq result | |
1293 (if speclist | |
1294 (edebug-match cursor speclist) | |
1295 | |
1296 ;; else wrap as an enter-form. | |
1297 (edebug-make-enter-wrapper (list (edebug-form cursor))))) | |
1298 | |
1299 ;; Set the name here if it was not set by edebug-make-enter-wrapper. | |
1300 (setq edebug-def-name | |
1301 (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) | |
1302 | |
1303 ;; Add this def as a dependent of containing def. Buggy. | |
1304 '(if (and edebug-containing-def-name | |
1305 (not (get edebug-containing-def-name 'edebug-dependents))) | |
1306 (put edebug-containing-def-name 'edebug-dependents | |
1307 (cons edebug-def-name | |
1308 (get edebug-containing-def-name | |
1309 'edebug-dependents)))) | |
1310 | |
1311 ;; Create a form-data-entry or modify existing entry's markers. | |
1312 ;; In the latter case, pointers to the entry remain eq. | |
1313 (if (not form-data-entry) | |
1314 (setq form-data-entry | |
1315 (edebug-make-form-data-entry | |
1316 edebug-def-name | |
1317 edebug-form-begin-marker | |
1318 ;; Buffer must be current-buffer. | |
1319 (set-marker (make-marker) form-end) | |
1320 )) | |
1321 (edebug-set-form-data-entry | |
1322 form-data-entry edebug-def-name ;; in case name is changed | |
1323 form-begin form-end)) | |
1324 | |
1325 ;; (message "defining: %s" edebug-def-name) (sit-for 2) | |
1326 (edebug-make-top-form-data-entry form-data-entry) | |
1327 (message "Edebug: %s" edebug-def-name) | |
1328 ;;(debug edebug-def-name) | |
1329 | |
1330 ;; Destructively reverse edebug-offset-list and make vector from it. | |
1331 (setq edebug-offset-list (vconcat (nreverse edebug-offset-list))) | |
1332 | |
1333 ;; Side effects on the property list of edebug-def-name. | |
1334 (edebug-clear-frequency-count edebug-def-name) | |
1335 (edebug-clear-coverage edebug-def-name) | |
1336 | |
1337 ;; Set up the initial window data. | |
1338 (if (not edebug-top-window-data) ;; if not already set, do it now. | |
1339 (let ((window ;; Find the best window for this buffer. | |
1340 (or (get-buffer-window (current-buffer)) | |
1341 (selected-window)))) | |
1342 (setq edebug-top-window-data | |
1343 (cons window (window-start window))))) | |
1344 | |
1345 ;; Store the edebug data in symbol's property list. | |
1346 (put edebug-def-name 'edebug | |
1347 ;; A struct or vector would be better here!! | |
1348 (list edebug-form-begin-marker | |
1349 nil ; clear breakpoints | |
1350 edebug-offset-list | |
1351 edebug-top-window-data | |
1352 )) | |
1353 result | |
1354 ))) | |
1355 | |
1356 | |
1357 (defun edebug-clear-frequency-count (name) | |
1358 ;; Create initial frequency count vector. | |
1359 ;; For each stop point, the counter is incremented each time it is visited. | |
1360 (put name 'edebug-freq-count | |
1361 (make-vector (length edebug-offset-list) 0))) | |
1362 | |
1363 | |
1364 (defun edebug-clear-coverage (name) | |
1365 ;; Create initial coverage vector. | |
1366 ;; Only need one per expression, but it is simpler to use stop points. | |
1367 (put name 'edebug-coverage | |
1368 (make-vector (length edebug-offset-list) 'unknown))) | |
1369 | |
1370 | |
1371 (defun edebug-form (cursor) | |
1372 ;; Return the instrumented form for the following form. | |
1373 ;; Add the point offsets to the edebug-offset-list for the form. | |
1374 (let* ((form (edebug-top-element-required cursor "Expected form")) | |
1375 (offset (edebug-top-offset cursor))) | |
1376 (prog1 | |
1377 (cond | |
1378 ((consp form) | |
1379 ;; The first offset for a list form is for the list form itself. | |
1380 (if (eq 'quote (car form)) | |
1381 form | |
1382 (let* ((head (car form)) | |
1383 (spec (and (symbolp head) (get-edebug-spec head))) | |
1384 (new-cursor (edebug-new-cursor form offset))) | |
1385 ;; Find out if this is a defining form from first symbol. | |
1386 ;; An indirect spec would not work here, yet. | |
1387 (if (and (consp spec) (eq '&define (car spec))) | |
1388 (edebug-defining-form | |
1389 new-cursor | |
1390 (car offset);; before the form | |
1391 (edebug-after-offset cursor) | |
1392 (cons (symbol-name head) (cdr spec))) | |
1393 ;; Wrap a regular form. | |
1394 (edebug-make-before-and-after-form | |
1395 (edebug-inc-offset (car offset)) | |
1396 (edebug-list-form new-cursor) | |
1397 ;; After processing the list form, the new-cursor is left | |
1398 ;; with the offset after the form. | |
1399 (edebug-inc-offset (edebug-cursor-offsets new-cursor)))) | |
1400 ))) | |
1401 | |
1402 ((symbolp form) | |
1403 (cond | |
1404 ;; Check for constant symbols that dont get wrapped. | |
1405 ((or (memq form '(t nil)) | |
1406 (and (fboundp 'edebug-keywordp) (edebug-keywordp form))) | |
1407 form) | |
1408 | |
1409 ;; This option may go away. | |
1410 (edebug-stop-before-symbols | |
1411 (edebug-make-before-and-after-form | |
1412 (edebug-inc-offset (car offset)) | |
1413 form | |
1414 (edebug-inc-offset (cdr offset)) | |
1415 )) | |
1416 | |
1417 (t ;; just a variable | |
1418 (edebug-make-after-form form (edebug-inc-offset (cdr offset)))))) | |
1419 | |
1420 ;; Anything else is self-evaluating. | |
1421 (t form)) | |
1422 (edebug-move-cursor cursor)))) | |
1423 | |
1424 | |
1425 (defsubst edebug-forms (cursor) (edebug-match cursor '(&rest form))) | |
1426 (defsubst edebug-sexps (cursor) (edebug-match cursor '(&rest sexp))) | |
1427 | |
1428 (defsubst edebug-list-form-args (head cursor) | |
1429 ;; Process the arguments of a list form given that head of form is a symbol. | |
1430 ;; Helper for edebug-list-form | |
1431 (let ((spec (get-edebug-spec head))) | |
1432 (cond | |
1433 (spec | |
1434 (cond | |
1435 ((consp spec) | |
1436 ;; It is a speclist. | |
1437 (let (edebug-best-error | |
1438 edebug-error-point);; This may not be needed. | |
1439 (edebug-match-sublist cursor spec))) | |
1440 ((eq t spec) (edebug-forms cursor)) | |
1441 ((eq 0 spec) (edebug-sexps cursor)) | |
1442 ((symbolp spec) (funcall spec cursor));; Not used by edebug, | |
1443 ; but leave it in for compatibility. | |
1444 )) | |
1445 ;; No edebug-form-spec provided. | |
1446 ((edebug-macrop head) | |
1447 (if edebug-eval-macro-args | |
1448 (edebug-forms cursor) | |
1449 (edebug-sexps cursor))) | |
1450 (t ;; Otherwise it is a function call. | |
1451 (edebug-forms cursor))))) | |
1452 | |
1453 | |
1454 (defun edebug-list-form (cursor) | |
1455 ;; Return an instrumented form built from the list form. | |
1456 ;; The after offset will be left in the cursor after processing the form. | |
1457 (let ((head (edebug-top-element-required cursor "Expected elements")) | |
1458 ;; Prevent backtracking whenever instrumenting. | |
1459 (edebug-gate t) | |
1460 ;; A list form is never optional because it matches anything. | |
1461 (edebug-&optional nil) | |
1462 (edebug-&rest nil)) | |
1463 ;; Skip the first offset. | |
1464 (edebug-set-cursor cursor (edebug-cursor-expressions cursor) | |
1465 (cdr (edebug-cursor-offsets cursor))) | |
1466 (cond | |
1467 ((null head) nil) ; () is legal. | |
1468 | |
1469 ((symbolp head) | |
1470 (cond | |
1471 ((null head) | |
1472 (edebug-syntax-error "nil head")) | |
1473 ((eq head 'interactive-p) | |
1474 ;; Special case: replace (interactive-p) with variable | |
1475 (setq edebug-def-interactive 'check-it) | |
1476 (edebug-move-cursor cursor) | |
1477 (edebug-interactive-p-name)) | |
1478 (t | |
1479 (cons head (edebug-list-form-args | |
1480 head (edebug-move-cursor cursor)))))) | |
1481 | |
1482 ((consp head) | |
1483 (if (and (listp head) (eq (car head) ',)) | |
1484 (edebug-match cursor '(("," def-form) body)) | |
1485 ;; Process anonymous function and args. | |
1486 ;; This assumes no anonymous macros. | |
1487 (edebug-match-specs cursor '(lambda-expr body) 'edebug-match-specs))) | |
1488 | |
1489 (t (edebug-syntax-error | |
1490 "Head of list form must be a symbol or lambda expression."))) | |
1491 )) | |
1492 | |
1493 | |
1494 ;;;; Matching of specs. | |
1495 ;;; =================== | |
1496 | |
1497 (defvar edebug-after-dotted-spec nil) | |
1498 | |
1499 (defvar edebug-matching-depth 0) ;; initial value | |
1500 (defconst edebug-max-depth 150) ;; maximum number of matching recursions. | |
1501 | |
1502 | |
1503 ;;;; Failure to match | |
1504 ;;; ================== | |
1505 ;; This throws to no-match, if there are higher alternatives. | |
1506 ;; Otherwise it signals an error. The place of the error is found | |
1507 ;; with the two before- and after-offset functions. | |
1508 | |
1509 (defun edebug-no-match (cursor &rest edebug-args) | |
1510 ;; Throw a no-match, or signal an error immediately if gate is active. | |
1511 ;; Remember this point in case we need to report this error. | |
1512 (setq edebug-error-point (or edebug-error-point | |
1513 (edebug-before-offset cursor)) | |
1514 edebug-best-error (or edebug-best-error edebug-args)) | |
1515 (if (and edebug-gate (not edebug-&optional)) | |
1516 (progn | |
1517 (if edebug-error-point | |
1518 (goto-char edebug-error-point)) | |
1519 (apply 'edebug-syntax-error edebug-args)) | |
1520 (funcall 'throw 'no-match edebug-args))) | |
1521 | |
1522 | |
1523 (defun edebug-match (cursor specs) | |
1524 ;; Top level spec matching function. | |
1525 ;; Used also at each lower level of specs. | |
1526 (let (edebug-&optional | |
1527 edebug-&rest | |
1528 edebug-best-error | |
1529 edebug-error-point | |
1530 (edebug-gate edebug-gate) ;; locally bound to limit effect | |
1531 ) | |
1532 (edebug-match-specs cursor specs 'edebug-match-specs))) | |
1533 | |
1534 | |
1535 (defun edebug-match-one-spec (cursor spec) | |
1536 ;; Match one spec, which is not a keyword &-spec. | |
1537 (cond | |
1538 ((symbolp spec) (edebug-match-symbol cursor spec)) | |
1539 ((vectorp spec) (edebug-match cursor (append spec nil))) | |
1540 ((stringp spec) (edebug-match-string cursor spec)) | |
1541 ((listp spec) (edebug-match-list cursor spec)) | |
1542 )) | |
1543 | |
1544 | |
1545 (defun edebug-match-specs (cursor specs remainder-handler) | |
1546 ;; Append results of matching the list of specs. | |
1547 ;; The first spec is handled and the remainder-handler handles the rest. | |
1548 (let ((edebug-matching-depth | |
1549 (if (> edebug-matching-depth edebug-max-depth) | |
1550 (error "too deep - perhaps infinite loop in spec?") | |
1551 (1+ edebug-matching-depth)))) | |
1552 (cond | |
1553 ((null specs) nil) | |
1554 | |
1555 ;; Is the spec dotted? | |
1556 ((atom specs) | |
1557 (let ((edebug-dotted-spec t));; Containing spec list was dotted. | |
1558 (edebug-match-specs cursor (list specs) remainder-handler))) | |
1559 | |
1560 ;; Is the form dotted? | |
1561 ((not (listp (edebug-cursor-expressions cursor)));; allow nil | |
1562 (if (not edebug-dotted-spec) | |
1563 (edebug-no-match cursor "Dotted spec required.")) | |
1564 ;; Cancel dotted spec and dotted form. | |
1565 (let ((edebug-dotted-spec) | |
1566 (this-form (edebug-cursor-expressions cursor)) | |
1567 (this-offset (edebug-cursor-offsets cursor))) | |
1568 ;; Wrap the form in a list, (by changing the cursor??)... | |
1569 (edebug-set-cursor cursor (list this-form) this-offset) | |
1570 ;; and process normally, then unwrap the result. | |
1571 (car (edebug-match-specs cursor specs remainder-handler)))) | |
1572 | |
1573 (t;; Process normally. | |
1574 (let* ((spec (car specs)) | |
1575 (rest) | |
1576 (first-char (and (symbolp spec) (aref (symbol-name spec) 0)))) | |
1577 ;;(message "spec = %s first char = %s" spec first-char) (sit-for 1) | |
1578 (nconc | |
1579 (cond | |
1580 ((eq ?& first-char);; "&" symbols take all following specs. | |
1581 (funcall (get-edebug-spec spec) cursor (cdr specs))) | |
1582 ((eq ?: first-char);; ":" symbols take one following spec. | |
1583 (setq rest (cdr (cdr specs))) | |
1584 (funcall (get-edebug-spec spec) cursor (car (cdr specs)))) | |
1585 (t;; Any other normal spec. | |
1586 (setq rest (cdr specs)) | |
1587 (edebug-match-one-spec cursor spec))) | |
1588 (funcall remainder-handler cursor rest remainder-handler))))))) | |
1589 | |
1590 | |
1591 ;; Define specs for all the symbol specs with functions used to process them. | |
1592 ;; Perhaps we shouldnt be doing this with edebug-form-specs since the | |
1593 ;; user may want to define macros or functions with the same names. | |
1594 ;; We could use an internal obarray for these primitive specs. | |
1595 | |
1596 (mapcar | |
1597 (function (lambda (pair) | |
1598 (put (car pair) 'edebug-form-spec (cdr pair)))) | |
1599 '((&optional . edebug-match-&optional) | |
1600 (&rest . edebug-match-&rest) | |
1601 (&or . edebug-match-&or) | |
1602 (form . edebug-match-form) | |
1603 (sexp . edebug-match-sexp) | |
1604 (body . edebug-match-body) | |
1605 (&define . edebug-match-&define) | |
1606 (name . edebug-match-name) | |
1607 (:name . edebug-match-colon-name) | |
1608 (arg . edebug-match-arg) | |
1609 (def-body . edebug-match-def-body) | |
1610 (def-form . edebug-match-def-form) | |
1611 ;; Less frequently used: | |
1612 ;; (function . edebug-match-function) | |
1613 (lambda-expr . edebug-match-lambda-expr) | |
1614 (¬ . edebug-match-¬) | |
1615 (&key . edebug-match-&key) | |
1616 (place . edebug-match-place) | |
1617 (gate . edebug-match-gate) | |
1618 ;; (nil . edebug-match-nil) not this one - special case it. | |
1619 )) | |
1620 | |
1621 (defun edebug-match-symbol (cursor symbol) | |
1622 ;; Match a symbol spec. | |
1623 (let* ((spec (get-edebug-spec symbol))) | |
1624 (cond | |
1625 (spec | |
1626 (if (consp spec) | |
1627 ;; It is an indirect spec. | |
1628 (edebug-match cursor spec) | |
1629 ;; Otherwise it should be the symbol name of a function. | |
1630 ;; There could be a bug here - maybe need to do edebug-match bindings. | |
1631 (funcall spec cursor))) | |
1632 | |
1633 ((null symbol) ;; special case this. | |
1634 (edebug-match-nil cursor)) | |
1635 | |
1636 ((fboundp symbol) ; is it a predicate? | |
1637 (let ((sexp (edebug-top-element-required cursor "Expected" symbol))) | |
1638 ;; Special case for edebug-`. | |
1639 (if (and (listp sexp) (eq (car sexp) ',)) | |
1640 (edebug-match cursor '(("," def-form))) | |
1641 (if (not (funcall symbol sexp)) | |
1642 (edebug-no-match cursor symbol "failed")) | |
1643 (edebug-move-cursor cursor) | |
1644 (list sexp)))) | |
1645 (t (error "%s is not a form-spec or function" symbol)) | |
1646 ))) | |
1647 | |
1648 | |
1649 (defun edebug-match-sexp (cursor) | |
1650 (list (prog1 (edebug-top-element-required cursor "Expected sexp") | |
1651 (edebug-move-cursor cursor)))) | |
1652 | |
1653 (defun edebug-match-form (cursor) | |
1654 (list (edebug-form cursor))) | |
1655 | |
1656 (defalias 'edebug-match-place 'edebug-match-form) | |
1657 ;; Currently identical to edebug-match-form. | |
1658 ;; This is for common lisp setf-style place arguments. | |
1659 | |
1660 (defsubst edebug-match-body (cursor) (edebug-forms cursor)) | |
1661 | |
1662 (defun edebug-match-&optional (cursor specs) | |
1663 ;; Keep matching until one spec fails. | |
1664 (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) | |
1665 | |
1666 (defun edebug-&optional-wrapper (cursor specs remainder-handler) | |
1667 (let (result | |
1668 (edebug-&optional specs) | |
1669 (edebug-gate nil) | |
1670 (this-form (edebug-cursor-expressions cursor)) | |
1671 (this-offset (edebug-cursor-offsets cursor))) | |
1672 (if (null (catch 'no-match | |
1673 (setq result | |
1674 (edebug-match-specs cursor specs remainder-handler)) | |
1675 ;; Returning nil means no no-match was thrown. | |
1676 nil)) | |
1677 result | |
1678 ;; no-match, but don't fail; just reset cursor and return nil. | |
1679 (edebug-set-cursor cursor this-form this-offset) | |
1680 nil))) | |
1681 | |
1682 | |
1683 (defun edebug-&rest-wrapper (cursor specs remainder-handler) | |
1684 (if (null specs) (setq specs edebug-&rest)) | |
1685 ;; Reuse the &optional handler with this as the remainder handler. | |
1686 (edebug-&optional-wrapper cursor specs remainder-handler)) | |
1687 | |
1688 (defun edebug-match-&rest (cursor specs) | |
1689 ;; Repeatedly use specs until failure. | |
1690 (let ((edebug-&rest specs) ;; remember these | |
1691 edebug-best-error | |
1692 edebug-error-point) | |
1693 (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) | |
1694 | |
1695 | |
1696 (defun edebug-match-&or (cursor specs) | |
1697 ;; Keep matching until one spec succeeds, and return its results. | |
1698 ;; If none match, fail. | |
1699 ;; This needs to be optimized since most specs spend time here. | |
1700 (let ((original-specs specs) | |
1701 (this-form (edebug-cursor-expressions cursor)) | |
1702 (this-offset (edebug-cursor-offsets cursor))) | |
1703 (catch 'matched | |
1704 (while specs | |
1705 (catch 'no-match | |
1706 (throw 'matched | |
1707 (let (edebug-gate ;; only while matching each spec | |
1708 edebug-best-error | |
1709 edebug-error-point) | |
1710 ;; Doesnt support e.g. &or symbolp &rest form | |
1711 (edebug-match-one-spec cursor (car specs))))) | |
1712 ;; Match failed, so reset and try again. | |
1713 (setq specs (cdr specs)) | |
1714 ;; Reset the cursor for the next match. | |
1715 (edebug-set-cursor cursor this-form this-offset)) | |
1716 ;; All failed. | |
1717 (apply 'edebug-no-match cursor "Expected one of" original-specs)) | |
1718 )) | |
1719 | |
1720 | |
1721 (defun edebug-match-¬ (cursor specs) | |
1722 ;; If any specs match, then fail | |
1723 (if (null (catch 'no-match | |
1724 (let ((edebug-gate nil)) | |
1725 (save-excursion | |
1726 (edebug-match-&or cursor specs))) | |
1727 nil)) | |
1728 ;; This means something matched, so it is a no match. | |
1729 (edebug-no-match cursor "Unexpected")) | |
1730 ;; This means nothing matched, so it is OK. | |
1731 nil) ;; So, return nothing | |
1732 | |
1733 | |
1734 (def-edebug-spec &key edebug-match-&key) | |
1735 | |
1736 (defun edebug-match-&key (cursor specs) | |
1737 ;; Following specs must look like (<name> <spec>) ... | |
1738 ;; where <name> is the name of a keyword, and spec is its spec. | |
1739 ;; This really doesnt save much over the expanded form and takes time. | |
1740 (edebug-match-&rest | |
1741 cursor | |
1742 (cons '&or | |
1743 (mapcar (function (lambda (pair) | |
1744 (vector (format ":%s" (car pair)) | |
1745 (car (cdr pair))))) | |
1746 specs)))) | |
1747 | |
1748 | |
1749 (defun edebug-match-gate (cursor) | |
1750 ;; Simply set the gate to prevent backtracking at this level. | |
1751 (setq edebug-gate t) | |
1752 nil) | |
1753 | |
1754 | |
1755 (defun edebug-match-list (cursor specs) | |
1756 ;; The spec is a list, but what kind of list, and what context? | |
1757 (if edebug-dotted-spec | |
1758 ;; After dotted spec but form did not contain dot, | |
1759 ;; so match list spec elements as if spliced in. | |
1760 (prog1 | |
1761 (let ((edebug-dotted-spec)) | |
1762 (edebug-match-specs cursor specs 'edebug-match-specs)) | |
1763 ;; If it matched, really clear the dotted-spec flag. | |
1764 (setq edebug-dotted-spec nil)) | |
1765 (let ((spec (car specs)) | |
1766 (form (edebug-top-element-required cursor "Expected" specs))) | |
1767 (cond | |
1768 ((eq 'quote spec) | |
1769 (let ((spec (car (cdr specs)))) | |
1770 (cond | |
1771 ((symbolp spec) | |
1772 ;; Special case: spec quotes a symbol to match. | |
1773 ;; Change in future. Use "..." instead. | |
1774 (if (not (eq spec form)) | |
1775 (edebug-no-match cursor "Expected" spec)) | |
1776 (edebug-move-cursor cursor) | |
1777 (setq edebug-gate t) | |
1778 form) | |
1779 (t | |
1780 (error "Bad spec: %s" specs))))) | |
1781 | |
1782 ((listp form) | |
1783 (prog1 | |
1784 (list (edebug-match-sublist | |
1785 ;; First offset is for the list form itself. | |
1786 ;; Treat nil as empty list. | |
1787 (edebug-new-cursor form (cdr (edebug-top-offset cursor))) | |
1788 specs)) | |
1789 (edebug-move-cursor cursor))) | |
1790 | |
1791 ((and (eq 'vector spec) (vectorp form)) | |
1792 ;; Special case: match a vector with the specs. | |
1793 (let ((result (edebug-match-sublist | |
1794 (edebug-new-cursor | |
1795 form (cdr (edebug-top-offset cursor))) | |
1796 (cdr specs)))) | |
1797 (edebug-move-cursor cursor) | |
1798 (list (apply 'vector result)))) | |
1799 | |
1800 (t (edebug-no-match cursor "Expected" specs))) | |
1801 ))) | |
1802 | |
1803 | |
1804 (defun edebug-match-sublist (cursor specs) | |
1805 ;; Match a sublist of specs. | |
1806 (let (edebug-&optional | |
1807 ;;edebug-best-error | |
1808 ;;edebug-error-point | |
1809 ) | |
1810 (prog1 | |
1811 ;; match with edebug-match-specs so edebug-best-error is not bound. | |
1812 (edebug-match-specs cursor specs 'edebug-match-specs) | |
1813 (if (not (edebug-empty-cursor cursor)) | |
1814 (if edebug-best-error | |
1815 (apply 'edebug-no-match cursor edebug-best-error) | |
1816 ;; A failed &rest or &optional spec may leave some args. | |
1817 (edebug-no-match cursor "Failed matching" specs) | |
1818 ))))) | |
1819 | |
1820 | |
1821 (defun edebug-match-string (cursor spec) | |
1822 (let ((sexp (edebug-top-element-required cursor "Expected" spec))) | |
1823 (if (not (eq (intern spec) sexp)) | |
1824 (edebug-no-match cursor "Expected" spec) | |
1825 ;; Since it matched, failure means immediate error, unless &optional. | |
1826 (setq edebug-gate t) | |
1827 (edebug-move-cursor cursor) | |
1828 (list sexp) | |
1829 ))) | |
1830 | |
1831 (defun edebug-match-nil (cursor) | |
1832 ;; There must be nothing left to match a nil. | |
1833 (if (not (edebug-empty-cursor cursor)) | |
1834 (edebug-no-match cursor "Unmatched argument(s)") | |
1835 nil)) | |
1836 | |
1837 | |
1838 (defun edebug-match-function (cursor) | |
1839 (error "Use function-form instead of function in edebug spec")) | |
1840 | |
1841 (defun edebug-match-&define (cursor specs) | |
1842 ;; Match a defining form. | |
1843 ;; Normally, &define is interpretted specially other places. | |
1844 ;; This should only be called inside of a spec list to match the remainder | |
1845 ;; of the current list. e.g. ("lambda" &define args def-body) | |
1846 (edebug-make-form-wrapper | |
1847 cursor | |
1848 (edebug-before-offset cursor) | |
1849 ;; Find the last offset in the list. | |
1850 (let ((offsets (edebug-cursor-offsets cursor))) | |
1851 (while (consp offsets) (setq offsets (cdr offsets))) | |
1852 offsets) | |
1853 specs)) | |
1854 | |
1855 (defun edebug-match-lambda-expr (cursor) | |
1856 ;; The expression must be a function. | |
1857 ;; This will match any list form that begins with a symbol | |
1858 ;; that has an edebug-form-spec beginning with &define. In | |
1859 ;; practice, only lambda expressions should be used. | |
1860 ;; I could add a &lambda specification to avoid confusion. | |
1861 (let* ((sexp (edebug-top-element-required | |
1862 cursor "Expected lambda expression")) | |
1863 (offset (edebug-top-offset cursor)) | |
1864 (head (and (consp sexp) (car sexp))) | |
1865 (spec (and (symbolp head) (get-edebug-spec head))) | |
1866 (edebug-inside-func nil)) | |
1867 ;; Find out if this is a defining form from first symbol. | |
1868 (if (and (consp spec) (eq '&define (car spec))) | |
1869 (prog1 | |
1870 (list | |
1871 (edebug-defining-form | |
1872 (edebug-new-cursor sexp offset) | |
1873 (car offset);; before the sexp | |
1874 (edebug-after-offset cursor) | |
1875 (cons (symbol-name head) (cdr spec)))) | |
1876 (edebug-move-cursor cursor)) | |
1877 (edebug-no-match cursor "Expected lambda expression") | |
1878 ))) | |
1879 | |
1880 | |
1881 (defun edebug-match-name (cursor) | |
1882 ;; Set the edebug-def-name bound in edebug-defining-form. | |
1883 (let ((name (edebug-top-element-required cursor "Expected name"))) | |
1884 ;; Maybe strings and numbers could be used. | |
1885 (if (not (symbolp name)) | |
1886 (edebug-no-match cursor "Symbol expected for name of definition")) | |
1887 (setq edebug-def-name | |
1888 (if edebug-def-name | |
1889 ;; Construct a new name by appending to previous name. | |
1890 (intern (format "%s@%s" edebug-def-name name)) | |
1891 name)) | |
1892 (edebug-move-cursor cursor) | |
1893 (list name))) | |
1894 | |
1895 (defun edebug-match-colon-name (cursor spec) | |
1896 ;; Set the edebug-def-name to the spec. | |
1897 (setq edebug-def-name | |
1898 (if edebug-def-name | |
1899 ;; Construct a new name by appending to previous name. | |
1900 (intern (format "%s@%s" edebug-def-name spec)) | |
1901 spec)) | |
1902 nil) | |
1903 | |
1904 (defun edebug-match-arg (cursor) | |
1905 ;; set the def-args bound in edebug-defining-form | |
1906 (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) | |
1907 (if (or (not (symbolp edebug-arg)) | |
1908 (edebug-lambda-list-keywordp edebug-arg)) | |
1909 (edebug-no-match cursor "Bad argument:" edebug-arg)) | |
1910 (edebug-move-cursor cursor) | |
1911 (setq edebug-def-args (cons edebug-arg edebug-def-args)) | |
1912 (list edebug-arg))) | |
1913 | |
1914 (defun edebug-match-def-form (cursor) | |
1915 ;; Like form but the form is wrapped in edebug-enter form. | |
1916 ;; The form is assumed to be executing outside of the function context. | |
1917 ;; This is a hack for now, since a def-form might execute inside as well. | |
1918 ;; Not to be used otherwise. | |
1919 (let ((edebug-inside-func nil)) | |
1920 (list (edebug-make-enter-wrapper (list (edebug-form cursor)))))) | |
1921 | |
1922 (defun edebug-match-def-body (cursor) | |
1923 ;; Like body but body is wrapped in edebug-enter form. | |
1924 ;; The body is assumed to be executing inside of the function context. | |
1925 ;; Not to be used otherwise. | |
1926 (let ((edebug-inside-func t)) | |
1927 (list (edebug-wrap-def-body (edebug-forms cursor))))) | |
1928 | |
1929 | |
1930 ;;;; Edebug Form Specs | |
1931 ;;; ========================================================== | |
1932 ;;; See cl-specs.el for common lisp specs. | |
1933 | |
1934 ;;;;* Spec for def-edebug-spec | |
1935 ;;; Out of date. | |
1936 | |
1937 (defun edebug-spec-p (object) | |
1938 "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." | |
1939 (and (symbolp object) | |
1940 (get object 'edebug-form-spec))) | |
1941 | |
1942 (def-edebug-spec def-edebug-spec | |
1943 ;; Top level is different from lower levels. | |
1944 (&define :name edebug-spec name | |
1945 &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec))) | |
1946 | |
1947 (def-edebug-spec edebug-spec-list | |
1948 ;; A list must have something in it, or it is nil, a symbolp | |
1949 ((edebug-spec . [&or nil edebug-spec]))) | |
1950 | |
1951 (def-edebug-spec edebug-spec | |
1952 (&or | |
1953 (vector &rest edebug-spec) ; matches a vector | |
1954 ("vector" &rest edebug-spec) ; matches a vector spec | |
1955 ("quote" symbolp) | |
1956 edebug-spec-list | |
1957 stringp | |
1958 [edebug-lambda-list-keywordp &rest edebug-spec] | |
1959 ;; [edebug-keywordp gate edebug-spec] ;; need edebug-keywordp for this. | |
1960 edebug-spec-p ;; Including all the special ones e.g. form. | |
1961 symbolp;; a predicate | |
1962 )) | |
1963 | |
1964 | |
1965 ;;;;* Emacs special forms and some functions. | |
1966 | |
1967 ;; quote expects only one argument, although it allows any number. | |
1968 (def-edebug-spec quote sexp) | |
1969 | |
1970 ;; The standard defining forms. | |
1971 (def-edebug-spec defconst defvar) | |
1972 (def-edebug-spec defvar (symbolp &optional form stringp)) | |
1973 | |
1974 (def-edebug-spec defun | |
1975 (&define name lambda-list | |
1976 [&optional stringp] | |
1977 [&optional ("interactive" interactive)] | |
1978 def-body)) | |
1979 (def-edebug-spec defmacro | |
1980 (&define name lambda-list def-body)) | |
1981 | |
1982 (def-edebug-spec arglist lambda-list) ;; denegrated - use lambda-list. | |
1983 | |
1984 (def-edebug-spec lambda-list | |
1985 (([&rest arg] | |
1986 [&optional ["&optional" arg &rest arg]] | |
1987 &optional ["&rest" arg] | |
1988 ))) | |
1989 | |
1990 (def-edebug-spec interactive | |
1991 (&optional &or stringp def-form)) | |
1992 | |
1993 ;; A function-form is for an argument that may be a function or a form. | |
1994 ;; This specially recognizes anonymous functions quoted with quote. | |
1995 (def-edebug-spec function-form | |
1996 ;; form at the end could also handle "function", | |
1997 ;; but recognize it specially to avoid wrapping function forms. | |
1998 (&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) | |
1999 | |
2000 ;; function expects a symbol or a lambda or macro expression | |
2001 ;; A macro is allowed by Emacs. | |
2002 (def-edebug-spec function (&or symbolp lambda-expr)) | |
2003 | |
2004 ;; lambda is a macro in emacs 19. | |
2005 (def-edebug-spec lambda (&define lambda-list | |
2006 [&optional stringp] | |
2007 [&optional ("interactive" interactive)] | |
2008 def-body)) | |
2009 | |
2010 ;; A macro expression is a lambda expression with "macro" prepended. | |
2011 (def-edebug-spec macro (&define "lambda" lambda-list def-body)) | |
2012 | |
2013 ;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro]))) | |
2014 | |
2015 ;; Standard functions that take function-forms arguments. | |
2016 (def-edebug-spec mapcar (function-form form)) | |
2017 (def-edebug-spec mapconcat (function-form form form)) | |
2018 (def-edebug-spec mapatoms (function-form &optional form)) | |
2019 (def-edebug-spec apply (function-form &rest form)) | |
2020 (def-edebug-spec funcall (function-form &rest form)) | |
2021 | |
2022 (def-edebug-spec let | |
2023 ((&rest &or (symbolp &optional form) symbolp) | |
2024 body)) | |
2025 | |
2026 (def-edebug-spec let* let) | |
2027 | |
2028 (def-edebug-spec setq (&rest symbolp form)) | |
2029 (def-edebug-spec setq-default setq) | |
2030 | |
2031 (def-edebug-spec cond (&rest (&rest form))) | |
2032 | |
2033 (def-edebug-spec condition-case | |
2034 (symbolp | |
2035 form | |
2036 &rest (symbolp body))) | |
2037 | |
2038 | |
2039 (def-edebug-spec \` (backquote-form)) | |
2040 | |
2041 ;; Supports quotes inside backquotes, | |
2042 ;; but only at the top level inside unquotes. | |
2043 (def-edebug-spec backquote-form | |
2044 (&or | |
2045 ([&or "," ",@"] &or ("quote" backquote-form) form) | |
2046 (backquote-form &rest backquote-form) | |
2047 ;; If you use dotted forms in backquotes, replace the previous line | |
2048 ;; with the following. This takes quite a bit more stack space, however. | |
2049 ;; (backquote-form . [&or nil backquote-form]) | |
2050 (vector &rest backquote-form) | |
2051 sexp)) | |
2052 | |
2053 ;; Special version of backquote that instruments backquoted forms | |
2054 ;; destined to be evaluated, usually as the result of a | |
2055 ;; macroexpansion. Backquoted code can only have unquotes (, and ,@) | |
2056 ;; in places where list forms are allowed, and predicates. If the | |
2057 ;; backquote is used in a macro, unquoted code that come from | |
2058 ;; arguments must be instrumented, if at all, with def-form not def-body. | |
2059 | |
2060 ;; We could assume that all forms (not nested in other forms) | |
2061 ;; in arguments of macros should be def-forms, whether or not the macros | |
2062 ;; are defined with edebug-` but this would be expensive. | |
2063 | |
2064 ;; ,@ might have some problems. | |
2065 | |
2066 (defalias 'edebug-\` '\`) ;; same macro as regular backquote. | |
2067 (def-edebug-spec edebug-\` (def-form)) | |
2068 | |
2069 ;; Assume immediate quote in unquotes mean backquote at next higher level. | |
2070 (def-edebug-spec , (&or ("quote" edebug-`) def-form)) | |
2071 (def-edebug-spec ,@ (&define ;; so (,@ form) is never wrapped. | |
2072 &or ("quote" edebug-`) def-form)) | |
2073 | |
2074 ;; New byte compiler. | |
2075 (def-edebug-spec defsubst defun) | |
2076 (def-edebug-spec dont-compile t) | |
2077 (def-edebug-spec eval-when-compile t) | |
2078 (def-edebug-spec eval-and-compile t) | |
2079 | |
2080 ;; Anything else? | |
2081 | |
2082 | |
2083 ;;==================== | |
2084 ;; Some miscellaneous specs for macros in public packages. | |
2085 ;; Send me yours. | |
2086 | |
2087 ;; advice.el by Hans Chalupsky (hans@cs.buffalo.edu) | |
2088 | |
2089 (def-edebug-spec ad-dolist ((symbolp form &optional form) body)) | |
2090 (def-edebug-spec defadvice | |
2091 (&define name ;; thing being advised. | |
2092 (name ;; class is [&or "before" "around" "after" | |
2093 ;; "activation" "deactivation"] | |
2094 name ;; name of advice | |
2095 &rest sexp ;; optional position and flags | |
2096 ) | |
2097 [&optional stringp] | |
2098 [&optional ("interactive" interactive)] | |
2099 def-body)) | |
2100 | |
2101 | |
2102 ;;;; The debugger itself | |
2103 ;;; =============================== | |
2104 | |
2105 (defvar edebug-active nil) ;; Non-nil when edebug is active | |
2106 | |
2107 ;;; add minor-mode-alist entry | |
2108 (or (assq 'edebug-active minor-mode-alist) | |
2109 (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*") | |
2110 minor-mode-alist))) | |
2111 | |
2112 (defvar edebug-stack nil) | |
2113 ;; Stack of active functions evaluated via edebug. | |
2114 ;; Should be nil at the top level. | |
2115 | |
2116 (defvar edebug-stack-depth -1) | |
2117 ;; Index of last edebug-stack item. | |
2118 | |
2119 (defvar edebug-offset-indices nil) | |
2120 ;; Stack of offset indices of visited edebug sexps. | |
2121 ;; Should be nil at the top level. | |
2122 ;; Each function adds one cons. Top is modified with setcar. | |
2123 | |
2124 | |
2125 (defvar edebug-entered nil | |
2126 ;; Non-nil if edebug has already been entered at this recursive edit level. | |
2127 ;; This should stay nil at the top level. | |
2128 ) | |
2129 | |
2130 ;; Should these be options? | |
2131 (defconst edebug-debugger 'edebug | |
2132 ;; Name of function to use for debugging when error or quit occurs. | |
2133 ;; Set this to 'debug if you want to debug edebug. | |
2134 ) | |
2135 | |
2136 | |
2137 ;; Dynamically bound variables, declared globally but left unbound. | |
2138 (defvar edebug-function) ; the function being executed. change name!! | |
2139 (defvar edebug-args) ; the arguments of the function | |
2140 (defvar edebug-data) ; the edebug data for the function | |
2141 (defvar edebug-value) ; the result of the expression | |
2142 (defvar edebug-after-index) | |
2143 (defvar edebug-def-mark) ; the mark for the definition | |
2144 (defvar edebug-freq-count) ; the count of expression visits. | |
2145 (defvar edebug-coverage) ; the coverage results of each expression of function. | |
2146 | |
2147 (defvar edebug-buffer) ; which buffer the function is in. | |
2148 (defvar edebug-result) ; the result of the function call returned by body | |
2149 (defvar edebug-outside-executing-macro) | |
2150 (defvar edebug-outside-defining-kbd-macro) | |
2151 | |
2152 (defvar edebug-execution-mode 'step) ; Current edebug mode set by user. | |
2153 (defvar edebug-next-execution-mode nil) ; Use once instead of initial mode. | |
2154 | |
2155 (defvar edebug-outside-debug-on-error) ; the value of debug-on-error outside | |
2156 (defvar edebug-outside-debug-on-quit) ; the value of debug-on-quit outside | |
2157 | |
2158 (defvar edebug-outside-pre-command-hook) | |
2159 (defvar edebug-outside-post-command-hook) | |
2160 (defvar edebug-outside-post-command-idle-hook) | |
2161 | |
2162 ;; Emacs 19 | |
2163 (defvar pre-command-hook nil) | |
2164 (defvar post-command-hook nil) | |
2165 (defvar post-command-idle-hook nil) | |
2166 | |
2167 (defvar cl-lexical-debug) ;; Defined in cl.el | |
2168 | |
2169 ;;; Handling signals | |
2170 ;;; ================= | |
2171 | |
2172 (if (not (fboundp 'edebug-original-signal)) | |
2173 (defalias 'edebug-original-signal (symbol-function 'signal))) | |
2174 ;; We should use advise for this!! | |
2175 | |
2176 (defun edebug-signal (edebug-signal-name edebug-signal-data) | |
2177 "Signal an error. Args are SIGNAL-NAME, and associated DATA. | |
2178 A signal name is a symbol with an `error-conditions' property | |
2179 that is a list of condition names. | |
2180 A handler for any of those names will get to handle this signal. | |
2181 The symbol `error' should always be one of them. | |
2182 | |
2183 DATA should be a list. Its elements are printed as part of the error message. | |
2184 If the signal is handled, DATA is made available to the handler. | |
2185 See `condition-case'. | |
2186 | |
2187 This is the Edebug replacement for the standard `signal'. It should | |
2188 only be active while Edebug is. It checks `debug-on-error' to see | |
2189 whether it should call the debugger. When execution is resumed, the | |
2190 error is signaled again." | |
2191 (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error)) | |
2192 (edebug 'error (cons edebug-signal-name edebug-signal-data))) | |
2193 ;; If we reach here without another non-local exit, then send signal again. | |
2194 ;; i.e. the signal is not continuable, yet. | |
2195 (edebug-original-signal edebug-signal-name edebug-signal-data)) | |
2196 | |
2197 | |
2198 ;;; Entering Edebug | |
2199 ;;; ================== | |
2200 | |
2201 (defun edebug-enter (edebug-function edebug-args edebug-body) | |
2202 ;; Entering FUNC. The arguments are ARGS, and the body is BODY. | |
2203 ;; Setup edebug variables and evaluate BODY. This function is called | |
2204 ;; when a function evaluated with edebug-eval-top-level-form is entered. | |
2205 ;; Return the result of BODY. | |
2206 | |
2207 ;; Is this the first time we are entering edebug since | |
2208 ;; lower-level recursive-edit command? | |
2209 ;; More precisely, this tests whether Edebug is currently active. | |
2210 (if (not edebug-entered) | |
2211 (let ((edebug-entered t) | |
2212 ;; Binding max-lisp-eval-depth here is OK, | |
2213 ;; but not inside an unwind-protect. | |
2214 ;; Doing it here also keeps it from growing too large. | |
2215 (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? | |
2216 (max-specpdl-size (+ 200 max-specpdl-size)) | |
2217 | |
2218 (debugger edebug-debugger) ; only while edebug is active. | |
2219 (edebug-outside-debug-on-error debug-on-error) | |
2220 (edebug-outside-debug-on-quit debug-on-quit) | |
2221 ;; Binding these may not be the right thing to do. | |
2222 ;; We want to allow the global values to be changed. | |
2223 (debug-on-error (or debug-on-error edebug-on-error)) | |
2224 (debug-on-quit edebug-on-quit) | |
2225 | |
2226 ;; Lexical bindings must be uncompiled for this to work. | |
2227 (cl-lexical-debug t) | |
2228 | |
2229 ;; Save the outside value of executing macro. (here??) | |
2230 (edebug-outside-executing-macro executing-macro) | |
2231 (edebug-outside-pre-command-hook pre-command-hook) | |
2232 (edebug-outside-post-command-hook post-command-hook) | |
2233 (edebug-outside-post-command-idle-hook post-command-idle-hook)) | |
2234 (unwind-protect | |
2235 (let (;; Don't keep reading from an executing kbd macro | |
2236 ;; within edebug unless edebug-continue-kbd-macro is | |
2237 ;; non-nil. Again, local binding may not be best. | |
2238 (executing-macro | |
2239 (if edebug-continue-kbd-macro executing-macro)) | |
2240 | |
2241 ;; Disable command hooks. This is essential when | |
2242 ;; a hook function is instrumented - to avoid infinite loop. | |
2243 ;; This may be more than we need, however. | |
2244 (pre-command-hook nil) | |
2245 (post-command-hook nil) | |
2246 (post-command-idle-hook nil)) | |
2247 (setq edebug-execution-mode (or edebug-next-execution-mode | |
2248 edebug-initial-mode | |
2249 edebug-execution-mode) | |
2250 edebug-next-execution-mode nil) | |
2251 ;; Bind signal to edebug-signal only while Edebug is active. | |
2252 (fset 'signal 'edebug-signal) | |
2253 (unwind-protect | |
2254 (edebug-enter edebug-function edebug-args edebug-body) | |
2255 (fset 'signal (symbol-function 'edebug-original-signal)))) | |
2256 ;; Reset global variables in case outside value was changed. | |
2257 (setq executing-macro edebug-outside-executing-macro | |
2258 pre-command-hook edebug-outside-pre-command-hook | |
2259 post-command-hook edebug-outside-post-command-hook | |
2260 post-command-idle-hook edebug-outside-post-command-idle-hook | |
2261 ))) | |
2262 | |
2263 (let* ((edebug-data (get edebug-function 'edebug)) | |
2264 (edebug-def-mark (car edebug-data)) ; mark at def start | |
2265 (edebug-freq-count (get edebug-function 'edebug-freq-count)) | |
2266 (edebug-coverage (get edebug-function 'edebug-coverage)) | |
2267 (edebug-buffer (marker-buffer edebug-def-mark)) | |
2268 | |
2269 (edebug-stack (cons edebug-function edebug-stack)) | |
2270 (edebug-offset-indices (cons 0 edebug-offset-indices)) | |
2271 ) | |
2272 (if (get edebug-function 'edebug-on-entry) | |
2273 (progn | |
2274 (setq edebug-execution-mode 'step) | |
2275 (if (eq (get edebug-function 'edebug-on-entry) 'temp) | |
2276 (put edebug-function 'edebug-on-entry nil)))) | |
2277 (if edebug-trace | |
2278 (edebug-enter-trace edebug-body) | |
2279 (funcall edebug-body)) | |
2280 ))) | |
2281 | |
2282 | |
2283 (defun edebug-enter-trace (edebug-body) | |
2284 (let ((edebug-stack-depth (1+ edebug-stack-depth)) | |
2285 edebug-result) | |
2286 (edebug-print-trace-before | |
2287 (format "%s args: %s" edebug-function edebug-args)) | |
2288 (prog1 (setq edebug-result (funcall edebug-body)) | |
2289 (edebug-print-trace-after | |
2290 (format "%s result: %s" edebug-function edebug-result))))) | |
2291 | |
2292 (def-edebug-spec edebug-tracing (form body)) | |
2293 | |
2294 (defmacro edebug-tracing (msg &rest body) | |
2295 "Print MSG in *edebug-trace* before and after evaluating BODY. | |
2296 The result of BODY is also printed." | |
2297 (` (let ((edebug-stack-depth (1+ edebug-stack-depth)) | |
2298 edebug-result) | |
2299 (edebug-print-trace-before (, msg)) | |
2300 (prog1 (setq edebug-result (progn (,@ body))) | |
2301 (edebug-print-trace-after | |
2302 (format "%s result: %s" (, msg) edebug-result)))))) | |
2303 | |
2304 (defun edebug-print-trace-before (msg) | |
2305 "Function called to print trace info before expression evaluation. | |
2306 MSG is printed after `::::{ '." | |
2307 (edebug-trace-display | |
2308 edebug-trace-buffer "%s{ %s" (make-string edebug-stack-depth ?\:) msg)) | |
2309 | |
2310 (defun edebug-print-trace-after (msg) | |
2311 "Function called to print trace info after expression evaluation. | |
2312 MSG is printed after `::::} '." | |
2313 (edebug-trace-display | |
2314 edebug-trace-buffer "%s} %s" (make-string edebug-stack-depth ?\:) msg)) | |
2315 | |
2316 | |
2317 | |
2318 (defun edebug-slow-before (edebug-before-index) | |
2319 ;; Debug current function given BEFORE position. | |
2320 ;; Called from functions compiled with edebug-eval-top-level-form. | |
2321 ;; Return the before index. | |
2322 (setcar edebug-offset-indices edebug-before-index) | |
2323 | |
2324 ;; Increment frequency count | |
2325 (aset edebug-freq-count edebug-before-index | |
2326 (1+ (aref edebug-freq-count edebug-before-index))) | |
2327 | |
2328 (if (or (not (memq edebug-execution-mode '(Go-nonstop next))) | |
2329 (edebug-input-pending-p)) | |
2330 (edebug-debugger edebug-before-index 'before nil)) | |
2331 edebug-before-index) | |
2332 | |
2333 (defun edebug-fast-before (edebug-before-index) | |
2334 ;; Do nothing. | |
2335 ) | |
2336 | |
2337 (defun edebug-slow-after (edebug-before-index edebug-after-index edebug-value) | |
2338 ;; Debug current function given AFTER position and VALUE. | |
2339 ;; Called from functions compiled with edebug-eval-top-level-form. | |
2340 ;; Return VALUE. | |
2341 (setcar edebug-offset-indices edebug-after-index) | |
2342 | |
2343 ;; Increment frequency count | |
2344 (aset edebug-freq-count edebug-after-index | |
2345 (1+ (aref edebug-freq-count edebug-after-index))) | |
2346 (if edebug-test-coverage (edebug-update-coverage)) | |
2347 | |
2348 (if (and (eq edebug-execution-mode 'Go-nonstop) | |
2349 (not (edebug-input-pending-p))) | |
2350 ;; Just return result. | |
2351 edebug-value | |
2352 (edebug-debugger edebug-after-index 'after edebug-value) | |
2353 )) | |
2354 | |
2355 (defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value) | |
2356 ;; Do nothing but return the value. | |
2357 edebug-value) | |
2358 | |
2359 (defun edebug-run-slow () | |
2360 (defalias 'edebug-before 'edebug-slow-before) | |
2361 (defalias 'edebug-after 'edebug-slow-after)) | |
2362 | |
2363 ;; This is not used, yet. | |
2364 (defun edebug-run-fast () | |
2365 (defalias 'edebug-before 'edebug-fast-before) | |
2366 (defalias 'edebug-after 'edebug-fast-after)) | |
2367 | |
2368 (edebug-run-slow) | |
2369 | |
2370 | |
2371 (defun edebug-update-coverage () | |
2372 (let ((old-result (aref edebug-coverage edebug-after-index))) | |
2373 (cond | |
2374 ((eq 'ok-coverage old-result)) | |
2375 ((eq 'unknown old-result) | |
2376 (aset edebug-coverage edebug-after-index edebug-value)) | |
2377 ;; Test if a different result. | |
2378 ((not (eq edebug-value old-result)) | |
2379 (aset edebug-coverage edebug-after-index 'ok-coverage))))) | |
2380 | |
2381 | |
2382 ;; Dynamically declared unbound variables. | |
2383 (defvar edebug-arg-mode) ; the mode, either before, after, or error | |
2384 (defvar edebug-breakpoints) | |
2385 (defvar edebug-break-data) ; break data for current function. | |
2386 (defvar edebug-break) ; whether a break occurred. | |
2387 (defvar edebug-global-break) ; whether a global break occurred. | |
2388 (defvar edebug-break-condition) ; whether the breakpoint is conditional. | |
2389 | |
2390 (defvar edebug-break-result nil) | |
2391 (defvar edebug-global-break-result nil) | |
2392 | |
2393 | |
2394 (defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value) | |
2395 ;; Check breakpoints and pending input. | |
2396 ;; If edebug display should be updated, call edebug-display. | |
2397 ;; Return edebug-value. | |
2398 (let* (;; This needs to be here since breakpoints may be changed. | |
2399 (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints | |
2400 (edebug-break-data (assq edebug-offset-index edebug-breakpoints)) | |
2401 (edebug-break-condition (car (cdr edebug-break-data))) | |
2402 (edebug-global-break | |
2403 (if edebug-global-break-condition | |
2404 (condition-case nil | |
2405 (setq edebug-global-break-result | |
2406 (eval edebug-global-break-condition)) | |
2407 (error nil)))) | |
2408 (edebug-break)) | |
2409 | |
2410 ;;; (edebug-trace "exp: %s" edebug-value) | |
2411 ;; Test whether we should break. | |
2412 (setq edebug-break | |
2413 (or edebug-global-break | |
2414 (and edebug-break-data | |
2415 (or (not edebug-break-condition) | |
2416 (setq edebug-break-result | |
2417 (eval edebug-break-condition)))))) | |
2418 (if (and edebug-break | |
2419 (nth 2 edebug-break-data)) ; is it temporary? | |
2420 ;; Delete the breakpoint. | |
2421 (setcdr edebug-data | |
2422 (cons (delq edebug-break-data edebug-breakpoints) | |
2423 (cdr (cdr edebug-data))))) | |
2424 | |
2425 ;; Display if mode is not go, continue, or Continue-fast | |
2426 ;; or break, or input is pending, | |
2427 (if (or (not (memq edebug-execution-mode '(go continue Continue-fast))) | |
2428 edebug-break | |
2429 (edebug-input-pending-p)) | |
2430 (edebug-display)) ; <--------------- display | |
2431 | |
2432 edebug-value | |
2433 )) | |
2434 | |
2435 | |
2436 ;; window-start now stored with each function. | |
2437 ;;(defvar edebug-window-start nil) | |
2438 ;; Remember where each buffers' window starts between edebug calls. | |
2439 ;; This is to avoid spurious recentering. | |
2440 ;; Does this still need to be buffer-local?? | |
2441 ;;(setq-default edebug-window-start nil) | |
2442 ;;(make-variable-buffer-local 'edebug-window-start) | |
2443 | |
2444 | |
2445 ;; Dynamically declared unbound vars | |
2446 (defvar edebug-point) ; the point in edebug buffer | |
2447 (defvar edebug-outside-buffer) ; the current-buffer outside of edebug | |
2448 (defvar edebug-outside-point) ; the point outside of edebug | |
2449 (defvar edebug-outside-mark) ; the mark outside of edebug | |
2450 (defvar edebug-window-data) ; window and window-start for current function | |
2451 (defvar edebug-outside-windows) ; outside window configuration | |
2452 (defvar edebug-eval-buffer) ; for the evaluation list. | |
2453 (defvar edebug-outside-o-a-p) ; outside overlay-arrow-position | |
2454 (defvar edebug-outside-o-a-s) ; outside overlay-arrow-string | |
2455 (defvar edebug-outside-c-i-e-a) ; outside cursor-in-echo-area | |
2456 | |
2457 (defvar edebug-eval-list nil) ;; List of expressions to evaluate. | |
2458 | |
2459 (defvar edebug-previous-result nil) ;; Last result returned. | |
2460 | |
2461 ;; Emacs 19 adds an arg to mark and mark-marker. | |
2462 (defalias 'edebug-mark 'mark) | |
2463 (defalias 'edebug-mark-marker 'mark-marker) | |
2464 | |
2465 | |
2466 (defun edebug-display () | |
2467 ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. | |
2468 ;; Uses local variables of edebug-enter, edebug-before, edebug-after | |
2469 ;; and edebug-debugger. | |
2470 (let ((edebug-active t) ; for minor mode alist | |
2471 edebug-stop ; should we enter recursive-edit | |
2472 (edebug-point (+ edebug-def-mark | |
2473 (aref (nth 2 edebug-data) edebug-offset-index))) | |
2474 edebug-buffer-outside-point ; current point in edebug-buffer | |
2475 ;; window displaying edebug-buffer | |
2476 (edebug-window-data (nth 3 edebug-data)) | |
2477 (edebug-outside-window (selected-window)) | |
2478 (edebug-outside-buffer (current-buffer)) | |
2479 (edebug-outside-point (point)) | |
2480 (edebug-outside-mark (edebug-mark)) | |
2481 edebug-outside-windows ; window or screen configuration | |
2482 edebug-buffer-points | |
2483 | |
2484 edebug-eval-buffer ; declared here so we can kill it below | |
2485 (edebug-eval-result-list (and edebug-eval-list | |
2486 (edebug-eval-result-list))) | |
2487 edebug-trace-window | |
2488 edebug-trace-window-start | |
2489 | |
2490 (edebug-outside-o-a-p overlay-arrow-position) | |
2491 (edebug-outside-o-a-s overlay-arrow-string) | |
2492 (edebug-outside-c-i-e-a cursor-in-echo-area)) | |
2493 (unwind-protect | |
2494 (let ((overlay-arrow-position overlay-arrow-position) | |
2495 (overlay-arrow-string overlay-arrow-string) | |
2496 (cursor-in-echo-area nil) | |
2497 ;; any others?? | |
2498 ) | |
2499 (if (not (buffer-name edebug-buffer)) | |
2500 (let ((debug-on-error nil)) | |
2501 (error "Buffer defining %s not found" edebug-function))) | |
2502 | |
2503 (if (eq 'after edebug-arg-mode) | |
2504 ;; Compute result string now before windows are modified. | |
2505 (edebug-compute-previous-result edebug-value)) | |
2506 | |
2507 (if edebug-save-windows | |
2508 ;; Save windows now before we modify them. | |
2509 (setq edebug-outside-windows | |
2510 (edebug-current-windows edebug-save-windows))) | |
2511 | |
2512 (if edebug-save-displayed-buffer-points | |
2513 (setq edebug-buffer-points (edebug-get-displayed-buffer-points))) | |
2514 | |
2515 ;; First move the edebug buffer point to edebug-point | |
2516 ;; so that window start doesnt get changed when we display it. | |
2517 ;; I dont know if this is going to help. | |
2518 ;;(set-buffer edebug-buffer) | |
2519 ;;(goto-char edebug-point) | |
2520 | |
2521 ;; If edebug-buffer is not currently displayed, | |
2522 ;; first find a window for it. | |
2523 (edebug-pop-to-buffer edebug-buffer (car edebug-window-data)) | |
2524 (setcar edebug-window-data (selected-window)) | |
2525 | |
2526 ;; Now display eval list, if any. | |
2527 ;; This is done after the pop to edebug-buffer | |
2528 ;; so that buffer-window correspondence is correct after quitting. | |
2529 (edebug-eval-display edebug-eval-result-list) | |
2530 ;; The evaluation list better not have deleted edebug-window-data. | |
2531 (select-window (car edebug-window-data)) | |
2532 (set-buffer edebug-buffer) | |
2533 | |
2534 (setq edebug-buffer-outside-point (point)) | |
2535 (goto-char edebug-point) | |
2536 | |
2537 (if (eq 'before edebug-arg-mode) | |
2538 ;; Check whether positions are up-to-date. | |
2539 ;; This assumes point is never before symbol. | |
2540 (if (not (memq (following-char) '(?\( ?\# ?\` ))) | |
2541 (let ((debug-on-error nil)) | |
2542 (error "Source has changed - reevaluate definition of %s" | |
2543 edebug-function) | |
2544 ))) | |
2545 | |
2546 (setcdr edebug-window-data | |
2547 (edebug-adjust-window (cdr edebug-window-data))) | |
2548 | |
2549 ;; Test if there is input, not including keyboard macros. | |
2550 (if (edebug-input-pending-p) | |
2551 (progn | |
2552 (setq edebug-execution-mode 'step | |
2553 edebug-stop t) | |
2554 (edebug-stop) | |
2555 ;; (discard-input) ; is this unfriendly?? | |
2556 )) | |
2557 ;; Now display arrow based on mode. | |
2558 (edebug-overlay-arrow) | |
2559 | |
2560 (cond | |
2561 ((eq 'error edebug-arg-mode) | |
2562 ;; Display error message | |
2563 (setq edebug-execution-mode 'step) | |
2564 (edebug-overlay-arrow) | |
2565 (beep) | |
2566 (if (eq 'quit (car edebug-value)) | |
2567 (message "Quit") | |
2568 (edebug-report-error edebug-value))) | |
2569 (edebug-break | |
2570 (cond | |
2571 (edebug-global-break | |
2572 (message "Global Break: %s => %s" | |
2573 edebug-global-break-condition | |
2574 edebug-global-break-result)) | |
2575 (edebug-break-condition | |
2576 (message "Break: %s => %s" | |
2577 edebug-break-condition | |
2578 edebug-break-result)) | |
2579 ((not (eq edebug-execution-mode 'Continue-fast)) | |
2580 (message "Break")) | |
2581 (t))) | |
2582 | |
2583 (t (message ""))) | |
2584 | |
2585 (if (eq 'after edebug-arg-mode) | |
2586 (progn | |
2587 ;; Display result of previous evaluation. | |
2588 (if (and edebug-break | |
2589 (not (eq edebug-execution-mode 'Continue-fast))) | |
2590 (sit-for 1)) ; Show break message. | |
2591 (edebug-previous-result))) | |
2592 | |
2593 (cond | |
2594 (edebug-break | |
2595 (cond | |
2596 ((eq edebug-execution-mode 'continue) (edebug-sit-for 1)) | |
2597 ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0)) | |
2598 (t (setq edebug-stop t)))) | |
2599 ;; not edebug-break | |
2600 ((eq edebug-execution-mode 'trace) | |
2601 (edebug-sit-for 1)) ; Force update and pause. | |
2602 ((eq edebug-execution-mode 'Trace-fast) | |
2603 (edebug-sit-for 0)) ; Force update and continue. | |
2604 ) | |
2605 | |
2606 (unwind-protect | |
2607 (if (or edebug-stop | |
2608 (memq edebug-execution-mode '(step next)) | |
2609 (eq edebug-arg-mode 'error)) | |
2610 (progn | |
2611 ;; (setq edebug-execution-mode 'step) | |
2612 ;; (edebug-overlay-arrow) ; this doesnt always show up. | |
2613 (edebug-recursive-edit))) ; <---------- Recursive edit | |
2614 | |
2615 ;; Reset the edebug-window-data to whatever it is now. | |
2616 (let ((window (if (eq (window-buffer) edebug-buffer) | |
2617 (selected-window) | |
2618 (edebug-get-buffer-window edebug-buffer)))) | |
2619 ;; Remember window-start for edebug-buffer, if still displayed. | |
2620 (if window | |
2621 (progn | |
2622 (setcar edebug-window-data window) | |
2623 (setcdr edebug-window-data (window-start window))))) | |
2624 | |
2625 ;; Save trace window point before restoring outside windows. | |
2626 ;; Could generalize this for other buffers. | |
2627 (setq edebug-trace-window (get-buffer-window edebug-trace-buffer)) | |
2628 (if edebug-trace-window | |
2629 (setq edebug-trace-window-start | |
2630 (and edebug-trace-window | |
2631 (window-start edebug-trace-window)))) | |
2632 | |
2633 ;; Restore windows before continuing. | |
2634 (if edebug-save-windows | |
2635 (progn | |
2636 (edebug-set-windows edebug-outside-windows) | |
2637 | |
2638 ;; Restore displayed buffer points. | |
2639 ;; Needed even if restoring windows because | |
2640 ;; window-points are not restored. (should they be??) | |
2641 (if edebug-save-displayed-buffer-points | |
2642 (edebug-set-buffer-points edebug-buffer-points)) | |
2643 | |
2644 ;; Unrestore trace window's window-point. | |
2645 (if edebug-trace-window | |
2646 (set-window-start edebug-trace-window | |
2647 edebug-trace-window-start)) | |
2648 | |
2649 ;; Unrestore edebug-buffer's window-start, if displayed. | |
2650 (let ((window (car edebug-window-data))) | |
2651 (if (and window (edebug-window-live-p window) | |
2652 (eq (window-buffer) edebug-buffer)) | |
2653 (progn | |
2654 (set-window-start window (cdr edebug-window-data) | |
2655 'no-force) | |
2656 ;; Unrestore edebug-buffer's window-point. | |
2657 ;; Needed in addition to setting the buffer point | |
2658 ;; - otherwise quitting doesnt leave point as is. | |
2659 ;; But this causes point to not be restored at times. | |
2660 ;; Also, it may not be a visible window. | |
2661 ;; (set-window-point window edebug-point) | |
2662 ))) | |
2663 | |
2664 ;; Unrestore edebug-buffer's point. Rerestored below. | |
2665 ;; (goto-char edebug-point) ;; in edebug-buffer | |
2666 ) | |
2667 ;; Since we may be in a save-excursion, in case of quit, | |
2668 ;; reselect the outside window only. | |
2669 ;; Only needed if we are not recovering windows?? | |
2670 (if (edebug-window-live-p edebug-outside-window) | |
2671 (select-window edebug-outside-window)) | |
2672 ) ; if edebug-save-windows | |
2673 | |
2674 ;; Restore current buffer always, in case application needs it. | |
2675 (set-buffer edebug-outside-buffer) | |
2676 ;; Restore point, and mark. | |
2677 ;; Needed even if restoring windows because | |
2678 ;; that doesnt restore point and mark in the current buffer. | |
2679 ;; But dont restore point if edebug-buffer is current buffer. | |
2680 (if (not (eq edebug-buffer edebug-outside-buffer)) | |
2681 (goto-char edebug-outside-point)) | |
2682 (if (marker-buffer (edebug-mark-marker)) | |
2683 ;; Does zmacs-regions need to be nil while doing set-marker? | |
2684 (set-marker (edebug-mark-marker) edebug-outside-mark)) | |
2685 ) ; unwind-protect | |
2686 ;; None of the following is done if quit or signal occurs. | |
2687 | |
2688 ;; Restore edebug-buffer's outside point. | |
2689 ;; (edebug-trace "restore edebug-buffer point: %s" | |
2690 ;; edebug-buffer-outside-point) | |
2691 (let ((current-buffer (current-buffer))) | |
2692 (set-buffer edebug-buffer) | |
2693 (goto-char edebug-buffer-outside-point) | |
2694 (set-buffer current-buffer)) | |
2695 ;; ... nothing more. | |
2696 ) | |
2697 ;; Reset global variables to outside values in case they were changed. | |
2698 (setq | |
2699 overlay-arrow-position edebug-outside-o-a-p | |
2700 overlay-arrow-string edebug-outside-o-a-s | |
2701 cursor-in-echo-area edebug-outside-c-i-e-a) | |
2702 ))) | |
2703 | |
2704 | |
2705 (defvar edebug-number-of-recursions 0) | |
2706 ;; Number of recursive edits started by edebug. | |
2707 ;; Should be 0 at the top level. | |
2708 | |
2709 (defvar edebug-recursion-depth 0) | |
2710 ;; Value of recursion-depth when edebug was called. | |
2711 | |
2712 ;; Dynamically declared unbound vars | |
2713 (defvar edebug-outside-match-data) ; match data outside of edebug | |
2714 (defvar edebug-backtrace-buffer) ; each recursive edit gets its own | |
2715 (defvar edebug-inside-windows) | |
2716 (defvar edebug-interactive-p) | |
2717 | |
2718 (defvar edebug-outside-map) | |
2719 (defvar edebug-outside-standard-output) | |
2720 (defvar edebug-outside-standard-input) | |
2721 (defvar edebug-outside-last-command-char) | |
2722 (defvar edebug-outside-last-command) | |
2723 (defvar edebug-outside-this-command) | |
2724 (defvar edebug-outside-last-input-char) | |
2725 | |
2726 ;; Note: here we have defvars for variables that are | |
2727 ;; built-in in certain versions. | |
2728 ;; Each defvar makes a difference | |
2729 ;; in versions where the variable is *not* built-in. | |
2730 | |
2731 ;; Emacs 18 | |
2732 (defvar edebug-outside-unread-command-char) | |
2733 | |
2734 ;; XEmacs | |
2735 (defvar edebug-outside-unread-command-event) ;; like unread-command-events | |
2736 (defvar unread-command-event nil) | |
2737 | |
2738 ;; Emacs 19. | |
2739 (defvar edebug-outside-last-command-event) | |
2740 (defvar edebug-outside-unread-command-events) | |
2741 (defvar edebug-outside-last-input-event) | |
2742 (defvar edebug-outside-last-event-frame) | |
2743 (defvar edebug-outside-last-nonmenu-event) | |
2744 (defvar edebug-outside-track-mouse) | |
2745 | |
2746 ;; Disable byte compiler warnings about unread-command-char and -event | |
2747 ;; (maybe works with byte-compile-version 2.22 at least) | |
2748 (defvar edebug-unread-command-char-warning) | |
2749 (defvar edebug-unread-command-event-warning) | |
2750 (eval-when-compile | |
2751 (setq edebug-unread-command-char-warning | |
2752 (get 'unread-command-char 'byte-obsolete-variable)) | |
2753 (put 'unread-command-char 'byte-obsolete-variable nil) | |
2754 (setq edebug-unread-command-event-warning | |
2755 (get 'unread-command-event 'byte-obsolete-variable)) | |
2756 (put 'unread-command-event 'byte-obsolete-variable nil)) | |
2757 | |
2758 (defun edebug-recursive-edit () | |
2759 ;; Start up a recursive edit inside of edebug. | |
2760 ;; The current buffer is the edebug-buffer, which is put into edebug-mode. | |
2761 ;; Assume that none of the variables below are buffer-local. | |
2762 (let ((edebug-buffer-read-only buffer-read-only) | |
2763 ;; match-data must be done in the outside buffer | |
2764 (edebug-outside-match-data | |
2765 (save-excursion ; might be unnecessary now?? | |
2766 (set-buffer edebug-outside-buffer) ; in case match buffer different | |
2767 (match-data))) | |
2768 | |
2769 ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions)) | |
2770 (edebug-recursion-depth (recursion-depth)) | |
2771 edebug-entered ; bind locally to nil | |
2772 (edebug-interactive-p nil) ; again non-interactive | |
2773 edebug-backtrace-buffer ; each recursive edit gets its own | |
2774 ;; The window configuration may be saved and restored | |
2775 ;; during a recursive-edit | |
2776 edebug-inside-windows | |
2777 | |
2778 (edebug-outside-map (current-local-map)) | |
2779 | |
2780 (edebug-outside-standard-output standard-output) | |
2781 (edebug-outside-standard-input standard-input) | |
2782 (edebug-outside-defining-kbd-macro defining-kbd-macro) | |
2783 | |
2784 (edebug-outside-last-command-char last-command-char) | |
2785 (edebug-outside-last-command last-command) | |
2786 (edebug-outside-this-command this-command) | |
2787 (edebug-outside-last-input-char last-input-char) | |
2788 | |
2789 ;; XEmacs: added the boundp checks | |
2790 (edebug-outside-unread-command-char | |
2791 (and (boundp 'unread-command-char) unread-command-char)) | |
2792 | |
2793 (edebug-outside-last-input-event | |
2794 (and (boundp 'last-input-event) last-input-event)) | |
2795 (edebug-outside-last-command-event | |
2796 (and (boundp 'last-command-event) last-command-event)) | |
2797 (edebug-outside-unread-command-event | |
2798 (and (boundp 'unread-command-event) unread-command-event)) | |
2799 (edebug-outside-unread-command-events | |
2800 (and (boundp 'unread-command-events) unread-command-events)) | |
2801 (edebug-outside-last-event-frame | |
2802 (and (boundp 'last-event-frame) last-event-frame)) | |
2803 (edebug-outside-last-nonmenu-event | |
2804 (and (boundp 'last-nonmenu-event) last-nonmenu-event)) | |
2805 (edebug-outside-track-mouse | |
2806 (and (boundp 'track-mouse) track-mouse)) | |
2807 ) | |
2808 | |
2809 (unwind-protect | |
2810 (let ( | |
2811 ;; Declare global values local but using the same global value. | |
2812 ;; We could set these to the values for previous edebug call. | |
2813 (last-command-char last-command-char) | |
2814 (last-command last-command) | |
2815 (this-command this-command) | |
2816 (last-input-char last-input-char) | |
2817 | |
2818 ;; Assume no edebug command sets unread-command-char. | |
2819 (unread-command-char -1) | |
2820 | |
2821 ;; More for Emacs 19 | |
2822 (last-input-event nil) | |
2823 (last-command-event nil) | |
2824 (unread-command-event nil);; XEmacs | |
2825 (unread-command-events nil) | |
2826 (last-event-frame nil) | |
2827 (last-nonmenu-event nil) | |
2828 (track-mouse nil) | |
2829 | |
2830 ;; Bind again to outside values. | |
2831 (debug-on-error edebug-outside-debug-on-error) | |
2832 (debug-on-quit edebug-outside-debug-on-quit) | |
2833 | |
2834 ;; Don't keep defining a kbd macro. | |
2835 (defining-kbd-macro | |
2836 (if edebug-continue-kbd-macro defining-kbd-macro)) | |
2837 | |
2838 ;; others?? | |
2839 ) | |
2840 | |
2841 (if (fboundp 'zmacs-deactivate-region);; for XEmacs | |
2842 (zmacs-deactivate-region)) | |
2843 (if (and (eq edebug-execution-mode 'go) | |
2844 (not (memq edebug-arg-mode '(after error)))) | |
2845 (message "Break")) | |
2846 | |
2847 (setq buffer-read-only t) | |
2848 (fset 'signal (symbol-function 'edebug-original-signal)) | |
2849 | |
2850 (edebug-mode) | |
2851 (unwind-protect | |
2852 (recursive-edit) ; <<<<<<<<<< Recursive edit | |
2853 | |
2854 ;; Do the following, even if quit occurs. | |
2855 (fset 'signal 'edebug-signal) | |
2856 (if edebug-backtrace-buffer | |
2857 (kill-buffer edebug-backtrace-buffer)) | |
2858 ;; Could be an option to keep eval display up. | |
2859 (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) | |
2860 | |
2861 ;; Remember selected-window after recursive-edit. | |
2862 ;; (setq edebug-inside-window (selected-window)) | |
2863 | |
2864 (store-match-data edebug-outside-match-data) | |
2865 | |
2866 ;; Recursive edit may have changed buffers, | |
2867 ;; so set it back before exiting let. | |
2868 (if (buffer-name edebug-buffer) ; if it still exists | |
2869 (progn | |
2870 (set-buffer edebug-buffer) | |
2871 (if (memq edebug-execution-mode '(go Go-nonstop)) | |
2872 (edebug-overlay-arrow)) | |
2873 (setq buffer-read-only edebug-buffer-read-only) | |
2874 (use-local-map edebug-outside-map) | |
2875 ) | |
2876 ;; gotta have a buffer to let its buffer local variables be set | |
2877 (get-buffer-create " bogus edebug buffer")) | |
2878 ));; inner let | |
2879 | |
2880 ;; Reset global vars to outside values, in case they have been changed. | |
2881 (setq | |
2882 last-command-char edebug-outside-last-command-char | |
2883 last-command-event edebug-outside-last-command-event | |
2884 last-command edebug-outside-last-command | |
2885 this-command edebug-outside-this-command | |
2886 unread-command-char edebug-outside-unread-command-char | |
2887 unread-command-event edebug-outside-unread-command-event | |
2888 unread-command-events edebug-outside-unread-command-events | |
2889 last-input-char edebug-outside-last-input-char | |
2890 last-input-event edebug-outside-last-input-event | |
2891 last-event-frame edebug-outside-last-event-frame | |
2892 last-nonmenu-event edebug-outside-last-nonmenu-event | |
2893 track-mouse edebug-outside-track-mouse | |
2894 | |
2895 standard-output edebug-outside-standard-output | |
2896 standard-input edebug-outside-standard-input | |
2897 defining-kbd-macro edebug-outside-defining-kbd-macro | |
2898 )) | |
2899 )) | |
2900 | |
2901 | |
2902 ;;; Display related functions | |
2903 ;;; =============================== | |
2904 | |
2905 (defun edebug-adjust-window (old-start) | |
2906 ;; If pos is not visible, adjust current window to fit following context. | |
2907 ;;; (message "window: %s old-start: %s window-start: %s pos: %s" | |
2908 ;;; (selected-window) old-start (window-start) (point)) (sit-for 5) | |
2909 (if (not (pos-visible-in-window-p)) | |
2910 (progn | |
2911 ;; First try old-start | |
2912 (if old-start | |
2913 (set-window-start (selected-window) old-start)) | |
2914 (if (not (pos-visible-in-window-p)) | |
2915 (progn | |
2916 ;; (message "resetting window start") (sit-for 2) | |
2917 (set-window-start | |
2918 (selected-window) | |
2919 (save-excursion | |
2920 (forward-line | |
2921 (if (< (point) (window-start)) -1 ; one line before if in back | |
2922 (- (/ (window-height) 2)) ; center the line moving forward | |
2923 )) | |
2924 (beginning-of-line) | |
2925 (point))))))) | |
2926 (window-start)) | |
2927 | |
2928 | |
2929 | |
2930 (defconst edebug-arrow-alist | |
2931 '((Continue-fast . "=") | |
2932 (Trace-fast . "-") | |
2933 (continue . ">") | |
2934 (trace . "->") | |
2935 (step . "=>") | |
2936 (next . "=>") | |
2937 (go . "<>") | |
2938 (Go-nonstop . "..") ; not used | |
2939 ) | |
2940 "Association list of arrows for each edebug mode.") | |
2941 | |
2942 (defun edebug-overlay-arrow () | |
2943 ;; Set up the overlay arrow at beginning-of-line in current buffer. | |
2944 ;; The arrow string is derived from edebug-arrow-alist and | |
2945 ;; edebug-execution-mode. | |
2946 (let ((pos (save-excursion (beginning-of-line) (point)))) | |
2947 (setq overlay-arrow-string | |
2948 (cdr (assq edebug-execution-mode edebug-arrow-alist))) | |
2949 (setq overlay-arrow-position (make-marker)) | |
2950 (set-marker overlay-arrow-position pos (current-buffer)))) | |
2951 | |
2952 | |
2953 (defun edebug-toggle-save-all-windows () | |
2954 "Toggle the saving and restoring of all windows. | |
2955 Also, each time you toggle it on, the inside and outside window | |
2956 configurations become the same as the current configuration." | |
2957 (interactive) | |
2958 (setq edebug-save-windows (not edebug-save-windows)) | |
2959 (if edebug-save-windows | |
2960 (setq edebug-inside-windows | |
2961 (setq edebug-outside-windows | |
2962 (edebug-current-windows | |
2963 edebug-save-windows)))) | |
2964 (message "Window saving is %s for all windows." | |
2965 (if edebug-save-windows "on" "off"))) | |
2966 | |
2967 (defmacro edebug-changing-windows (&rest body) | |
2968 (` (let ((window (selected-window))) | |
2969 (setq edebug-inside-windows (edebug-current-windows t)) | |
2970 (edebug-set-windows edebug-outside-windows) | |
2971 (,@ body) ;; Code to change edebug-save-windows | |
2972 (setq edebug-outside-windows (edebug-current-windows | |
2973 edebug-save-windows)) | |
2974 ;; Problem: what about outside windows that are deleted inside? | |
2975 (edebug-set-windows edebug-inside-windows)))) | |
2976 | |
2977 (defun edebug-toggle-save-selected-window () | |
2978 "Toggle the saving and restoring of the selected window. | |
2979 Also, each time you toggle it on, the inside and outside window | |
2980 configurations become the same as the current configuration." | |
2981 (interactive) | |
2982 (cond | |
2983 ((eq t edebug-save-windows) | |
2984 ;; Save all outside windows except the selected one. | |
2985 ;; Remove (selected-window) from outside-windows. | |
2986 (edebug-changing-windows | |
2987 (setq edebug-save-windows (delq window (edebug-window-list))))) | |
2988 | |
2989 ((memq (selected-window) edebug-save-windows) | |
2990 (setq edebug-outside-windows | |
2991 (delq (assq (selected-window) edebug-outside-windows) | |
2992 edebug-outside-windows)) | |
2993 (setq edebug-save-windows | |
2994 (delq (selected-window) edebug-save-windows))) | |
2995 (t ; Save a new window. | |
2996 (edebug-changing-windows | |
2997 (setq edebug-save-windows (cons window edebug-save-windows))))) | |
2998 | |
2999 (message "Window saving is %s for %s." | |
3000 (if (memq (selected-window) edebug-save-windows) | |
3001 "on" "off") | |
3002 (selected-window))) | |
3003 | |
3004 (defun edebug-toggle-save-windows (arg) | |
3005 "Toggle the saving and restoring of windows. | |
3006 With prefix, toggle for just the selected window. | |
3007 Otherwise, toggle for all windows." | |
3008 (interactive "P") | |
3009 (if arg | |
3010 (edebug-toggle-save-selected-window) | |
3011 (edebug-toggle-save-all-windows))) | |
3012 | |
3013 | |
3014 (defun edebug-where () | |
3015 "Show the debug windows and where we stopped in the program." | |
3016 (interactive) | |
3017 (if (not edebug-active) | |
3018 (error "Edebug is not active")) | |
3019 ;; Restore the window configuration to what it last was inside. | |
3020 ;; But it is not always set. - experiment | |
3021 ;;(if edebug-inside-windows | |
3022 ;; (edebug-set-windows edebug-inside-windows)) | |
3023 (edebug-pop-to-buffer edebug-buffer) | |
3024 (goto-char edebug-point)) | |
3025 | |
3026 (defun edebug-view-outside () | |
3027 "Change to the outside window configuration." | |
3028 (interactive) | |
3029 (if (not edebug-active) | |
3030 (error "Edebug is not active")) | |
3031 (setq edebug-inside-windows | |
3032 (edebug-current-windows edebug-save-windows)) | |
3033 (edebug-set-windows edebug-outside-windows) | |
3034 (goto-char edebug-outside-point) | |
3035 (message "Window configuration outside of Edebug. Return with %s" | |
3036 (substitute-command-keys "\\<global-map>\\[edebug-where]"))) | |
3037 | |
3038 | |
3039 (defun edebug-bounce-point (arg) | |
3040 "Bounce the point in the outside current buffer. | |
3041 If prefix arg is supplied, sit for that many seconds before returning. | |
3042 The default is one second." | |
3043 (interactive "p") | |
3044 (if (not edebug-active) | |
3045 (error "Edebug is not active")) | |
3046 (save-excursion | |
3047 ;; If the buffer's currently displayed, avoid set-window-configuration. | |
3048 (save-window-excursion | |
3049 (edebug-pop-to-buffer edebug-outside-buffer) | |
3050 (goto-char edebug-outside-point) | |
3051 (message "Current buffer: %s Point: %s Mark: %s" | |
3052 (current-buffer) (point) | |
3053 (if (marker-buffer (edebug-mark-marker)) | |
3054 (marker-position (edebug-mark-marker)) "<not set>")) | |
3055 (edebug-sit-for arg) | |
3056 (edebug-pop-to-buffer edebug-buffer (car edebug-window-data))))) | |
3057 | |
3058 | |
3059 ;; Joe Wells, here is a start at your idea of adding a buffer to the internal | |
3060 ;; display list. Still need to use this list in edebug-display. | |
3061 | |
3062 '(defvar edebug-display-buffer-list nil | |
3063 "List of buffers that edebug will display when it is active.") | |
3064 | |
3065 '(defun edebug-display-buffer (buffer) | |
3066 "Toggle display of a buffer inside of edebug." | |
3067 (interactive "bBuffer: ") | |
3068 (let ((already-displaying (memq buffer edebug-display-buffer-list))) | |
3069 (setq edebug-display-buffer-list | |
3070 (if already-displaying | |
3071 (delq buffer edebug-display-buffer-list) | |
3072 (cons buffer edebug-display-buffer-list))) | |
3073 (message "Displaying %s %s" buffer | |
3074 (if already-displaying "off" "on")))) | |
3075 | |
3076 | |
3077 ;;; Breakpoint related functions | |
3078 ;;; =============================== | |
3079 | |
3080 (defun edebug-find-stop-point () | |
3081 ;; Return (function . index) of the nearest edebug stop point. | |
3082 (let* ((edebug-def-name (edebug-form-data-symbol)) | |
3083 (edebug-data | |
3084 (let ((data (get edebug-def-name 'edebug))) | |
3085 (if (or (null data) (markerp data)) | |
3086 (error "%s is not instrumented for Edebug" edebug-def-name)) | |
3087 data)) ; we could do it automatically, if data is a marker. | |
3088 ;; pull out parts of edebug-data. | |
3089 (edebug-def-mark (car edebug-data)) | |
3090 ;; (edebug-breakpoints (car (cdr edebug-data))) | |
3091 | |
3092 (offset-vector (nth 2 edebug-data)) | |
3093 (offset (- (save-excursion | |
3094 (if (looking-at "[ \t]") | |
3095 ;; skip backwards until non-whitespace, or bol | |
3096 (skip-chars-backward " \t")) | |
3097 (point)) | |
3098 edebug-def-mark)) | |
3099 len i) | |
3100 ;; the offsets are in order so we can do a linear search | |
3101 (setq len (length offset-vector)) | |
3102 (setq i 0) | |
3103 (while (and (< i len) (> offset (aref offset-vector i))) | |
3104 (setq i (1+ i))) | |
3105 (if (and (< i len) | |
3106 (<= offset (aref offset-vector i))) | |
3107 ;; return the relevant info | |
3108 (cons edebug-def-name i) | |
3109 (message "Point is not on an expression in %s." | |
3110 edebug-def-name) | |
3111 ))) | |
3112 | |
3113 | |
3114 (defun edebug-next-breakpoint () | |
3115 "Move point to the next breakpoint, or first if none past point." | |
3116 (interactive) | |
3117 (let ((edebug-stop-point (edebug-find-stop-point))) | |
3118 (if edebug-stop-point | |
3119 (let* ((edebug-def-name (car edebug-stop-point)) | |
3120 (index (cdr edebug-stop-point)) | |
3121 (edebug-data (get edebug-def-name 'edebug)) | |
3122 | |
3123 ;; pull out parts of edebug-data | |
3124 (edebug-def-mark (car edebug-data)) | |
3125 (edebug-breakpoints (car (cdr edebug-data))) | |
3126 (offset-vector (nth 2 edebug-data)) | |
3127 breakpoint) | |
3128 (if (not edebug-breakpoints) | |
3129 (message "No breakpoints in this function.") | |
3130 (let ((breaks edebug-breakpoints)) | |
3131 (while (and breaks | |
3132 (<= (car (car breaks)) index)) | |
3133 (setq breaks (cdr breaks))) | |
3134 (setq breakpoint | |
3135 (if breaks | |
3136 (car breaks) | |
3137 ;; goto the first breakpoint | |
3138 (car edebug-breakpoints))) | |
3139 (goto-char (+ edebug-def-mark | |
3140 (aref offset-vector (car breakpoint)))) | |
3141 | |
3142 (message (concat (if (nth 2 breakpoint) | |
3143 "Temporary " "") | |
3144 (if (car (cdr breakpoint)) | |
3145 (format "Condition: %s" | |
3146 (edebug-safe-prin1-to-string | |
3147 (car (cdr breakpoint)))) | |
3148 ""))) | |
3149 )))))) | |
3150 | |
3151 | |
3152 (defun edebug-modify-breakpoint (flag &optional condition temporary) | |
3153 "Modify the breakpoint for the form at point or after it according | |
3154 to FLAG: set if t, clear if nil. Then move to that point. | |
3155 If CONDITION or TEMPORARY are non-nil, add those attributes to | |
3156 the breakpoint. " | |
3157 (let ((edebug-stop-point (edebug-find-stop-point))) | |
3158 (if edebug-stop-point | |
3159 (let* ((edebug-def-name (car edebug-stop-point)) | |
3160 (index (cdr edebug-stop-point)) | |
3161 (edebug-data (get edebug-def-name 'edebug)) | |
3162 | |
3163 ;; pull out parts of edebug-data | |
3164 (edebug-def-mark (car edebug-data)) | |
3165 (edebug-breakpoints (car (cdr edebug-data))) | |
3166 (offset-vector (nth 2 edebug-data)) | |
3167 present) | |
3168 ;; delete it either way | |
3169 (setq present (assq index edebug-breakpoints)) | |
3170 (setq edebug-breakpoints (delq present edebug-breakpoints)) | |
3171 (if flag | |
3172 (progn | |
3173 ;; add it to the list and resort | |
3174 (setq edebug-breakpoints | |
3175 (edebug-sort-alist | |
3176 (cons | |
3177 (list index condition temporary) | |
3178 edebug-breakpoints) '<)) | |
3179 (if condition | |
3180 (message "Breakpoint set in %s with condition: %s" | |
3181 edebug-def-name condition) | |
3182 (message "Breakpoint set in %s" edebug-def-name))) | |
3183 (if present | |
3184 (message "Breakpoint unset in %s" edebug-def-name) | |
3185 (message "No breakpoint here"))) | |
3186 | |
3187 (setcar (cdr edebug-data) edebug-breakpoints) | |
3188 (goto-char (+ edebug-def-mark (aref offset-vector index))) | |
3189 )))) | |
3190 | |
3191 (defun edebug-set-breakpoint (arg) | |
3192 "Set the breakpoint of nearest sexp. | |
3193 With prefix argument, make it a temporary breakpoint." | |
3194 (interactive "P") | |
3195 (edebug-modify-breakpoint t nil arg)) | |
3196 | |
3197 (defun edebug-unset-breakpoint () | |
3198 "Clear the breakpoint of nearest sexp." | |
3199 (interactive) | |
3200 (edebug-modify-breakpoint nil)) | |
3201 | |
3202 | |
3203 ;; For emacs 18, no read-expression-history | |
3204 (defun edebug-set-conditional-breakpoint (arg condition) | |
3205 "Set a conditional breakpoint at nearest sexp. | |
3206 The condition is evaluated in the outside context. | |
3207 With prefix argument, make it a temporary breakpoint." | |
3208 ;; (interactive "P\nxCondition: ") | |
3209 (interactive | |
3210 (list | |
3211 current-prefix-arg | |
3212 ;; Edit previous condition as follows, but it is cumbersome: | |
3213 (let ((edebug-stop-point (edebug-find-stop-point))) | |
3214 (if edebug-stop-point | |
3215 (let* ((edebug-def-name (car edebug-stop-point)) | |
3216 (index (cdr edebug-stop-point)) | |
3217 (edebug-data (get edebug-def-name 'edebug)) | |
3218 (edebug-breakpoints (car (cdr edebug-data))) | |
3219 (edebug-break-data (assq index edebug-breakpoints)) | |
3220 (edebug-break-condition (car (cdr edebug-break-data)))) | |
3221 (read-minibuffer | |
3222 (format "Condition in %s: " edebug-def-name) | |
3223 (if edebug-break-condition | |
3224 (format "%s" edebug-break-condition) | |
3225 (format "")))))))) | |
3226 (edebug-modify-breakpoint t condition arg)) | |
3227 | |
3228 | |
3229 (defun edebug-set-global-break-condition (expression) | |
3230 (interactive (list (read-minibuffer | |
3231 "Global Condition: " | |
3232 (format "%s" edebug-global-break-condition)))) | |
3233 (setq edebug-global-break-condition expression)) | |
3234 | |
3235 | |
3236 ;;; Mode switching functions | |
3237 ;;; =============================== | |
3238 | |
3239 (defun edebug-set-mode (mode shortmsg msg) | |
3240 ;; Set the edebug mode to MODE. | |
3241 ;; Display SHORTMSG, or MSG if not within edebug. | |
3242 (if (eq (1+ edebug-recursion-depth) (recursion-depth)) | |
3243 (progn | |
3244 (setq edebug-execution-mode mode) | |
3245 (message shortmsg) | |
3246 ;; Continue execution | |
3247 (exit-recursive-edit)) | |
3248 ;; This is not terribly useful!! | |
3249 (setq edebug-next-execution-mode mode) | |
3250 (message msg))) | |
3251 | |
3252 | |
3253 (defalias 'edebug-step-through-mode 'edebug-step-mode) | |
3254 | |
3255 (defun edebug-step-mode () | |
3256 "Proceed to next stop point." | |
3257 (interactive) | |
3258 (edebug-set-mode 'step "" "Edebug will stop at next stop point.")) | |
3259 | |
3260 (defun edebug-next-mode () | |
3261 "Proceed to next `after' stop point." | |
3262 (interactive) | |
3263 (edebug-set-mode 'next "" "Edebug will stop after next eval.")) | |
3264 | |
3265 (defun edebug-go-mode (arg) | |
3266 "Go, evaluating until break. | |
3267 With prefix ARG, set temporary break at current point and go." | |
3268 (interactive "P") | |
3269 (if arg | |
3270 (edebug-set-breakpoint t)) | |
3271 (edebug-set-mode 'go "Go..." "Edebug will go until break.")) | |
3272 | |
3273 (defun edebug-Go-nonstop-mode () | |
3274 "Go, evaluating without debugging." | |
3275 (interactive) | |
3276 (edebug-set-mode 'Go-nonstop "Go-Nonstop..." | |
3277 "Edebug will not stop at breaks.")) | |
3278 | |
3279 | |
3280 (defun edebug-trace-mode () | |
3281 "Begin trace mode." | |
3282 (interactive) | |
3283 (edebug-set-mode 'trace "Tracing..." "Edebug will trace with pause.")) | |
3284 | |
3285 (defun edebug-Trace-fast-mode () | |
3286 "Trace with no wait at each step." | |
3287 (interactive) | |
3288 (edebug-set-mode 'Trace-fast | |
3289 "Trace fast..." "Edebug will trace without pause.")) | |
3290 | |
3291 (defun edebug-continue-mode () | |
3292 "Begin continue mode." | |
3293 (interactive) | |
3294 (edebug-set-mode 'continue "Continue..." | |
3295 "Edebug will pause at breakpoints.")) | |
3296 | |
3297 (defun edebug-Continue-fast-mode () | |
3298 "Trace with no wait at each step." | |
3299 (interactive) | |
3300 (edebug-set-mode 'Continue-fast "Continue fast..." | |
3301 "Edebug will stop and go at breakpoints.")) | |
3302 | |
3303 ;; ------------------------------------------------------------ | |
3304 ;; The following use the mode changing commands and breakpoints. | |
3305 | |
3306 | |
3307 (defun edebug-goto-here () | |
3308 "Proceed to this stop point." | |
3309 (interactive) | |
3310 (edebug-go-mode t)) | |
3311 | |
3312 | |
3313 (defun edebug-stop () | |
3314 "Stop execution and do not continue. | |
3315 Useful for exiting from trace or continue loop." | |
3316 (interactive) | |
3317 (message "Stop")) | |
3318 | |
3319 | |
3320 '(defun edebug-forward () | |
3321 "Proceed to the exit of the next expression to be evaluated." | |
3322 (interactive) | |
3323 (edebug-set-mode | |
3324 'forward "Forward" | |
3325 "Edebug will stop after exiting the next expression.")) | |
3326 | |
3327 | |
3328 (defun edebug-forward-sexp (arg) | |
3329 "Proceed from the current point to the end of the ARGth sexp ahead. | |
3330 If there are not ARG sexps ahead, then do edebug-step-out." | |
3331 (interactive "p") | |
3332 (condition-case nil | |
3333 (let ((parse-sexp-ignore-comments t)) | |
3334 ;; Call forward-sexp repeatedly until done or failure. | |
3335 (forward-sexp arg) | |
3336 (edebug-go-mode t)) | |
3337 (error | |
3338 (edebug-step-out) | |
3339 ))) | |
3340 | |
3341 (defun edebug-step-out () | |
3342 "Proceed from the current point to the end of the containing sexp. | |
3343 If there is no containing sexp that is not the top level defun, | |
3344 go to the end of the last sexp, or if that is the same point, then step." | |
3345 (interactive) | |
3346 (condition-case nil | |
3347 (let ((parse-sexp-ignore-comments t)) | |
3348 (up-list 1) | |
3349 (save-excursion | |
3350 ;; Is there still a containing expression? | |
3351 (up-list 1)) | |
3352 (edebug-go-mode t)) | |
3353 (error | |
3354 ;; At top level - 1, so first check if there are more sexps at this level. | |
3355 (let ((start-point (point))) | |
3356 ;; (up-list 1) | |
3357 (down-list -1) | |
3358 (if (= (point) start-point) | |
3359 (edebug-step-mode) ; No more at this level, so step. | |
3360 (edebug-go-mode t) | |
3361 ))))) | |
3362 | |
3363 (defun edebug-instrument-function (func) | |
3364 ;; Func should be a function symbol. | |
3365 ;; Return the function symbol, or nil if not instrumented. | |
3366 (let ((func-marker)) | |
3367 (setq func-marker (get func 'edebug)) | |
3368 (cond | |
3369 ((markerp func-marker) | |
3370 ;; It is uninstrumented, so instrument it. | |
3371 (save-excursion | |
3372 (set-buffer (marker-buffer func-marker)) | |
3373 (goto-char func-marker) | |
3374 (edebug-eval-top-level-form) | |
3375 func)) | |
3376 ((consp func-marker) | |
3377 (message "%s is already instrumented." func) | |
3378 func) | |
3379 (t | |
3380 ;; We could try harder, e.g. do a tags search. | |
3381 (error "Don't know where %s is defined" func) | |
3382 nil)))) | |
3383 | |
3384 (defun edebug-instrument-callee () | |
3385 "Instrument the definition of the function or macro about to be called. | |
3386 Do this when stopped before the form or it will be too late. | |
3387 One side effect of using this command is that the next time the | |
3388 function or macro is called, Edebug will be called there as well." | |
3389 (interactive) | |
3390 (if (not (looking-at "\(")) | |
3391 (error "You must be before a list form") | |
3392 (let ((func | |
3393 (save-excursion | |
3394 (down-list 1) | |
3395 (if (looking-at "\(") | |
3396 (edebug-form-data-name | |
3397 (edebug-get-form-data-entry (point))) | |
3398 (edebug-original-read (current-buffer)))))) | |
3399 (edebug-instrument-function func)))) | |
3400 | |
3401 | |
3402 (defun edebug-step-in () | |
3403 "Step into the definition of the function or macro about to be called. | |
3404 This first does `edebug-instrument-callee' to ensure that it is | |
3405 instrumented. Then it does `edebug-on-entry' and switches to `go' mode." | |
3406 (interactive) | |
3407 (let ((func (edebug-instrument-callee))) | |
3408 (if func | |
3409 (progn | |
3410 (edebug-on-entry func 'temp) | |
3411 (edebug-go-mode nil))))) | |
3412 | |
3413 (defun edebug-on-entry (function &optional flag) | |
3414 "Cause Edebug to stop when FUNCTION is called. | |
3415 With prefix argument, make this temporary so it is automatically | |
3416 cancelled the first time the function is entered." | |
3417 (interactive "aEdebug on entry to: \nP") | |
3418 ;; Could store this in the edebug data instead. | |
3419 (put function 'edebug-on-entry (if flag 'temp t))) | |
3420 | |
3421 (defun cancel-edebug-on-entry (function) | |
3422 (interactive "aEdebug on entry to: ") | |
3423 (put function 'edebug-on-entry nil)) | |
3424 | |
3425 | |
3426 (if (not (fboundp 'edebug-original-debug-on-entry)) | |
3427 (fset 'edebug-original-debug-on-entry (symbol-function 'debug-on-entry))) | |
3428 '(fset 'debug-on-entry 'edebug-debug-on-entry) ;; Should we do this? | |
3429 ;; Also need edebug-cancel-debug-on-entry | |
3430 | |
3431 '(defun edebug-debug-on-entry (function) | |
3432 "Request FUNCTION to invoke debugger each time it is called. | |
3433 If the user continues, FUNCTION's execution proceeds. | |
3434 Works by modifying the definition of FUNCTION, | |
3435 which must be written in Lisp, not predefined. | |
3436 Use `cancel-debug-on-entry' to cancel the effect of this command. | |
3437 Redefining FUNCTION also does that. | |
3438 | |
3439 This version is from Edebug. If the function is instrumented for | |
3440 Edebug, it calls `edebug-on-entry'" | |
3441 (interactive "aDebug on entry (to function): ") | |
3442 (let ((func-data (get function 'edebug))) | |
3443 (if (or (null func-data) (markerp func-data)) | |
3444 (edebug-original-debug-on-entry function) | |
3445 (edebug-on-entry function)))) | |
3446 | |
3447 | |
3448 (defun edebug-top-level-nonstop () | |
3449 "Set mode to Go-nonstop, and exit to top-level. | |
3450 This is useful for exiting even if unwind-protect code may be executed." | |
3451 (interactive) | |
3452 (setq edebug-execution-mode 'Go-nonstop) | |
3453 (top-level)) | |
3454 | |
3455 | |
3456 ;;(defun edebug-exit-out () | |
3457 ;; "Go until the current function exits." | |
3458 ;; (interactive) | |
3459 ;; (edebug-set-mode 'exiting "Exit...")) | |
3460 | |
3461 | |
3462 ;;; ----------------------------------------------------------------- | |
3463 ;;; The following initial mode setting definitions are not used yet. | |
3464 | |
3465 '(defconst edebug-initial-mode-alist | |
3466 '((edebug-Continue-fast . Continue-fast) | |
3467 (edebug-Trace-fast . Trace-fast) | |
3468 (edebug-continue . continue) | |
3469 (edebug-trace . trace) | |
3470 (edebug-go . go) | |
3471 (edebug-step-through . step) | |
3472 (edebug-Go-nonstop . Go-nonstop) | |
3473 ) | |
3474 "Association list between commands and the modes they set.") | |
3475 | |
3476 | |
3477 '(defun edebug-set-initial-mode () | |
3478 "Ask for the initial mode of the enclosing function. | |
3479 The mode is requested via the key that would be used to set the mode in | |
3480 edebug-mode." | |
3481 (interactive) | |
3482 (let* ((this-function (edebug-which-function)) | |
3483 (keymap (if (eq edebug-mode-map (current-local-map)) | |
3484 edebug-mode-map)) | |
3485 (old-mode (or (get this-function 'edebug-initial-mode) | |
3486 edebug-initial-mode)) | |
3487 (key (read-key-sequence | |
3488 (format | |
3489 "Change initial edebug mode for %s from %s (%s) to (enter key): " | |
3490 this-function | |
3491 old-mode | |
3492 (where-is-internal | |
3493 (car (rassq old-mode edebug-initial-mode-alist)) | |
3494 keymap 'firstonly | |
3495 )))) | |
3496 (mode (cdr (assq (key-binding key) edebug-initial-mode-alist))) | |
3497 ) | |
3498 (if (and mode | |
3499 (or (get this-function 'edebug-initial-mode) | |
3500 (not (eq mode edebug-initial-mode)))) | |
3501 (progn | |
3502 (put this-function 'edebug-initial-mode mode) | |
3503 (message "Initial mode for %s is now: %s" | |
3504 this-function mode)) | |
3505 (error "Key must map to one of the mode changing commands") | |
3506 ))) | |
3507 | |
3508 | |
3509 ;;; Evaluation of expressions | |
3510 ;;; =============================== | |
3511 | |
3512 (def-edebug-spec edebug-outside-excursion t) | |
3513 | |
3514 (defmacro edebug-outside-excursion (&rest body) | |
3515 "Evaluate an expression list in the outside context. | |
3516 Return the result of the last expression." | |
3517 (` (save-excursion ; of current-buffer | |
3518 (if edebug-save-windows | |
3519 (progn | |
3520 ;; After excursion, we will | |
3521 ;; restore to current window configuration. | |
3522 (setq edebug-inside-windows | |
3523 (edebug-current-windows edebug-save-windows)) | |
3524 ;; Restore outside windows. | |
3525 (edebug-set-windows edebug-outside-windows))) | |
3526 | |
3527 (set-buffer edebug-buffer) ; why? | |
3528 ;; (use-local-map edebug-outside-map) | |
3529 (store-match-data edebug-outside-match-data) | |
3530 ;; Restore outside context. | |
3531 (let (;; (edebug-inside-map (current-local-map)) ;; restore map?? | |
3532 (last-command-char edebug-outside-last-command-char) | |
3533 (last-command-event edebug-outside-last-command-event) | |
3534 (last-command edebug-outside-last-command) | |
3535 (this-command edebug-outside-this-command) | |
3536 (unread-command-char edebug-outside-unread-command-char) | |
3537 (unread-command-event edebug-outside-unread-command-event) | |
3538 (unread-command-events edebug-outside-unread-command-events) | |
3539 (last-input-char edebug-outside-last-input-char) | |
3540 (last-input-event edebug-outside-last-input-event) | |
3541 (last-event-frame edebug-outside-last-event-frame) | |
3542 (last-nonmenu-event edebug-outside-last-nonmenu-event) | |
3543 (track-mouse edebug-outside-track-mouse) | |
3544 (standard-output edebug-outside-standard-output) | |
3545 (standard-input edebug-outside-standard-input) | |
3546 | |
3547 (executing-macro edebug-outside-executing-macro) | |
3548 (defining-kbd-macro edebug-outside-defining-kbd-macro) | |
3549 (pre-command-hook edebug-outside-pre-command-hook) | |
3550 (post-command-hook edebug-outside-post-command-hook) | |
3551 (post-command-idle-hook edebug-outside-post-command-idle-hook) | |
3552 | |
3553 ;; See edebug-display | |
3554 (overlay-arrow-position edebug-outside-o-a-p) | |
3555 (overlay-arrow-string edebug-outside-o-a-s) | |
3556 (cursor-in-echo-area edebug-outside-c-i-e-a) | |
3557 ) | |
3558 (unwind-protect | |
3559 (save-excursion ; of edebug-buffer | |
3560 (set-buffer edebug-outside-buffer) | |
3561 (goto-char edebug-outside-point) | |
3562 (if (marker-buffer (edebug-mark-marker)) | |
3563 (set-marker (edebug-mark-marker) edebug-outside-mark)) | |
3564 (,@ body)) | |
3565 | |
3566 ;; Back to edebug-buffer. Restore rest of inside context. | |
3567 ;; (use-local-map edebug-inside-map) | |
3568 (if edebug-save-windows | |
3569 ;; Restore inside windows. | |
3570 (edebug-set-windows edebug-inside-windows)) | |
3571 | |
3572 ;; Save values that may have been changed. | |
3573 (setq | |
3574 edebug-outside-last-command-char last-command-char | |
3575 edebug-outside-last-command-event last-command-event | |
3576 edebug-outside-last-command last-command | |
3577 edebug-outside-this-command this-command | |
3578 edebug-outside-unread-command-char unread-command-char | |
3579 edebug-outside-unread-command-event unread-command-event | |
3580 edebug-outside-unread-command-events unread-command-events | |
3581 edebug-outside-last-input-char last-input-char | |
3582 edebug-outside-last-input-event last-input-event | |
3583 edebug-outside-last-event-frame last-event-frame | |
3584 edebug-outside-last-nonmenu-event last-nonmenu-event | |
3585 edebug-outside-track-mouse track-mouse | |
3586 edebug-outside-standard-output standard-output | |
3587 edebug-outside-standard-input standard-input | |
3588 | |
3589 edebug-outside-executing-macro executing-macro | |
3590 edebug-outside-defining-kbd-macro defining-kbd-macro | |
3591 edebug-outside-pre-command-hook pre-command-hook | |
3592 edebug-outside-post-command-hook post-command-hook | |
3593 edebug-outside-post-command-idle-hook post-command-idle-hook | |
3594 | |
3595 edebug-outside-o-a-p overlay-arrow-position | |
3596 edebug-outside-o-a-s overlay-arrow-string | |
3597 edebug-outside-c-i-e-a cursor-in-echo-area | |
3598 ))) ; let | |
3599 ))) | |
3600 | |
3601 (defvar cl-debug-env nil) ;; defined in cl; non-nil when lexical env used. | |
3602 | |
3603 (defun edebug-eval (edebug-expr) | |
3604 ;; Are there cl lexical variables active? | |
3605 (if cl-debug-env | |
3606 (eval (cl-macroexpand-all edebug-expr cl-debug-env)) | |
3607 (eval edebug-expr))) | |
3608 | |
3609 (defun edebug-safe-eval (edebug-expr) | |
3610 ;; Evaluate EXPR safely. | |
3611 ;; If there is an error, a string is returned describing the error. | |
3612 (condition-case edebug-err | |
3613 (edebug-eval edebug-expr) | |
3614 (error (edebug-format "%s: %s" ;; could | |
3615 (get (car edebug-err) 'error-message) | |
3616 (car (cdr edebug-err)))))) | |
3617 | |
3618 ;;;; Printing | |
3619 ;;; ========= | |
3620 ;; Replace printing functions. | |
3621 | |
3622 ;; obsolete names | |
3623 (defalias 'edebug-install-custom-print-funcs 'edebug-install-custom-print) | |
3624 (defalias 'edebug-reset-print-funcs 'edebug-uninstall-custom-print) | |
3625 (defalias 'edebug-uninstall-custom-print-funcs 'edebug-uninstall-custom-print) | |
3626 | |
3627 (defun edebug-install-custom-print () | |
3628 "Replace print functions used by Edebug with custom versions." | |
3629 ;; Modifying the custom print functions, or changing print-length, | |
3630 ;; print-level, print-circle, custom-print-list or custom-print-vector | |
3631 ;; have immediate effect. | |
3632 (interactive) | |
3633 (require 'cust-print) | |
3634 (defalias 'edebug-prin1 'custom-prin1) | |
3635 (defalias 'edebug-print 'custom-print) | |
3636 (defalias 'edebug-prin1-to-string 'custom-prin1-to-string) | |
3637 (defalias 'edebug-format 'custom-format) | |
3638 (defalias 'edebug-message 'custom-message) | |
3639 "Installed") | |
3640 | |
3641 (eval-and-compile | |
3642 (defun edebug-uninstall-custom-print () | |
3643 "Replace edebug custom print functions with internal versions." | |
3644 (interactive) | |
3645 (defalias 'edebug-prin1 'prin1) | |
3646 (defalias 'edebug-print 'print) | |
3647 (defalias 'edebug-prin1-to-string 'prin1-to-string) | |
3648 (defalias 'edebug-format 'format) | |
3649 (defalias 'edebug-message 'message) | |
3650 "Uninstalled") | |
3651 | |
3652 ;; Default print functions are the same as Emacs'. | |
3653 (edebug-uninstall-custom-print)) | |
3654 | |
3655 | |
3656 (defun edebug-report-error (edebug-value) | |
3657 ;; Print an error message like command level does. | |
3658 ;; This also prints the error name if it has no error-message. | |
3659 (message "%s: %s" | |
3660 (or (get (car edebug-value) 'error-message) | |
3661 (format "peculiar error (%s)" (car edebug-value))) | |
3662 (mapconcat (function (lambda (edebug-arg) | |
3663 ;; continuing after an error may | |
3664 ;; complain about edebug-arg. why?? | |
3665 (prin1-to-string edebug-arg))) | |
3666 (cdr edebug-value) ", "))) | |
3667 | |
3668 ;; Define here in case they are not already defined. | |
3669 (defvar print-level nil) | |
3670 (defvar print-circle nil) | |
3671 (defvar print-readably) ;; defined by XEmacs | |
3672 ;; Alternatively, we could change the definition of | |
3673 ;; edebug-safe-prin1-to-string to only use these if defined. | |
3674 | |
3675 (defun edebug-safe-prin1-to-string (value) | |
3676 (let ((print-escape-newlines t) | |
3677 (print-length (or edebug-print-length print-length)) | |
3678 (print-level (or edebug-print-level print-level)) | |
3679 (print-circle (or edebug-print-circle print-circle)) | |
3680 (print-readably nil)) ;; XEmacs uses this. | |
3681 (edebug-prin1-to-string value))) | |
3682 | |
3683 (defun edebug-compute-previous-result (edebug-previous-value) | |
3684 (setq edebug-previous-result | |
3685 (if (and (numberp edebug-previous-value) | |
3686 (< edebug-previous-value 256) | |
3687 (>= edebug-previous-value 0)) | |
3688 (format "Result: %s = %s" edebug-previous-value | |
3689 (single-key-description edebug-previous-value)) | |
3690 (if edebug-unwrap-results | |
3691 (setq edebug-previous-value | |
3692 (edebug-unwrap* edebug-previous-value))) | |
3693 (concat "Result: " | |
3694 (edebug-safe-prin1-to-string edebug-previous-value))))) | |
3695 | |
3696 (defun edebug-previous-result () | |
3697 "Print the previous result." | |
3698 (interactive) | |
3699 (message "%s" edebug-previous-result)) | |
3700 | |
3701 ;;;; Read, Eval and Print | |
3702 ;;; ===================== | |
3703 | |
3704 (defun edebug-eval-expression (edebug-expr) | |
3705 "Evaluate an expression in the outside environment. | |
3706 If interactive, prompt for the expression. | |
3707 Print result in minibuffer." | |
3708 (interactive "xEval: ") | |
3709 (princ | |
3710 (edebug-outside-excursion | |
3711 (setq values (cons (edebug-eval edebug-expr) values)) | |
3712 (edebug-safe-prin1-to-string (car values))))) | |
3713 | |
3714 (defun edebug-eval-last-sexp () | |
3715 "Evaluate sexp before point in the outside environment; | |
3716 print value in minibuffer." | |
3717 (interactive) | |
3718 (edebug-eval-expression (edebug-last-sexp))) | |
3719 | |
3720 (defun edebug-eval-print-last-sexp () | |
3721 "Evaluate sexp before point in the outside environment; | |
3722 print value into current buffer." | |
3723 (interactive) | |
3724 (let* ((edebug-form (edebug-last-sexp)) | |
3725 (edebug-result-string | |
3726 (edebug-outside-excursion | |
3727 (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form)))) | |
3728 (standard-output (current-buffer))) | |
3729 (princ "\n") | |
3730 ;; princ the string to get rid of quotes. | |
3731 (princ edebug-result-string) | |
3732 (princ "\n") | |
3733 )) | |
3734 | |
3735 | |
3736 ;;;; Edebug Minor Mode | |
3737 ;;; =============================== | |
3738 | |
3739 ;; Global GUD bindings for all emacs-lisp-mode buffers. | |
3740 (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) | |
3741 (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) | |
3742 (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) | |
3743 (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) | |
3744 | |
3745 | |
3746 (defvar edebug-mode-map nil) | |
3747 (if edebug-mode-map | |
3748 nil | |
3749 (progn | |
3750 (setq edebug-mode-map (copy-keymap emacs-lisp-mode-map)) | |
3751 ;; control | |
3752 (define-key edebug-mode-map " " 'edebug-step-mode) | |
3753 (define-key edebug-mode-map "n" 'edebug-next-mode) | |
3754 (define-key edebug-mode-map "g" 'edebug-go-mode) | |
3755 (define-key edebug-mode-map "G" 'edebug-Go-nonstop-mode) | |
3756 (define-key edebug-mode-map "t" 'edebug-trace-mode) | |
3757 (define-key edebug-mode-map "T" 'edebug-Trace-fast-mode) | |
3758 (define-key edebug-mode-map "c" 'edebug-continue-mode) | |
3759 (define-key edebug-mode-map "C" 'edebug-Continue-fast-mode) | |
3760 | |
3761 ;;(define-key edebug-mode-map "f" 'edebug-forward) not implemented | |
3762 (define-key edebug-mode-map "f" 'edebug-forward-sexp) | |
3763 (define-key edebug-mode-map "h" 'edebug-goto-here) | |
3764 | |
3765 (define-key edebug-mode-map "I" 'edebug-instrument-callee) | |
3766 (define-key edebug-mode-map "i" 'edebug-step-in) | |
3767 (define-key edebug-mode-map "o" 'edebug-step-out) | |
3768 | |
3769 ;; quitting and stopping | |
3770 (define-key edebug-mode-map "q" 'top-level) | |
3771 (define-key edebug-mode-map "Q" 'edebug-top-level-nonstop) | |
3772 (define-key edebug-mode-map "a" 'abort-recursive-edit) | |
3773 (define-key edebug-mode-map "S" 'edebug-stop) | |
3774 | |
3775 ;; breakpoints | |
3776 (define-key edebug-mode-map "b" 'edebug-set-breakpoint) | |
3777 (define-key edebug-mode-map "u" 'edebug-unset-breakpoint) | |
3778 (define-key edebug-mode-map "B" 'edebug-next-breakpoint) | |
3779 (define-key edebug-mode-map "x" 'edebug-set-conditional-breakpoint) | |
3780 (define-key edebug-mode-map "X" 'edebug-set-global-break-condition) | |
3781 | |
3782 ;; evaluation | |
3783 (define-key edebug-mode-map "r" 'edebug-previous-result) | |
3784 (define-key edebug-mode-map "e" 'edebug-eval-expression) | |
3785 (define-key edebug-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) | |
3786 (define-key edebug-mode-map "E" 'edebug-visit-eval-list) | |
3787 | |
3788 ;; views | |
3789 (define-key edebug-mode-map "w" 'edebug-where) | |
3790 (define-key edebug-mode-map "v" 'edebug-view-outside) ;; maybe obsolete?? | |
3791 (define-key edebug-mode-map "p" 'edebug-bounce-point) | |
3792 (define-key edebug-mode-map "P" 'edebug-view-outside) ;; same as v | |
3793 (define-key edebug-mode-map "W" 'edebug-toggle-save-windows) | |
3794 | |
3795 ;; misc | |
3796 (define-key edebug-mode-map "?" 'edebug-help) | |
3797 (define-key edebug-mode-map "d" 'edebug-backtrace) | |
3798 | |
3799 (define-key edebug-mode-map "-" 'negative-argument) | |
3800 | |
3801 ;; statistics | |
3802 (define-key edebug-mode-map "=" 'edebug-temp-display-freq-count) | |
3803 | |
3804 ;; GUD bindings | |
3805 (define-key edebug-mode-map "\C-c\C-s" 'edebug-step-mode) | |
3806 (define-key edebug-mode-map "\C-c\C-n" 'edebug-next-mode) | |
3807 (define-key edebug-mode-map "\C-c\C-c" 'edebug-go-mode) | |
3808 | |
3809 (define-key edebug-mode-map "\C-x " 'edebug-set-breakpoint) | |
3810 (define-key edebug-mode-map "\C-c\C-d" 'edebug-unset-breakpoint) | |
3811 (define-key edebug-mode-map "\C-c\C-t" | |
3812 (function (lambda () (edebug-set-breakpoint t)))) | |
3813 (define-key edebug-mode-map "\C-c\C-l" 'edebug-where) | |
3814 )) | |
3815 | |
3816 ;; Autoloading these global bindings doesn't make sense because | |
3817 ;; they cannot be used anyway unless Edebug is already loaded and active. | |
3818 | |
3819 (defvar global-edebug-prefix "\^XX" | |
3820 "Prefix key for global edebug commands, available from any buffer.") | |
3821 | |
3822 (defvar global-edebug-map nil | |
3823 "Global map of edebug commands, available from any buffer.") | |
3824 | |
3825 (if global-edebug-map | |
3826 nil | |
3827 (setq global-edebug-map (make-sparse-keymap)) | |
3828 | |
3829 (global-unset-key global-edebug-prefix) | |
3830 (global-set-key global-edebug-prefix global-edebug-map) | |
3831 | |
3832 (define-key global-edebug-map " " 'edebug-step-mode) | |
3833 (define-key global-edebug-map "g" 'edebug-go-mode) | |
3834 (define-key global-edebug-map "G" 'edebug-Go-nonstop-mode) | |
3835 (define-key global-edebug-map "t" 'edebug-trace-mode) | |
3836 (define-key global-edebug-map "T" 'edebug-Trace-fast-mode) | |
3837 (define-key global-edebug-map "c" 'edebug-continue-mode) | |
3838 (define-key global-edebug-map "C" 'edebug-Continue-fast-mode) | |
3839 | |
3840 ;; breakpoints | |
3841 (define-key global-edebug-map "b" 'edebug-set-breakpoint) | |
3842 (define-key global-edebug-map "u" 'edebug-unset-breakpoint) | |
3843 (define-key global-edebug-map "x" 'edebug-set-conditional-breakpoint) | |
3844 (define-key global-edebug-map "X" 'edebug-set-global-break-condition) | |
3845 | |
3846 ;; views | |
3847 (define-key global-edebug-map "w" 'edebug-where) | |
3848 (define-key global-edebug-map "W" 'edebug-toggle-save-windows) | |
3849 | |
3850 ;; quitting | |
3851 (define-key global-edebug-map "q" 'top-level) | |
3852 (define-key global-edebug-map "Q" 'edebug-top-level-nonstop) | |
3853 (define-key global-edebug-map "a" 'abort-recursive-edit) | |
3854 | |
3855 ;; statistics | |
3856 (define-key global-edebug-map "=" 'edebug-display-freq-count) | |
3857 ) | |
3858 | |
3859 (defun edebug-help () | |
3860 (interactive) | |
3861 (describe-function 'edebug-mode)) | |
3862 | |
3863 (defun edebug-mode () | |
3864 "Mode for Emacs Lisp buffers while in Edebug. | |
3865 | |
3866 In addition to all Emacs Lisp commands (except those that modify the | |
3867 buffer) there are local and global key bindings to several Edebug | |
3868 specific commands. E.g. `edebug-step-mode' is bound to \\[edebug-step-mode] | |
3869 in the Edebug buffer and \\<global-map>\\[edebug-step-mode] in any buffer. | |
3870 | |
3871 Also see bindings for the eval list buffer, *edebug*. | |
3872 | |
3873 The edebug buffer commands: | |
3874 \\{edebug-mode-map} | |
3875 | |
3876 Global commands prefixed by `global-edebug-prefix': | |
3877 \\{global-edebug-map} | |
3878 | |
3879 Options: | |
3880 edebug-setup-hook | |
3881 edebug-all-defs | |
3882 edebug-all-forms | |
3883 edebug-save-windows | |
3884 edebug-save-displayed-buffer-points | |
3885 edebug-initial-mode | |
3886 edebug-trace | |
3887 edebug-test-coverage | |
3888 edebug-continue-kbd-macro | |
3889 edebug-print-length | |
3890 edebug-print-level | |
3891 edebug-print-circle | |
3892 edebug-on-error | |
3893 edebug-on-quit | |
3894 edebug-on-signal | |
3895 edebug-unwrap-results | |
3896 edebug-global-break-condition | |
3897 " | |
3898 (use-local-map edebug-mode-map)) | |
3899 | |
3900 | |
3901 ;;;; edebug eval list mode | |
3902 ;;; =============================================== | |
3903 ;; A list of expressions and their evaluations is displayed in *edebug*. | |
3904 | |
3905 (defun edebug-eval-result-list () | |
3906 "Return a list of evaluations of edebug-eval-list" | |
3907 ;; Assumes in outside environment. | |
3908 ;; Don't do any edebug things now. | |
3909 (let ((edebug-execution-mode 'Go-nonstop) | |
3910 (edebug-trace nil)) | |
3911 (mapcar 'edebug-safe-eval edebug-eval-list))) | |
3912 | |
3913 (defun edebug-eval-display-list (edebug-eval-result-list) | |
3914 ;; Assumes edebug-eval-buffer exists. | |
3915 (let ((edebug-eval-list-temp edebug-eval-list) | |
3916 (standard-output edebug-eval-buffer) | |
3917 (edebug-comment-line | |
3918 (format ";%s\n" (make-string (- (window-width) 2) ?-)))) | |
3919 (set-buffer edebug-eval-buffer) | |
3920 (erase-buffer) | |
3921 (while edebug-eval-list-temp | |
3922 (prin1 (car edebug-eval-list-temp)) (terpri) | |
3923 (prin1 (car edebug-eval-result-list)) (terpri) | |
3924 (princ edebug-comment-line) | |
3925 (setq edebug-eval-list-temp (cdr edebug-eval-list-temp)) | |
3926 (setq edebug-eval-result-list (cdr edebug-eval-result-list))) | |
3927 (edebug-pop-to-buffer edebug-eval-buffer) | |
3928 )) | |
3929 | |
3930 (defun edebug-create-eval-buffer () | |
3931 (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer))) | |
3932 (progn | |
3933 (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) | |
3934 (edebug-eval-mode)))) | |
3935 | |
3936 ;; Should generalize this to be callable outside of edebug | |
3937 ;; with calls in user functions, e.g. (edebug-eval-display) | |
3938 | |
3939 (defun edebug-eval-display (edebug-eval-result-list) | |
3940 "Display expressions and evaluations in EVAL-LIST. | |
3941 It modifies the context by popping up the eval display." | |
3942 (if edebug-eval-result-list | |
3943 (progn | |
3944 (edebug-create-eval-buffer) | |
3945 (edebug-eval-display-list edebug-eval-result-list) | |
3946 ))) | |
3947 | |
3948 (defun edebug-eval-redisplay () | |
3949 "Redisplay eval list in outside environment. | |
3950 May only be called from within edebug-recursive-edit." | |
3951 (edebug-create-eval-buffer) | |
3952 (edebug-outside-excursion | |
3953 (edebug-eval-display-list (edebug-eval-result-list)) | |
3954 )) | |
3955 | |
3956 (defun edebug-visit-eval-list () | |
3957 (interactive) | |
3958 (edebug-eval-redisplay) | |
3959 (edebug-pop-to-buffer edebug-eval-buffer)) | |
3960 | |
3961 | |
3962 (defun edebug-update-eval-list () | |
3963 "Replace the evaluation list with the sexps now in the eval buffer." | |
3964 (interactive) | |
3965 (let ((starting-point (point)) | |
3966 new-list) | |
3967 (goto-char (point-min)) | |
3968 ;; get the first expression | |
3969 (edebug-skip-whitespace) | |
3970 (if (not (eobp)) | |
3971 (progn | |
3972 (forward-sexp 1) | |
3973 (setq new-list (cons (edebug-last-sexp) new-list)))) | |
3974 | |
3975 (while (re-search-forward "^;" nil t) | |
3976 (forward-line 1) | |
3977 (skip-chars-forward " \t\n\r") | |
3978 (if (and (/= ?\; (following-char)) | |
3979 (not (eobp))) | |
3980 (progn | |
3981 (forward-sexp 1) | |
3982 (setq new-list (cons (edebug-last-sexp) new-list))))) | |
3983 | |
3984 (setq edebug-eval-list (nreverse new-list)) | |
3985 (edebug-eval-redisplay) | |
3986 (goto-char starting-point))) | |
3987 | |
3988 | |
3989 (defun edebug-delete-eval-item () | |
3990 "Delete the item under point and redisplay." | |
3991 ;; could add arg to do repeatedly | |
3992 (interactive) | |
3993 (if (re-search-backward "^;" nil 'nofail) | |
3994 (forward-line 1)) | |
3995 (delete-region | |
3996 (point) (progn (re-search-forward "^;" nil 'nofail) | |
3997 (beginning-of-line) | |
3998 (point))) | |
3999 (edebug-update-eval-list)) | |
4000 | |
4001 | |
4002 | |
4003 (defvar edebug-eval-mode-map nil | |
4004 "Keymap for edebug-eval-mode. Superset of lisp-interaction-mode.") | |
4005 | |
4006 (if edebug-eval-mode-map | |
4007 nil | |
4008 (setq edebug-eval-mode-map (copy-keymap lisp-interaction-mode-map)) | |
4009 | |
4010 (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where) | |
4011 (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item) | |
4012 (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list) | |
4013 (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) | |
4014 (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp) | |
4015 ) | |
4016 | |
4017 | |
4018 (defun edebug-eval-mode () | |
4019 "Mode for evaluation list buffer while in Edebug. | |
4020 | |
4021 In addition to all Interactive Emacs Lisp commands there are local and | |
4022 global key bindings to several Edebug specific commands. E.g. | |
4023 `edebug-step-mode' is bound to \\[edebug-step-mode] in the Edebug | |
4024 buffer and \\<global-map>\\[edebug-step-mode] in any buffer. | |
4025 | |
4026 Eval list buffer commands: | |
4027 \\{edebug-eval-mode-map} | |
4028 | |
4029 Global commands prefixed by global-edebug-prefix: | |
4030 \\{global-edebug-map} | |
4031 " | |
4032 (lisp-interaction-mode) | |
4033 (setq major-mode 'edebug-eval-mode) | |
4034 (setq mode-name "Edebug-Eval") | |
4035 (use-local-map edebug-eval-mode-map)) | |
4036 | |
4037 | |
4038 ;;;; Interface with standard debugger. | |
4039 ;;; ======================================== | |
4040 | |
4041 ;; (setq debugger 'edebug) ; to use the edebug debugger | |
4042 ;; (setq debugger 'debug) ; use the standard debugger | |
4043 | |
4044 ;; Note that debug and its utilities must be byte-compiled to work, | |
4045 ;; since they depend on the backtrace looking a certain way. But | |
4046 ;; edebug is not dependent on this, yet. | |
4047 | |
4048 (defun edebug (&optional edebug-arg-mode &rest debugger-args) | |
4049 "Replacement for debug. | |
4050 If we are running an edebugged function, | |
4051 show where we last were. Otherwise call debug normally." | |
4052 ;; (message "entered: %s depth: %s edebug-recursion-depth: %s" | |
4053 ;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) | |
4054 (if (and edebug-entered ; anything active? | |
4055 (eq (recursion-depth) edebug-recursion-depth)) | |
4056 (let (;; Where were we before the error occurred? | |
4057 (edebug-offset-index (car edebug-offset-indices)) | |
4058 ;; Bind variables required by edebug-display | |
4059 (edebug-value (car debugger-args)) | |
4060 edebug-breakpoints | |
4061 edebug-break-data | |
4062 edebug-break-condition | |
4063 edebug-global-break | |
4064 (edebug-break (null edebug-arg-mode)) ;; if called explicitly | |
4065 ) | |
4066 (edebug-display) | |
4067 (if (eq edebug-arg-mode 'error) | |
4068 nil | |
4069 edebug-value)) | |
4070 | |
4071 ;; Otherwise call debug normally. | |
4072 ;; Still need to remove extraneous edebug calls from stack. | |
4073 (apply 'debug edebug-arg-mode debugger-args) | |
4074 )) | |
4075 | |
4076 | |
4077 (defun edebug-backtrace () | |
4078 "Display a non-working backtrace. Better than nothing..." | |
4079 (interactive) | |
4080 (if (or (not edebug-backtrace-buffer) | |
4081 (null (buffer-name edebug-backtrace-buffer))) | |
4082 (setq edebug-backtrace-buffer | |
4083 (generate-new-buffer "*Backtrace*")) | |
4084 ;; else, could just display edebug-backtrace-buffer | |
4085 ) | |
4086 (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) | |
4087 (setq edebug-backtrace-buffer standard-output) | |
4088 (let ((print-escape-newlines t) | |
4089 (print-length 50) | |
4090 last-ok-point) | |
4091 (backtrace) | |
4092 | |
4093 ;; Clean up the backtrace. | |
4094 ;; Not quite right for current edebug scheme. | |
4095 (set-buffer edebug-backtrace-buffer) | |
4096 (setq truncate-lines t) | |
4097 (goto-char (point-min)) | |
4098 (setq last-ok-point (point)) | |
4099 (if t (progn | |
4100 | |
4101 ;; Delete interspersed edebug internals. | |
4102 (while (re-search-forward "^ \(?edebug" nil t) | |
4103 (beginning-of-line) | |
4104 (cond | |
4105 ((looking-at "^ \(edebug-after") | |
4106 ;; Previous lines may contain code, so just delete this line | |
4107 (setq last-ok-point (point)) | |
4108 (forward-line 1) | |
4109 (delete-region last-ok-point (point))) | |
4110 | |
4111 ((looking-at "^ edebug") | |
4112 (forward-line 1) | |
4113 (delete-region last-ok-point (point)) | |
4114 ))) | |
4115 ))))) | |
4116 | |
4117 | |
4118 ;;;; Trace display | |
4119 ;; =============================== | |
4120 | |
4121 (defun edebug-trace-display (buf-name fmt &rest args) | |
4122 "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible. | |
4123 The buffer is created if it does not exist. | |
4124 You must include newlines in FMT to break lines, but one newline is appended." | |
4125 ;; e.g. | |
4126 ;; (edebug-trace-display "*trace-point*" | |
4127 ;; "saving: point = %s window-start = %s" | |
4128 ;; (point) (window-start)) | |
4129 (let* ((selected-window (selected-window)) | |
4130 (buffer (get-buffer-create buf-name)) | |
4131 buf-window) | |
4132 ;; (message "before pop-to-buffer") (sit-for 1) | |
4133 (edebug-pop-to-buffer buffer) | |
4134 (setq truncate-lines t) | |
4135 (setq buf-window (selected-window)) | |
4136 (goto-char (point-max)) | |
4137 (insert (apply 'edebug-format fmt args) "\n") | |
4138 ;; Make it visible. | |
4139 (vertical-motion (- 1 (window-height))) | |
4140 (set-window-start buf-window (point)) | |
4141 (goto-char (point-max)) | |
4142 ;; (set-window-point buf-window (point)) | |
4143 ;; (edebug-sit-for 0) | |
4144 (bury-buffer buffer) | |
4145 (select-window selected-window)) | |
4146 buf-name) | |
4147 | |
4148 | |
4149 (defun edebug-trace (fmt &rest args) | |
4150 "Convenience call to edebug-trace-display using edebug-trace-buffer" | |
4151 (apply 'edebug-trace-display edebug-trace-buffer fmt args)) | |
4152 | |
4153 | |
4154 ;;;; Frequency count and coverage | |
4155 ;;; ============================== | |
4156 | |
4157 (defun edebug-display-freq-count () | |
4158 "Display the frequency count data for each line of the current | |
4159 definition. The frequency counts are inserted as comment lines after | |
4160 each line, and you can undo all insertions with one `undo' command. | |
4161 | |
4162 The counts are inserted starting under the `(' before an expression | |
4163 or the `)' after an expression, or on the last char of a symbol. | |
4164 The counts are only displayed when they differ from previous counts on | |
4165 the same line. | |
4166 | |
4167 If coverage is being tested, whenever all known results of an expression | |
4168 are `eq', the char `=' will be appended after the count | |
4169 for that expression. Note that this is always the case for an | |
4170 expression only evaluated once. | |
4171 | |
4172 To clear the frequency count and coverage data for a definition, | |
4173 reinstrument it." | |
4174 (interactive) | |
4175 (let* ((function (edebug-form-data-symbol)) | |
4176 (counts (get function 'edebug-freq-count)) | |
4177 (coverages (get function 'edebug-coverage)) | |
4178 (data (get function 'edebug)) | |
4179 (def-mark (car data)) ; mark at def start | |
4180 (edebug-points (nth 2 data)) | |
4181 (i (1- (length edebug-points))) | |
4182 (last-index) | |
4183 (first-index) | |
4184 (start-of-line) | |
4185 (start-of-count-line) | |
4186 (last-count) | |
4187 ) | |
4188 (save-excursion | |
4189 ;; Traverse in reverse order so offsets are correct. | |
4190 (while (<= 0 i) | |
4191 ;; Start at last expression in line. | |
4192 (goto-char (+ def-mark (aref edebug-points i))) | |
4193 (beginning-of-line) | |
4194 (setq start-of-line (- (point) def-mark) | |
4195 last-index i) | |
4196 | |
4197 ;; Find all indexes on same line. | |
4198 (while (and (<= 0 (setq i (1- i))) | |
4199 (<= start-of-line (aref edebug-points i)))) | |
4200 ;; Insert all the indices for this line. | |
4201 (forward-line 1) | |
4202 (setq start-of-count-line (point) | |
4203 first-index i ; really last index for line above this one. | |
4204 last-count -1) ; cause first count to always appear. | |
4205 (insert ";#") | |
4206 ;; i == first-index still | |
4207 (while (<= (setq i (1+ i)) last-index) | |
4208 (let ((count (aref counts i)) | |
4209 (coverage (aref coverages i)) | |
4210 (col (save-excursion | |
4211 (goto-char (+ (aref edebug-points i) def-mark)) | |
4212 (- (current-column) | |
4213 (if (= ?\( (following-char)) 0 1))))) | |
4214 (insert (make-string | |
4215 (max 0 (- col (- (point) start-of-count-line))) ?\ ) | |
4216 (if (and (< 0 count) | |
4217 (not (memq coverage | |
4218 '(unknown ok-coverage)))) | |
4219 "=" "") | |
4220 (if (= count last-count) "" (int-to-string count)) | |
4221 " ") | |
4222 (setq last-count count))) | |
4223 (insert "\n") | |
4224 (setq i first-index))))) | |
4225 | |
4226 (defun edebug-temp-display-freq-count () | |
4227 "Temporarily display the frequency count data for the current definition. | |
4228 It is removed when you hit any char." | |
4229 ;; This seems not to work with Emacs 18.59. It undoes too far. | |
4230 (interactive) | |
4231 (let ((buffer-read-only nil)) | |
4232 (undo-boundary) | |
4233 (edebug-display-freq-count) | |
4234 (setq unread-command-char (read-char)) | |
4235 (undo))) | |
4236 | |
4237 | |
4238 ;;;; Menus | |
4239 ;;;========= | |
4240 | |
4241 (defun edebug-toggle (variable) | |
4242 (set variable (not (eval variable))) | |
4243 (message "%s: %s" variable (eval variable))) | |
4244 | |
4245 ;; We have to require easymenu (even for Emacs 18) just so | |
4246 ;; the easy-menu-define macro call is compiled correctly. | |
4247 (require 'easymenu) | |
4248 | |
4249 (defconst edebug-mode-menus | |
4250 '("Edebug" | |
4251 "----" | |
4252 ["Stop" edebug-stop t] | |
4253 ["Step" edebug-step-mode t] | |
4254 ["Next" edebug-next-mode t] | |
4255 ["Trace" edebug-trace-mode t] | |
4256 ["Trace Fast" edebug-Trace-fast-mode t] | |
4257 ["Continue" edebug-continue-mode t] | |
4258 ["Continue Fast" edebug-Continue-fast-mode t] | |
4259 ["Go" edebug-go-mode t] | |
4260 ["Go Nonstop" edebug-Go-nonstop-mode t] | |
4261 "----" | |
4262 ["Help" edebug-help t] | |
4263 ["Abort" abort-recursive-edit t] | |
4264 ["Quit to Top Level" top-level t] | |
4265 ["Quit Nonstop" edebug-top-level-nonstop t] | |
4266 "----" | |
4267 ("Jumps" | |
4268 ["Forward Sexp" edebug-forward-sexp t] | |
4269 ["Step In" edebug-step-in t] | |
4270 ["Step Out" edebug-step-out t] | |
4271 ["Goto Here" edebug-goto-here t]) | |
4272 | |
4273 ("Breaks" | |
4274 ["Set Breakpoint" edebug-set-breakpoint t] | |
4275 ["Unset Breakpoint" edebug-unset-breakpoint t] | |
4276 ["Set Conditional Breakpoint" edebug-set-conditional-breakpoint t] | |
4277 ["Set Global Break Condition" edebug-set-global-break-condition t] | |
4278 ["Show Next Breakpoint" edebug-next-breakpoint t]) | |
4279 | |
4280 ("Views" | |
4281 ["Where am I?" edebug-where t] | |
4282 ["Bounce to Current Point" edebug-bounce-point t] | |
4283 ["View Outside Windows" edebug-view-outside t] | |
4284 ["Previous Result" edebug-previous-result t] | |
4285 ["Show Backtrace" edebug-backtrace t] | |
4286 ["Display Freq Count" edebug-display-freq-count t]) | |
4287 | |
4288 ("Eval" | |
4289 ["Expression" edebug-eval-expression t] | |
4290 ["Last Sexp" edebug-eval-last-sexp t] | |
4291 ["Visit Eval List" edebug-visit-eval-list t]) | |
4292 | |
4293 ("Options" | |
4294 ["Edebug All Defs" edebug-all-defs t] | |
4295 ["Edebug All Forms" edebug-all-forms t] | |
4296 "----" | |
4297 ["Toggle Tracing" (edebug-toggle 'edebug-trace) t] | |
4298 ["Toggle Coverage Testing" (edebug-toggle 'edebug-test-coverage) t] | |
4299 ["Toggle Window Saving" edebug-toggle-save-windows t] | |
4300 ["Toggle Point Saving" | |
4301 (edebug-toggle 'edebug-save-displayed-buffer-points) t] | |
4302 )) | |
4303 "XEmacs style menus for Edebug.") | |
4304 | |
4305 | |
4306 ;;;; Emacs version specific code | |
4307 ;;;============================= | |
4308 ;;; The default for all above is Emacs 18, because it is easier to compile | |
4309 ;;; Emacs 18 code in Emacs 19 than vice versa. This default will | |
4310 ;;; change once most people are using Emacs 19 or derivatives. | |
4311 | |
4312 ;; Epoch specific code is in a separate file: edebug-epoch.el. | |
4313 | |
4314 ;; The byte-compiler will complain about changes in number of arguments | |
4315 ;; to functions like mark and read-from-minibuffer. These warnings | |
4316 ;; may be ignored because the right call should always be made. | |
4317 | |
4318 (defun edebug-emacs-19-specific () | |
4319 | |
4320 (defalias 'edebug-window-live-p 'window-live-p) | |
4321 | |
4322 ;; Mark takes an argument in Emacs 19. | |
4323 (defun edebug-mark () | |
4324 (mark t));; Does this work for XEmacs too? | |
4325 | |
4326 ;; Use minibuffer-history when reading expressions. | |
4327 (defvar read-expression-history) ;; hush bytecomp | |
4328 (defvar read-expression-map) | |
4329 | |
4330 (defun edebug-set-conditional-breakpoint (arg condition) | |
4331 "Set a conditional breakpoint at nearest sexp. | |
4332 The condition is evaluated in the outside context. | |
4333 With prefix argument, make it a temporary breakpoint." | |
4334 ;; (interactive "P\nxCondition: ") | |
4335 (interactive | |
4336 (list | |
4337 current-prefix-arg | |
4338 ;; Read condition as follows; getting previous condition is cumbersome: | |
4339 (let ((edebug-stop-point (edebug-find-stop-point))) | |
4340 (if edebug-stop-point | |
4341 (let* ((edebug-def-name (car edebug-stop-point)) | |
4342 (index (cdr edebug-stop-point)) | |
4343 (edebug-data (get edebug-def-name 'edebug)) | |
4344 (edebug-breakpoints (car (cdr edebug-data))) | |
4345 (edebug-break-data (assq index edebug-breakpoints)) | |
4346 (edebug-break-condition (car (cdr edebug-break-data))) | |
4347 (edebug-expression-history | |
4348 ;; Prepend the current condition, if any. | |
4349 (if edebug-break-condition | |
4350 (cons edebug-break-condition read-expression-history) | |
4351 read-expression-history))) | |
4352 (prog1 | |
4353 (read-from-minibuffer | |
4354 "Condition: " nil read-expression-map t | |
4355 'edebug-expression-history) | |
4356 (setq read-expression-history edebug-expression-history) | |
4357 )))))) | |
4358 (edebug-modify-breakpoint t condition arg)) | |
4359 | |
4360 (defun edebug-eval-expression (edebug-expr) | |
4361 "Evaluate an expression in the outside environment. | |
4362 If interactive, prompt for the expression. | |
4363 Print result in minibuffer." | |
4364 (interactive (list (read-from-minibuffer | |
4365 "Eval: " nil read-expression-map t | |
4366 'read-expression-history))) | |
4367 (princ | |
4368 (edebug-outside-excursion | |
4369 (setq values (cons (edebug-eval edebug-expr) values)) | |
4370 (edebug-safe-prin1-to-string (car values))))) | |
4371 | |
4372 (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) | |
4373 (if window-system | |
4374 (x-popup-menu nil (lookup-key edebug-mode-map [menu-bar Edebug]))) | |
4375 ) | |
4376 | |
4377 | |
4378 (defun edebug-xemacs-specific () | |
4379 | |
4380 ;; We need to bind zmacs-regions to nil around all calls to `mark' and | |
4381 ;; `mark-marker' but don't bind it to nil before entering a recursive edit, | |
4382 ;; that is, don't interfere with the binding the user might see while | |
4383 ;; executing a command. | |
4384 | |
4385 (defvar zmacs-regions) | |
4386 | |
4387 (defun edebug-mark () | |
4388 (let ((zmacs-regions nil)) | |
4389 (mark))) | |
4390 | |
4391 (defun edebug-mark-marker () | |
4392 (let ((zmacs-regions nil));; for XEmacs | |
4393 (mark-marker))) | |
4394 | |
4395 | |
4396 (defun edebug-mode-menu (event) | |
4397 (interactive "@event") | |
4398 (popup-menu edebug-mode-menus)) | |
4399 | |
4400 (define-key edebug-mode-map 'button3 'edebug-mode-menu) | |
4401 ) | |
4402 | |
4403 (defun edebug-emacs-version-specific () | |
4404 (cond | |
4405 ((string-match "XEmacs" emacs-version);; XEmacs | |
4406 (edebug-xemacs-specific)) | |
4407 | |
4408 ((and (boundp 'epoch::version) epoch::version) | |
4409 (require 'edebug-epoch)) | |
4410 | |
4411 ((not (string-match "^18" emacs-version)) | |
4412 (edebug-emacs-19-specific)))) | |
4413 | |
4414 (edebug-emacs-version-specific) | |
4415 | |
4416 | |
4417 ;;;; Byte-compiler | |
4418 ;;; ==================== | |
4419 ;; Extension for bytecomp to resolve undefined function references. | |
4420 ;; Requires new byte compiler. | |
4421 | |
4422 ;; Reenable byte compiler warnings about unread-command-char and -event. | |
4423 ;; Disabled before edebug-recursive-edit. | |
4424 (eval-when-compile | |
4425 (if edebug-unread-command-char-warning | |
4426 (put 'unread-command-char 'byte-obsolete-variable | |
4427 edebug-unread-command-char-warning)) | |
4428 (if edebug-unread-command-event-warning | |
4429 (put 'unread-command-event 'byte-obsolete-variable | |
4430 edebug-unread-command-event-warning))) | |
4431 | |
4432 (eval-when-compile | |
4433 ;; The body of eval-when-compile seems to get evaluated with eval-defun. | |
4434 ;; We only want to evaluate when actually byte compiling. | |
4435 ;; But it is OK to evaluate as long as byte-compiler has been loaded. | |
4436 (if (featurep 'byte-compile) (progn | |
4437 | |
4438 (defun byte-compile-resolve-functions (funcs) | |
4439 "Say it is OK for the named functions to be unresolved." | |
4440 (mapcar | |
4441 (function | |
4442 (lambda (func) | |
4443 (setq byte-compile-unresolved-functions | |
4444 (delq (assq func byte-compile-unresolved-functions) | |
4445 byte-compile-unresolved-functions)))) | |
4446 funcs) | |
4447 nil) | |
4448 | |
4449 '(defun byte-compile-resolve-free-references (vars) | |
4450 "Say it is OK for the named variables to be referenced." | |
4451 (mapcar | |
4452 (function | |
4453 (lambda (var) | |
4454 (setq byte-compile-free-references | |
4455 (delq var byte-compile-free-references)))) | |
4456 vars) | |
4457 nil) | |
4458 | |
4459 '(defun byte-compile-resolve-free-assignments (vars) | |
4460 "Say it is OK for the named variables to be assigned." | |
4461 (mapcar | |
4462 (function | |
4463 (lambda (var) | |
4464 (setq byte-compile-free-assignments | |
4465 (delq var byte-compile-free-assignments)))) | |
4466 vars) | |
4467 nil) | |
4468 | |
4469 (byte-compile-resolve-functions | |
4470 '(reporter-submit-bug-report | |
4471 edebug-gensym ;; also in cl.el | |
4472 ;; Interfaces to standard functions. | |
4473 edebug-original-eval-defun | |
4474 edebug-original-read | |
4475 edebug-get-buffer-window | |
4476 edebug-mark | |
4477 edebug-mark-marker | |
4478 edebug-input-pending-p | |
4479 edebug-sit-for | |
4480 edebug-prin1-to-string | |
4481 edebug-format | |
4482 edebug-original-signal | |
4483 ;; XEmacs | |
4484 zmacs-deactivate-region | |
4485 popup-menu | |
4486 ;; CL | |
4487 cl-macroexpand-all | |
4488 ;; And believe it or not, the byte compiler doesnt know about: | |
4489 byte-compile-resolve-functions | |
4490 )) | |
4491 | |
4492 '(byte-compile-resolve-free-references | |
4493 '(read-expression-history | |
4494 read-expression-map)) | |
4495 | |
4496 '(byte-compile-resolve-free-assignments | |
4497 '(read-expression-history)) | |
4498 | |
4499 ))) | |
4500 | |
4501 | |
4502 ;;;; Autoloading of Edebug accessories | |
4503 ;;;=================================== | |
4504 | |
4505 (if (featurep 'cl) | |
4506 (add-hook 'edebug-setup-hook | |
4507 (function (lambda () (require 'cl-specs)))) | |
4508 ;; The following causes cl-specs to be loaded if you load cl.el. | |
4509 (add-hook 'cl-load-hook | |
4510 (function (lambda () (require 'cl-specs))))) | |
4511 | |
4512 ;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu | |
4513 (if (featurep 'cl-read) | |
4514 (add-hook 'edebug-setup-hook | |
4515 (function (lambda () (require 'edebug-cl-read)))) | |
4516 ;; The following causes edebug-cl-read to be loaded when you load cl-read.el. | |
4517 (add-hook 'cl-read-load-hooks | |
4518 (function (lambda () (require 'edebug-cl-read))))) | |
4519 | |
4520 | |
4521 ;;;; Finalize Loading | |
4522 ;;;=================== | |
4523 | |
4524 ;;; Finally, hook edebug into the rest of Emacs. | |
4525 ;;; There are probably some other things that could go here. | |
4526 | |
4527 ;; Install edebug read and eval functions. | |
4528 (edebug-install-read-eval-functions) | |
4529 | |
4530 (provide 'edebug) | |
4531 | |
4532 ;;; edebug.el ends here | |
4533 | |
4534 |