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