aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorEric S. Raymond1992-05-30 23:52:26 +0000
committerEric S. Raymond1992-05-30 23:52:26 +0000
commit84fc2cfa7d62e9ff77405340bae99cf5b1a9e164 (patch)
tree083533c3b19b07b621afbe6e49ee7b6357c294b9
parent1a06eabd17a8eff0635bc7058349f7c22057864c (diff)
downloademacs-84fc2cfa7d62e9ff77405340bae99cf5b1a9e164.tar.gz
emacs-84fc2cfa7d62e9ff77405340bae99cf5b1a9e164.zip
Initial revision
Diffstat
-rw-r--r--lisp/add-log.el103
-rw-r--r--lisp/dired.el785
-rw-r--r--lisp/emacs-lisp/edebug.el2521
3 files changed, 3409 insertions, 0 deletions
diff --git a/lisp/add-log.el b/lisp/add-log.el
new file mode 100644
index 00000000000..f2c279ae357
--- /dev/null
+++ b/lisp/add-log.el
@@ -0,0 +1,103 @@
1;;; add-log.el --- change log maintenance commands for Emacs
2
3;; Copyright (C) 1985-1991 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation; either version 1, or (at your option)
10;; any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs; see the file COPYING. If not, write to
19;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20
21
22;;;###autoload
23(defvar change-log-default-name nil
24 "*Name of a change log file for \\[add-change-log-entry].")
25
26(defun change-log-name ()
27 (or change-log-default-name
28 (if (eq system-type 'vax-vms) "$CHANGE_LOG$.TXT" "ChangeLog")))
29
30(defun prompt-for-change-log-name ()
31 "Prompt for a change log name."
32 (let ((default (change-log-name)))
33 (expand-file-name
34 (read-file-name (format "Log file (default %s): " default)
35 nil default))))
36
37;;;###autoload
38(defun add-change-log-entry (&optional whoami file-name other-window)
39 "Find change log file and add an entry for today.
40Optional arg (interactive prefix) non-nil means prompt for user name and site.
41Second arg is file name of change log. If nil, uses `change-log-default-name'.
42Third arg OTHER-WINDOW non-nil means visit in other window."
43 (interactive (list current-prefix-arg
44 (prompt-for-change-log-name)))
45 (let* ((full-name (if whoami
46 (read-input "Full name: " (user-full-name))
47 (user-full-name)))
48 ;; Note that some sites have room and phone number fields in
49 ;; full name which look silly when inserted. Rather than do
50 ;; anything about that here, let user give prefix argument so that
51 ;; s/he can edit the full name field in prompter if s/he wants.
52 (login-name (if whoami
53 (read-input "Login name: " (user-login-name))
54 (user-login-name)))
55 (site-name (if whoami
56 (read-input "Site name: " (system-name))
57 (system-name))))
58 (or file-name
59 (setq file-name (or change-log-default-name
60 default-directory)))
61 (if (file-directory-p file-name)
62 (setq file-name (concat (file-name-as-directory file-name)
63 (change-log-name))))
64 (set (make-local-variable 'change-log-default-name) file-name)
65 (if (and other-window (not (equal file-name buffer-file-name)))
66 (find-file-other-window file-name)
67 (find-file file-name))
68 (undo-boundary)
69 (goto-char (point-min))
70 (if (not (and (looking-at (substring (current-time-string) 0 10))
71 (looking-at (concat ".* " full-name " (" login-name "@"))))
72 (progn (insert (current-time-string)
73 " " full-name
74 " (" login-name
75 "@" site-name ")\n\n")))
76 (goto-char (point-min))
77 (forward-line 1)
78 (while (looking-at "\\sW")
79 (forward-line 1))
80 (delete-region (point)
81 (progn
82 (skip-chars-backward "\n")
83 (point)))
84 (open-line 3)
85 (forward-line 2)
86 (indent-to left-margin)
87 (insert "* ")))
88
89;;;###autoload
90(define-key ctl-x-4-map "a" 'add-change-log-entry-other-window)
91
92;;;###autoload
93(defun add-change-log-entry-other-window (&optional whoami file-name)
94 "Find change log file in other window and add an entry for today.
95First arg (interactive prefix) non-nil means prompt for user name and site.
96Second arg is file name of change log.
97Interactively, with a prefix argument, the file name is prompted for."
98 (interactive (if current-prefix-arg
99 (list current-prefix-arg
100 (prompt-for-change-log-name))))
101 (add-change-log-entry whoami file-name t))
102
103;;; add-log.el ends here
diff --git a/lisp/dired.el b/lisp/dired.el
new file mode 100644
index 00000000000..16a86f72b26
--- /dev/null
+++ b/lisp/dired.el
@@ -0,0 +1,785 @@
1;;; dired.el --- DIRED commands for Emacs
2
3;;; Missing: P command, sorting, setting file modes.
4;;; Dired buffer containing multiple directories gets totally confused
5;;; Implement insertion of subdirectories in situ --- tree dired
6
7;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 1, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to
23;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
24
25
26;;;###autoload
27(defvar dired-listing-switches "-al" "\
28Switches passed to ls for dired. MUST contain the `l' option.
29CANNOT contain the `F' option.")
30
31(defvar dired-chown-program
32 (if (memq system-type '(hpux usg-unix-v))
33 "/bin/chown" "/etc/chown")
34 "Pathname of chown command.")
35
36(defvar dired-directory nil)
37
38(defun dired-readin (dirname buffer)
39 (save-excursion
40 (message "Reading directory %s..." dirname)
41 (set-buffer buffer)
42 (let ((buffer-read-only nil))
43 (widen)
44 (erase-buffer)
45 (setq dirname (expand-file-name dirname))
46 (if (eq system-type 'vax-vms)
47 (vms-read-directory dirname dired-listing-switches buffer)
48 (if (file-directory-p dirname)
49 (call-process "ls" nil buffer nil
50 dired-listing-switches dirname)
51 (if (not (file-readable-p (directory-file-name (file-name-directory dirname))))
52 (insert "Directory " dirname " inaccessible or nonexistent.\n")
53 (let ((default-directory (file-name-directory dirname)))
54 (call-process shell-file-name nil buffer nil
55 "-c" (concat "ls -d " dired-listing-switches " "
56 (file-name-nondirectory dirname)))))))
57 (goto-char (point-min))
58 (indent-rigidly (point-min) (point-max) 2))
59 (set-buffer-modified-p nil)
60 (message "Reading directory %s...done" dirname)))
61
62(defun dired-find-buffer (dirname)
63 (let ((blist (buffer-list))
64 found)
65 (while blist
66 (save-excursion
67 (set-buffer (car blist))
68 (if (and (eq major-mode 'dired-mode)
69 (equal dired-directory dirname))
70 (setq found (car blist)
71 blist nil)
72 (setq blist (cdr blist)))))
73 (or found
74 (create-file-buffer (directory-file-name dirname)))))
75
76;;;###autoload
77(defun dired (dirname)
78 "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it.
79Dired displays the list of files in DIRNAME.
80You can move around in it with the usual movement commands.
81You can flag files for deletion with \\<dired-mode-map>\\[dired-flag-file-deleted]
82and then delete them by typing `x'.
83Type `h' after entering dired for more info."
84 (interactive (list (read-file-name "Dired (directory): "
85 nil default-directory nil)))
86 (switch-to-buffer (dired-noselect dirname)))
87;;;###autoload
88(define-key ctl-x-map "d" 'dired)
89
90;;;###autoload
91(defun dired-other-window (dirname)
92 "\"Edit\" directory DIRNAME. Like `dired' but selects in another window."
93 (interactive (list (read-file-name "Dired in other window (directory): "
94 nil default-directory nil)))
95 (switch-to-buffer-other-window (dired-noselect dirname)))
96;;;###autoload
97(define-key ctl-x-4-map "d" 'dired-other-window)
98
99;;;###autoload
100(defun dired-noselect (dirname)
101 "Like `dired' but returns the dired buffer as value, does not select it."
102 (or dirname (setq dirname default-directory))
103 (setq dirname (expand-file-name (directory-file-name dirname)))
104 (if (file-directory-p dirname)
105 (setq dirname (file-name-as-directory dirname)))
106 (let ((buffer (dired-find-buffer dirname)))
107 (save-excursion
108 (set-buffer buffer)
109 (dired-readin dirname buffer)
110 (while (and (not (dired-move-to-filename)) (not (eobp)))
111 (forward-line 1))
112 (dired-mode dirname))
113 buffer))
114
115(defun dired-revert (&optional arg noconfirm)
116 (let ((opoint (point))
117 (ofile (dired-get-filename t t))
118 (buffer-read-only nil)
119 delete-list already-deleted column-dots)
120 (goto-char 1)
121 (if (re-search-forward "^D" nil t)
122 (progn
123 (beginning-of-line)
124 (while (re-search-forward "^D" nil t)
125 (setq delete-list (cons (dired-get-filename t) delete-list)))))
126 (dired-readin dired-directory (current-buffer))
127 (while (and (not (dired-move-to-filename)) (not (eobp)))
128 (forward-line 1))
129 (setq column-dots (concat "^" (make-string (current-column) ?.))
130 delete-list (nreverse delete-list))
131 (while delete-list
132 ;; assumptions: the directory was reread with the files listed in the
133 ;; same order as they were originally. the string of "."s is rather silly
134 ;; but it seems the fastest way to avoid messing with -F flags and
135 ;; matches that occur in places other than the filename column
136 (if (re-search-forward
137 (concat column-dots (regexp-quote (car delete-list))) nil t)
138 (progn (beginning-of-line)
139 (delete-char 1)
140 (insert "D"))
141 (setq already-deleted (cons (car delete-list) already-deleted)))
142 (setq delete-list (cdr delete-list)))
143 (goto-char 0)
144 (or (and ofile (re-search-forward (concat column-dots (regexp-quote ofile))
145 nil t))
146 (goto-char opoint))
147 (dired-move-to-filename)
148 (if already-deleted (message "Already deleted: %s"
149 (prin1-to-string (reverse already-deleted))))))
150
151(defvar dired-mode-map nil "Local keymap for dired-mode buffers.")
152(if dired-mode-map
153 nil
154 (setq dired-mode-map (make-keymap))
155 (suppress-keymap dired-mode-map)
156 (define-key dired-mode-map "r" 'dired-rename-file)
157 (define-key dired-mode-map "\C-d" 'dired-flag-file-deleted)
158 (define-key dired-mode-map "d" 'dired-flag-file-deleted)
159 (define-key dired-mode-map "v" 'dired-view-file)
160 (define-key dired-mode-map "e" 'dired-find-file)
161 (define-key dired-mode-map "f" 'dired-find-file)
162 (define-key dired-mode-map "o" 'dired-find-file-other-window)
163 (define-key dired-mode-map "u" 'dired-unflag)
164 (define-key dired-mode-map "x" 'dired-do-deletions)
165 (define-key dired-mode-map "\177" 'dired-backup-unflag)
166 (define-key dired-mode-map "?" 'dired-summary)
167 (define-key dired-mode-map "c" 'dired-copy-file)
168 (define-key dired-mode-map "#" 'dired-flag-auto-save-files)
169 (define-key dired-mode-map "~" 'dired-flag-backup-files)
170 (define-key dired-mode-map "F" 'dired-flag-regexp-files)
171 (define-key dired-mode-map "." 'dired-clean-directory)
172 (define-key dired-mode-map "h" 'describe-mode)
173 (define-key dired-mode-map " " 'dired-next-line)
174 (define-key dired-mode-map "\C-n" 'dired-next-line)
175 (define-key dired-mode-map "\C-p" 'dired-previous-line)
176 (define-key dired-mode-map "n" 'dired-next-line)
177 (define-key dired-mode-map "p" 'dired-previous-line)
178 (define-key dired-mode-map "g" 'revert-buffer)
179 (define-key dired-mode-map "D" 'dired-create-directory)
180 (define-key dired-mode-map "m" 'dired-move-file)
181 (define-key dired-mode-map "C" 'dired-compress)
182 (define-key dired-mode-map "U" 'dired-uncompress)
183 (define-key dired-mode-map "B" 'dired-byte-recompile)
184 (define-key dired-mode-map "M" 'dired-chmod)
185 (define-key dired-mode-map "G" 'dired-chgrp)
186 (define-key dired-mode-map "O" 'dired-chown)
187 (define-key dired-mode-map "=" 'dired-diff)
188 (define-key dired-mode-map "<" 'dired-up-directory))
189
190
191;; Dired mode is suitable only for specially formatted data.
192(put 'dired-mode 'mode-class 'special)
193
194(defun dired-mode (&optional dirname)
195 "Mode for \"editing\" directory listings.
196In dired, you are \"editing\" a list of the files in a directory.
197You can move using the usual cursor motion commands.
198Letters no longer insert themselves.
199Instead, use the following commands:
200\\{dired-mode-map}"
201 (interactive)
202 (kill-all-local-variables)
203 (make-local-variable 'revert-buffer-function)
204 (setq revert-buffer-function 'dired-revert)
205 (setq major-mode 'dired-mode)
206 (setq mode-name "Dired")
207 (make-local-variable 'dired-directory)
208 (setq dired-directory (or dirname default-directory))
209 (make-local-variable 'list-buffers-directory)
210 (setq list-buffers-directory dired-directory)
211 (set (make-local-variable 'dired-used-F)
212 (string-match "F" dired-listing-switches))
213 (if dirname
214 (setq default-directory
215 (if (file-directory-p dirname)
216 dirname (file-name-directory dirname))))
217 (setq mode-line-buffer-identification '("Dired: %17f"))
218 (setq case-fold-search nil)
219 (setq buffer-read-only t)
220 (use-local-map dired-mode-map)
221 (run-hooks 'dired-mode-hook))
222
223;; FUNCTION receives no arguments
224;; and should return t iff it deletes the current line from the buffer.
225(defun dired-repeat-over-lines (arg function)
226 (beginning-of-line)
227 (while (and (> arg 0) (not (eobp)))
228 (setq arg (1- arg))
229 (let (deleted)
230 (save-excursion
231 (beginning-of-line)
232 (and (bobp) (looking-at " total")
233 (error "No file on this line"))
234 (setq deleted (funcall function)))
235 (or deleted
236 (forward-line 1)))
237 (dired-move-to-filename))
238 (while (and (< arg 0) (not (bobp)))
239 (setq arg (1+ arg))
240 (forward-line -1)
241 (dired-move-to-filename)
242 (save-excursion
243 (beginning-of-line)
244 (funcall function))))
245
246(defun dired-flag-file-deleted (arg)
247 "In dired, flag the current line's file for deletion.
248With prefix arg, repeat over several lines."
249 (interactive "p")
250 (dired-repeat-over-lines arg
251 '(lambda ()
252 (let ((buffer-read-only nil))
253 (delete-char 1)
254 (insert "D")
255 nil))))
256
257(defun dired-flag-regexp-files (regexp)
258 "In dired, flag all files matching the specified REGEXP for deletion."
259 (interactive "sFlagging regexp: ")
260 (save-excursion
261 (let ((buffer-read-only nil))
262 (goto-char (point-min))
263 (while (not (eobp))
264 (and (not (looking-at " d"))
265 (not (eolp))
266 (let ((fn (dired-get-filename t t)))
267 (if fn (string-match regexp fn)))
268 (progn (beginning-of-line)
269 (delete-char 1)
270 (insert "D")))
271 (forward-line 1)))))
272
273(defun dired-summary ()
274 (interactive)
275 ;>> this should check the key-bindings and use substitute-command-keys if non-standard
276 (message
277 "d-elete, u-ndelete, x-ecute, f-ind, o-ther window, r-ename, c-opy, v-iew"))
278
279(defun dired-unflag (arg)
280 "In dired, remove the current line's delete flag then move to next line."
281 (interactive "p")
282 (dired-repeat-over-lines arg
283 '(lambda ()
284 (let ((buffer-read-only nil))
285 (delete-char 1)
286 (insert " ")
287 (forward-char -1)
288 nil))))
289
290(defun dired-backup-unflag (arg)
291 "In dired, move up lines and remove deletion flag there.
292Optional prefix ARG says how many lines to unflag; default is one line."
293 (interactive "p")
294 (dired-unflag (- arg)))
295
296(defun dired-next-line (arg)
297 "Move down lines then position at filename.
298Optional prefix ARG says how many lines to move; default is one line."
299 (interactive "p")
300 (next-line arg)
301 (dired-move-to-filename))
302
303(defun dired-previous-line (arg)
304 "Move up lines then position at filename.
305Optional prefix ARG says how many lines to move; default is one line."
306 (interactive "p")
307 (previous-line arg)
308 (dired-move-to-filename))
309
310(defun dired-up-directory ()
311 "Run dired on the parent of the current directory."
312 (interactive)
313 (find-file ".."))
314
315(defun dired-find-file ()
316 "In dired, visit the file or directory named on this line."
317 (interactive)
318 (find-file (dired-get-filename)))
319
320(defun dired-view-file ()
321 "In dired, examine a file in view mode, returning to dired when done."
322 (interactive)
323 (if (file-directory-p (dired-get-filename))
324 (dired (dired-get-filename))
325 (view-file (dired-get-filename))))
326
327(defun dired-find-file-other-window ()
328 "In dired, visit this file or directory in another window."
329 (interactive)
330 (find-file-other-window (dired-get-filename)))
331
332(defun dired-get-filename (&optional localp no-error-if-not-filep)
333 "In dired, return name of file mentioned on this line.
334Value returned normally includes the directory name.
335Optional arg LOCALP means don't include it.
336Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename
337on this line, otherwise an error occurs."
338 (let (eol file type ex (case-fold-search nil))
339 (save-excursion
340 (end-of-line)
341 (setq eol (point))
342 (beginning-of-line)
343 (if (eq system-type 'vax-vms)
344 ;; Non-filename lines don't match
345 ;; because they have lower case letters.
346 (if (re-search-forward "^..\\([][.A-Z-0-9_$;<>]+\\)" eol t)
347 (setq file (buffer-substring (match-beginning 1) (match-end 1))))
348 ;; Unix case
349 (if (not (re-search-forward
350 "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
351 eol t)) ()
352 (skip-chars-forward " ")
353 (skip-chars-forward "^ " eol)
354 (skip-chars-forward " " eol)
355 (setq file (buffer-substring (point) eol))
356 (re-search-backward "\\(.\\)[-r][-w]\\(.\\)[-r][-w]\\(.\\)[-r][-w]\\(.\\)")
357 (setq flag (buffer-substring (match-beginning 1) (match-end 1))
358 ex (string-match "[xst]" ;; execute bit set anywhere?
359 (concat
360 (buffer-substring (match-beginning 2) (match-end 2))
361 (buffer-substring (match-beginning 3) (match-end 3))
362 (buffer-substring (match-beginning 4) (match-end 4)))))
363 (cond
364 ((string= flag "l")
365 ;; strip the link name. Bombs if file contains " ->"
366 (if (string-match " ->" file)
367 (setq file (substring file 0 (match-beginning 0)))))
368 ((and dired-used-F ;; strip off -F stuff if there
369 (or (string= flag "d") (string= flag "s") ex))
370 (setq file (substring file 0 -1)))))))
371 (or no-error-if-not-filep file
372 (error "No file on this line"))
373 ;; ??? uses default-directory, could lose on cd, multiple.
374 (or localp (setq file (expand-file-name file default-directory)))
375 file))
376
377(defun dired-move-to-filename ()
378 "In dired, move to first char of filename on this line.
379Returns position (point) or nil if no filename on this line."
380 (let ((eol (progn (end-of-line) (point))))
381 (beginning-of-line)
382 (if (re-search-forward
383 "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
384 eol t)
385 (progn
386 (skip-chars-forward " ")
387 (skip-chars-forward "^ " eol)
388 (skip-chars-forward " " eol)
389 (point)))))
390
391(defun dired-map-dired-file-lines (fn)
392 "Perform function FN with point at the end of each non-directory line.
393The arguments given to FN are the short and long filename"
394 (save-excursion
395 (let (filename longfilename (buffer-read-only nil))
396 (goto-char (point-min))
397 (while (not (eobp))
398 (save-excursion
399 (and (not (looking-at " \\s *[0-9]*\\s *[0-9]* d"))
400 (not (eolp))
401 (setq filename (dired-get-filename t t)
402 longfilename (dired-get-filename nil t))
403 (progn (end-of-line)
404 (funcall fn filename longfilename))))
405 (forward-line 1)))))
406
407(defun dired-flag-auto-save-files (unflag-p)
408 "Flag for deletion files whose names suggest they are auto save files.
409A prefix argument says to unflag those files instead."
410 (interactive "P")
411 (save-excursion
412 (let ((buffer-read-only nil))
413 (goto-char (point-min))
414 (while (not (eobp))
415 (and (not (looking-at " \\s *[0-9]*\\s *[0-9]* d"))
416 (not (eolp))
417 (if (fboundp 'auto-save-file-name-p)
418 (let ((fn (dired-get-filename t t)))
419 (if fn (auto-save-file-name-p fn)))
420 (if (dired-move-to-filename)
421 (looking-at "#")))
422 (progn (beginning-of-line)
423 (delete-char 1)
424 (insert (if unflag-p " " "D"))))
425 (forward-line 1)))))
426
427(defun dired-clean-directory (keep)
428 "Flag numerical backups for deletion.
429Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
430Positive prefix arg KEEP overrides `dired-kept-versions';
431Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
432
433To clear the flags on these files, you can use \\[dired-flag-backup-files]
434with a prefix argument."
435 (interactive "P")
436 (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions))
437 (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
438 (late-retention (if (<= keep 0) dired-kept-versions keep))
439 (file-version-assoc-list ()))
440 ;; Look at each file.
441 ;; If the file has numeric backup versions,
442 ;; put on file-version-assoc-list an element of the form
443 ;; (FILENAME . VERSION-NUMBER-LIST)
444 (dired-map-dired-file-lines 'dired-collect-file-versions)
445 ;; Sort each VERSION-NUMBER-LIST,
446 ;; and remove the versions not to be deleted.
447 (let ((fval file-version-assoc-list))
448 (while fval
449 (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
450 (v-count (length sorted-v-list)))
451 (if (> v-count (+ early-retention late-retention))
452 (rplacd (nthcdr early-retention sorted-v-list)
453 (nthcdr (- v-count late-retention)
454 sorted-v-list)))
455 (rplacd (car fval)
456 (cdr sorted-v-list)))
457 (setq fval (cdr fval))))
458 ;; Look at each file. If it is a numeric backup file,
459 ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
460 (dired-map-dired-file-lines 'dired-trample-file-versions)))
461
462(defun dired-collect-file-versions (ignore fn)
463 "If it looks like file FN has versions, return a list of the versions.
464That is a list of strings which are file names.
465The caller may want to flag some of these files for deletion."
466 (let* ((base-versions
467 (concat (file-name-nondirectory fn) ".~"))
468 (bv-length (length base-versions))
469 (possibilities (file-name-all-completions
470 base-versions
471 (file-name-directory fn)))
472 (versions (mapcar 'backup-extract-version possibilities)))
473 (if versions
474 (setq file-version-assoc-list (cons (cons fn versions)
475 file-version-assoc-list)))))
476
477(defun dired-trample-file-versions (ignore fn)
478 (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
479 base-version-list)
480 (and start-vn
481 (setq base-version-list ; there was a base version to which
482 (assoc (substring fn 0 start-vn) ; this looks like a
483 file-version-assoc-list)) ; subversion
484 (not (memq (string-to-int (substring fn (+ 2 start-vn)))
485 base-version-list)) ; this one doesn't make the cut
486 (dired-flag-this-line-for-DEATH))))
487
488(defun dired-flag-this-line-for-DEATH ()
489 (beginning-of-line)
490 (delete-char 1)
491 (insert "D"))
492
493(defun dired-flag-backup-files (unflag-p)
494 "Flag all backup files (names ending with `~') for deletion.
495With prefix argument, unflag these files."
496 (interactive "P")
497 (save-excursion
498 (let ((buffer-read-only nil))
499 (goto-char (point-min))
500 (while (not (eobp))
501 (and (not (looking-at " d"))
502 (not (eolp))
503 (if (fboundp 'backup-file-name-p)
504 (let ((fn (dired-get-filename t t)))
505 (if fn (backup-file-name-p fn)))
506 (end-of-line)
507 (forward-char -1)
508 (looking-at "~"))
509 (progn (beginning-of-line)
510 (delete-char 1)
511 (insert (if unflag-p " " "D"))))
512 (forward-line 1)))))
513
514(defun dired-flag-backup-and-auto-save-files (unflag-p)
515 "Flag all backup and temporary files for deletion.
516Backup files have names ending in `~'.
517Auto save file names usually start with `#'.
518With prefix argument, unflag these files."
519 (interactive "P")
520 (dired-flag-backup-files unflag-p)
521 (dired-flag-auto-save-files unflag-p))
522
523(defun dired-create-directory (directory)
524 "Create a directory called DIRECTORY."
525 (interactive "FCreate directory: ")
526 (let ((expanded (expand-file-name directory)))
527 (make-directory expanded)
528 (dired-add-entry (file-name-directory expanded)
529 (file-name-nondirectory expanded))
530 (dired-next-line 1)))
531
532(defun dired-move-file (to-dir &optional count)
533 "Move this file to directory TO-DIR.
534Optional second argument COUNT (the prefix argument)
535specifies moving several consecutive files."
536 (interactive
537 (let ((count (prefix-numeric-value current-prefix-arg)))
538 (list (read-file-name (format "Move %s to directory: "
539 (if (> count 1)
540 (format "%d files" count)
541 (file-name-nondirectory (dired-get-filename))))
542 nil t)
543 count)))
544 (let ((dir (file-name-as-directory (expand-file-name to-dir))))
545 (dired-repeat-over-lines
546 count
547 (function (lambda ()
548 (let ((this (dired-get-filename)))
549 (rename-file this
550 (expand-file-name (file-name-nondirectory this)
551 dir)))
552 (let ((buffer-read-only nil))
553 (beginning-of-line)
554 (delete-region (point) (progn (forward-line 1) (point))))
555 t)))))
556
557(defun dired-rename-file (to-file)
558 "Rename the current file to TO-FILE."
559 (interactive
560 (list (read-file-name (format "Rename %s to: "
561 (file-name-nondirectory (dired-get-filename)))
562 nil (dired-get-filename))))
563 (setq to-file (expand-file-name to-file))
564 (let ((filename (dired-get-filename))
565 (buffer-read-only nil))
566 (rename-file filename to-file)
567 (beginning-of-line)
568 (delete-region (point) (progn (forward-line 1) (point)))
569 (setq to-file (expand-file-name to-file))
570 (dired-add-entry (file-name-directory to-file)
571 (file-name-nondirectory to-file))
572 ;; Optionally rename the visited file of any buffer visiting this file.
573 (and (get-file-buffer filename)
574 (y-or-n-p (message "Change visited file name of buffer %s too? "
575 (buffer-name (get-file-buffer filename))))
576 (save-excursion
577 (set-buffer (get-file-buffer filename))
578 (let ((modflag (buffer-modified-p)))
579 (set-visited-file-name to-file)
580 (set-buffer-modified-p modflag))))))
581
582(defun dired-copy-file (to-file)
583 "Copy the current file to TO-FILE."
584 (interactive "FCopy to: ")
585 (copy-file (dired-get-filename) to-file)
586 (setq to-file (expand-file-name to-file))
587 (dired-add-entry (file-name-directory to-file)
588 (file-name-nondirectory to-file)))
589
590(defun dired-add-entry (directory filename)
591 ;; If tree dired is implemented, this function will have to do
592 ;; something smarter with the directory. Currently, just check
593 ;; default directory, if same, add the new entry at point. With tree
594 ;; dired, should call 'dired-current-directory' or similar. Note
595 ;; that this adds the entry 'out of order' if files sorted by time,
596 ;; etc.
597 (if (string-equal directory default-directory)
598 (let ((buffer-read-only nil))
599 (beginning-of-line)
600 (call-process "ls" nil t nil
601 "-d" dired-listing-switches (concat directory filename))
602 (forward-line -1)
603 (insert " ")
604 (dired-move-to-filename)
605 (let* ((beg (point))
606 (end (progn (end-of-line) (point))))
607 (setq filename (buffer-substring beg end))
608 (delete-region beg end)
609 (insert (file-name-nondirectory filename)))
610 (beginning-of-line))))
611
612(defun dired-diff (point mark)
613 "Compare files at POINT1 and POINT2 by running `diff'.
614Interactively, these are the files at point and mark.
615The file at mark (POINT2) is the first file given to `diff'.
616See the command `diff'."
617 (interactive "d\nm")
618 (let (name1 name2)
619 (setq name2 (dired-get-filename))
620 (save-excursion
621 (goto-char mark)
622 (setq name1 (dired-get-filename)))
623 (diff name1 name2)))
624
625(defun dired-compress ()
626 "Compress the current file."
627 (interactive)
628 (let* ((buffer-read-only nil)
629 (error-buffer (get-buffer-create " *Dired compress output*"))
630 (from-file (dired-get-filename))
631 (to-file (concat from-file ".Z")))
632 (if (string-match "\\.Z$" from-file)
633 (error "%s is already compressed!" from-file))
634 (message "Compressing %s..." from-file)
635 (unwind-protect
636 (progn
637 (save-excursion
638 (set-buffer error-buffer)
639 (erase-buffer))
640 ;; Must have default-directory of dired buffer in call-process
641 (call-process "compress" nil error-buffer nil "-f" from-file)
642 (if (save-excursion
643 (set-buffer error-buffer)
644 (= 0 (buffer-size)))
645 (progn
646 (message "Compressing %s... done" from-file)
647 (kill-buffer error-buffer))
648 (display-buffer error-buffer)
649 (setq error-buffer nil)
650 (error "Compress error on %s." from-file)))
651 (if error-buffer (kill-buffer error-buffer)))
652 (dired-redisplay to-file)))
653
654(defun dired-uncompress ()
655 "Uncompress the current file."
656 (interactive)
657 (let* ((buffer-read-only nil)
658 (error-buffer (get-buffer-create " *Dired compress output*"))
659 (from-file (dired-get-filename))
660 (to-file (substring from-file 0 -2)))
661 (if (string-match "\\.Z$" from-file) nil
662 (error "%s is not compressed!" from-file))
663 (message "Uncompressing %s..." from-file)
664 (unwind-protect
665 (progn
666 (save-excursion
667 (set-buffer error-buffer)
668 (erase-buffer))
669 ;; Must have default-directory of dired buffer in call-process
670 (call-process "uncompress" nil error-buffer nil "-f" from-file)
671 (if (save-excursion
672 (set-buffer error-buffer)
673 (= 0 (buffer-size)))
674 (progn
675 (message "Uncompressing %s... done" from-file)
676 (kill-buffer error-buffer))
677 (display-buffer error-buffer)
678 (setq error-buffer nil)
679 (error "Uncompress error on %s." from-file)))
680 (if error-buffer (kill-buffer error-buffer)))
681 (dired-redisplay to-file)))
682
683(defun dired-byte-recompile ()
684 "Byte recompile the current file."
685 (interactive)
686 (let* ((buffer-read-only nil)
687 (from-file (dired-get-filename))
688 (to-file (substring from-file 0 -3)))
689 (if (string-match "\\.el$" from-file) nil
690 (error "%s is uncompilable!" from-file))
691 (byte-compile-file from-file)))
692
693(defun dired-chmod (mode)
694 "Change mode of the current file to MODE."
695 (interactive "sChange to Mode: ")
696 (let ((buffer-read-only nil)
697 (file (dired-get-filename)))
698 (call-process "/bin/chmod" nil nil nil mode file)
699 (dired-redisplay file)))
700
701(defun dired-chgrp (group)
702 "Change group of the current file to GROUP."
703 (interactive "sChange to Group: ")
704 (let ((buffer-read-only nil)
705 (file (dired-get-filename)))
706 (call-process "/bin/chgrp" nil nil nil group file)
707 (dired-redisplay file)))
708
709(defun dired-chown (owner)
710 "Change owner of the current file to OWNER."
711 (interactive "sChange to Owner: ")
712 (let ((buffer-read-only nil)
713 (file (dired-get-filename)))
714 (call-process dired-chown-program
715 nil nil nil owner file)
716 (dired-redisplay file)))
717
718(defun dired-redisplay (&optional file)
719 "Delete the current line, and insert an entry for file FILE.
720If FILE is nil, then just delete the current line."
721 (beginning-of-line)
722 (delete-region (point) (progn (forward-line 1) (point)))
723 (if file (dired-add-entry (file-name-directory file)
724 (file-name-nondirectory file)))
725 (dired-move-to-filename))
726
727(defun dired-do-deletions ()
728 "In dired, delete the files flagged for deletion."
729 (interactive)
730 (let (delete-list answer)
731 (save-excursion
732 (goto-char 1)
733 (while (re-search-forward "^D" nil t)
734 (setq delete-list
735 (cons (cons (dired-get-filename t) (1- (point)))
736 delete-list))))
737 (if (null delete-list)
738 (message "(No deletions requested)")
739 (save-window-excursion
740 (set-buffer (get-buffer-create " *Deletions*"))
741 (funcall (if (> (length delete-list) (* (window-height) 2))
742 'switch-to-buffer 'switch-to-buffer-other-window)
743 (current-buffer))
744 (erase-buffer)
745 (setq fill-column 70)
746 (let ((l (reverse delete-list)))
747 ;; Files should be in forward order for this loop.
748 (while l
749 (if (> (current-column) 59)
750 (insert ?\n)
751 (or (bobp)
752 (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
753 (insert (car (car l)))
754 (setq l (cdr l))))
755 (goto-char (point-min))
756 (setq answer (yes-or-no-p "Delete these files? ")))
757 (if answer
758 (let ((l delete-list)
759 failures)
760 ;; Files better be in reverse order for this loop!
761 ;; That way as changes are made in the buffer
762 ;; they do not shift the lines still to be changed.
763 (while l
764 (goto-char (cdr (car l)))
765 (let ((buffer-read-only nil))
766 (condition-case ()
767 (let ((fn (concat default-directory (car (car l)))))
768 (if (file-directory-p fn)
769 (progn
770 (remove-directory fn)
771 (if (file-exists-p fn) (delete-file fn)))
772 (delete-file fn))
773 (delete-region (point)
774 (progn (forward-line 1) (point))))
775 (error (delete-char 1)
776 (insert " ")
777 (setq failures (cons (car (car l)) failures)))))
778 (setq l (cdr l)))
779 (if failures
780 (message "Deletions failed: %s"
781 (prin1-to-string failures))))))))
782
783(provide 'dired)
784
785;;; dired.el ends here
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
new file mode 100644
index 00000000000..d586367933b
--- /dev/null
+++ b/lisp/emacs-lisp/edebug.el
@@ -0,0 +1,2521 @@
1;;; edebug.el --- a source-level debugger for emacs lisp.
2
3;; Copyright (C) 1988, 1989, 1990, 1991 Free Software Foundation, Inc
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is distributed in the hope that it will be useful,
8;; but WITHOUT ANY WARRANTY. No author or distributor
9;; accepts responsibility to anyone for the consequences of using it
10;; or for whether it serves any particular purpose or works at all,
11;; unless he says so in writing. Refer to the GNU Emacs General Public
12;; License for full details.
13
14;; Everyone is granted permission to copy, modify and redistribute
15;; GNU Emacs, but only under the conditions described in the
16;; GNU Emacs General Public License. A copy of this license is
17;; supposed to have been given to you along with GNU Emacs so you
18;; can know your rights and responsibilities. It should be in a
19;; file named COPYING. Among other things, the copyright notice
20;; and this notice must be preserved on all copies.
21
22;;;================================================================
23;;; This minor mode allows programmers to step through elisp source
24;;; code while executing, set breakpoints, etc. See the texinfo
25;;; document (being constructed...) for more detailed instructions
26;;; than contained here. Send me your enhancement, ideas, bugs, or
27;;; fixes.
28
29;;; Daniel LaLiberte 217-244-0785
30;;; University of Illinois, Urbana-Champaign
31;;; Department of Computer Science
32;;; 1304 W Springfield
33;;; Urbana, IL 61801
34
35;;; uiucdcs!liberte
36;;; liberte@cs.uiuc.edu
37
38;;; Contents:
39;;; =========
40;;; Change list
41;;; Installation
42;;; Todo list
43;;; Utilities
44;;; Parser
45;;; Debugger
46
47
48;;;================================================================
49;;; Change list
50;;; -----------
51
52;;; $Header: /import/kaplan/kaplan/liberte/Edebug/RCS/edebug.el,v 2.5 91/07/25 13:32:53 liberte Exp Locker: liberte $
53;;; $Log: edebug.el,v $
54;;; Revision 2.5 91/07/25 13:32:53 liberte
55;;; Doc string cleanup.
56;;; If edebug-form-hook is t, evaluate all arguments.
57;;; If edebug-form-hook is 0, evaluate no arguments.
58;;; If edebug-form-hook is nil, evaluate macro args according
59;;; to edebug-eval-macro-args.
60;;; Save the outside value of executing macro.
61;;; Save and restore the outside restriction.
62;;; Dont force update for go and Go-nonstop.
63;;; Save and restore last-command-char, last-command,
64;;; this-command, last-input-char.
65;;; For epoch, do epoch::dispatch-events before sit-for
66;;; and input-pending-p since X events could interfere.
67;;; Warn about unsetting non-existent breakpoint.
68;;; Fix edebug-forward-sexp with prefix arg.
69;;; Add edebug-step-out to exit from current sexp.
70;;;
71;;; Revision 2.4 91/03/18 12:35:44 liberte
72;;; Force update after go or Go-nonstop modes, so overlay arrow is correct.
73;;; Support debug-on-quit. Remove edebug-on-error.
74;;; Fix edebug-anonymous. Bug found by jackr@wpd.sgi.com (Jack Repenning).
75;;; Don't discard-input anymore. Easier to change modes this way.
76;;; Fix max-lisp-eval-depth and max-specpdl-size incrementing.
77;;; Save and restore points in all buffers, if
78;;; edebug-save-buffer-points is non-nil. Expensive!
79;;; Bug caught by wolfgang@wsrcc.com (Wolfgang S. Rupprecht)
80;;; Save standard-output and standard-input in edebug-recursive-edit
81;;; so that edebug-outside-excursion can restore them.
82;;; Call set-buffer in edebug-pop-to-buffer since
83;;; select-window does not do that.
84;;; Fix edebug's eval-defun to remember current buffer inside evaluations
85;;; and to evaluate top-level forms. Found by Jamie Zawinski.
86;;; Add edebug-interactive-entry to support interactive forms with
87;;; non-string arg. Bug found by Jack Repenning.
88;;; Simplify edebug-restore-match-data to just store-match-data.
89;;; Motivated by linus@lysator.liu.se.
90;;; Move the match-data call to before the outside
91;;; buffer is changed, since it assumes that.
92;;;
93;;; Revision 2.3 91/01/17 20:55:14 liberte
94;;; Fix bug found by hollen@megatek.uucp.
95;;; Current buffer was not being restored.
96;;; Call edebug with (edebug begin end 'exp)
97;;; and add additional wrapper around body of functions:
98;;; (edebug-enter function body).
99;;; Make &optional only apply to immediate next arg
100;;; in edebug-form-parser (was edebug-macro-parser).
101;;; Catch debug errors with edebug. Yeah!
102;;; Reset edebug-mode on first function entry. Yeah!
103;;; Motivated by Dion Hollenbeck.
104;;; Add the missing bindings to the global-edebug-map.
105;;; eval-current-buffer now uses eval-region.
106;;; eval-region now does not narrow region.
107;;; Narrowing was the cause of the window-start being set wrong.
108;;; Reset edebug-mode only on
109;;; first entry of any function at each recursive-edit level.
110;;; Add edebug-backtrace, to generate cleaned up
111;;; backtrace. It doesnt "work" like the debug backtrace, however.
112;;; Require reselecting outside window even if
113;;; quit occurs, otherwise save-excursions may restore
114;;; buffer to the wrong window.
115;;;
116;;; Revision 2.2 90/11/26 21:14:22 liberte
117;;; Shadow eval-defun and eval-region. Toggle
118;;; edebugging with edebug-all-defuns.
119;;; Call edebug with (edebug 'function begin end 'exp)
120;;; Suggested by Jamie Zawinski <jwz@lucid.com>.
121;;; Add edebug-form-parser to process macro args.
122;;; Motivated by Darryl Okahata darrylo@hpnmxx.hp.com.
123;;; Fix by Roland McGrath <roland@ai.mit.edu>
124;;; to wrap body of edebug-save-restriction in progn.
125;;; Fix by Darryl Okahata <darrylo%hpnmd@hpcea.hp.com>
126;;; to add (set-window-hscroll (selected-window) 0) to
127;;; edebug-pop-to-buffer.
128;;;
129;;; Revision 2.1 90/11/16 21:55:35 liberte
130;;; Clean up.
131;;; Add edebug-form-hook to edebug macro calls. Thanks to Joe Wells.
132;;; edebug-forward-sexp uses step mode if no forward-sexp.
133;;;
134;;; Revision 2.0 90/11/14 22:30:54 liberte
135;;; Handle lambda forms, function, interactive evals, defmacro.
136;;; Clean up display for Epoch - save and restore screen configurations.
137;;; Note: epoch 3.2 broke set-window-configuration.
138;;; Also, sit-for pauses do not always work in epoch.
139;;; Display evaluations window.
140;;; Display result after expression evaluation.
141;;; Thanks to discussions with Shinichirou Sugou.
142;;; Conditional and temporary breakpoints.
143;;; Change "continue" to "go" mode and add different "continue" mode.
144;;; Option to stop before symbols.
145;;;
146;;; Fix by: Glen Ditchfield gjditchfield@violet.uwaterloo.ca
147;;; to handle ?# type chars.
148;;;
149;;; Revision 1.5 89/05/10 02:39:27 liberte
150;;; Fix condition-case expression lists.
151;;; Reorganize edebug.
152;;;
153;;; Revision 1.4 89/02/14 22:58:34 liberte
154;;; Fix broken breakpointing.
155;;; Temporarily widen elisp buffer during edebug.
156;;;
157;;; Revision 1.3 89/01/30 00:26:09 liberte
158;;; More bug fixes for cond and let.
159;;; Another parsing fix backquote.
160;;; Fix for lambda forms inside defuns.
161;;; Leave point at syntax error, mark at starting position.
162;;;
163;;; Revision 1.2 88/11/28 12:14:15 liberte
164;;; Bug fixes: cond construct didnt execute.
165;;; () in sexp list didnt parse
166;;; () as variable in condition-case didnt parse.
167;;;
168;;; Revision 1.1 88/11/28 12:11:27 liberte
169;;; Initial revision
170;;;
171
172
173;;; Installation
174;;; ------------
175;; Put edebug.el in some directory in your load-path and byte-compile it.
176
177;; Put the following forms in your .emacs file.
178;; (setq edebug-global-prefix "...whatever you want") ; default is C-xX
179;; (define-key emacs-lisp-mode-map "\^Xx" 'edebug-defun)
180;; (autoload 'edebug-defun "edebug")
181;; (autoload 'edebug-debug "edebug")
182;; (setq debugger 'edebug-debug)
183;; ... other options, described in the next section.
184
185;; Evaluate a defun for edebug with edebug-defun.
186;; Evaluate your function normally.
187;; Use the "?" command in edebug to describe other commands.
188;; See edebug.texinfo for more instructions.
189
190
191;;; Options
192;;; -------
193
194(defvar edebug-all-defuns nil
195 "*If non-nil, all defuns and defmacros evaluated will use edebug.
196eval-defun without prefix arg and eval-region will use edebug-defun.
197
198If nil, eval-region evaluates normally, but eval-defun with prefix arg
199uses edebug-defun. eval-region is called by eval-defun, eval-last-sexp,
200and eval-print-last-sexp.
201
202You may wish to make this variable local to each elisp buffer by calling
203(make-local-variable 'edebug-all-defuns) in your emacs-lisp-mode-hook.
204You can use the function edebug-all-defuns to toggle its value.")
205
206
207(defvar edebug-eval-macro-args nil
208 "*If non-nil, edebug will assume that all macro call arguments for
209macros that have no edebug-form-hook may be evaluated, otherwise it
210will not. To specify exceptions for macros that have some arguments
211evaluated and some not, you should specify an edebug-form-hook")
212
213(defvar edebug-stop-before-symbols nil
214 "*Non-nil causes edebug to stop before symbols as well as after.
215In any case, it is possible to stop before a symbol with a breakpoint or
216interrupt.")
217
218(defvar edebug-save-windows t
219 "*If non-nil, save and restore window configuration on edebug calls.
220It takes some time to save and restore, so if your program does not care
221what happens to the window configurations, it is better to set this
222variable to nil.")
223
224(defvar edebug-save-point t
225 "*If non-nil, save and restore the point and mark in source code buffers.")
226
227(defvar edebug-save-buffer-points nil
228 "*If non-nil, save and restore the points of all buffers, displayed or not.
229
230Saving and restoring buffer points is necessary if you are debugging
231code that changes the point of a buffer which is displayed in a
232non-selected window. If edebug or the user then selects the
233window, the buffer's point will be changed to the window's point.
234
235Saving and restoring all the points is an expensive operation since it
236visits each buffer twice for each edebug call, so it is best to avoid
237it if you can.")
238
239(defvar edebug-initial-mode 'step
240 "*Global initial mode for edebug, if non-nil.
241This is used when edebug is first entered for each recursive-edit level.
242Possible values are nil (meaning keep using edebug-mode), step, go,
243Go-nonstop, trace, Trace-fast, continue, and Continue-fast.")
244
245(defvar edebug-trace nil
246 "*Non-nil if edebug should show a trace of function entry and exit.
247Tracing output is displayed in a buffer named *edebug-trace*, one
248function entry or exit per line, indented by the recursion level. You
249can customize by replacing functions edebug-print-trace-entry and
250edebug-print-trace-exit.")
251
252
253
254;;;========================================================================
255;;; Utilities
256;;; ---------
257
258(defun edebug-which-function ()
259 "Return the symbol of the function we are in"
260 (save-excursion
261 (end-of-defun)
262 (beginning-of-defun)
263 (down-list 1)
264 (if (not (memq (read (current-buffer)) '(defun defmacro)))
265 (error "Not in defun or defmacro."))
266 (read (current-buffer))))
267
268(defun edebug-last-sexp ()
269 "Return the last sexp before point in current buffer.
270Assumes elisp syntax is active."
271 (car
272 (read-from-string
273 (buffer-substring
274 (save-excursion
275 (forward-sexp -1)
276 (point))
277 (point)))))
278
279(defun edebug-window-list ()
280 "Return a list of windows, in order of next-window."
281 ;; This doesnt work for epoch.
282 (let* ((first-window (selected-window))
283 (window-list (list first-window))
284 (next (next-window first-window)))
285 (while (not (eq next first-window))
286 (setq window-list (cons next window-list))
287 (setq next (next-window next)))
288 (nreverse window-list)))
289
290(defun edebug-get-buffer-points ()
291 "Return a list of buffer point pairs, for all buffers."
292 (save-excursion
293 (mapcar (function (lambda (buf)
294 (set-buffer buf)
295 (cons buf (point))))
296 (buffer-list))))
297
298(defun edebug-set-buffer-points ()
299 "Restore the buffer-points given by edebug-get-buffer-points."
300 (mapcar (function (lambda (buf-point)
301 (if (buffer-name (car buf-point)) ; still exists
302 (progn
303 (set-buffer (car buf-point))
304 (goto-char (cdr buf-point))))))
305 edebug-buffer-points))
306
307(defun edebug-two-window-p ()
308 "Return t if there are two windows."
309 (and (not (one-window-p))
310 (eq (selected-window)
311 (next-window (next-window (selected-window))))))
312
313(defun edebug-macrop (object)
314 "Return the macro named by OBJECT, or nil if it is not a macro."
315 (while (and (symbolp object) (fboundp object))
316 (setq object (symbol-function object)))
317 (if (and (listp object)
318 (eq 'macro (car object))
319 (edebug-functionp (cdr object)))
320 object))
321
322(defun edebug-functionp (object)
323 "Returns the function named by OBJECT, or nil if it is not a function."
324 (while (and (symbolp object) (fboundp object))
325 (setq object (symbol-function object)))
326 (if (or (subrp object)
327 (and (listp object)
328 (eq (car object) 'lambda)
329 (listp (car (cdr object)))))
330 object))
331
332(defun edebug-sort-alist (alist function)
333 "Return the ALIST sorted with comparison function FUNCTION.
334This uses 'sort so the sorting is destructive."
335 (sort alist (function
336 (lambda (e1 e2)
337 (funcall function (car e1) (car e2))))))
338
339(put 'edebug-save-restriction 'edebug-form-hook
340 '(&rest form))
341
342(defmacro edebug-save-restriction (&rest body)
343 "Evaluate BODY while saving the current buffers restriction.
344BODY may change buffer outside of current restriction, unlike
345save-restriction. BODY may change the current buffer,
346and the restriction will be restored to the original buffer,
347and the current buffer remains current.
348Return the result of the last expression in BODY."
349 (` (let ((edebug:s-r-beg (point-min-marker))
350 (edebug:s-r-end (point-max-marker)))
351 (unwind-protect
352 (progn (,@ body))
353 (save-excursion
354 (set-buffer (marker-buffer edebug:s-r-beg))
355 (narrow-to-region edebug:s-r-beg edebug:s-r-end))))))
356
357
358;;;=============================================================
359;;; Redefine eval-defun, eval-region, and eval-current-buffer.
360;;; -----------------------------------------------------------
361
362(defun edebug-all-defuns ()
363 "Toggle edebugging of all defuns and defmacros,
364not including those evaluated in the minibuffer, or during load."
365 (interactive)
366 (setq edebug-all-defuns (not edebug-all-defuns))
367 (message "Edebugging is %s." (if edebug-all-defuns "on" "off")))
368
369
370(if (not (fboundp 'edebug-emacs-eval-defun))
371 (fset 'edebug-emacs-eval-defun (symbol-function 'eval-defun)))
372;;(fset 'eval-defun (symbol-function 'edebug-emacs-eval-defun))
373
374(defun eval-defun (edebug-debug)
375 "Edebug replacement for eval-defun. Print value in the minibuffer.
376Evaluate the top-level form that point is in or before. Note:
377eval-defun normally evaluates any top-level form, not just defuns.
378
379Here are the differences from the standard eval-defun. If the prefix
380argument is the same as edebug-all-defuns (nil or non-nil), evaluate
381normally; otherwise edebug-defun is called to wrap edebug calls around
382evaluatable expressions in the defun or defmacro body. Also, the
383value printed by edebug-defun is not just the function name."
384 (interactive "P")
385 (let ((edebug-all-defuns
386 (not (eq (not edebug-debug) (not edebug-all-defuns)))))
387 (edebug-emacs-eval-defun nil)
388 ))
389
390
391(if (not (fboundp 'edebug-emacs-eval-region))
392 (fset 'edebug-emacs-eval-region (symbol-function 'eval-region)))
393;; (fset 'eval-region (symbol-function 'edebug-emacs-eval-region))
394
395(defun eval-region (edebug-e-r-start edebug-e-r-end
396 &optional edebug-e-r-output)
397 "Edebug replacement for eval-defun.
398Like eval-region, but call edebug-defun for defuns or defmacros.
399Also, this eval-region does not narrow to the region and
400if an error occurs, point is left at the error."
401 ;; One other piddling difference concerns whitespace after the expression.
402 (interactive "r")
403 (let ((standard-output (or edebug-e-r-output 'symbolp))
404 (edebug-e-r-pnt (point))
405 (edebug-e-r-buf (current-buffer))
406 (edebug-e-r-inside-buf (current-buffer))
407 ;; Mark the end because it may move.
408 (edebug-e-r-end-marker (set-marker (make-marker) edebug-e-r-end))
409 edebug-e-r-val
410 )
411 (goto-char edebug-e-r-start)
412 (edebug-skip-whitespace)
413 (while (< (point) edebug-e-r-end-marker)
414 (if (and edebug-all-defuns
415 (eq 'lparen (edebug-next-token-class))
416 (save-excursion
417 (forward-char 1) ; skip \(
418 (memq (edebug-read-sexp) '(defun defmacro))))
419 (progn
420 (edebug-defun)
421 ;; Potential problem: edebug-defun always prints name.
422 (forward-sexp 1) ; skip the defun
423 )
424 (if (and (eq 'lparen (edebug-next-token-class))
425 (save-excursion
426 (forward-char 1) ; skip \(
427 (memq (edebug-read-sexp) '(defun defmacro))))
428 ;; If it's a defun or defmacro, but not edebug-all-defuns
429 ;; reset the symbols edebug property to be just a marker at
430 ;; the definitions source code.
431 (put (edebug-which-function) 'edebug (point-marker)))
432
433 ;; Evaluate normally - after restoring the current-buffer.
434 (setq edebug-e-r-val (edebug-read-sexp))
435 (save-excursion
436 (set-buffer edebug-e-r-inside-buf)
437 (setq edebug-e-r-val (eval edebug-e-r-val))
438 ;; Remember current buffer for next time.
439 (setq edebug-e-r-inside-buf (current-buffer)))
440
441 (if edebug-e-r-output
442 (progn
443 (setq values (cons edebug-e-r-val values))
444 (if (eq standard-output t)
445 (prin1 edebug-e-r-val)
446 (print edebug-e-r-val))))
447 )
448 (goto-char
449 (min (max edebug-e-r-end-marker (point))
450 (progn (edebug-skip-whitespace) (point))))
451 ) ; while
452 (if (null edebug-e-r-output)
453 ;; do the save-excursion recovery
454 (progn
455 ;; but mark is not restored
456 (set-buffer edebug-e-r-buf)
457 (goto-char edebug-e-r-pnt)))
458 nil
459 ))
460
461
462;; The standard eval-current-buffer doesn't use eval-region.
463(if (not (fboundp 'edebug-emacs-eval-current-buffer))
464 (fset 'edebug-emacs-eval-current-buffer
465 (symbol-function 'eval-current-buffer)))
466;; (fset 'eval-current-buffer (symbol-function 'edebug-emacs-eval-current-buffer))
467
468(defun eval-current-buffer (&optional edebug-e-c-b-output)
469 "Call eval-region on the whole buffer."
470 (interactive)
471 (eval-region (point-min) (point-max) edebug-e-c-b-output))
472
473
474
475;;;======================================================================
476;;; The Parser
477;;; ----------
478
479;;; The top level function for parsing defuns is edebug-defun; it
480;;; calls all the rest. It checks the syntax a bit and leaves point
481;;; at any error it finds, but otherwise should appear to work like
482;;; eval-defun.
483
484;;; The basic plan is to surround each expression with a call to the
485;;; function edebug together with indexes into a table of positions of
486;;; all expressions. Thus an expression "exp" in function foo
487;;; becomes:
488
489;;; (edebug 1 2 'exp)
490
491;;; First point moved to to the beginning of exp (offset 1 of the
492;;; current function). Then the expression is evaluated and point is
493;;; moved to offset 2, at the end of exp.
494
495;;; The top level expressions of the function are wrapped in a call to
496;;; edebug-enter, which supplies the function name and the actual
497;;; arguments to the function. See functions edebug and edebug-enter
498;;; for more details.
499
500
501(defun edebug-defun ()
502 "Evaluate defun or defmacro, like eval-defun, but with edebug calls.
503Print its name in the minibuffer and leave point after any error it finds,
504with mark at the original point."
505 (interactive)
506 (let (def-kind ; whether defmacro or defun
507 def-name
508 def-args
509 def-docstring
510 defun-interactive
511 (edebug-offset-index 0)
512 edebug-offset-list
513 edebug-func-mark
514 (starting-point (point))
515 tmp-point
516 (parse-sexp-ignore-comments t))
517
518 (condition-case err
519 (progn
520 (end-of-defun)
521 (beginning-of-defun)
522 (down-list 1)
523
524 (setq edebug-func-mark (point-marker))
525 (if (not (eq 'defun (setq def-kind (edebug-read-sexp))))
526 (if (not (eq 'defmacro def-kind))
527 (edebug-syntax-error "%s is not a defun or defmacro."
528 def-kind)))
529 (setq def-name (edebug-read-sexp))
530 (if (not (symbolp def-name))
531 (edebug-syntax-error "Bad defun name: %s" def-name))
532 (setq def-args (edebug-read-sexp))
533 (if (not (listp def-args))
534 (edebug-syntax-error "Bad defun arg list: %s" def-args))
535
536 ;; look for doc string
537 (setq tmp-point (point))
538 (if (eq 'string (edebug-next-token-class))
539 (progn
540 (setq def-docstring (edebug-read-sexp))
541 (setq tmp-point (point))))
542
543 ;; look for interactive form
544 (if (eq 'lparen (edebug-next-token-class))
545 (progn
546 (forward-char 1) ; skip \(
547 (if (eq 'interactive (edebug-read-sexp))
548 (progn
549 (setq defun-interactive
550 (cons 'interactive (edebug-interactive)))
551 (forward-char 1) ; skip \)
552 (setq tmp-point (point))
553 ))))
554
555 (goto-char tmp-point)
556
557 ;; build the new definition
558 (fset def-name (` (lambda
559 (, def-args)
560 (, def-docstring)
561 (, defun-interactive)
562 ;; the remainder is a list of sexps
563 (edebug-enter
564 (quote (, def-name))
565 (quote (, def-args))
566 (quote (progn
567 (,@ (edebug-sexp-list t)))))
568 )))
569 ;; if it is a defmacro, prepend 'macro
570 (if (eq 'defmacro def-kind)
571 (fset def-name (cons 'macro (symbol-function def-name))))
572
573 ;; recover point, like save-excursion but only if no error occurs
574 (goto-char starting-point)
575
576 ;; store the offset list in functions property list
577 (put def-name 'edebug
578 (list edebug-func-mark
579 nil ; clear breakpoints
580 (vconcat (nreverse edebug-offset-list))))
581 (message "edebug: %s" def-name)
582 ) ; progn
583
584 (invalid-read-syntax
585 ;; Set mark at starting-point so user can return.
586 ;; Leave point at error.
587 (save-excursion
588 (goto-char starting-point)
589 (set-mark-command nil))
590 (message "Syntax error: %s" (cdr err))
591;; (signal 'invalid-read-syntax (cdr err)) ; pass it on, to who?
592 )
593 ) ; condition-case
594 def-name
595 ))
596
597
598(defun edebug-sexp-list (debuggable)
599 "Return an edebug form built from the sexp list following point in the
600current buffer. If DEBUGGABLE then wrap edebug calls around each sexp.
601The sexp list does not start with a left paren; we are already in the list.
602Leave point at (before) the trailing right paren."
603 (let (sexp-list)
604 (while (not (eq 'rparen (edebug-next-token-class)))
605 (setq sexp-list (cons (if debuggable
606 (edebug-form)
607 (edebug-read-sexp))
608 sexp-list)))
609 (nreverse sexp-list)))
610
611
612(defun edebug-increment-offset ()
613 ;; accesses edebug-offset-index and edebug-offset-list
614 (setq edebug-offset-index (1+ edebug-offset-index))
615 (setq edebug-offset-list (cons (- (point) edebug-func-mark)
616 edebug-offset-list)))
617
618
619(defun edebug-make-edebug-form (index form)
620 "Return the edebug form for the current function at offset INDEX given FORM.
621Looks like: (edebug def-name INDEX edebug-offset-index 'FORM).
622Also increment the offset index."
623 (prog1
624 (list 'edebug
625 index
626 edebug-offset-index
627 (list 'quote form))
628 (edebug-increment-offset)
629 ))
630
631
632(defun edebug-form ()
633 "Return the debug form for the following form. Add the point offset
634to the edebug-offset-list for the function and move point to
635immediately after the form."
636 (let* ((index edebug-offset-index)
637 form class)
638 ;; The point must be added to the offset list now
639 ;; because edebug-list will add more offsets indirectly.
640 (edebug-skip-whitespace)
641 (edebug-increment-offset)
642 (setq class (edebug-next-token-class))
643 (cond
644 ((eq 'lparen class)
645 (edebug-make-edebug-form index (edebug-list)))
646
647 ((eq 'symbol class)
648 (if (and (not (memq (setq form (edebug-read-sexp)) '(nil t)))
649 ;; note: symbol includes numbers, see parsing utilities
650 (not (numberp form)))
651 (edebug-make-edebug-form index form)
652 form))
653 (t (edebug-read-sexp)))))
654
655
656(defun edebug-list ()
657 "Return an edebug form built from the list form that follows point.
658Insert debug calls as appropriate to the form. Start with point at
659the left paren. Leave point after the right paren."
660 (let ((beginning (point))
661 class
662 head)
663
664 (forward-char 1) ; skip \(
665 (setq class (edebug-next-token-class))
666 (cond
667 ((eq 'symbol class)
668 (setq head (edebug-read-sexp)))
669 ((eq 'lparen class)
670 (setq head (edebug-anonymous)))
671 ((eq 'rparen class)
672 (setq head nil))
673 (t (edebug-syntax-error
674 "Head of list must be a symbol or lambda expression.")))
675
676 (prog1
677 (if head
678 (cons head
679 (cond
680
681;; None of the edebug-form-hooks defined below are used, for speed.
682;; They are included for documentation, though the hook would not
683;; necessarily behave the same as the function it is replacing.
684
685;;; Using the edebug-form-hooks should work, but would take more time.
686;;; ((symbolp head)
687;;; (let ((form (get head 'edebug-form-hook)))
688;;; (if form
689;;; (edebug-form-parser form)
690;;; (if (edebug-macrop head)
691;;; (if edebug-eval-macro-args
692;;; (edebug-sexp-list t)
693;;; (edebug-sexp-list nil))
694;;; ;; assume it is a function
695;;; (edebug-sexp-list t)))))
696
697 ;; handle all special-forms with unevaluated arguments
698 ((memq head '(let let*)) (edebug-let))
699 ((memq head '(setq setq-default)) (edebug-setq))
700 ((eq head 'cond) (edebug-cond))
701 ((eq head 'condition-case) (edebug-condition-case))
702
703 ((memq head '(quote ; permits more than one arg
704 defun defvar defconst defmacro))
705 (edebug-sexp-list nil))
706 ((eq head 'function)
707 (list
708 (if (eq 'lparen (edebug-next-token-class))
709 (edebug-anonymous)
710 (edebug-read-sexp) ; should be just a symbol
711 )))
712
713 ;; is it a lisp macro?
714 ((edebug-macrop head)
715 (or (and (symbolp head)
716 (let ((form (get head 'edebug-form-hook)))
717 (if form
718 (if (eq form t)
719 (edebug-sexp-list t)
720 (if (eq form 0)
721 (edebug-sexp-list nil)
722 (edebug-form-parser form))))))
723 (edebug-sexp-list edebug-eval-macro-args)))
724
725 ((eq head 'interactive)
726 (edebug-syntax-error "interactive not expected here."))
727
728 ;; otherwise it is a function call
729 (t (edebug-sexp-list t))
730 )))
731
732 (if (eq 'rparen (edebug-next-token-class))
733 (forward-char 1) ; skip \)
734 (edebug-syntax-error "Too many arguments."))
735 )))
736
737
738(defun edebug-form-parser (args)
739 "Parse the macro arguments that follow based on ARGS.
740ARGS describes the types of the arguments of a list form. Each of the ARGS
741is processed left to right, in the same order as the arguments of the
742list form. See the edebug documentation for more details. The ARGS
743may be one of the following:
744
745 symbolp - an unevaluated symbol
746 integerp - an unevaluated number
747 stringp - an unevaluated string
748 vectorp - an unevaluated vector
749 atom - an unevaluated number, string, symbol, or vector
750
751 sexp - an unevaluated sexp (atom or list); may not be empty
752 form - an evaluated sexp; may not be empty
753
754 foo - any other symbol should be the name of a function; this
755 function is called on the argument as a predicate and an error
756 is signaled if the predicate fails.
757
758 &optional - one following arg in the list may or may not appear.
759 &rest - all following args are repeated zero or more times as a group.
760 This is an extension of the normal meaning of &rest.
761 &or - each of the following args are alternatives, processed left to
762 right until one succeeds. There is no way to group
763 more than one list element as one alternative.
764
765 (...) - a sublist, of the same format as the top level, processed recursively.
766 Special case: if the car of the list is quote, the argument must match
767 the quoted sexp (see example below of 'for macro).
768"
769
770 (let ((arglist args)
771 arg form form-list class
772 &optional &rest &or)
773 (while (and arglist
774 (not (eq 'rparen (setq class (edebug-next-token-class)))))
775 (catch 'no-match
776 (setq arg (car arglist))
777 (setq arglist (cdr arglist))
778 (if (and &rest (null arglist))
779 (setq arglist &rest))
780
781 (cond
782 ((memq arg '(&optional &rest &or))
783 ;; remember arglist at this point
784 (set arg arglist)
785 (throw 'no-match nil))
786
787 ((eq arg 'form)
788 (setq form (edebug-form)))
789
790 ((eq arg 'sexp)
791 (setq form (edebug-read-sexp)))
792
793 ((listp arg)
794 (if (eq 'quote (car arg))
795 ;; special case, match the quoted symbol
796 (let ((pnt (point)))
797 (setq arg (car (cdr arg)))
798 (if (not (eq arg (setq form (edebug-read-sexp))))
799 (edebug-form-parser-error)
800 ))
801 (if (eq class 'lparen)
802 (progn
803 (forward-char 1) ; skip \(
804 (setq form (edebug-form-parser arg))
805 (forward-char 1) ; skip \)
806 ))))
807 ((symbolp arg)
808 (let ((pnt (point))
809 (pred (if (fboundp arg) (symbol-function arg))))
810 (and pred
811 (not (funcall pred (setq form (edebug-read-sexp))))
812 (edebug-form-parser-error)
813 )))
814 (t (throw 'no-match nil))
815 ) ; cond
816 (setq &optional nil) ; only lasts for one match
817 (setq form-list (cons form form-list)) ; skipped by no-match throw
818 )) ; while
819
820 (if (and arglist (not (or &optional &rest
821 (memq (car arglist) '(&optional &rest)))))
822 (edebug-syntax-error "Not enough arguments."))
823 (if (not (eq 'rparen (edebug-next-token-class)))
824 (if &or
825 (edebug-syntax-error "Unrecognized argument.")
826 (edebug-syntax-error "Too many arguments.")))
827 (nreverse form-list)))
828
829
830(defun edebug-form-parser-error ()
831 (goto-char pnt)
832 (if &or
833 (throw 'no-match nil)
834 (if &optional
835 (progn
836 (setq &optional nil) ; only lasts for one failed match not in &or
837 (throw 'no-match nil))
838 (edebug-syntax-error "%s is not %s" form arg))))
839
840;; for loop defined in elisp manual
841(put 'for 'edebug-form-hook
842 '(symbolp 'from form 'to form 'do &rest form))
843
844;; case and do defined in cl.el
845(put 'case 'edebug-form-hook
846 '(form &rest (sexp form)))
847
848(put 'do 'edebug-form-hook
849 '((&rest
850 &or symbolp
851 (symbolp &optional form
852 &optional form))
853 (form &rest form)
854 &rest body))
855
856(put 'defvar 'edebug-form-hook
857 (put 'defconst 'edebug-form-hook
858 '(symbolp &optional form &optional stringp)))
859
860(put 'defun 'edebug-form-hook
861 (put 'defmacro 'edebug-form-hook
862 '(symbolp (&rest symbolp)
863 &optional stringp
864 &optional ('interactive &or stringp form)
865 &rest form)))
866
867(put 'anonymous 'edebug-form-hook
868 '(&optional 'macro 'lambda (&rest symbolp) &rest form))
869
870(defun edebug-anonymous ()
871 "Return the edebug form for an anonymous lambda or macro.
872Point starts before the left paren and ends after it."
873 (forward-char 1) ; skip \(
874 (prog1
875 (let ((head (edebug-read-sexp)))
876 (cond
877 ((eq head 'lambda)
878 (edebug-lambda))
879 ((eq head 'macro)
880 (if (not (eq 'lambda (edebug-read-sexp)))
881 (edebug-syntax-error "lambda expected."))
882 (cons 'macro (edebug-lambda)))
883 (t (edebug-syntax-error "Anonymous lambda or macro expected."))))
884 (forward-char 1) ; skip \)
885 ))
886
887
888(defun edebug-lambda ()
889 "Return the edebug form for the lambda form that follows.
890Point starts after the lambda symbol and is moved to before the right paren."
891 (append
892 (list 'lambda (edebug-read-sexp)) ; the args
893 (edebug-sexp-list t))) ; the body
894
895
896
897(put 'let 'edebug-form-hook
898 (put 'let* 'edebug-form-hook
899 '((&rest
900 &or (symbolp &optional form)
901 symbolp)
902 &rest form)))
903
904(defun edebug-let ()
905 "Return the edebug form of the let or let* form.
906Leave point before the right paren."
907 (let (var-value-list
908 token
909 class)
910 (cons
911 ;; first process the var/value list
912 (if (not (eq 'lparen (edebug-next-token-class)))
913 (if (setq token (edebug-read-sexp))
914 (edebug-syntax-error "Bad var list in let.") ; should be nil
915 token ; == nil
916 )
917
918 (forward-char 1) ; lparen
919 (while (not (eq 'rparen (setq class (edebug-next-token-class))))
920 (setq var-value-list
921 (cons
922 (if (not (eq 'lparen class))
923 (edebug-read-sexp)
924 (forward-char 1) ; lparen
925 (prog1
926 (edebug-var-value)
927 (if (not (eq 'rparen (edebug-next-token-class)))
928 (edebug-syntax-error "Right paren expected in let.")
929 (forward-char 1) ; rparen
930 )))
931 var-value-list)))
932 (forward-char 1) ; rparen
933 (nreverse var-value-list))
934
935 ;; now process the expression list
936 (edebug-sexp-list t))))
937
938
939(defun edebug-var-value ()
940 "Return the edebug form of the var and optional value that follow point.
941Leave point after the value, if there is one."
942 (list
943 (edebug-read-sexp) ; the variable
944 (and (not (eq 'rparen (edebug-next-token-class)))
945 (edebug-form))))
946
947
948(put 'setq 'edebug-form-hook
949 (put 'setq-default 'edebug-form-hook
950 '(&rest symbolp form)))
951
952(defun edebug-setq ()
953 "Return the edebug form of the setq or setq-default var-value list."
954 (let (var-value-list)
955 (while (not (eq 'rparen (edebug-next-token-class)))
956 (setq var-value-list
957 (append var-value-list
958 (edebug-var-value))))
959 var-value-list))
960
961
962(put 'interactive 'edebug-form-hook
963 '(&optional &or stringp form))
964
965(defun edebug-interactive ()
966 "Return the edebug form of the interactive form."
967 (list
968 (if (not (eq 'rparen (edebug-next-token-class)))
969 (if (eq 'string (edebug-next-token-class))
970 (edebug-read-sexp)
971 (prog1
972 (` (edebug-interactive-entry
973 (quote (, def-name))
974 (quote ((,@ (edebug-form))))))
975 (if (not (eq 'rparen (edebug-next-token-class)))
976 (edebug-syntax-error
977 "Only first expression used in interactive form.")))))))
978
979
980(put 'cond 'edebug-form-hook
981 '(&rest (form &rest form)))
982
983(defun edebug-cond ()
984 "Return the edebug form of the cond form."
985 (let (value-value-list
986 class)
987 (while (not (eq 'rparen (setq class (edebug-next-token-class))))
988 (setq value-value-list
989 (cons
990 (if (not (eq 'lparen class))
991 (let ((thing (edebug-read-sexp)))
992 (if thing
993 (edebug-syntax-error "Condition expected in cond")
994 nil))
995 (forward-char 1) ; \(
996 (prog1
997 (cons
998 (edebug-form)
999 (if (eq 'rparen (edebug-next-token-class))
1000 nil
1001 (edebug-sexp-list t)))
1002 (if (not (eq 'rparen (edebug-next-token-class)))
1003 (edebug-syntax-error "Right paren expected in cond"))
1004 (forward-char 1) ; \)
1005 ))
1006 value-value-list)))
1007 (nreverse value-value-list)))
1008
1009
1010;; Bug: this doesnt support condition name lists
1011(put 'condition-case 'edebug-form-hook
1012 '(symbolp
1013 form
1014 &rest (symbolp &optional form)))
1015
1016(defun edebug-condition-case ()
1017 "Return the edebug form of the condition-case form."
1018 (cons
1019 (let (token)
1020 ;; read the variable or nil
1021 (setq token (edebug-read-sexp))
1022 (if (not (symbolp token))
1023 (edebug-syntax-error
1024 "Variable or nil required for condition-case; found: %s" token))
1025 token)
1026
1027 (cons
1028 (edebug-form) ; the form
1029
1030 ;; process handlers
1031 (let (symb-sexp-list
1032 class)
1033 (while (not (eq 'rparen (setq class (edebug-next-token-class))))
1034 (setq symb-sexp-list
1035 (cons
1036 (if (not (eq 'lparen class))
1037 (edebug-syntax-error "Bad handler in condition-case.")
1038 (forward-char 1) ; \(
1039 (prog1
1040 (cons
1041 (edebug-read-sexp) ; the error-condition
1042 (and (not (eq 'rparen (edebug-next-token-class)))
1043 (edebug-sexp-list t)))
1044 (forward-char 1) ; \)
1045 ))
1046 symb-sexp-list)))
1047 (nreverse symb-sexp-list)))))
1048
1049
1050
1051;;------------------------------------------------
1052;; Parser utilities
1053
1054(defun edebug-syntax-error (msg &rest args)
1055 "Signal an invalid-read-syntax with MSG and ARGS.
1056 This is caught by edebug-defun."
1057 (signal 'invalid-read-syntax (apply 'format msg args)))
1058
1059
1060(defun edebug-skip-whitespace ()
1061 "Leave point before the next token, skipping white space and comments."
1062 (skip-chars-forward " \t\r\n\f")
1063 (while (= (following-char) ?\;)
1064 (skip-chars-forward "^\n\r") ; skip the comment
1065 (skip-chars-forward " \t\r\n\f")))
1066
1067(defun edebug-read-sexp ()
1068 "Read one sexp from the current buffer starting at point.
1069Leave point immediately after it. A sexp can be a list or atom.
1070An atom is a symbol (or number), character, string, or vector."
1071 ;; This is gummed up by parser inconsistencies (bugs?)
1072 (let (token)
1073 (edebug-skip-whitespace)
1074 (if (or (= (following-char) ?\[) (= (following-char) ??))
1075 ;; scan-sexps doesn't read vectors or character literals correctly,
1076 ;; but read does.
1077 (setq token (read (current-buffer)))
1078 (goto-char
1079 (min ; use the lesser of the read and scan-sexps motion
1080 ;; read goes one too far if (quoted) string or symbol
1081 ;; is immediately followed by non-whitespace
1082 (save-excursion
1083 (setq token (read (current-buffer)))
1084 (point))
1085 ;; scan-sexps reads too far if a quoting character is read
1086 (scan-sexps (point) 1))))
1087 token))
1088
1089(defconst edebug-syntax-table
1090 (let ((table (make-vector 256 'symbol)))
1091 ;; Treat numbers as symbols, because of confusion with -, -1, and 1-.
1092 (aset table ?\( 'lparen)
1093 (aset table ?\) 'rparen)
1094 (aset table ?\' 'quote)
1095 (aset table ?\" 'string)
1096 (aset table ?\? 'char)
1097 (aset table ?\[ 'vector)
1098 (aset table ?\. 'dot)
1099 ;; We dont care about any other chars since they wont be seen.
1100 table)
1101 "Lookup table for the token class of each character.")
1102
1103(defun edebug-next-token-class ()
1104 "Move to the next token and return its class. We only care about
1105lparen, rparen, dot, quote, string, char, vector, or symbol."
1106 (edebug-skip-whitespace)
1107 (aref edebug-syntax-table (following-char)))
1108
1109
1110;;;=================================================================
1111;;; The debugger itself
1112;;; -------------------
1113
1114
1115(defvar edebug-active nil
1116 "Non-nil when edebug is active")
1117
1118
1119;;; add minor-mode-alist entry
1120(or (assq 'edebug-active minor-mode-alist)
1121 (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*")
1122 minor-mode-alist)))
1123
1124(defvar edebug-backtrace nil
1125 "Stack of active functions evaluated via edebug.
1126Should be nil at the top level.")
1127
1128(defvar edebug-offset-indices nil ; not used yet.
1129 "Stack of offset indices of visited edebug sexps.
1130Should be nil at the top level.")
1131
1132(defvar edebug-entered nil
1133 "Non-nil if edebug has already been entered at this recursive edit level.")
1134
1135
1136(defun edebug-enter (edebug-func edebug-args edebug-body)
1137 "Entering FUNC. The arguments are ARGS, and the body is BODY.
1138Setup edebug variables and evaluate BODY. This function is called
1139when a function evaluated with edebug-defun is entered. Return the
1140result of BODY."
1141
1142 ;; Is this the first time we are entering edebug since
1143 ;; lower-level recursive-edit command?
1144 (if (and (not edebug-entered)
1145 edebug-initial-mode)
1146 ;; Reset edebug-mode to the initial mode.
1147 (setq edebug-mode edebug-initial-mode))
1148 (let* ((edebug-entered t)
1149 (edebug-data (get edebug-func 'edebug))
1150 ;; pull out parts of the edebug-data
1151 (edebug-func-mark (car edebug-data)) ; mark at function start
1152
1153 (edebug-buffer (marker-buffer edebug-func-mark))
1154 (edebug-backtrace (cons edebug-func edebug-backtrace))
1155 (max-lisp-eval-depth (+ 6 max-lisp-eval-depth)) ; too much??
1156 (max-specpdl-size (+ 10 max-specpdl-size)) ; the args and these vars
1157 )
1158 (if edebug-trace
1159 (let ((edebug-stack-depth (1- (length edebug-backtrace)))
1160 edebug-result)
1161 (edebug-print-trace-entry
1162 "*edebug-trace*" edebug-func edebug-args edebug-stack-depth)
1163 (setq edebug-result (eval edebug-body))
1164 (edebug-print-trace-exit
1165 "*edebug-trace*" edebug-func edebug-result edebug-stack-depth)
1166 edebug-result)
1167 (eval edebug-body)
1168 )))
1169
1170(defun edebug-interactive-entry (edebug-func edebug-args)
1171 "Evaluating FUNCs non-string argument of interactive form ARGS."
1172 (if (and (not edebug-entered)
1173 edebug-initial-mode)
1174 ;; Reset edebug-mode to the initial mode.
1175 (setq edebug-mode edebug-initial-mode))
1176 (let* ((edebug-entered t)
1177 (edebug-data (get edebug-func 'edebug))
1178 ;; pull out parts of the edebug-data
1179 (edebug-func-mark (car edebug-data)) ; mark at function start
1180
1181 (edebug-buffer (marker-buffer edebug-func-mark))
1182;; (edebug-backtrace (cons edebug-func edebug-backtrace))
1183 )
1184 (eval edebug-args)))
1185
1186
1187(defun edebug-print-trace-entry
1188 (edebug-stream edebug-function edebug-args edebug-stack-depth)
1189 (edebug-trace-display
1190 edebug-stream
1191 "%sEnter: %s\n" (make-string edebug-stack-depth ?\ ) edebug-function)
1192 )
1193
1194(defun edebug-print-trace-exit
1195 (edebug-stream edebug-function edebug-result edebug-stack-depth)
1196 (edebug-trace-display
1197 edebug-stream
1198 "%sExit: %s\n" (make-string edebug-stack-depth ?\ ) edebug-function)
1199 )
1200
1201
1202(defun edebug (edebug-before-index edebug-after-index edebug-exp)
1203 "Debug current function given BEFORE and AFTER positions around EXP.
1204BEFORE and AFTER are indexes into the position offset vector in the
1205functions 'edebug property. edebug is called from functions compiled
1206with edebug-defun."
1207 (let ((max-lisp-eval-depth (+ 5 max-lisp-eval-depth)) ; enough??
1208 (max-specpdl-size (+ 7 max-specpdl-size)) ; the args and these vars
1209 (edebug-offset-indices
1210 (cons edebug-before-index edebug-offset-indices))
1211 ;; Save the outside value of executing macro.
1212 (edebug-outside-executing-macro executing-macro)
1213 ;; Don't keep reading from an executing kbd macro within edebug!
1214 (executing-macro nil)
1215 )
1216 (if (and (eq edebug-mode 'Go-nonstop)
1217 (not (edebug-input-pending-p)))
1218 ;; Just return evalled expression.
1219 (eval edebug-exp)
1220 (edebug-debugger edebug-before-index 'enter edebug-exp)
1221 (edebug-debugger edebug-after-index 'exit (eval edebug-exp))
1222 )))
1223
1224
1225(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-exp)
1226 "Determine if edebug display should be updated."
1227 (let* (
1228 ;; This needs to be here since breakpoints may be changed.
1229 (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints
1230 (edebug-break-data (assq edebug-offset-index edebug-breakpoints))
1231 (edebug-break
1232 (if edebug-break-data
1233 (let ((edebug-break-condition
1234 (car (cdr edebug-break-data))))
1235 (or (not edebug-break-condition)
1236 (eval edebug-break-condition)))))
1237 )
1238 (if (and edebug-break
1239 (car (cdr (cdr edebug-break-data)))) ; is it temporary?
1240 ;; Delete the breakpoint.
1241 (setcdr edebug-data
1242 (cons (delq edebug-break-data edebug-breakpoints)
1243 (cdr (cdr edebug-data)))))
1244
1245 ;; Dont do anything if mode is go, continue, or Continue-fast
1246 ;; and no break, and no input.
1247 (if (or (and (not (memq edebug-mode '(go continue Continue-fast)))
1248 (or edebug-stop-before-symbols
1249 (not (and (eq edebug-arg-mode 'enter)
1250 (symbolp edebug-exp)))))
1251 (edebug-input-pending-p)
1252 edebug-break)
1253 (edebug-display))
1254
1255 edebug-exp
1256 ))
1257
1258
1259(defvar edebug-window-start 0
1260 "Remember where each buffers' window starts between edebug calls.
1261This is to avoid spurious recentering.")
1262
1263(setq-default edebug-window-start 0)
1264(make-variable-buffer-local 'edebug-window-start)
1265
1266(defun edebug-display ()
1267 "Setup windows for edebug, determine mode, maybe enter recursive-edit."
1268 ;; uses local variables of edebug-enter, edebug, and edebug-debugger.
1269 (let ((edebug-active t) ; for minor mode alist
1270 edebug-stop ; should we enter recursive-edit
1271 (edebug-point (+ edebug-func-mark
1272 (aref (car (cdr (cdr edebug-data)))
1273 edebug-offset-index)))
1274 (edebug-buffer-points
1275 (if edebug-save-buffer-points (edebug-get-buffer-points)))
1276 edebug-window ; window displaying edebug-buffer
1277 edebug-inside-window ; window displayed after recursive edit
1278 (edebug-outside-window (selected-window))
1279 (edebug-outside-buffer (current-buffer))
1280 (edebug-outside-point (point))
1281 (edebug-outside-mark (mark))
1282 edebug-outside-windows ; window or screen configuration
1283 edebug-outside-edebug-point ; old point in edebug buffer
1284 edebug-outside-edebug-mark
1285
1286 edebug-eval-buffer ; declared here so we can kill it below
1287 (edebug-eval-result-list (and edebug-eval-list
1288 (edebug-eval-result-list)))
1289 (edebug-outside-o-a-p overlay-arrow-position)
1290 (edebug-outside-o-a-s overlay-arrow-string)
1291 (edebug-outside-c-i-e-a cursor-in-echo-area)
1292
1293 edebug-outside-point-min
1294 edebug-outside-point-max
1295
1296 overlay-arrow-position
1297 overlay-arrow-string
1298 (cursor-in-echo-area nil)
1299 ;; any others??
1300 )
1301 (if (not (buffer-name edebug-buffer))
1302 (let (debug-on-error nil)
1303 (error "Buffer defining %s not found." edebug-func)))
1304
1305 ;; Save windows now before we modify them.
1306 (if edebug-save-windows
1307 (setq edebug-outside-windows
1308 (edebug-current-window-configuration)))
1309
1310 ;; If edebug-buffer is not currently displayed,
1311 ;; first find a window for it.
1312 (edebug-pop-to-buffer edebug-buffer)
1313 (setq edebug-window (selected-window))
1314
1315 ;; Now display eval list, if any.
1316 ;; This is done after the pop to edebug-buffer
1317 ;; so that buffer-window correspondence is correct after quit.
1318 (edebug-eval-display edebug-eval-result-list)
1319 (select-window edebug-window)
1320
1321 (if edebug-save-point
1322 (progn
1323 (setq edebug-outside-edebug-point (point))
1324 (setq edebug-outside-edebug-mark (mark))))
1325
1326 (edebug-save-restriction
1327 (setq edebug-outside-point-min (point-min))
1328 (setq edebug-outside-point-max (point-max))
1329 (widen)
1330 (goto-char edebug-point)
1331
1332 (setq edebug-window-start
1333 (edebug-adjust-window edebug-window-start))
1334
1335 (if (edebug-input-pending-p) ; not including keyboard macros
1336 (progn
1337 (setq edebug-mode 'step)
1338 (setq edebug-stop t)
1339 (edebug-stop)
1340 ;; (discard-input) ; is this unfriendly??
1341 ))
1342 (edebug-overlay-arrow)
1343
1344 (cond
1345 ((eq 'exit edebug-arg-mode)
1346 ;; Display result of previous evaluation.
1347 (setq edebug-previous-result edebug-exp)
1348 (edebug-previous-result))
1349
1350 ((eq 'error edebug-arg-mode)
1351 ;; Display error message
1352 (beep)
1353 (if (eq 'quit (car edebug-exp))
1354 (message "Quit")
1355 (message "%s: %s"
1356 (get (car edebug-exp) 'error-message)
1357 (car (cdr edebug-exp)))))
1358
1359 (edebug-break
1360 (message "Break"))
1361 (t (message "")))
1362
1363 (if edebug-break
1364 (if (not (memq edebug-mode '(continue Continue-fast)))
1365 (setq edebug-stop t)
1366 (if (eq edebug-mode 'continue)
1367 (edebug-sit-for 1)
1368 (edebug-sit-for 0)))
1369 ;; not edebug-break
1370 (if (eq edebug-mode 'trace)
1371 (edebug-sit-for 1) ; Force update and pause.
1372 (if (eq edebug-mode 'Trace-fast)
1373 (edebug-sit-for 0) ; Force update and continue.
1374 )))
1375
1376 (unwind-protect
1377 (if (or edebug-stop
1378 (eq edebug-mode 'step)
1379 (eq edebug-arg-mode 'error))
1380 (progn
1381 (setq edebug-mode 'step)
1382 (edebug-overlay-arrow) ; this doesnt always show up.
1383 (edebug-recursive-edit));; <<<<<< Recursive edit
1384 )
1385
1386 (if edebug-save-buffer-points
1387 (edebug-set-buffer-points))
1388 ;; Since we may be in a save-excursion, in case of quit
1389 ;; restore the outside window only.
1390 (select-window edebug-outside-window)
1391 ) ; unwind-protect
1392
1393 ;; None of the following is done if quit or signal occurs.
1394 (if edebug-save-point
1395 ;; Restore point and mark in edebug-buffer.
1396 ;; This does the save-excursion recovery only if no quit.
1397 ;; If edebug-buffer == edebug-outside-buffer,
1398 ;; then this is redundant with outside save-excursion.
1399 (progn
1400 (set-buffer edebug-buffer)
1401 (goto-char edebug-outside-edebug-point)
1402 (if (mark-marker)
1403 (set-marker (mark-marker) edebug-outside-edebug-mark))
1404 ))
1405 ) ; edebug-save-restriction
1406
1407 ;; Restore windows, buffer, point, and mark.
1408 (if edebug-save-windows
1409 ;; Restore windows before continuing.
1410 (edebug-set-window-configuration edebug-outside-windows))
1411 (set-buffer edebug-outside-buffer)
1412 (goto-char edebug-outside-point)
1413 (if (mark-marker)
1414 (set-marker (mark-marker) edebug-outside-mark))
1415 ;; The following is not sufficient, and sometimes annoying.
1416 ;; (if (memq edebug-mode '(go Go-nonstop))
1417 ;; (edebug-sit-for 0))
1418 ))
1419
1420
1421(defvar edebug-depth 0
1422 "Number of recursive edits started by edebug.
1423Should be 0 at the top level.")
1424
1425(defvar edebug-recursion-depth 0
1426 "Value of recursion-depth when edebug was called.")
1427
1428
1429(defun edebug-recursive-edit ()
1430 "Start up a recursive edit inside of edebug."
1431 ;; The current buffer is the edebug-buffer, which is put into edebug-mode.
1432 (let ((edebug-buffer-read-only buffer-read-only)
1433 ;; match-data must be done in the outside buffer
1434 (edebug-outside-match-data
1435 (save-excursion
1436 (set-buffer edebug-outside-buffer)
1437 (match-data)))
1438
1439 (edebug-depth (1+ edebug-depth))
1440 (edebug-recursion-depth (recursion-depth))
1441 edebug-entered ; bind locally to nil
1442 edebug-backtrace-buffer ; each recursive edit gets its own
1443 ;; The window configuration may be saved and restored
1444 ;; during a recursive-edit
1445 edebug-inside-windows
1446
1447 (edebug-outside-map (current-local-map))
1448 (edebug-outside-standard-output standard-output)
1449 (edebug-outside-standard-input standard-input)
1450
1451 (edebug-outside-last-command-char last-command-char)
1452 (edebug-outside-last-command last-command)
1453 (edebug-outside-this-command this-command)
1454 (edebug-outside-last-input-char last-input-char)
1455;; (edebug-outside-unread-command-char unread-command-char)
1456
1457 ;; Declare the following local variables to protect global values.
1458 ;; We could set these to the values for previous edebug call.
1459 ;; But instead make it local, but use global value.
1460 (last-command-char last-command-char)
1461 (last-command last-command)
1462 (this-command this-command)
1463 (last-input-char last-input-char)
1464 ;; Assume no edebug command sets unread-command-char.
1465;; (unread-command-char -1)
1466
1467 (debug-on-error debug-on-error)
1468
1469 ;; others??
1470 )
1471
1472 (if (and (eq edebug-mode 'go)
1473 (not (memq edebug-arg-mode '(exit error))))
1474 (message "Break"))
1475 (edebug-mode)
1476 (if (boundp 'edebug-outside-debug-on-error)
1477 (setq debug-on-error edebug-outside-debug-on-error))
1478
1479 (setq buffer-read-only t)
1480 (unwind-protect
1481 (recursive-edit) ; <<<<<<<<<< Recursive edit
1482
1483 ;; Do the following, even if quit occurs.
1484 (if edebug-backtrace-buffer
1485 (kill-buffer edebug-backtrace-buffer))
1486 ;; Could be an option to keep eval display up.
1487 (if edebug-eval-buffer (kill-buffer edebug-eval-buffer))
1488
1489 ;; Remember selected-window after recursive-edit.
1490 (setq edebug-inside-window (selected-window))
1491
1492 (store-match-data edebug-outside-match-data)
1493
1494 ;; Recursive edit may have changed buffers,
1495 ;; so set it back before exiting let.
1496 (if (buffer-name edebug-buffer) ; if it still exists
1497 (progn
1498 (set-buffer edebug-buffer)
1499 (if (memq edebug-mode '(go Go-nonstop))
1500 (edebug-overlay-arrow))
1501 (setq buffer-read-only edebug-buffer-read-only)
1502 (use-local-map edebug-outside-map)
1503 ;; Remember current window-start for next visit.
1504 (select-window edebug-window)
1505 (if (eq edebug-buffer (window-buffer edebug-window))
1506 (setq edebug-window-start (window-start)))
1507 (select-window edebug-inside-window)
1508 ))
1509 )))
1510
1511
1512;;--------------------------
1513;; Display related functions
1514
1515(defun edebug-adjust-window (old-start)
1516 "Adjust window to fit as much as possible following point.
1517The display should prefer to start at OLD-START if point is not visible.
1518Return the new window-start."
1519 (if (not (pos-visible-in-window-p))
1520 (progn
1521 (set-window-start (selected-window) old-start)
1522 (if (not (pos-visible-in-window-p))
1523 (let ((start (window-start))
1524 (pnt (point)))
1525 (set-window-start
1526 (selected-window)
1527 (save-excursion
1528 (forward-line
1529 (if (< pnt start) -1 ; one line before
1530 (- (/ (window-height) 2)) ; center the line
1531 ))
1532 (beginning-of-line)
1533 (point)))))))
1534 (window-start))
1535
1536
1537(defconst edebug-arrow-alist
1538 '((Continue-fast . ">")
1539 (Trace-fast . ">")
1540 (continue . ">")
1541 (trace . "->")
1542 (step . "=>")
1543 (go . "<>")
1544 (Go-nonstop . "..") ; not used
1545 )
1546 "Association list of arrows for each edebug mode.
1547If you come up with arrows that make more sense, let me know.")
1548
1549(defun edebug-overlay-arrow ()
1550 "Set up the overlay arrow at beginning-of-line in current buffer.
1551The arrow string is derived from edebug-arrow-alist and edebug-mode."
1552 (let* ((pos))
1553 (save-excursion
1554 (beginning-of-line)
1555 (setq pos (point)))
1556 (setq overlay-arrow-string
1557 (cdr (assq edebug-mode edebug-arrow-alist)))
1558 (setq overlay-arrow-position (make-marker))
1559 (set-marker overlay-arrow-position pos (current-buffer))))
1560
1561
1562(put 'edebug-outside-excursion 'edebug-form-hook
1563 '(&rest form))
1564
1565(defmacro edebug-outside-excursion (&rest body)
1566 "Evaluate an expression list in the outside context.
1567Return the result of the last expression."
1568 (` (save-excursion ; of current-buffer
1569 (if edebug-save-windows
1570 (progn
1571 ;; After excursion, we will
1572 ;; restore to current window configuration.
1573 (setq edebug-inside-windows
1574 (edebug-current-window-configuration))
1575 ;; Restore outside windows.
1576 (edebug-set-window-configuration edebug-outside-windows)))
1577
1578 (set-buffer edebug-buffer)
1579 ;; Restore outside context.
1580 (let ((edebug-inside-map (current-local-map))
1581 (last-command-char edebug-outside-last-command-char)
1582 (last-command edebug-outside-last-command)
1583 (this-command edebug-outside-this-command)
1584;; (unread-command-char edebug-outside-unread-command-char)
1585 (last-input-char edebug-outside-last-input-char)
1586 (overlay-arrow-position edebug-outside-o-a-p)
1587 (overlay-arrow-string edebug-outside-o-a-s)
1588 (cursor-in-echo-area edebug-outside-c-i-e-a)
1589 (standard-output edebug-outside-standard-output)
1590 (standard-input edebug-outside-standard-input)
1591 (executing-macro edebug-outside-executing-macro)
1592 )
1593 (unwind-protect
1594 (save-restriction
1595 (narrow-to-region edebug-outside-point-min
1596 edebug-outside-point-max)
1597 (save-excursion ; of edebug-buffer
1598 (if edebug-save-point
1599 (progn
1600 (goto-char edebug-outside-edebug-point)
1601 (if (mark-marker)
1602 (set-marker (mark-marker)
1603 edebug-outside-edebug-mark))
1604 ))
1605 (use-local-map edebug-outside-map)
1606 (store-match-data edebug-outside-match-data)
1607 (select-window edebug-outside-window)
1608 (set-buffer edebug-outside-buffer)
1609 (goto-char edebug-outside-point)
1610 (,@ body)
1611 ) ; save-excursion
1612 ) ; save-restriction
1613 ;; Back to edebug-buffer. Restore rest of inside context.
1614 (use-local-map edebug-inside-map)
1615 (if edebug-save-windows
1616 ;; Restore inside windows.
1617 (edebug-set-window-configuration edebug-inside-windows))
1618 )) ; let
1619 )))
1620
1621
1622(defun edebug-toggle-save-windows ()
1623 "Toggle the edebug-save-windows variable.
1624Each time you toggle it, the inside and outside window configurations
1625become the same as the current configuration."
1626 (interactive)
1627 (if (setq edebug-save-windows (not edebug-save-windows))
1628 (setq edebug-inside-windows
1629 (setq edebug-outside-windows
1630 (edebug-current-window-configuration))))
1631 (message "Window saving is %s."
1632 (if edebug-save-windows "on" "off")))
1633
1634
1635(defun edebug-where ()
1636 "Show the debug windows and where we stopped in the program."
1637 (interactive)
1638 (if (not edebug-active)
1639 (error "edebug is not active."))
1640 (edebug-pop-to-buffer edebug-buffer)
1641 (goto-char edebug-point) ; from edebug
1642 )
1643
1644(defun edebug-view-outside ()
1645 "Change to the outside window configuration."
1646 (interactive)
1647 (if (not edebug-active)
1648 (error "edebug is not active."))
1649 (setq edebug-inside-windows (edebug-current-window-configuration))
1650 (edebug-set-window-configuration edebug-outside-windows)
1651 (goto-char edebug-outside-point)
1652 (message "Window configuration outside of edebug. Return with %s"
1653 (substitute-command-keys "\\<global-map>\\[edebug-where]")))
1654
1655
1656(defun edebug-bounce-point ()
1657 "Bounce the point in the outside current buffer."
1658 (interactive)
1659 (if (not edebug-active)
1660 (error "edebug is not active."))
1661 (save-excursion
1662 ;; If the buffer's currently displayed, avoid the set-window-configuration.
1663 (save-window-excursion
1664 (edebug-pop-to-buffer edebug-outside-buffer)
1665 ;; (edebug-sit-for 1) ; this shouldnt be necessary
1666 (goto-char edebug-outside-point)
1667 ;; (message "current buffer: %s" (current-buffer))
1668 (edebug-sit-for 1)
1669 (edebug-pop-to-buffer edebug-buffer))))
1670
1671
1672
1673;;--------------------------
1674;; epoch related things
1675
1676(defvar edebug-epoch-running (and (boundp 'epoch::version) epoch::version)
1677 "non-nil if epoch is running.
1678Windows are handled a little differently under epoch.")
1679
1680
1681(defun edebug-current-window-configuration ()
1682 "Return the current window or screen configuration."
1683 (if edebug-epoch-running
1684 (edebug-current-screen-configuration)
1685 (current-window-configuration)))
1686
1687
1688(defun edebug-set-window-configuration (conf)
1689 "Set the window or screen configuration to CONF."
1690 (if edebug-epoch-running
1691 (edebug-set-screen-configuration conf)
1692 (set-window-configuration conf)))
1693
1694
1695(defun edebug-get-buffer-window (buffer)
1696 (if edebug-epoch-running
1697 (epoch::get-buffer-window buffer)
1698 (get-buffer-window buffer)))
1699
1700
1701(defun edebug-pop-to-buffer (buffer)
1702 "Like pop-to-buffer, but select a screen that buffer was shown in."
1703 (let ((edebug-window (edebug-get-buffer-window buffer)))
1704 (if edebug-window
1705 (select-window edebug-window)
1706 ;; It is not currently displayed, so find some place to display it.
1707 (if edebug-epoch-running
1708 ;; Select a screen that the buffer has been displayed in before
1709 ;; or the current screen otherwise.
1710 (select-screen
1711 ;; allowed-screens in epoch 3.2, was called screens before that
1712 (or (car (symbol-buffer-value 'allowed-screens buffer))
1713 (epoch::current-screen))))
1714 (if (one-window-p)
1715 (split-window))
1716 (select-window (next-window))
1717 (set-window-buffer (selected-window) buffer)
1718 (set-window-hscroll (selected-window) 0)
1719 ))
1720 ;; Selecting the window does not set the buffer.
1721 (set-buffer buffer)
1722 )
1723
1724
1725(defun edebug-current-screen-configuration ()
1726 "Return an object recording the current configuration of Epoch screen-list.
1727The object is a list of pairs of the form (SCREEN . CONFIGURATION)
1728where SCREEN has window-configuration CONFIGURATION. The current
1729screen is the head of the list."
1730 (let ((screen-list (epoch::screen-list 'unmapped))
1731 (current-screen (epoch::get-screen))
1732 (current-buffer (current-buffer))
1733 )
1734 ;; put current screen first
1735 (setq screen-list (cons current-screen (delq current-screen screen-list)))
1736 (prog1
1737 (mapcar (function
1738 (lambda (screen)
1739 (cons screen
1740 (progn
1741 (epoch::select-screen screen)
1742 (current-window-configuration)))))
1743 screen-list)
1744 (epoch::select-screen current-screen)
1745 (set-buffer current-buffer)
1746 )))
1747
1748(defun edebug-set-screen-configuration (sc)
1749 "Set the window-configuration for all the screens in SC.
1750Set the current screen to be the head of SC."
1751 (mapcar (function
1752 (lambda (screen-conf)
1753 (if (epoch::screen-p (car screen-conf)) ; still exist?
1754 (progn
1755 (epoch::select-screen (car screen-conf))
1756 (set-window-configuration (cdr screen-conf))))))
1757 sc)
1758 (if (epoch::screen-p (car (car sc)))
1759 (epoch::select-screen (car (car sc))))
1760 )
1761
1762
1763(defun edebug-sit-for (arg)
1764 (if edebug-epoch-running
1765 (epoch::dispatch-events))
1766 (sit-for arg)
1767)
1768
1769(defun edebug-input-pending-p ()
1770 (if edebug-epoch-running
1771 (epoch::dispatch-events))
1772 (input-pending-p)
1773)
1774
1775
1776
1777;;--------------------------
1778;; breakpoint related functions
1779
1780(defun edebug-find-stop-point ()
1781 "Return (function . index) of the nearest edebug stop point."
1782 (let* ((def-name (edebug-which-function))
1783 (edebug-data
1784 (or (get def-name 'edebug)
1785 (error
1786 "%s must first be evaluated with edebug-defun." def-name)))
1787 ;; pull out parts of edebug-data.
1788 (edebug-func-mark (car edebug-data))
1789 (edebug-breakpoints (car (cdr edebug-data)))
1790
1791 (offset-vector (car (cdr (cdr edebug-data))))
1792 (offset (- (save-excursion
1793 (if (looking-at "[ \t]")
1794 ;; skip backwards until non-whitespace, or bol
1795 (skip-chars-backward " \t"))
1796 (point))
1797 edebug-func-mark))
1798 len i)
1799 ;; the offsets are in order so we can do a linear search
1800 (setq len (length offset-vector))
1801 (setq i 0)
1802 (while (and (< i len) (> offset (aref offset-vector i)))
1803 (setq i (1+ i)))
1804 (if (and (< i len)
1805 (<= offset (aref offset-vector i)))
1806 ;; return the relevant info
1807 (cons def-name i)
1808 (message "Point is not on an expression in %s."
1809 def-name)
1810 )))
1811
1812
1813(defun edebug-next-breakpoint ()
1814 "Move point to the next breakpoint, or first if none past point."
1815 (interactive)
1816 (let ((edebug-stop-point (edebug-find-stop-point)))
1817 (if edebug-stop-point
1818 (let* ((def-name (car edebug-stop-point))
1819 (index (cdr edebug-stop-point))
1820 (edebug-data (get def-name 'edebug))
1821
1822 ;; pull out parts of edebug-data
1823 (edebug-func-mark (car edebug-data))
1824 (edebug-breakpoints (car (cdr edebug-data)))
1825 (offset-vector (car (cdr (cdr edebug-data))))
1826 breakpoint)
1827 (if (not edebug-breakpoints)
1828 (message "No breakpoints in this function.")
1829 (let ((breaks edebug-breakpoints))
1830 (while (and breaks
1831 (<= (car (car breaks)) index))
1832 (setq breaks (cdr breaks)))
1833 (setq breakpoint
1834 (if breaks
1835 (car breaks)
1836 ;; goto the first breakpoint
1837 (car edebug-breakpoints)))
1838 (goto-char (+ edebug-func-mark
1839 (aref offset-vector (car breakpoint))))
1840
1841 (message (concat (if (car (cdr (cdr breakpoint)))
1842 "Temporary " "")
1843 (if (car (cdr breakpoint))
1844 (format "Condition: %s"
1845 (prin1-to-string
1846 (car (cdr breakpoint))))
1847 "")))
1848 ))))))
1849
1850
1851(defun edebug-modify-breakpoint (flag &optional condition temporary)
1852 "Modify the breakpoint for the form at point or after it according
1853to FLAG: set if t, clear if nil. Then move to that point.
1854If CONDITION or TEMPORARY are non-nil, add those attributes to
1855the breakpoint. "
1856 (let ((edebug-stop-point (edebug-find-stop-point)))
1857 (if edebug-stop-point
1858 (let* ((def-name (car edebug-stop-point))
1859 (index (cdr edebug-stop-point))
1860 (edebug-data (get def-name 'edebug))
1861
1862 ;; pull out parts of edebug-data
1863 (edebug-func-mark (car edebug-data))
1864 (edebug-breakpoints (car (cdr edebug-data)))
1865 (offset-vector (car (cdr (cdr edebug-data))))
1866 present)
1867 ;; delete it either way
1868 (setq present (assq index edebug-breakpoints))
1869 (setq edebug-breakpoints (delq present edebug-breakpoints))
1870 (if flag
1871 (progn
1872 ;; add it to the list and resort
1873 (setq edebug-breakpoints
1874 (edebug-sort-alist
1875 (cons
1876 (list index condition temporary)
1877 edebug-breakpoints) '<))
1878 (message "Breakpoint set in %s." def-name))
1879 (if present
1880 (message "Breakpoint unset in %s." def-name)
1881 (message "No breakpoint here.")))
1882
1883 (setcdr edebug-data
1884 (cons edebug-breakpoints (cdr (cdr edebug-data))))
1885 (goto-char (+ edebug-func-mark (aref offset-vector index)))
1886 ))))
1887
1888(defun edebug-set-breakpoint (arg)
1889 "Set the breakpoint of nearest sexp.
1890With prefix argument, make it a temporary breakpoint."
1891 (interactive "P")
1892 (edebug-modify-breakpoint t nil arg))
1893
1894(defun edebug-unset-breakpoint ()
1895 "Clear the breakpoint of nearest sexp."
1896 (interactive)
1897 (edebug-modify-breakpoint nil))
1898
1899(defun edebug-set-conditional-breakpoint (arg condition)
1900 "Set a conditional breakpoint at nearest sexp.
1901The condition is evaluated in the outside context.
1902With prefix argument, make it a temporary breakpoint."
1903 (interactive "P\nxCondition: ")
1904 (edebug-modify-breakpoint t condition arg))
1905
1906
1907;;--------------------------
1908;; Mode switching functions
1909
1910(defun edebug-set-mode (mode shortmsg msg)
1911 "Set the edebug mode to MODE.
1912Display SHORTMSG, or MSG if not within edebug."
1913 (interactive)
1914 (setq edebug-mode mode)
1915 (if (< 0 edebug-depth)
1916 (if (eq (current-buffer) edebug-buffer)
1917 (progn
1918 (message shortmsg)
1919 (exit-recursive-edit)))
1920 (message msg)))
1921
1922
1923(defun edebug-step-through ()
1924 "Proceed to next debug step."
1925 (interactive)
1926 (edebug-set-mode 'step "" "edebug will stop before next eval."))
1927
1928(defun edebug-go (arg)
1929 "Go, evaluating until break.
1930With ARG set temporary break at stop point and go."
1931 (interactive "P")
1932 (if arg
1933 (edebug-set-breakpoint t))
1934 (edebug-set-mode 'go "Go..." "edebug will go until break."))
1935
1936(defun edebug-Go-nonstop ()
1937 "Go, evaluating without debugging."
1938 (interactive)
1939 (edebug-set-mode 'Go-nonstop "Go-Nonstop..."
1940 "edebug will not stop at breaks."))
1941
1942(defun edebug-forward-sexp (arg)
1943 "Proceed from the current point to the end of the ARGth sexp ahead.
1944If there are not ARG sexps ahead, then do edebug-step-out."
1945 (interactive "p")
1946 (condition-case err
1947 (let ((parse-sexp-ignore-comments t))
1948 ;; Call forward-sexp repeatedly until done or failure.
1949 (forward-sexp arg)
1950 (edebug-go t))
1951 (error
1952 (edebug-step-out)
1953 )))
1954
1955(defun edebug-step-out ()
1956 "Proceed from the current point to the end of the containing sexp.
1957If there is no containing sexp that is not the top level defun,
1958go to the end of the last sexp, or if that is the same point, then step."
1959 (interactive)
1960 (condition-case err
1961 (let ((parse-sexp-ignore-comments t))
1962 (up-list 1)
1963 (save-excursion
1964 ;; Is there still a containing expression?
1965 (up-list 1))
1966 (edebug-go t))
1967 (error
1968 ;; At top level - 1, so first check if there are more sexps at this level.
1969 (let ((start-point (point)))
1970;; (up-list 1)
1971 (down-list -1)
1972 (if (= (point) start-point)
1973 (edebug-step-through) ; No more at this level, so step.
1974 (edebug-go t)
1975 )))))
1976
1977
1978(defun edebug-goto-here ()
1979 "Proceed to this stop point."
1980 (interactive)
1981 (edebug-go t)
1982 )
1983
1984(defun edebug-trace ()
1985 "Begin trace mode."
1986 (interactive)
1987 (edebug-set-mode 'trace "Tracing..." "edebug will trace with pause."))
1988
1989(defun edebug-Trace-fast ()
1990 "Trace with no wait at each step."
1991 (interactive)
1992 (edebug-set-mode 'Trace-fast
1993 "Trace fast..." "edebug will trace without pause."))
1994
1995(defun edebug-continue ()
1996 "Begin continue mode."
1997 (interactive)
1998 (edebug-set-mode 'continue "Continue..."
1999 "edebug will pause at breakpoints."))
2000
2001(defun edebug-Continue-fast ()
2002 "Trace with no wait at each step."
2003 (interactive)
2004 (edebug-set-mode 'Continue-fast "Continue fast..."
2005 "edebug will stop and go at breakpoints."))
2006
2007
2008(defun edebug-step-in ()
2009 "Step into the function about to be called.
2010Do this before the arguments are evaluated since otherwise it will be
2011too late. One side effect of using edebug-step-in is that the next
2012time the function is called, edebug will be called there as well."
2013 (interactive)
2014 (if (not (eq 'enter edebug-arg-mode))
2015 (error "You must be in front of a function or macro call."))
2016 (let* ((func (car edebug-exp))
2017 (func-marker (get func 'edebug)))
2018 (cond
2019 ((markerp func-marker)
2020 (save-excursion
2021 (set-buffer (marker-buffer func-marker))
2022 (goto-char func-marker)
2023 (edebug-defun)))
2024 ((listp func-marker)
2025 ;; its already been evaluated for edebug
2026 nil)
2027 (t (error "You must first evaluate %s in a buffer." func))))
2028 (exit-recursive-edit))
2029
2030
2031;;(defun edebug-exit-out ()
2032;; "Go until the current function exits."
2033;; (interactive)
2034;; (edebug-set-mode 'exiting "Exit..."))
2035
2036
2037(defun edebug-stop ()
2038 "Useful for exiting from trace loop."
2039 (interactive)
2040 (message "Stop"))
2041
2042
2043;;; The following initial mode setting definitions are not used yet.
2044
2045(defconst edebug-initial-mode-alist
2046 '((edebug-Continue-fast . Continue-fast)
2047 (edebug-Trace-fast . Trace-fast)
2048 (edebug-continue . continue)
2049 (edebug-trace . trace)
2050 (edebug-go . go)
2051 (edebug-step-through . step)
2052 (edebug-Go-nonstop . Go-nonstop)
2053 )
2054 "Association list between commands and the modes they set.")
2055
2056
2057(defun edebug-set-initial-mode ()
2058 "Ask for the initial mode of the enclosing function.
2059The mode is requested via the key that would be used to set the mode in
2060edebug-mode."
2061 (interactive)
2062 (let* ((this-function (edebug-which-function))
2063 (keymap (if (eq edebug-mode-map (current-local-map))
2064 edebug-mode-map))
2065 (old-mode (or (get this-function 'edebug-initial-mode)
2066 edebug-initial-mode))
2067 (key (read-key-sequence
2068 (format
2069 "Change initial edebug mode for %s from %s (%s) to (enter key): "
2070 this-function
2071 old-mode
2072 (where-is-internal
2073 (car (rassq old-mode edebug-initial-mode-alist))
2074 keymap 'firstonly
2075 ))))
2076 (mode (cdr (assq (key-binding key) edebug-initial-mode-alist)))
2077 )
2078 (if (and mode
2079 (or (get this-function 'edebug-initial-mode)
2080 (not (eq mode edebug-initial-mode))))
2081 (progn
2082 (put this-function 'edebug-initial-mode mode)
2083 (message "Initial mode for %s is now: %s"
2084 this-function mode))
2085 (error "Key must map to one of the mode changing commands.")
2086 )))
2087
2088
2089
2090;;--------------------------
2091;; Evaluation of expressions
2092
2093(defvar edebug-previous-result nil
2094 "Last result returned from an expression.")
2095
2096(defun edebug-previous-result ()
2097 "Return the previous result."
2098 (interactive)
2099 (let ((print-escape-newlines t)
2100 (print-length 20))
2101 (message "Result: %s" (prin1-to-string edebug-previous-result))))
2102
2103
2104(defun edebug-eval (expr)
2105 "Evaluate EXPR in the outside environment."
2106 (if (not edebug-active)
2107 (error "edebug is not active."))
2108 (edebug-outside-excursion
2109 (eval expr)))
2110
2111(defun edebug-eval-expression (expr)
2112 "Prompt and evaluate an expression in the outside environment.
2113Print result in minibuffer."
2114 (interactive "xEval: ")
2115 (prin1 (edebug-eval expr)))
2116
2117(defun edebug-eval-last-sexp ()
2118 "Evaluate sexp before point in the outside environment;
2119print value in minibuffer."
2120 (interactive)
2121 (prin1 (edebug-eval (edebug-last-sexp))))
2122
2123(defun edebug-eval-print-last-sexp ()
2124 "Evaluate sexp before point in the outside environment;
2125print value into current buffer."
2126 (interactive)
2127 (let ((standard-output (current-buffer)))
2128 (print
2129 (condition-case err
2130 (edebug-eval (edebug-last-sexp))
2131 (error (format "%s: %s"
2132 (get (car err) 'error-message)
2133 (car (cdr err))))))))
2134
2135;;;---------------------------------
2136;;; edebug minor mode initialization
2137
2138(defvar edebug-mode 'step
2139 "Current edebug mode set by user.")
2140
2141(defvar edebug-mode-map nil)
2142(if edebug-mode-map
2143 nil
2144 (progn
2145 (setq edebug-mode-map (copy-keymap emacs-lisp-mode-map))
2146 ;; control
2147 (define-key edebug-mode-map " " 'edebug-step-through)
2148 (define-key edebug-mode-map "g" 'edebug-go)
2149 (define-key edebug-mode-map "G" 'edebug-Go-nonstop)
2150 (define-key edebug-mode-map "t" 'edebug-trace)
2151 (define-key edebug-mode-map "T" 'edebug-Trace-fast)
2152 (define-key edebug-mode-map "c" 'edebug-continue)
2153 (define-key edebug-mode-map "C" 'edebug-Continue-fast)
2154
2155 (define-key edebug-mode-map "f" 'edebug-forward-sexp)
2156 (define-key edebug-mode-map "h" 'edebug-goto-here)
2157
2158 (define-key edebug-mode-map "r" 'edebug-previous-result)
2159
2160 (define-key edebug-mode-map "i" 'edebug-step-in)
2161 (define-key edebug-mode-map "o" 'edebug-step-out)
2162
2163;; (define-key edebug-mode-map "m" 'edebug-set-initial-mode)
2164
2165 (define-key edebug-mode-map "q" 'top-level)
2166 (define-key edebug-mode-map "a" 'abort-recursive-edit)
2167 (define-key edebug-mode-map "S" 'edebug-stop)
2168
2169 ;; breakpoints
2170 (define-key edebug-mode-map "b" 'edebug-set-breakpoint)
2171 (define-key edebug-mode-map "u" 'edebug-unset-breakpoint)
2172 (define-key edebug-mode-map "B" 'edebug-next-breakpoint)
2173 (define-key edebug-mode-map "x" 'edebug-set-conditional-breakpoint)
2174
2175 ;; evaluation
2176 (define-key edebug-mode-map "e" 'edebug-eval-expression)
2177 (define-key edebug-mode-map "\C-x\C-e" 'edebug-eval-last-sexp)
2178 (define-key edebug-mode-map "E" 'edebug-visit-eval-list)
2179
2180 ;; views
2181 (define-key edebug-mode-map "w" 'edebug-where)
2182 (define-key edebug-mode-map "v" 'edebug-view-outside)
2183 (define-key edebug-mode-map "p" 'edebug-bounce-point)
2184 (define-key edebug-mode-map "W" 'edebug-toggle-save-windows)
2185
2186 ;; misc
2187 (define-key edebug-mode-map "?" 'edebug-help)
2188 (define-key edebug-mode-map "d" 'edebug-backtrace)
2189
2190 (define-key edebug-mode-map "-" 'negative-argument)
2191 ))
2192
2193
2194(defvar global-edebug-prefix "\^XX"
2195 "Prefix key for global edebug commands, available from any buffer.")
2196
2197(defvar global-edebug-map nil
2198 "Global map of edebug commands, available from any buffer.")
2199
2200(if global-edebug-map
2201 nil
2202 (setq global-edebug-map (make-sparse-keymap))
2203
2204 (global-unset-key global-edebug-prefix)
2205 (global-set-key global-edebug-prefix global-edebug-map)
2206
2207;; (define-key global-edebug-map "X" 'edebug-step-through)
2208 (define-key global-edebug-map " " 'edebug-step-through)
2209 (define-key global-edebug-map "g" 'edebug-go)
2210 (define-key global-edebug-map "G" 'edebug-Go-nonstop)
2211 (define-key global-edebug-map "t" 'edebug-trace)
2212 (define-key global-edebug-map "T" 'edebug-Trace-fast)
2213 (define-key global-edebug-map "c" 'edebug-continue)
2214 (define-key global-edebug-map "C" 'edebug-Continue-fast)
2215
2216;; (define-key global-edebug-map "m" 'edebug-set-initial-mode)
2217 (define-key global-edebug-map "b" 'edebug-set-breakpoint)
2218 (define-key global-edebug-map "x" 'edebug-set-conditional-breakpoint)
2219 (define-key global-edebug-map "u" 'edebug-unset-breakpoint)
2220 (define-key global-edebug-map "w" 'edebug-where)
2221 (define-key global-edebug-map "q" 'top-level)
2222 )
2223
2224
2225(defun edebug-help ()
2226 (interactive)
2227 (describe-function 'edebug-mode))
2228
2229
2230(defun edebug-mode ()
2231 "Mode for elisp buffers while in edebug. Under construction.
2232
2233There are both buffer local and global key bindings to several
2234functions. E.g. edebug-step-through is bound to
2235\\[edebug-step-through] in the debug buffer and
2236\\<global-map>\\[edebug-step-through] in any buffer.
2237
2238edebug buffer commands:
2239\\{edebug-mode-map}
2240
2241Global commands prefixed by global-edbug-prefix:
2242\\{global-edebug-map}
2243
2244Options:
2245edebug-all-defuns
2246edebug-eval-macro-args
2247edebug-stop-before-symbols
2248edebug-save-windows
2249edebug-save-point
2250edebug-save-buffer-points
2251edebug-initial-mode
2252edebug-trace
2253"
2254 (use-local-map edebug-mode-map))
2255
2256
2257
2258;;===============================================
2259;; edebug eval list mode
2260;; A list of expressions and their evaluations is displayed
2261;; in edebug-eval-buffer
2262
2263(defvar edebug-eval-list nil
2264 "List of expressions to evaluate.")
2265
2266;;(defvar edebug-eval-buffer "*edebug*"
2267;; "*Declared globally so edebug-eval-display can be called independent
2268;;of edebug (not implemented yet).")
2269
2270
2271(defun edebug-eval-result-list ()
2272 "Return a list of evaluations of edebug-eval-list"
2273 ;; Assumes in outside environment.
2274 (mapcar (function
2275 (lambda (expr)
2276 (condition-case err
2277 (eval expr)
2278 (error (format "%s: %s"
2279 (get (car err) 'error-message)
2280 (car (cdr err))))
2281 )))
2282 edebug-eval-list))
2283
2284(defun edebug-eval-display-list (edebug-eval-result-list)
2285 ;; Assumes edebug-eval-buffer exists.
2286 (let ((edebug-eval-list-temp edebug-eval-list)
2287 (standard-output edebug-eval-buffer)
2288 (edebug-display-line
2289 (format ";%s\n" (make-string (- (window-width) 2) ?-))))
2290 (edebug-pop-to-buffer edebug-eval-buffer)
2291 (erase-buffer)
2292 (while edebug-eval-list-temp
2293 (prin1 (car edebug-eval-list-temp)) (terpri)
2294 (prin1 (car edebug-eval-result-list)) (terpri)
2295 (princ edebug-display-line)
2296 (setq edebug-eval-list-temp (cdr edebug-eval-list-temp))
2297 (setq edebug-eval-result-list (cdr edebug-eval-result-list)))
2298 ))
2299
2300(defun edebug-create-eval-buffer ()
2301 (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer)))
2302 (progn
2303 (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*")))
2304 (edebug-eval-mode))))
2305
2306;; Should generalize this to be callable outside of edebug
2307;; with calls in user functions, e.g. (edebug-eval-display)
2308
2309(defun edebug-eval-display (edebug-eval-result-list)
2310 "Display expressions and evaluations in EVAL-LIST.
2311It modifies the context by popping up the eval display."
2312 (if edebug-eval-result-list
2313 (progn
2314 (edebug-create-eval-buffer)
2315 (edebug-pop-to-buffer edebug-eval-buffer)
2316 (edebug-eval-display-list edebug-eval-result-list)
2317 )))
2318
2319(defun edebug-eval-redisplay ()
2320 "Redisplay eval list in outside environment.
2321May only be called from within edebug-recursive-edit."
2322 (edebug-create-eval-buffer)
2323 (edebug-pop-to-buffer edebug-eval-buffer)
2324 (edebug-outside-excursion
2325 (edebug-eval-display-list (edebug-eval-result-list))
2326 ))
2327
2328(defun edebug-visit-eval-list ()
2329 (interactive)
2330 (edebug-eval-redisplay)
2331 (edebug-pop-to-buffer edebug-eval-buffer))
2332
2333
2334(defun edebug-update-eval-list ()
2335 "Replace the evaluation list with the sexps now in the eval buffer."
2336 (interactive)
2337 (let ((starting-point (point))
2338 new-list)
2339 (goto-char (point-min))
2340 ;; get the first expression
2341 (edebug-skip-whitespace)
2342 (if (not (eobp))
2343 (progn
2344 (forward-sexp 1)
2345 (setq new-list (cons (edebug-last-sexp) new-list))))
2346
2347 (while (re-search-forward "^;" nil t)
2348 (forward-line 1)
2349 (skip-chars-forward " \t\n\r")
2350 (if (and (/= ?\; (following-char))
2351 (not (eobp)))
2352 (progn
2353 (forward-sexp 1)
2354 (setq new-list (cons (edebug-last-sexp) new-list)))))
2355
2356 (setq edebug-eval-list (nreverse new-list))
2357 (edebug-eval-redisplay)
2358 (goto-char starting-point)))
2359
2360
2361(defun edebug-delete-eval-item ()
2362 "Delete the item under point and redisplay."
2363 ;; could add arg to do repeatedly
2364 (interactive)
2365 (if (re-search-backward "^;" nil 'nofail)
2366 (forward-line 1))
2367 (delete-region
2368 (point) (progn (re-search-forward "^;" nil 'nofail)
2369 (beginning-of-line)
2370 (point)))
2371 (edebug-update-eval-list))
2372
2373
2374
2375(defvar edebug-eval-mode-map nil
2376 "Keymap for edebug-eval-mode. Superset of lisp-interaction-mode.")
2377
2378(if edebug-eval-mode-map
2379 nil
2380 (setq edebug-eval-mode-map (copy-keymap lisp-interaction-mode-map))
2381
2382 (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where)
2383 (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item)
2384 (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list)
2385 (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp)
2386 (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp)
2387 )
2388
2389
2390(defun edebug-eval-mode ()
2391 "Mode for data display buffer while in edebug. Under construction.
2392... ignore the following...
2393There are both buffer local and global key bindings to several
2394functions. E.g. edebug-step-through is bound to
2395\\[edebug-step-through] in the debug buffer and
2396\\<global-map>\\[edebug-step-through] in any buffer.
2397
2398Eval list buffer commands:
2399\\{edebug-eval-mode-map}
2400
2401Global commands prefixed by global-edbug-prefix:
2402\\{global-edebug-map}
2403"
2404 (lisp-interaction-mode)
2405 (setq major-mode 'edebug-eval-mode)
2406 (setq mode-name "Edebug-Eval")
2407 (use-local-map edebug-eval-mode-map))
2408
2409
2410;;========================================
2411;; Interface with standard debugger.
2412
2413(setq debugger 'edebug-debug)
2414;; (setq debugger 'debug) ; use the default
2415
2416;; Note that debug and its utilities must be byte-compiled to work, since
2417;; they depend on the backtrace looking a certain way.
2418
2419(defun edebug-debug (&rest debugger-args)
2420 "Replacement for debug.
2421If an error or quit occurred and we are running an edebugged function,
2422show where we last were. Otherwise call debug normally."
2423 (if (and edebug-backtrace ; anything active?
2424 (eq (recursion-depth) edebug-recursion-depth)
2425 )
2426
2427 ;; Where were we before the error occurred?
2428 (let ((edebug-offset-index (car edebug-offset-indices))
2429 (edebug-arg-mode (car debugger-args))
2430 (edebug-exp (car (cdr debugger-args)))
2431 edebug-break-data
2432 edebug-break
2433 (edebug-outside-debug-on-eror debug-on-error)
2434 (debug-on-error nil))
2435 (edebug-display)
2436 )
2437
2438 ;; Otherwise call debug normally.
2439 ;; Still need to remove extraneous edebug calls from stack.
2440 (apply 'debug debugger-args)
2441 ))
2442
2443
2444(defun edebug-backtrace ()
2445 "Display a non-working backtrace. Better than nothing..."
2446 (interactive)
2447 (let ((old-buf (current-buffer)))
2448 (if (not edebug-backtrace-buffer)
2449 (setq edebug-backtrace-buffer
2450 (let ((default-major-mode 'fundamental-mode))
2451 (generate-new-buffer "*Backtrace*"))))
2452 (edebug-pop-to-buffer edebug-backtrace-buffer)
2453 (erase-buffer)
2454 (let ((standard-output (current-buffer))
2455 (print-escape-newlines t)
2456 (print-length 50)
2457 last-ok-point
2458 )
2459 (setq truncate-lines t)
2460 (backtrace)
2461
2462 ;; Clean up the backtrace.
2463 (goto-char (point-min))
2464 (delete-region
2465 (point)
2466 (progn
2467 ;; Everything up to the first edebug is internal.
2468 (re-search-forward "^ edebug(")
2469 (forward-line 1)
2470 (point)))
2471 (forward-line 1)
2472 (setq last-ok-point (point))
2473
2474 ;; Delete interspersed edebug internals.
2475 (while (re-search-forward "^ edebug" nil t)
2476 (if (looking-at "-enter")
2477 ;; delete extraneous progn at top level of function body
2478 (save-excursion
2479 (goto-char last-ok-point)
2480 (forward-line -1)
2481 (setq last-ok-point (point))))
2482 (forward-line 1)
2483 (delete-region last-ok-point (point))
2484 (forward-line 1) ; skip past the good line
2485 (setq last-ok-point (point))
2486 )
2487 )
2488 (edebug-pop-to-buffer old-buf)
2489 ))
2490
2491
2492;;========================================================================
2493;; Trace display - append text to a buffer, and update display.
2494;;; e.g.
2495;;; (edebug-trace-display
2496;;; "*trace-point*"
2497;;; "saving: point = %s window-start = %s\n"
2498;;; (point) (window-start))
2499
2500(defun edebug-trace-display (buf-name fmt &rest args)
2501 "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible.
2502The buffer is created if it does not exist.
2503You must include newlines in FMT to break lines."
2504 (let* ((selected-window (selected-window))
2505 (buffer (get-buffer-create buf-name))
2506 (buf-window))
2507 (edebug-pop-to-buffer buffer)
2508 (save-excursion
2509 (setq buf-window (selected-window))
2510 (set-buffer buffer)
2511 (goto-char (point-max))
2512 (insert (apply 'format fmt args))
2513 (set-window-point buf-window (point))
2514 (forward-line (- 1 (window-height buf-window)))
2515 (set-window-start buf-window (point))
2516;; (edebug-sit-for 1)
2517 (bury-buffer buffer)
2518 )
2519 (select-window selected-window)))
2520
2521;;; edebug.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-18 23:29:21 +0000