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