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