Mercurial > emacs
changeset 661:36fbc3f71803
Initial revision
| author | Eric S. Raymond <esr@snark.thyrsus.com> |
|---|---|
| date | Sat, 30 May 1992 23:52:26 +0000 |
| parents | 08eb386dd0f3 |
| children | 8a533acedb77 |
| files | lisp/add-log.el lisp/dired.el lisp/emacs-lisp/edebug.el |
| diffstat | 3 files changed, 3409 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/add-log.el Sat May 30 23:52:26 1992 +0000 @@ -0,0 +1,103 @@ +;;; add-log.el --- change log maintenance commands for Emacs + +;; Copyright (C) 1985-1991 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;###autoload +(defvar change-log-default-name nil + "*Name of a change log file for \\[add-change-log-entry].") + +(defun change-log-name () + (or change-log-default-name + (if (eq system-type 'vax-vms) "$CHANGE_LOG$.TXT" "ChangeLog"))) + +(defun prompt-for-change-log-name () + "Prompt for a change log name." + (let ((default (change-log-name))) + (expand-file-name + (read-file-name (format "Log file (default %s): " default) + nil default)))) + +;;;###autoload +(defun add-change-log-entry (&optional whoami file-name other-window) + "Find change log file and add an entry for today. +Optional arg (interactive prefix) non-nil means prompt for user name and site. +Second arg is file name of change log. If nil, uses `change-log-default-name'. +Third arg OTHER-WINDOW non-nil means visit in other window." + (interactive (list current-prefix-arg + (prompt-for-change-log-name))) + (let* ((full-name (if whoami + (read-input "Full name: " (user-full-name)) + (user-full-name))) + ;; Note that some sites have room and phone number fields in + ;; full name which look silly when inserted. Rather than do + ;; anything about that here, let user give prefix argument so that + ;; s/he can edit the full name field in prompter if s/he wants. + (login-name (if whoami + (read-input "Login name: " (user-login-name)) + (user-login-name))) + (site-name (if whoami + (read-input "Site name: " (system-name)) + (system-name)))) + (or file-name + (setq file-name (or change-log-default-name + default-directory))) + (if (file-directory-p file-name) + (setq file-name (concat (file-name-as-directory file-name) + (change-log-name)))) + (set (make-local-variable 'change-log-default-name) file-name) + (if (and other-window (not (equal file-name buffer-file-name))) + (find-file-other-window file-name) + (find-file file-name)) + (undo-boundary) + (goto-char (point-min)) + (if (not (and (looking-at (substring (current-time-string) 0 10)) + (looking-at (concat ".* " full-name " (" login-name "@")))) + (progn (insert (current-time-string) + " " full-name + " (" login-name + "@" site-name ")\n\n"))) + (goto-char (point-min)) + (forward-line 1) + (while (looking-at "\\sW") + (forward-line 1)) + (delete-region (point) + (progn + (skip-chars-backward "\n") + (point))) + (open-line 3) + (forward-line 2) + (indent-to left-margin) + (insert "* "))) + +;;;###autoload +(define-key ctl-x-4-map "a" 'add-change-log-entry-other-window) + +;;;###autoload +(defun add-change-log-entry-other-window (&optional whoami file-name) + "Find change log file in other window and add an entry for today. +First arg (interactive prefix) non-nil means prompt for user name and site. +Second arg is file name of change log. +Interactively, with a prefix argument, the file name is prompted for." + (interactive (if current-prefix-arg + (list current-prefix-arg + (prompt-for-change-log-name)))) + (add-change-log-entry whoami file-name t)) + +;;; add-log.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/dired.el Sat May 30 23:52:26 1992 +0000 @@ -0,0 +1,785 @@ +;;; dired.el --- DIRED commands for Emacs + +;;; Missing: P command, sorting, setting file modes. +;;; Dired buffer containing multiple directories gets totally confused +;;; Implement insertion of subdirectories in situ --- tree dired + +;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;###autoload +(defvar dired-listing-switches "-al" "\ +Switches passed to ls for dired. MUST contain the `l' option. +CANNOT contain the `F' option.") + +(defvar dired-chown-program + (if (memq system-type '(hpux usg-unix-v)) + "/bin/chown" "/etc/chown") + "Pathname of chown command.") + +(defvar dired-directory nil) + +(defun dired-readin (dirname buffer) + (save-excursion + (message "Reading directory %s..." dirname) + (set-buffer buffer) + (let ((buffer-read-only nil)) + (widen) + (erase-buffer) + (setq dirname (expand-file-name dirname)) + (if (eq system-type 'vax-vms) + (vms-read-directory dirname dired-listing-switches buffer) + (if (file-directory-p dirname) + (call-process "ls" nil buffer nil + dired-listing-switches dirname) + (if (not (file-readable-p (directory-file-name (file-name-directory dirname)))) + (insert "Directory " dirname " inaccessible or nonexistent.\n") + (let ((default-directory (file-name-directory dirname))) + (call-process shell-file-name nil buffer nil + "-c" (concat "ls -d " dired-listing-switches " " + (file-name-nondirectory dirname))))))) + (goto-char (point-min)) + (indent-rigidly (point-min) (point-max) 2)) + (set-buffer-modified-p nil) + (message "Reading directory %s...done" dirname))) + +(defun dired-find-buffer (dirname) + (let ((blist (buffer-list)) + found) + (while blist + (save-excursion + (set-buffer (car blist)) + (if (and (eq major-mode 'dired-mode) + (equal dired-directory dirname)) + (setq found (car blist) + blist nil) + (setq blist (cdr blist))))) + (or found + (create-file-buffer (directory-file-name dirname))))) + +;;;###autoload +(defun dired (dirname) + "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. +Dired displays the list of files in DIRNAME. +You can move around in it with the usual movement commands. +You can flag files for deletion with \\<dired-mode-map>\\[dired-flag-file-deleted] +and then delete them by typing `x'. +Type `h' after entering dired for more info." + (interactive (list (read-file-name "Dired (directory): " + nil default-directory nil))) + (switch-to-buffer (dired-noselect dirname))) +;;;###autoload +(define-key ctl-x-map "d" 'dired) + +;;;###autoload +(defun dired-other-window (dirname) + "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." + (interactive (list (read-file-name "Dired in other window (directory): " + nil default-directory nil))) + (switch-to-buffer-other-window (dired-noselect dirname))) +;;;###autoload +(define-key ctl-x-4-map "d" 'dired-other-window) + +;;;###autoload +(defun dired-noselect (dirname) + "Like `dired' but returns the dired buffer as value, does not select it." + (or dirname (setq dirname default-directory)) + (setq dirname (expand-file-name (directory-file-name dirname))) + (if (file-directory-p dirname) + (setq dirname (file-name-as-directory dirname))) + (let ((buffer (dired-find-buffer dirname))) + (save-excursion + (set-buffer buffer) + (dired-readin dirname buffer) + (while (and (not (dired-move-to-filename)) (not (eobp))) + (forward-line 1)) + (dired-mode dirname)) + buffer)) + +(defun dired-revert (&optional arg noconfirm) + (let ((opoint (point)) + (ofile (dired-get-filename t t)) + (buffer-read-only nil) + delete-list already-deleted column-dots) + (goto-char 1) + (if (re-search-forward "^D" nil t) + (progn + (beginning-of-line) + (while (re-search-forward "^D" nil t) + (setq delete-list (cons (dired-get-filename t) delete-list))))) + (dired-readin dired-directory (current-buffer)) + (while (and (not (dired-move-to-filename)) (not (eobp))) + (forward-line 1)) + (setq column-dots (concat "^" (make-string (current-column) ?.)) + delete-list (nreverse delete-list)) + (while delete-list + ;; assumptions: the directory was reread with the files listed in the + ;; same order as they were originally. the string of "."s is rather silly + ;; but it seems the fastest way to avoid messing with -F flags and + ;; matches that occur in places other than the filename column + (if (re-search-forward + (concat column-dots (regexp-quote (car delete-list))) nil t) + (progn (beginning-of-line) + (delete-char 1) + (insert "D")) + (setq already-deleted (cons (car delete-list) already-deleted))) + (setq delete-list (cdr delete-list))) + (goto-char 0) + (or (and ofile (re-search-forward (concat column-dots (regexp-quote ofile)) + nil t)) + (goto-char opoint)) + (dired-move-to-filename) + (if already-deleted (message "Already deleted: %s" + (prin1-to-string (reverse already-deleted)))))) + +(defvar dired-mode-map nil "Local keymap for dired-mode buffers.") +(if dired-mode-map + nil + (setq dired-mode-map (make-keymap)) + (suppress-keymap dired-mode-map) + (define-key dired-mode-map "r" 'dired-rename-file) + (define-key dired-mode-map "\C-d" 'dired-flag-file-deleted) + (define-key dired-mode-map "d" 'dired-flag-file-deleted) + (define-key dired-mode-map "v" 'dired-view-file) + (define-key dired-mode-map "e" 'dired-find-file) + (define-key dired-mode-map "f" 'dired-find-file) + (define-key dired-mode-map "o" 'dired-find-file-other-window) + (define-key dired-mode-map "u" 'dired-unflag) + (define-key dired-mode-map "x" 'dired-do-deletions) + (define-key dired-mode-map "\177" 'dired-backup-unflag) + (define-key dired-mode-map "?" 'dired-summary) + (define-key dired-mode-map "c" 'dired-copy-file) + (define-key dired-mode-map "#" 'dired-flag-auto-save-files) + (define-key dired-mode-map "~" 'dired-flag-backup-files) + (define-key dired-mode-map "F" 'dired-flag-regexp-files) + (define-key dired-mode-map "." 'dired-clean-directory) + (define-key dired-mode-map "h" 'describe-mode) + (define-key dired-mode-map " " 'dired-next-line) + (define-key dired-mode-map "\C-n" 'dired-next-line) + (define-key dired-mode-map "\C-p" 'dired-previous-line) + (define-key dired-mode-map "n" 'dired-next-line) + (define-key dired-mode-map "p" 'dired-previous-line) + (define-key dired-mode-map "g" 'revert-buffer) + (define-key dired-mode-map "D" 'dired-create-directory) + (define-key dired-mode-map "m" 'dired-move-file) + (define-key dired-mode-map "C" 'dired-compress) + (define-key dired-mode-map "U" 'dired-uncompress) + (define-key dired-mode-map "B" 'dired-byte-recompile) + (define-key dired-mode-map "M" 'dired-chmod) + (define-key dired-mode-map "G" 'dired-chgrp) + (define-key dired-mode-map "O" 'dired-chown) + (define-key dired-mode-map "=" 'dired-diff) + (define-key dired-mode-map "<" 'dired-up-directory)) + + +;; Dired mode is suitable only for specially formatted data. +(put 'dired-mode 'mode-class 'special) + +(defun dired-mode (&optional dirname) + "Mode for \"editing\" directory listings. +In dired, you are \"editing\" a list of the files in a directory. +You can move using the usual cursor motion commands. +Letters no longer insert themselves. +Instead, use the following commands: +\\{dired-mode-map}" + (interactive) + (kill-all-local-variables) + (make-local-variable 'revert-buffer-function) + (setq revert-buffer-function 'dired-revert) + (setq major-mode 'dired-mode) + (setq mode-name "Dired") + (make-local-variable 'dired-directory) + (setq dired-directory (or dirname default-directory)) + (make-local-variable 'list-buffers-directory) + (setq list-buffers-directory dired-directory) + (set (make-local-variable 'dired-used-F) + (string-match "F" dired-listing-switches)) + (if dirname + (setq default-directory + (if (file-directory-p dirname) + dirname (file-name-directory dirname)))) + (setq mode-line-buffer-identification '("Dired: %17f")) + (setq case-fold-search nil) + (setq buffer-read-only t) + (use-local-map dired-mode-map) + (run-hooks 'dired-mode-hook)) + +;; FUNCTION receives no arguments +;; and should return t iff it deletes the current line from the buffer. +(defun dired-repeat-over-lines (arg function) + (beginning-of-line) + (while (and (> arg 0) (not (eobp))) + (setq arg (1- arg)) + (let (deleted) + (save-excursion + (beginning-of-line) + (and (bobp) (looking-at " total") + (error "No file on this line")) + (setq deleted (funcall function))) + (or deleted + (forward-line 1))) + (dired-move-to-filename)) + (while (and (< arg 0) (not (bobp))) + (setq arg (1+ arg)) + (forward-line -1) + (dired-move-to-filename) + (save-excursion + (beginning-of-line) + (funcall function)))) + +(defun dired-flag-file-deleted (arg) + "In dired, flag the current line's file for deletion. +With prefix arg, repeat over several lines." + (interactive "p") + (dired-repeat-over-lines arg + '(lambda () + (let ((buffer-read-only nil)) + (delete-char 1) + (insert "D") + nil)))) + +(defun dired-flag-regexp-files (regexp) + "In dired, flag all files matching the specified REGEXP for deletion." + (interactive "sFlagging regexp: ") + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (and (not (looking-at " d")) + (not (eolp)) + (let ((fn (dired-get-filename t t))) + (if fn (string-match regexp fn))) + (progn (beginning-of-line) + (delete-char 1) + (insert "D"))) + (forward-line 1))))) + +(defun dired-summary () + (interactive) + ;>> this should check the key-bindings and use substitute-command-keys if non-standard + (message + "d-elete, u-ndelete, x-ecute, f-ind, o-ther window, r-ename, c-opy, v-iew")) + +(defun dired-unflag (arg) + "In dired, remove the current line's delete flag then move to next line." + (interactive "p") + (dired-repeat-over-lines arg + '(lambda () + (let ((buffer-read-only nil)) + (delete-char 1) + (insert " ") + (forward-char -1) + nil)))) + +(defun dired-backup-unflag (arg) + "In dired, move up lines and remove deletion flag there. +Optional prefix ARG says how many lines to unflag; default is one line." + (interactive "p") + (dired-unflag (- arg))) + +(defun dired-next-line (arg) + "Move down lines then position at filename. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (next-line arg) + (dired-move-to-filename)) + +(defun dired-previous-line (arg) + "Move up lines then position at filename. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (previous-line arg) + (dired-move-to-filename)) + +(defun dired-up-directory () + "Run dired on the parent of the current directory." + (interactive) + (find-file "..")) + +(defun dired-find-file () + "In dired, visit the file or directory named on this line." + (interactive) + (find-file (dired-get-filename))) + +(defun dired-view-file () + "In dired, examine a file in view mode, returning to dired when done." + (interactive) + (if (file-directory-p (dired-get-filename)) + (dired (dired-get-filename)) + (view-file (dired-get-filename)))) + +(defun dired-find-file-other-window () + "In dired, visit this file or directory in another window." + (interactive) + (find-file-other-window (dired-get-filename))) + +(defun dired-get-filename (&optional localp no-error-if-not-filep) + "In dired, return name of file mentioned on this line. +Value returned normally includes the directory name. +Optional arg LOCALP means don't include it. +Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename +on this line, otherwise an error occurs." + (let (eol file type ex (case-fold-search nil)) + (save-excursion + (end-of-line) + (setq eol (point)) + (beginning-of-line) + (if (eq system-type 'vax-vms) + ;; Non-filename lines don't match + ;; because they have lower case letters. + (if (re-search-forward "^..\\([][.A-Z-0-9_$;<>]+\\)" eol t) + (setq file (buffer-substring (match-beginning 1) (match-end 1)))) + ;; Unix case + (if (not (re-search-forward + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+" + eol t)) () + (skip-chars-forward " ") + (skip-chars-forward "^ " eol) + (skip-chars-forward " " eol) + (setq file (buffer-substring (point) eol)) + (re-search-backward "\\(.\\)[-r][-w]\\(.\\)[-r][-w]\\(.\\)[-r][-w]\\(.\\)") + (setq flag (buffer-substring (match-beginning 1) (match-end 1)) + ex (string-match "[xst]" ;; execute bit set anywhere? + (concat + (buffer-substring (match-beginning 2) (match-end 2)) + (buffer-substring (match-beginning 3) (match-end 3)) + (buffer-substring (match-beginning 4) (match-end 4))))) + (cond + ((string= flag "l") + ;; strip the link name. Bombs if file contains " ->" + (if (string-match " ->" file) + (setq file (substring file 0 (match-beginning 0))))) + ((and dired-used-F ;; strip off -F stuff if there + (or (string= flag "d") (string= flag "s") ex)) + (setq file (substring file 0 -1))))))) + (or no-error-if-not-filep file + (error "No file on this line")) + ;; ??? uses default-directory, could lose on cd, multiple. + (or localp (setq file (expand-file-name file default-directory))) + file)) + +(defun dired-move-to-filename () + "In dired, move to first char of filename on this line. +Returns position (point) or nil if no filename on this line." + (let ((eol (progn (end-of-line) (point)))) + (beginning-of-line) + (if (re-search-forward + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+" + eol t) + (progn + (skip-chars-forward " ") + (skip-chars-forward "^ " eol) + (skip-chars-forward " " eol) + (point))))) + +(defun dired-map-dired-file-lines (fn) + "Perform function FN with point at the end of each non-directory line. +The arguments given to FN are the short and long filename" + (save-excursion + (let (filename longfilename (buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (save-excursion + (and (not (looking-at " \\s *[0-9]*\\s *[0-9]* d")) + (not (eolp)) + (setq filename (dired-get-filename t t) + longfilename (dired-get-filename nil t)) + (progn (end-of-line) + (funcall fn filename longfilename)))) + (forward-line 1))))) + +(defun dired-flag-auto-save-files (unflag-p) + "Flag for deletion files whose names suggest they are auto save files. +A prefix argument says to unflag those files instead." + (interactive "P") + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (and (not (looking-at " \\s *[0-9]*\\s *[0-9]* d")) + (not (eolp)) + (if (fboundp 'auto-save-file-name-p) + (let ((fn (dired-get-filename t t))) + (if fn (auto-save-file-name-p fn))) + (if (dired-move-to-filename) + (looking-at "#"))) + (progn (beginning-of-line) + (delete-char 1) + (insert (if unflag-p " " "D")))) + (forward-line 1))))) + +(defun dired-clean-directory (keep) + "Flag numerical backups for deletion. +Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. +Positive prefix arg KEEP overrides `dired-kept-versions'; +Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. + +To clear the flags on these files, you can use \\[dired-flag-backup-files] +with a prefix argument." + (interactive "P") + (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) + (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) + (late-retention (if (<= keep 0) dired-kept-versions keep)) + (file-version-assoc-list ())) + ;; Look at each file. + ;; If the file has numeric backup versions, + ;; put on file-version-assoc-list an element of the form + ;; (FILENAME . VERSION-NUMBER-LIST) + (dired-map-dired-file-lines 'dired-collect-file-versions) + ;; Sort each VERSION-NUMBER-LIST, + ;; and remove the versions not to be deleted. + (let ((fval file-version-assoc-list)) + (while fval + (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) + (v-count (length sorted-v-list))) + (if (> v-count (+ early-retention late-retention)) + (rplacd (nthcdr early-retention sorted-v-list) + (nthcdr (- v-count late-retention) + sorted-v-list))) + (rplacd (car fval) + (cdr sorted-v-list))) + (setq fval (cdr fval)))) + ;; Look at each file. If it is a numeric backup file, + ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. + (dired-map-dired-file-lines 'dired-trample-file-versions))) + +(defun dired-collect-file-versions (ignore fn) + "If it looks like file FN has versions, return a list of the versions. +That is a list of strings which are file names. +The caller may want to flag some of these files for deletion." + (let* ((base-versions + (concat (file-name-nondirectory fn) ".~")) + (bv-length (length base-versions)) + (possibilities (file-name-all-completions + base-versions + (file-name-directory fn))) + (versions (mapcar 'backup-extract-version possibilities))) + (if versions + (setq file-version-assoc-list (cons (cons fn versions) + file-version-assoc-list))))) + +(defun dired-trample-file-versions (ignore fn) + (let* ((start-vn (string-match "\\.~[0-9]+~$" fn)) + base-version-list) + (and start-vn + (setq base-version-list ; there was a base version to which + (assoc (substring fn 0 start-vn) ; this looks like a + file-version-assoc-list)) ; subversion + (not (memq (string-to-int (substring fn (+ 2 start-vn))) + base-version-list)) ; this one doesn't make the cut + (dired-flag-this-line-for-DEATH)))) + +(defun dired-flag-this-line-for-DEATH () + (beginning-of-line) + (delete-char 1) + (insert "D")) + +(defun dired-flag-backup-files (unflag-p) + "Flag all backup files (names ending with `~') for deletion. +With prefix argument, unflag these files." + (interactive "P") + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (and (not (looking-at " d")) + (not (eolp)) + (if (fboundp 'backup-file-name-p) + (let ((fn (dired-get-filename t t))) + (if fn (backup-file-name-p fn))) + (end-of-line) + (forward-char -1) + (looking-at "~")) + (progn (beginning-of-line) + (delete-char 1) + (insert (if unflag-p " " "D")))) + (forward-line 1))))) + +(defun dired-flag-backup-and-auto-save-files (unflag-p) + "Flag all backup and temporary files for deletion. +Backup files have names ending in `~'. +Auto save file names usually start with `#'. +With prefix argument, unflag these files." + (interactive "P") + (dired-flag-backup-files unflag-p) + (dired-flag-auto-save-files unflag-p)) + +(defun dired-create-directory (directory) + "Create a directory called DIRECTORY." + (interactive "FCreate directory: ") + (let ((expanded (expand-file-name directory))) + (make-directory expanded) + (dired-add-entry (file-name-directory expanded) + (file-name-nondirectory expanded)) + (dired-next-line 1))) + +(defun dired-move-file (to-dir &optional count) + "Move this file to directory TO-DIR. +Optional second argument COUNT (the prefix argument) +specifies moving several consecutive files." + (interactive + (let ((count (prefix-numeric-value current-prefix-arg))) + (list (read-file-name (format "Move %s to directory: " + (if (> count 1) + (format "%d files" count) + (file-name-nondirectory (dired-get-filename)))) + nil t) + count))) + (let ((dir (file-name-as-directory (expand-file-name to-dir)))) + (dired-repeat-over-lines + count + (function (lambda () + (let ((this (dired-get-filename))) + (rename-file this + (expand-file-name (file-name-nondirectory this) + dir))) + (let ((buffer-read-only nil)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + t))))) + +(defun dired-rename-file (to-file) + "Rename the current file to TO-FILE." + (interactive + (list (read-file-name (format "Rename %s to: " + (file-name-nondirectory (dired-get-filename))) + nil (dired-get-filename)))) + (setq to-file (expand-file-name to-file)) + (let ((filename (dired-get-filename)) + (buffer-read-only nil)) + (rename-file filename to-file) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (setq to-file (expand-file-name to-file)) + (dired-add-entry (file-name-directory to-file) + (file-name-nondirectory to-file)) + ;; Optionally rename the visited file of any buffer visiting this file. + (and (get-file-buffer filename) + (y-or-n-p (message "Change visited file name of buffer %s too? " + (buffer-name (get-file-buffer filename)))) + (save-excursion + (set-buffer (get-file-buffer filename)) + (let ((modflag (buffer-modified-p))) + (set-visited-file-name to-file) + (set-buffer-modified-p modflag)))))) + +(defun dired-copy-file (to-file) + "Copy the current file to TO-FILE." + (interactive "FCopy to: ") + (copy-file (dired-get-filename) to-file) + (setq to-file (expand-file-name to-file)) + (dired-add-entry (file-name-directory to-file) + (file-name-nondirectory to-file))) + +(defun dired-add-entry (directory filename) + ;; If tree dired is implemented, this function will have to do + ;; something smarter with the directory. Currently, just check + ;; default directory, if same, add the new entry at point. With tree + ;; dired, should call 'dired-current-directory' or similar. Note + ;; that this adds the entry 'out of order' if files sorted by time, + ;; etc. + (if (string-equal directory default-directory) + (let ((buffer-read-only nil)) + (beginning-of-line) + (call-process "ls" nil t nil + "-d" dired-listing-switches (concat directory filename)) + (forward-line -1) + (insert " ") + (dired-move-to-filename) + (let* ((beg (point)) + (end (progn (end-of-line) (point)))) + (setq filename (buffer-substring beg end)) + (delete-region beg end) + (insert (file-name-nondirectory filename))) + (beginning-of-line)))) + +(defun dired-diff (point mark) + "Compare files at POINT1 and POINT2 by running `diff'. +Interactively, these are the files at point and mark. +The file at mark (POINT2) is the first file given to `diff'. +See the command `diff'." + (interactive "d\nm") + (let (name1 name2) + (setq name2 (dired-get-filename)) + (save-excursion + (goto-char mark) + (setq name1 (dired-get-filename))) + (diff name1 name2))) + +(defun dired-compress () + "Compress the current file." + (interactive) + (let* ((buffer-read-only nil) + (error-buffer (get-buffer-create " *Dired compress output*")) + (from-file (dired-get-filename)) + (to-file (concat from-file ".Z"))) + (if (string-match "\\.Z$" from-file) + (error "%s is already compressed!" from-file)) + (message "Compressing %s..." from-file) + (unwind-protect + (progn + (save-excursion + (set-buffer error-buffer) + (erase-buffer)) + ;; Must have default-directory of dired buffer in call-process + (call-process "compress" nil error-buffer nil "-f" from-file) + (if (save-excursion + (set-buffer error-buffer) + (= 0 (buffer-size))) + (progn + (message "Compressing %s... done" from-file) + (kill-buffer error-buffer)) + (display-buffer error-buffer) + (setq error-buffer nil) + (error "Compress error on %s." from-file))) + (if error-buffer (kill-buffer error-buffer))) + (dired-redisplay to-file))) + +(defun dired-uncompress () + "Uncompress the current file." + (interactive) + (let* ((buffer-read-only nil) + (error-buffer (get-buffer-create " *Dired compress output*")) + (from-file (dired-get-filename)) + (to-file (substring from-file 0 -2))) + (if (string-match "\\.Z$" from-file) nil + (error "%s is not compressed!" from-file)) + (message "Uncompressing %s..." from-file) + (unwind-protect + (progn + (save-excursion + (set-buffer error-buffer) + (erase-buffer)) + ;; Must have default-directory of dired buffer in call-process + (call-process "uncompress" nil error-buffer nil "-f" from-file) + (if (save-excursion + (set-buffer error-buffer) + (= 0 (buffer-size))) + (progn + (message "Uncompressing %s... done" from-file) + (kill-buffer error-buffer)) + (display-buffer error-buffer) + (setq error-buffer nil) + (error "Uncompress error on %s." from-file))) + (if error-buffer (kill-buffer error-buffer))) + (dired-redisplay to-file))) + +(defun dired-byte-recompile () + "Byte recompile the current file." + (interactive) + (let* ((buffer-read-only nil) + (from-file (dired-get-filename)) + (to-file (substring from-file 0 -3))) + (if (string-match "\\.el$" from-file) nil + (error "%s is uncompilable!" from-file)) + (byte-compile-file from-file))) + +(defun dired-chmod (mode) + "Change mode of the current file to MODE." + (interactive "sChange to Mode: ") + (let ((buffer-read-only nil) + (file (dired-get-filename))) + (call-process "/bin/chmod" nil nil nil mode file) + (dired-redisplay file))) + +(defun dired-chgrp (group) + "Change group of the current file to GROUP." + (interactive "sChange to Group: ") + (let ((buffer-read-only nil) + (file (dired-get-filename))) + (call-process "/bin/chgrp" nil nil nil group file) + (dired-redisplay file))) + +(defun dired-chown (owner) + "Change owner of the current file to OWNER." + (interactive "sChange to Owner: ") + (let ((buffer-read-only nil) + (file (dired-get-filename))) + (call-process dired-chown-program + nil nil nil owner file) + (dired-redisplay file))) + +(defun dired-redisplay (&optional file) + "Delete the current line, and insert an entry for file FILE. +If FILE is nil, then just delete the current line." + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (if file (dired-add-entry (file-name-directory file) + (file-name-nondirectory file))) + (dired-move-to-filename)) + +(defun dired-do-deletions () + "In dired, delete the files flagged for deletion." + (interactive) + (let (delete-list answer) + (save-excursion + (goto-char 1) + (while (re-search-forward "^D" nil t) + (setq delete-list + (cons (cons (dired-get-filename t) (1- (point))) + delete-list)))) + (if (null delete-list) + (message "(No deletions requested)") + (save-window-excursion + (set-buffer (get-buffer-create " *Deletions*")) + (funcall (if (> (length delete-list) (* (window-height) 2)) + 'switch-to-buffer 'switch-to-buffer-other-window) + (current-buffer)) + (erase-buffer) + (setq fill-column 70) + (let ((l (reverse delete-list))) + ;; Files should be in forward order for this loop. + (while l + (if (> (current-column) 59) + (insert ?\n) + (or (bobp) + (indent-to (* (/ (+ (current-column) 19) 20) 20) 1))) + (insert (car (car l))) + (setq l (cdr l)))) + (goto-char (point-min)) + (setq answer (yes-or-no-p "Delete these files? "))) + (if answer + (let ((l delete-list) + failures) + ;; Files better be in reverse order for this loop! + ;; That way as changes are made in the buffer + ;; they do not shift the lines still to be changed. + (while l + (goto-char (cdr (car l))) + (let ((buffer-read-only nil)) + (condition-case () + (let ((fn (concat default-directory (car (car l))))) + (if (file-directory-p fn) + (progn + (remove-directory fn) + (if (file-exists-p fn) (delete-file fn))) + (delete-file fn)) + (delete-region (point) + (progn (forward-line 1) (point)))) + (error (delete-char 1) + (insert " ") + (setq failures (cons (car (car l)) failures))))) + (setq l (cdr l))) + (if failures + (message "Deletions failed: %s" + (prin1-to-string failures)))))))) + +(provide 'dired) + +;;; dired.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/edebug.el Sat May 30 23:52:26 1992 +0000 @@ -0,0 +1,2521 @@ +;;; edebug.el --- a source-level debugger for emacs lisp. + +;; Copyright (C) 1988, 1989, 1990, 1991 Free Software Foundation, Inc + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +;;;================================================================ +;;; This minor mode allows programmers to step through elisp source +;;; code while executing, set breakpoints, etc. See the texinfo +;;; document (being constructed...) for more detailed instructions +;;; than contained here. Send me your enhancement, ideas, bugs, or +;;; fixes. + +;;; Daniel LaLiberte 217-244-0785 +;;; University of Illinois, Urbana-Champaign +;;; Department of Computer Science +;;; 1304 W Springfield +;;; Urbana, IL 61801 + +;;; uiucdcs!liberte +;;; liberte@cs.uiuc.edu + +;;; Contents: +;;; ========= +;;; Change list +;;; Installation +;;; Todo list +;;; Utilities +;;; Parser +;;; Debugger + + +;;;================================================================ +;;; Change list +;;; ----------- + +;;; $Header: /import/kaplan/kaplan/liberte/Edebug/RCS/edebug.el,v 2.5 91/07/25 13:32:53 liberte Exp Locker: liberte $ +;;; $Log: edebug.el,v $ +;;; Revision 2.5 91/07/25 13:32:53 liberte +;;; Doc string cleanup. +;;; If edebug-form-hook is t, evaluate all arguments. +;;; If edebug-form-hook is 0, evaluate no arguments. +;;; If edebug-form-hook is nil, evaluate macro args according +;;; to edebug-eval-macro-args. +;;; Save the outside value of executing macro. +;;; Save and restore the outside restriction. +;;; Dont force update for go and Go-nonstop. +;;; Save and restore last-command-char, last-command, +;;; this-command, last-input-char. +;;; For epoch, do epoch::dispatch-events before sit-for +;;; and input-pending-p since X events could interfere. +;;; Warn about unsetting non-existent breakpoint. +;;; Fix edebug-forward-sexp with prefix arg. +;;; Add edebug-step-out to exit from current sexp. +;;; +;;; Revision 2.4 91/03/18 12:35:44 liberte +;;; Force update after go or Go-nonstop modes, so overlay arrow is correct. +;;; Support debug-on-quit. Remove edebug-on-error. +;;; Fix edebug-anonymous. Bug found by jackr@wpd.sgi.com (Jack Repenning). +;;; Don't discard-input anymore. Easier to change modes this way. +;;; Fix max-lisp-eval-depth and max-specpdl-size incrementing. +;;; Save and restore points in all buffers, if +;;; edebug-save-buffer-points is non-nil. Expensive! +;;; Bug caught by wolfgang@wsrcc.com (Wolfgang S. Rupprecht) +;;; Save standard-output and standard-input in edebug-recursive-edit +;;; so that edebug-outside-excursion can restore them. +;;; Call set-buffer in edebug-pop-to-buffer since +;;; select-window does not do that. +;;; Fix edebug's eval-defun to remember current buffer inside evaluations +;;; and to evaluate top-level forms. Found by Jamie Zawinski. +;;; Add edebug-interactive-entry to support interactive forms with +;;; non-string arg. Bug found by Jack Repenning. +;;; Simplify edebug-restore-match-data to just store-match-data. +;;; Motivated by linus@lysator.liu.se. +;;; Move the match-data call to before the outside +;;; buffer is changed, since it assumes that. +;;; +;;; Revision 2.3 91/01/17 20:55:14 liberte +;;; Fix bug found by hollen@megatek.uucp. +;;; Current buffer was not being restored. +;;; Call edebug with (edebug begin end 'exp) +;;; and add additional wrapper around body of functions: +;;; (edebug-enter function body). +;;; Make &optional only apply to immediate next arg +;;; in edebug-form-parser (was edebug-macro-parser). +;;; Catch debug errors with edebug. Yeah! +;;; Reset edebug-mode on first function entry. Yeah! +;;; Motivated by Dion Hollenbeck. +;;; Add the missing bindings to the global-edebug-map. +;;; eval-current-buffer now uses eval-region. +;;; eval-region now does not narrow region. +;;; Narrowing was the cause of the window-start being set wrong. +;;; Reset edebug-mode only on +;;; first entry of any function at each recursive-edit level. +;;; Add edebug-backtrace, to generate cleaned up +;;; backtrace. It doesnt "work" like the debug backtrace, however. +;;; Require reselecting outside window even if +;;; quit occurs, otherwise save-excursions may restore +;;; buffer to the wrong window. +;;; +;;; Revision 2.2 90/11/26 21:14:22 liberte +;;; Shadow eval-defun and eval-region. Toggle +;;; edebugging with edebug-all-defuns. +;;; Call edebug with (edebug 'function begin end 'exp) +;;; Suggested by Jamie Zawinski <jwz@lucid.com>. +;;; Add edebug-form-parser to process macro args. +;;; Motivated by Darryl Okahata darrylo@hpnmxx.hp.com. +;;; Fix by Roland McGrath <roland@ai.mit.edu> +;;; to wrap body of edebug-save-restriction in progn. +;;; Fix by Darryl Okahata <darrylo%hpnmd@hpcea.hp.com> +;;; to add (set-window-hscroll (selected-window) 0) to +;;; edebug-pop-to-buffer. +;;; +;;; Revision 2.1 90/11/16 21:55:35 liberte +;;; Clean up. +;;; Add edebug-form-hook to edebug macro calls. Thanks to Joe Wells. +;;; edebug-forward-sexp uses step mode if no forward-sexp. +;;; +;;; Revision 2.0 90/11/14 22:30:54 liberte +;;; Handle lambda forms, function, interactive evals, defmacro. +;;; Clean up display for Epoch - save and restore screen configurations. +;;; Note: epoch 3.2 broke set-window-configuration. +;;; Also, sit-for pauses do not always work in epoch. +;;; Display evaluations window. +;;; Display result after expression evaluation. +;;; Thanks to discussions with Shinichirou Sugou. +;;; Conditional and temporary breakpoints. +;;; Change "continue" to "go" mode and add different "continue" mode. +;;; Option to stop before symbols. +;;; +;;; Fix by: Glen Ditchfield gjditchfield@violet.uwaterloo.ca +;;; to handle ?# type chars. +;;; +;;; Revision 1.5 89/05/10 02:39:27 liberte +;;; Fix condition-case expression lists. +;;; Reorganize edebug. +;;; +;;; Revision 1.4 89/02/14 22:58:34 liberte +;;; Fix broken breakpointing. +;;; Temporarily widen elisp buffer during edebug. +;;; +;;; Revision 1.3 89/01/30 00:26:09 liberte +;;; More bug fixes for cond and let. +;;; Another parsing fix backquote. +;;; Fix for lambda forms inside defuns. +;;; Leave point at syntax error, mark at starting position. +;;; +;;; Revision 1.2 88/11/28 12:14:15 liberte +;;; Bug fixes: cond construct didnt execute. +;;; () in sexp list didnt parse +;;; () as variable in condition-case didnt parse. +;;; +;;; Revision 1.1 88/11/28 12:11:27 liberte +;;; Initial revision +;;; + + +;;; Installation +;;; ------------ +;; Put edebug.el in some directory in your load-path and byte-compile it. + +;; Put the following forms in your .emacs file. +;; (setq edebug-global-prefix "...whatever you want") ; default is C-xX +;; (define-key emacs-lisp-mode-map "\^Xx" 'edebug-defun) +;; (autoload 'edebug-defun "edebug") +;; (autoload 'edebug-debug "edebug") +;; (setq debugger 'edebug-debug) +;; ... other options, described in the next section. + +;; Evaluate a defun for edebug with edebug-defun. +;; Evaluate your function normally. +;; Use the "?" command in edebug to describe other commands. +;; See edebug.texinfo for more instructions. + + +;;; Options +;;; ------- + +(defvar edebug-all-defuns nil + "*If non-nil, all defuns and defmacros evaluated will use edebug. +eval-defun without prefix arg and eval-region will use edebug-defun. + +If nil, eval-region evaluates normally, but eval-defun with prefix arg +uses edebug-defun. eval-region is called by eval-defun, eval-last-sexp, +and eval-print-last-sexp. + +You may wish to make this variable local to each elisp buffer by calling +(make-local-variable 'edebug-all-defuns) in your emacs-lisp-mode-hook. +You can use the function edebug-all-defuns to toggle its value.") + + +(defvar edebug-eval-macro-args nil + "*If non-nil, edebug will assume that all macro call arguments for +macros that have no edebug-form-hook may be evaluated, otherwise it +will not. To specify exceptions for macros that have some arguments +evaluated and some not, you should specify an edebug-form-hook") + +(defvar edebug-stop-before-symbols nil + "*Non-nil causes edebug to stop before symbols as well as after. +In any case, it is possible to stop before a symbol with a breakpoint or +interrupt.") + +(defvar edebug-save-windows t + "*If non-nil, save and restore window configuration on edebug calls. +It takes some time to save and restore, so if your program does not care +what happens to the window configurations, it is better to set this +variable to nil.") + +(defvar edebug-save-point t + "*If non-nil, save and restore the point and mark in source code buffers.") + +(defvar edebug-save-buffer-points nil + "*If non-nil, save and restore the points of all buffers, displayed or not. + +Saving and restoring buffer points is necessary if you are debugging +code that changes the point of a buffer which is displayed in a +non-selected window. If edebug or the user then selects the +window, the buffer's point will be changed to the window's point. + +Saving and restoring all the points is an expensive operation since it +visits each buffer twice for each edebug call, so it is best to avoid +it if you can.") + +(defvar edebug-initial-mode 'step + "*Global initial mode for edebug, if non-nil. +This is used when edebug is first entered for each recursive-edit level. +Possible values are nil (meaning keep using edebug-mode), step, go, +Go-nonstop, trace, Trace-fast, continue, and Continue-fast.") + +(defvar edebug-trace nil + "*Non-nil if edebug should show a trace of function entry and exit. +Tracing output is displayed in a buffer named *edebug-trace*, one +function entry or exit per line, indented by the recursion level. You +can customize by replacing functions edebug-print-trace-entry and +edebug-print-trace-exit.") + + + +;;;======================================================================== +;;; Utilities +;;; --------- + +(defun edebug-which-function () + "Return the symbol of the function we are in" + (save-excursion + (end-of-defun) + (beginning-of-defun) + (down-list 1) + (if (not (memq (read (current-buffer)) '(defun defmacro))) + (error "Not in defun or defmacro.")) + (read (current-buffer)))) + +(defun edebug-last-sexp () + "Return the last sexp before point in current buffer. +Assumes elisp syntax is active." + (car + (read-from-string + (buffer-substring + (save-excursion + (forward-sexp -1) + (point)) + (point))))) + +(defun edebug-window-list () + "Return a list of windows, in order of next-window." + ;; This doesnt work for epoch. + (let* ((first-window (selected-window)) + (window-list (list first-window)) + (next (next-window first-window))) + (while (not (eq next first-window)) + (setq window-list (cons next window-list)) + (setq next (next-window next))) + (nreverse window-list))) + +(defun edebug-get-buffer-points () + "Return a list of buffer point pairs, for all buffers." + (save-excursion + (mapcar (function (lambda (buf) + (set-buffer buf) + (cons buf (point)))) + (buffer-list)))) + +(defun edebug-set-buffer-points () + "Restore the buffer-points given by edebug-get-buffer-points." + (mapcar (function (lambda (buf-point) + (if (buffer-name (car buf-point)) ; still exists + (progn + (set-buffer (car buf-point)) + (goto-char (cdr buf-point)))))) + edebug-buffer-points)) + +(defun edebug-two-window-p () + "Return t if there are two windows." + (and (not (one-window-p)) + (eq (selected-window) + (next-window (next-window (selected-window)))))) + +(defun edebug-macrop (object) + "Return the macro named by OBJECT, or nil if it is not a macro." + (while (and (symbolp object) (fboundp object)) + (setq object (symbol-function object))) + (if (and (listp object) + (eq 'macro (car object)) + (edebug-functionp (cdr object))) + object)) + +(defun edebug-functionp (object) + "Returns the function named by OBJECT, or nil if it is not a function." + (while (and (symbolp object) (fboundp object)) + (setq object (symbol-function object))) + (if (or (subrp object) + (and (listp object) + (eq (car object) 'lambda) + (listp (car (cdr object))))) + object)) + +(defun edebug-sort-alist (alist function) + "Return the ALIST sorted with comparison function FUNCTION. +This uses 'sort so the sorting is destructive." + (sort alist (function + (lambda (e1 e2) + (funcall function (car e1) (car e2)))))) + +(put 'edebug-save-restriction 'edebug-form-hook + '(&rest form)) + +(defmacro edebug-save-restriction (&rest body) + "Evaluate BODY while saving the current buffers restriction. +BODY may change buffer outside of current restriction, unlike +save-restriction. BODY may change the current buffer, +and the restriction will be restored to the original buffer, +and the current buffer remains current. +Return the result of the last expression in BODY." + (` (let ((edebug:s-r-beg (point-min-marker)) + (edebug:s-r-end (point-max-marker))) + (unwind-protect + (progn (,@ body)) + (save-excursion + (set-buffer (marker-buffer edebug:s-r-beg)) + (narrow-to-region edebug:s-r-beg edebug:s-r-end)))))) + + +;;;============================================================= +;;; Redefine eval-defun, eval-region, and eval-current-buffer. +;;; ----------------------------------------------------------- + +(defun edebug-all-defuns () + "Toggle edebugging of all defuns and defmacros, +not including those evaluated in the minibuffer, or during load." + (interactive) + (setq edebug-all-defuns (not edebug-all-defuns)) + (message "Edebugging is %s." (if edebug-all-defuns "on" "off"))) + + +(if (not (fboundp 'edebug-emacs-eval-defun)) + (fset 'edebug-emacs-eval-defun (symbol-function 'eval-defun))) +;;(fset 'eval-defun (symbol-function 'edebug-emacs-eval-defun)) + +(defun eval-defun (edebug-debug) + "Edebug replacement for eval-defun. Print value in the minibuffer. +Evaluate the top-level form that point is in or before. Note: +eval-defun normally evaluates any top-level form, not just defuns. + +Here are the differences from the standard eval-defun. If the prefix +argument is the same as edebug-all-defuns (nil or non-nil), evaluate +normally; otherwise edebug-defun is called to wrap edebug calls around +evaluatable expressions in the defun or defmacro body. Also, the +value printed by edebug-defun is not just the function name." + (interactive "P") + (let ((edebug-all-defuns + (not (eq (not edebug-debug) (not edebug-all-defuns))))) + (edebug-emacs-eval-defun nil) + )) + + +(if (not (fboundp 'edebug-emacs-eval-region)) + (fset 'edebug-emacs-eval-region (symbol-function 'eval-region))) +;; (fset 'eval-region (symbol-function 'edebug-emacs-eval-region)) + +(defun eval-region (edebug-e-r-start edebug-e-r-end + &optional edebug-e-r-output) + "Edebug replacement for eval-defun. +Like eval-region, but call edebug-defun for defuns or defmacros. +Also, this eval-region does not narrow to the region and +if an error occurs, point is left at the error." + ;; One other piddling difference concerns whitespace after the expression. + (interactive "r") + (let ((standard-output (or edebug-e-r-output 'symbolp)) + (edebug-e-r-pnt (point)) + (edebug-e-r-buf (current-buffer)) + (edebug-e-r-inside-buf (current-buffer)) + ;; Mark the end because it may move. + (edebug-e-r-end-marker (set-marker (make-marker) edebug-e-r-end)) + edebug-e-r-val + ) + (goto-char edebug-e-r-start) + (edebug-skip-whitespace) + (while (< (point) edebug-e-r-end-marker) + (if (and edebug-all-defuns + (eq 'lparen (edebug-next-token-class)) + (save-excursion + (forward-char 1) ; skip \( + (memq (edebug-read-sexp) '(defun defmacro)))) + (progn + (edebug-defun) + ;; Potential problem: edebug-defun always prints name. + (forward-sexp 1) ; skip the defun + ) + (if (and (eq 'lparen (edebug-next-token-class)) + (save-excursion + (forward-char 1) ; skip \( + (memq (edebug-read-sexp) '(defun defmacro)))) + ;; If it's a defun or defmacro, but not edebug-all-defuns + ;; reset the symbols edebug property to be just a marker at + ;; the definitions source code. + (put (edebug-which-function) 'edebug (point-marker))) + + ;; Evaluate normally - after restoring the current-buffer. + (setq edebug-e-r-val (edebug-read-sexp)) + (save-excursion + (set-buffer edebug-e-r-inside-buf) + (setq edebug-e-r-val (eval edebug-e-r-val)) + ;; Remember current buffer for next time. + (setq edebug-e-r-inside-buf (current-buffer))) + + (if edebug-e-r-output + (progn + (setq values (cons edebug-e-r-val values)) + (if (eq standard-output t) + (prin1 edebug-e-r-val) + (print edebug-e-r-val)))) + ) + (goto-char + (min (max edebug-e-r-end-marker (point)) + (progn (edebug-skip-whitespace) (point)))) + ) ; while + (if (null edebug-e-r-output) + ;; do the save-excursion recovery + (progn + ;; but mark is not restored + (set-buffer edebug-e-r-buf) + (goto-char edebug-e-r-pnt))) + nil + )) + + +;; The standard eval-current-buffer doesn't use eval-region. +(if (not (fboundp 'edebug-emacs-eval-current-buffer)) + (fset 'edebug-emacs-eval-current-buffer + (symbol-function 'eval-current-buffer))) +;; (fset 'eval-current-buffer (symbol-function 'edebug-emacs-eval-current-buffer)) + +(defun eval-current-buffer (&optional edebug-e-c-b-output) + "Call eval-region on the whole buffer." + (interactive) + (eval-region (point-min) (point-max) edebug-e-c-b-output)) + + + +;;;====================================================================== +;;; The Parser +;;; ---------- + +;;; The top level function for parsing defuns is edebug-defun; it +;;; calls all the rest. It checks the syntax a bit and leaves point +;;; at any error it finds, but otherwise should appear to work like +;;; eval-defun. + +;;; The basic plan is to surround each expression with a call to the +;;; function edebug together with indexes into a table of positions of +;;; all expressions. Thus an expression "exp" in function foo +;;; becomes: + +;;; (edebug 1 2 'exp) + +;;; First point moved to to the beginning of exp (offset 1 of the +;;; current function). Then the expression is evaluated and point is +;;; moved to offset 2, at the end of exp. + +;;; The top level expressions of the function are wrapped in a call to +;;; edebug-enter, which supplies the function name and the actual +;;; arguments to the function. See functions edebug and edebug-enter +;;; for more details. + + +(defun edebug-defun () + "Evaluate defun or defmacro, like eval-defun, but with edebug calls. +Print its name in the minibuffer and leave point after any error it finds, +with mark at the original point." + (interactive) + (let (def-kind ; whether defmacro or defun + def-name + def-args + def-docstring + defun-interactive + (edebug-offset-index 0) + edebug-offset-list + edebug-func-mark + (starting-point (point)) + tmp-point + (parse-sexp-ignore-comments t)) + + (condition-case err + (progn + (end-of-defun) + (beginning-of-defun) + (down-list 1) + + (setq edebug-func-mark (point-marker)) + (if (not (eq 'defun (setq def-kind (edebug-read-sexp)))) + (if (not (eq 'defmacro def-kind)) + (edebug-syntax-error "%s is not a defun or defmacro." + def-kind))) + (setq def-name (edebug-read-sexp)) + (if (not (symbolp def-name)) + (edebug-syntax-error "Bad defun name: %s" def-name)) + (setq def-args (edebug-read-sexp)) + (if (not (listp def-args)) + (edebug-syntax-error "Bad defun arg list: %s" def-args)) + + ;; look for doc string + (setq tmp-point (point)) + (if (eq 'string (edebug-next-token-class)) + (progn + (setq def-docstring (edebug-read-sexp)) + (setq tmp-point (point)))) + + ;; look for interactive form + (if (eq 'lparen (edebug-next-token-class)) + (progn + (forward-char 1) ; skip \( + (if (eq 'interactive (edebug-read-sexp)) + (progn + (setq defun-interactive + (cons 'interactive (edebug-interactive))) + (forward-char 1) ; skip \) + (setq tmp-point (point)) + )))) + + (goto-char tmp-point) + + ;; build the new definition + (fset def-name (` (lambda + (, def-args) + (, def-docstring) + (, defun-interactive) + ;; the remainder is a list of sexps + (edebug-enter + (quote (, def-name)) + (quote (, def-args)) + (quote (progn + (,@ (edebug-sexp-list t))))) + ))) + ;; if it is a defmacro, prepend 'macro + (if (eq 'defmacro def-kind) + (fset def-name (cons 'macro (symbol-function def-name)))) + + ;; recover point, like save-excursion but only if no error occurs + (goto-char starting-point) + + ;; store the offset list in functions property list + (put def-name 'edebug + (list edebug-func-mark + nil ; clear breakpoints + (vconcat (nreverse edebug-offset-list)))) + (message "edebug: %s" def-name) + ) ; progn + + (invalid-read-syntax + ;; Set mark at starting-point so user can return. + ;; Leave point at error. + (save-excursion + (goto-char starting-point) + (set-mark-command nil)) + (message "Syntax error: %s" (cdr err)) +;; (signal 'invalid-read-syntax (cdr err)) ; pass it on, to who? + ) + ) ; condition-case + def-name + )) + + +(defun edebug-sexp-list (debuggable) + "Return an edebug form built from the sexp list following point in the +current buffer. If DEBUGGABLE then wrap edebug calls around each sexp. +The sexp list does not start with a left paren; we are already in the list. +Leave point at (before) the trailing right paren." + (let (sexp-list) + (while (not (eq 'rparen (edebug-next-token-class))) + (setq sexp-list (cons (if debuggable + (edebug-form) + (edebug-read-sexp)) + sexp-list))) + (nreverse sexp-list))) + + +(defun edebug-increment-offset () + ;; accesses edebug-offset-index and edebug-offset-list + (setq edebug-offset-index (1+ edebug-offset-index)) + (setq edebug-offset-list (cons (- (point) edebug-func-mark) + edebug-offset-list))) + + +(defun edebug-make-edebug-form (index form) + "Return the edebug form for the current function at offset INDEX given FORM. +Looks like: (edebug def-name INDEX edebug-offset-index 'FORM). +Also increment the offset index." + (prog1 + (list 'edebug + index + edebug-offset-index + (list 'quote form)) + (edebug-increment-offset) + )) + + +(defun edebug-form () + "Return the debug form for the following form. Add the point offset +to the edebug-offset-list for the function and move point to +immediately after the form." + (let* ((index edebug-offset-index) + form class) + ;; The point must be added to the offset list now + ;; because edebug-list will add more offsets indirectly. + (edebug-skip-whitespace) + (edebug-increment-offset) + (setq class (edebug-next-token-class)) + (cond + ((eq 'lparen class) + (edebug-make-edebug-form index (edebug-list))) + + ((eq 'symbol class) + (if (and (not (memq (setq form (edebug-read-sexp)) '(nil t))) + ;; note: symbol includes numbers, see parsing utilities + (not (numberp form))) + (edebug-make-edebug-form index form) + form)) + (t (edebug-read-sexp))))) + + +(defun edebug-list () + "Return an edebug form built from the list form that follows point. +Insert debug calls as appropriate to the form. Start with point at +the left paren. Leave point after the right paren." + (let ((beginning (point)) + class + head) + + (forward-char 1) ; skip \( + (setq class (edebug-next-token-class)) + (cond + ((eq 'symbol class) + (setq head (edebug-read-sexp))) + ((eq 'lparen class) + (setq head (edebug-anonymous))) + ((eq 'rparen class) + (setq head nil)) + (t (edebug-syntax-error + "Head of list must be a symbol or lambda expression."))) + + (prog1 + (if head + (cons head + (cond + +;; None of the edebug-form-hooks defined below are used, for speed. +;; They are included for documentation, though the hook would not +;; necessarily behave the same as the function it is replacing. + +;;; Using the edebug-form-hooks should work, but would take more time. +;;; ((symbolp head) +;;; (let ((form (get head 'edebug-form-hook))) +;;; (if form +;;; (edebug-form-parser form) +;;; (if (edebug-macrop head) +;;; (if edebug-eval-macro-args +;;; (edebug-sexp-list t) +;;; (edebug-sexp-list nil)) +;;; ;; assume it is a function +;;; (edebug-sexp-list t))))) + + ;; handle all special-forms with unevaluated arguments + ((memq head '(let let*)) (edebug-let)) + ((memq head '(setq setq-default)) (edebug-setq)) + ((eq head 'cond) (edebug-cond)) + ((eq head 'condition-case) (edebug-condition-case)) + + ((memq head '(quote ; permits more than one arg + defun defvar defconst defmacro)) + (edebug-sexp-list nil)) + ((eq head 'function) + (list + (if (eq 'lparen (edebug-next-token-class)) + (edebug-anonymous) + (edebug-read-sexp) ; should be just a symbol + ))) + + ;; is it a lisp macro? + ((edebug-macrop head) + (or (and (symbolp head) + (let ((form (get head 'edebug-form-hook))) + (if form + (if (eq form t) + (edebug-sexp-list t) + (if (eq form 0) + (edebug-sexp-list nil) + (edebug-form-parser form)))))) + (edebug-sexp-list edebug-eval-macro-args))) + + ((eq head 'interactive) + (edebug-syntax-error "interactive not expected here.")) + + ;; otherwise it is a function call + (t (edebug-sexp-list t)) + ))) + + (if (eq 'rparen (edebug-next-token-class)) + (forward-char 1) ; skip \) + (edebug-syntax-error "Too many arguments.")) + ))) + + +(defun edebug-form-parser (args) + "Parse the macro arguments that follow based on ARGS. +ARGS describes the types of the arguments of a list form. Each of the ARGS +is processed left to right, in the same order as the arguments of the +list form. See the edebug documentation for more details. The ARGS +may be one of the following: + + symbolp - an unevaluated symbol + integerp - an unevaluated number + stringp - an unevaluated string + vectorp - an unevaluated vector + atom - an unevaluated number, string, symbol, or vector + + sexp - an unevaluated sexp (atom or list); may not be empty + form - an evaluated sexp; may not be empty + + foo - any other symbol should be the name of a function; this + function is called on the argument as a predicate and an error + is signaled if the predicate fails. + + &optional - one following arg in the list may or may not appear. + &rest - all following args are repeated zero or more times as a group. + This is an extension of the normal meaning of &rest. + &or - each of the following args are alternatives, processed left to + right until one succeeds. There is no way to group + more than one list element as one alternative. + + (...) - a sublist, of the same format as the top level, processed recursively. + Special case: if the car of the list is quote, the argument must match + the quoted sexp (see example below of 'for macro). +" + + (let ((arglist args) + arg form form-list class + &optional &rest &or) + (while (and arglist + (not (eq 'rparen (setq class (edebug-next-token-class))))) + (catch 'no-match + (setq arg (car arglist)) + (setq arglist (cdr arglist)) + (if (and &rest (null arglist)) + (setq arglist &rest)) + + (cond + ((memq arg '(&optional &rest &or)) + ;; remember arglist at this point + (set arg arglist) + (throw 'no-match nil)) + + ((eq arg 'form) + (setq form (edebug-form))) + + ((eq arg 'sexp) + (setq form (edebug-read-sexp))) + + ((listp arg) + (if (eq 'quote (car arg)) + ;; special case, match the quoted symbol + (let ((pnt (point))) + (setq arg (car (cdr arg))) + (if (not (eq arg (setq form (edebug-read-sexp)))) + (edebug-form-parser-error) + )) + (if (eq class 'lparen) + (progn + (forward-char 1) ; skip \( + (setq form (edebug-form-parser arg)) + (forward-char 1) ; skip \) + )))) + ((symbolp arg) + (let ((pnt (point)) + (pred (if (fboundp arg) (symbol-function arg)))) + (and pred + (not (funcall pred (setq form (edebug-read-sexp)))) + (edebug-form-parser-error) + ))) + (t (throw 'no-match nil)) + ) ; cond + (setq &optional nil) ; only lasts for one match + (setq form-list (cons form form-list)) ; skipped by no-match throw + )) ; while + + (if (and arglist (not (or &optional &rest + (memq (car arglist) '(&optional &rest))))) + (edebug-syntax-error "Not enough arguments.")) + (if (not (eq 'rparen (edebug-next-token-class))) + (if &or + (edebug-syntax-error "Unrecognized argument.") + (edebug-syntax-error "Too many arguments."))) + (nreverse form-list))) + + +(defun edebug-form-parser-error () + (goto-char pnt) + (if &or + (throw 'no-match nil) + (if &optional + (progn + (setq &optional nil) ; only lasts for one failed match not in &or + (throw 'no-match nil)) + (edebug-syntax-error "%s is not %s" form arg)))) + +;; for loop defined in elisp manual +(put 'for 'edebug-form-hook + '(symbolp 'from form 'to form 'do &rest form)) + +;; case and do defined in cl.el +(put 'case 'edebug-form-hook + '(form &rest (sexp form))) + +(put 'do 'edebug-form-hook + '((&rest + &or symbolp + (symbolp &optional form + &optional form)) + (form &rest form) + &rest body)) + +(put 'defvar 'edebug-form-hook + (put 'defconst 'edebug-form-hook + '(symbolp &optional form &optional stringp))) + +(put 'defun 'edebug-form-hook + (put 'defmacro 'edebug-form-hook + '(symbolp (&rest symbolp) + &optional stringp + &optional ('interactive &or stringp form) + &rest form))) + +(put 'anonymous 'edebug-form-hook + '(&optional 'macro 'lambda (&rest symbolp) &rest form)) + +(defun edebug-anonymous () + "Return the edebug form for an anonymous lambda or macro. +Point starts before the left paren and ends after it." + (forward-char 1) ; skip \( + (prog1 + (let ((head (edebug-read-sexp))) + (cond + ((eq head 'lambda) + (edebug-lambda)) + ((eq head 'macro) + (if (not (eq 'lambda (edebug-read-sexp))) + (edebug-syntax-error "lambda expected.")) + (cons 'macro (edebug-lambda))) + (t (edebug-syntax-error "Anonymous lambda or macro expected.")))) + (forward-char 1) ; skip \) + )) + + +(defun edebug-lambda () + "Return the edebug form for the lambda form that follows. +Point starts after the lambda symbol and is moved to before the right paren." + (append + (list 'lambda (edebug-read-sexp)) ; the args + (edebug-sexp-list t))) ; the body + + + +(put 'let 'edebug-form-hook + (put 'let* 'edebug-form-hook + '((&rest + &or (symbolp &optional form) + symbolp) + &rest form))) + +(defun edebug-let () + "Return the edebug form of the let or let* form. +Leave point before the right paren." + (let (var-value-list + token + class) + (cons + ;; first process the var/value list + (if (not (eq 'lparen (edebug-next-token-class))) + (if (setq token (edebug-read-sexp)) + (edebug-syntax-error "Bad var list in let.") ; should be nil + token ; == nil + ) + + (forward-char 1) ; lparen + (while (not (eq 'rparen (setq class (edebug-next-token-class)))) + (setq var-value-list + (cons + (if (not (eq 'lparen class)) + (edebug-read-sexp) + (forward-char 1) ; lparen + (prog1 + (edebug-var-value) + (if (not (eq 'rparen (edebug-next-token-class))) + (edebug-syntax-error "Right paren expected in let.") + (forward-char 1) ; rparen + ))) + var-value-list))) + (forward-char 1) ; rparen + (nreverse var-value-list)) + + ;; now process the expression list + (edebug-sexp-list t)))) + + +(defun edebug-var-value () + "Return the edebug form of the var and optional value that follow point. +Leave point after the value, if there is one." + (list + (edebug-read-sexp) ; the variable + (and (not (eq 'rparen (edebug-next-token-class))) + (edebug-form)))) + + +(put 'setq 'edebug-form-hook + (put 'setq-default 'edebug-form-hook + '(&rest symbolp form))) + +(defun edebug-setq () + "Return the edebug form of the setq or setq-default var-value list." + (let (var-value-list) + (while (not (eq 'rparen (edebug-next-token-class))) + (setq var-value-list + (append var-value-list + (edebug-var-value)))) + var-value-list)) + + +(put 'interactive 'edebug-form-hook + '(&optional &or stringp form)) + +(defun edebug-interactive () + "Return the edebug form of the interactive form." + (list + (if (not (eq 'rparen (edebug-next-token-class))) + (if (eq 'string (edebug-next-token-class)) + (edebug-read-sexp) + (prog1 + (` (edebug-interactive-entry + (quote (, def-name)) + (quote ((,@ (edebug-form)))))) + (if (not (eq 'rparen (edebug-next-token-class))) + (edebug-syntax-error + "Only first expression used in interactive form."))))))) + + +(put 'cond 'edebug-form-hook + '(&rest (form &rest form))) + +(defun edebug-cond () + "Return the edebug form of the cond form." + (let (value-value-list + class) + (while (not (eq 'rparen (setq class (edebug-next-token-class)))) + (setq value-value-list + (cons + (if (not (eq 'lparen class)) + (let ((thing (edebug-read-sexp))) + (if thing + (edebug-syntax-error "Condition expected in cond") + nil)) + (forward-char 1) ; \( + (prog1 + (cons + (edebug-form) + (if (eq 'rparen (edebug-next-token-class)) + nil + (edebug-sexp-list t))) + (if (not (eq 'rparen (edebug-next-token-class))) + (edebug-syntax-error "Right paren expected in cond")) + (forward-char 1) ; \) + )) + value-value-list))) + (nreverse value-value-list))) + + +;; Bug: this doesnt support condition name lists +(put 'condition-case 'edebug-form-hook + '(symbolp + form + &rest (symbolp &optional form))) + +(defun edebug-condition-case () + "Return the edebug form of the condition-case form." + (cons + (let (token) + ;; read the variable or nil + (setq token (edebug-read-sexp)) + (if (not (symbolp token)) + (edebug-syntax-error + "Variable or nil required for condition-case; found: %s" token)) + token) + + (cons + (edebug-form) ; the form + + ;; process handlers + (let (symb-sexp-list + class) + (while (not (eq 'rparen (setq class (edebug-next-token-class)))) + (setq symb-sexp-list + (cons + (if (not (eq 'lparen class)) + (edebug-syntax-error "Bad handler in condition-case.") + (forward-char 1) ; \( + (prog1 + (cons + (edebug-read-sexp) ; the error-condition + (and (not (eq 'rparen (edebug-next-token-class))) + (edebug-sexp-list t))) + (forward-char 1) ; \) + )) + symb-sexp-list))) + (nreverse symb-sexp-list))))) + + + +;;------------------------------------------------ +;; Parser utilities + +(defun edebug-syntax-error (msg &rest args) + "Signal an invalid-read-syntax with MSG and ARGS. + This is caught by edebug-defun." + (signal 'invalid-read-syntax (apply 'format msg args))) + + +(defun edebug-skip-whitespace () + "Leave point before the next token, skipping white space and comments." + (skip-chars-forward " \t\r\n\f") + (while (= (following-char) ?\;) + (skip-chars-forward "^\n\r") ; skip the comment + (skip-chars-forward " \t\r\n\f"))) + +(defun edebug-read-sexp () + "Read one sexp from the current buffer starting at point. +Leave point immediately after it. A sexp can be a list or atom. +An atom is a symbol (or number), character, string, or vector." + ;; This is gummed up by parser inconsistencies (bugs?) + (let (token) + (edebug-skip-whitespace) + (if (or (= (following-char) ?\[) (= (following-char) ??)) + ;; scan-sexps doesn't read vectors or character literals correctly, + ;; but read does. + (setq token (read (current-buffer))) + (goto-char + (min ; use the lesser of the read and scan-sexps motion + ;; read goes one too far if (quoted) string or symbol + ;; is immediately followed by non-whitespace + (save-excursion + (setq token (read (current-buffer))) + (point)) + ;; scan-sexps reads too far if a quoting character is read + (scan-sexps (point) 1)))) + token)) + +(defconst edebug-syntax-table + (let ((table (make-vector 256 'symbol))) + ;; Treat numbers as symbols, because of confusion with -, -1, and 1-. + (aset table ?\( 'lparen) + (aset table ?\) 'rparen) + (aset table ?\' 'quote) + (aset table ?\" 'string) + (aset table ?\? 'char) + (aset table ?\[ 'vector) + (aset table ?\. 'dot) + ;; We dont care about any other chars since they wont be seen. + table) + "Lookup table for the token class of each character.") + +(defun edebug-next-token-class () + "Move to the next token and return its class. We only care about +lparen, rparen, dot, quote, string, char, vector, or symbol." + (edebug-skip-whitespace) + (aref edebug-syntax-table (following-char))) + + +;;;================================================================= +;;; The debugger itself +;;; ------------------- + + +(defvar edebug-active nil + "Non-nil when edebug is active") + + +;;; add minor-mode-alist entry +(or (assq 'edebug-active minor-mode-alist) + (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*") + minor-mode-alist))) + +(defvar edebug-backtrace nil + "Stack of active functions evaluated via edebug. +Should be nil at the top level.") + +(defvar edebug-offset-indices nil ; not used yet. + "Stack of offset indices of visited edebug sexps. +Should be nil at the top level.") + +(defvar edebug-entered nil + "Non-nil if edebug has already been entered at this recursive edit level.") + + +(defun edebug-enter (edebug-func edebug-args edebug-body) + "Entering FUNC. The arguments are ARGS, and the body is BODY. +Setup edebug variables and evaluate BODY. This function is called +when a function evaluated with edebug-defun is entered. Return the +result of BODY." + + ;; Is this the first time we are entering edebug since + ;; lower-level recursive-edit command? + (if (and (not edebug-entered) + edebug-initial-mode) + ;; Reset edebug-mode to the initial mode. + (setq edebug-mode edebug-initial-mode)) + (let* ((edebug-entered t) + (edebug-data (get edebug-func 'edebug)) + ;; pull out parts of the edebug-data + (edebug-func-mark (car edebug-data)) ; mark at function start + + (edebug-buffer (marker-buffer edebug-func-mark)) + (edebug-backtrace (cons edebug-func edebug-backtrace)) + (max-lisp-eval-depth (+ 6 max-lisp-eval-depth)) ; too much?? + (max-specpdl-size (+ 10 max-specpdl-size)) ; the args and these vars + ) + (if edebug-trace + (let ((edebug-stack-depth (1- (length edebug-backtrace))) + edebug-result) + (edebug-print-trace-entry + "*edebug-trace*" edebug-func edebug-args edebug-stack-depth) + (setq edebug-result (eval edebug-body)) + (edebug-print-trace-exit + "*edebug-trace*" edebug-func edebug-result edebug-stack-depth) + edebug-result) + (eval edebug-body) + ))) + +(defun edebug-interactive-entry (edebug-func edebug-args) + "Evaluating FUNCs non-string argument of interactive form ARGS." + (if (and (not edebug-entered) + edebug-initial-mode) + ;; Reset edebug-mode to the initial mode. + (setq edebug-mode edebug-initial-mode)) + (let* ((edebug-entered t) + (edebug-data (get edebug-func 'edebug)) + ;; pull out parts of the edebug-data + (edebug-func-mark (car edebug-data)) ; mark at function start + + (edebug-buffer (marker-buffer edebug-func-mark)) +;; (edebug-backtrace (cons edebug-func edebug-backtrace)) + ) + (eval edebug-args))) + + +(defun edebug-print-trace-entry + (edebug-stream edebug-function edebug-args edebug-stack-depth) + (edebug-trace-display + edebug-stream + "%sEnter: %s\n" (make-string edebug-stack-depth ?\ ) edebug-function) + ) + +(defun edebug-print-trace-exit + (edebug-stream edebug-function edebug-result edebug-stack-depth) + (edebug-trace-display + edebug-stream + "%sExit: %s\n" (make-string edebug-stack-depth ?\ ) edebug-function) + ) + + +(defun edebug (edebug-before-index edebug-after-index edebug-exp) + "Debug current function given BEFORE and AFTER positions around EXP. +BEFORE and AFTER are indexes into the position offset vector in the +functions 'edebug property. edebug is called from functions compiled +with edebug-defun." + (let ((max-lisp-eval-depth (+ 5 max-lisp-eval-depth)) ; enough?? + (max-specpdl-size (+ 7 max-specpdl-size)) ; the args and these vars + (edebug-offset-indices + (cons edebug-before-index edebug-offset-indices)) + ;; Save the outside value of executing macro. + (edebug-outside-executing-macro executing-macro) + ;; Don't keep reading from an executing kbd macro within edebug! + (executing-macro nil) + ) + (if (and (eq edebug-mode 'Go-nonstop) + (not (edebug-input-pending-p))) + ;; Just return evalled expression. + (eval edebug-exp) + (edebug-debugger edebug-before-index 'enter edebug-exp) + (edebug-debugger edebug-after-index 'exit (eval edebug-exp)) + ))) + + +(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-exp) + "Determine if edebug display should be updated." + (let* ( + ;; This needs to be here since breakpoints may be changed. + (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints + (edebug-break-data (assq edebug-offset-index edebug-breakpoints)) + (edebug-break + (if edebug-break-data + (let ((edebug-break-condition + (car (cdr edebug-break-data)))) + (or (not edebug-break-condition) + (eval edebug-break-condition))))) + ) + (if (and edebug-break + (car (cdr (cdr edebug-break-data)))) ; is it temporary? + ;; Delete the breakpoint. + (setcdr edebug-data + (cons (delq edebug-break-data edebug-breakpoints) + (cdr (cdr edebug-data))))) + + ;; Dont do anything if mode is go, continue, or Continue-fast + ;; and no break, and no input. + (if (or (and (not (memq edebug-mode '(go continue Continue-fast))) + (or edebug-stop-before-symbols + (not (and (eq edebug-arg-mode 'enter) + (symbolp edebug-exp))))) + (edebug-input-pending-p) + edebug-break) + (edebug-display)) + + edebug-exp + )) + + +(defvar edebug-window-start 0 + "Remember where each buffers' window starts between edebug calls. +This is to avoid spurious recentering.") + +(setq-default edebug-window-start 0) +(make-variable-buffer-local 'edebug-window-start) + +(defun edebug-display () + "Setup windows for edebug, determine mode, maybe enter recursive-edit." + ;; uses local variables of edebug-enter, edebug, and edebug-debugger. + (let ((edebug-active t) ; for minor mode alist + edebug-stop ; should we enter recursive-edit + (edebug-point (+ edebug-func-mark + (aref (car (cdr (cdr edebug-data))) + edebug-offset-index))) + (edebug-buffer-points + (if edebug-save-buffer-points (edebug-get-buffer-points))) + edebug-window ; window displaying edebug-buffer + edebug-inside-window ; window displayed after recursive edit + (edebug-outside-window (selected-window)) + (edebug-outside-buffer (current-buffer)) + (edebug-outside-point (point)) + (edebug-outside-mark (mark)) + edebug-outside-windows ; window or screen configuration + edebug-outside-edebug-point ; old point in edebug buffer + edebug-outside-edebug-mark + + edebug-eval-buffer ; declared here so we can kill it below + (edebug-eval-result-list (and edebug-eval-list + (edebug-eval-result-list))) + (edebug-outside-o-a-p overlay-arrow-position) + (edebug-outside-o-a-s overlay-arrow-string) + (edebug-outside-c-i-e-a cursor-in-echo-area) + + edebug-outside-point-min + edebug-outside-point-max + + overlay-arrow-position + overlay-arrow-string + (cursor-in-echo-area nil) + ;; any others?? + ) + (if (not (buffer-name edebug-buffer)) + (let (debug-on-error nil) + (error "Buffer defining %s not found." edebug-func))) + + ;; Save windows now before we modify them. + (if edebug-save-windows + (setq edebug-outside-windows + (edebug-current-window-configuration))) + + ;; If edebug-buffer is not currently displayed, + ;; first find a window for it. + (edebug-pop-to-buffer edebug-buffer) + (setq edebug-window (selected-window)) + + ;; Now display eval list, if any. + ;; This is done after the pop to edebug-buffer + ;; so that buffer-window correspondence is correct after quit. + (edebug-eval-display edebug-eval-result-list) + (select-window edebug-window) + + (if edebug-save-point + (progn + (setq edebug-outside-edebug-point (point)) + (setq edebug-outside-edebug-mark (mark)))) + + (edebug-save-restriction + (setq edebug-outside-point-min (point-min)) + (setq edebug-outside-point-max (point-max)) + (widen) + (goto-char edebug-point) + + (setq edebug-window-start + (edebug-adjust-window edebug-window-start)) + + (if (edebug-input-pending-p) ; not including keyboard macros + (progn + (setq edebug-mode 'step) + (setq edebug-stop t) + (edebug-stop) + ;; (discard-input) ; is this unfriendly?? + )) + (edebug-overlay-arrow) + + (cond + ((eq 'exit edebug-arg-mode) + ;; Display result of previous evaluation. + (setq edebug-previous-result edebug-exp) + (edebug-previous-result)) + + ((eq 'error edebug-arg-mode) + ;; Display error message + (beep) + (if (eq 'quit (car edebug-exp)) + (message "Quit") + (message "%s: %s" + (get (car edebug-exp) 'error-message) + (car (cdr edebug-exp))))) + + (edebug-break + (message "Break")) + (t (message ""))) + + (if edebug-break + (if (not (memq edebug-mode '(continue Continue-fast))) + (setq edebug-stop t) + (if (eq edebug-mode 'continue) + (edebug-sit-for 1) + (edebug-sit-for 0))) + ;; not edebug-break + (if (eq edebug-mode 'trace) + (edebug-sit-for 1) ; Force update and pause. + (if (eq edebug-mode 'Trace-fast) + (edebug-sit-for 0) ; Force update and continue. + ))) + + (unwind-protect + (if (or edebug-stop + (eq edebug-mode 'step) + (eq edebug-arg-mode 'error)) + (progn + (setq edebug-mode 'step) + (edebug-overlay-arrow) ; this doesnt always show up. + (edebug-recursive-edit));; <<<<<< Recursive edit + ) + + (if edebug-save-buffer-points + (edebug-set-buffer-points)) + ;; Since we may be in a save-excursion, in case of quit + ;; restore the outside window only. + (select-window edebug-outside-window) + ) ; unwind-protect + + ;; None of the following is done if quit or signal occurs. + (if edebug-save-point + ;; Restore point and mark in edebug-buffer. + ;; This does the save-excursion recovery only if no quit. + ;; If edebug-buffer == edebug-outside-buffer, + ;; then this is redundant with outside save-excursion. + (progn + (set-buffer edebug-buffer) + (goto-char edebug-outside-edebug-point) + (if (mark-marker) + (set-marker (mark-marker) edebug-outside-edebug-mark)) + )) + ) ; edebug-save-restriction + + ;; Restore windows, buffer, point, and mark. + (if edebug-save-windows + ;; Restore windows before continuing. + (edebug-set-window-configuration edebug-outside-windows)) + (set-buffer edebug-outside-buffer) + (goto-char edebug-outside-point) + (if (mark-marker) + (set-marker (mark-marker) edebug-outside-mark)) + ;; The following is not sufficient, and sometimes annoying. + ;; (if (memq edebug-mode '(go Go-nonstop)) + ;; (edebug-sit-for 0)) + )) + + +(defvar edebug-depth 0 + "Number of recursive edits started by edebug. +Should be 0 at the top level.") + +(defvar edebug-recursion-depth 0 + "Value of recursion-depth when edebug was called.") + + +(defun edebug-recursive-edit () + "Start up a recursive edit inside of edebug." + ;; The current buffer is the edebug-buffer, which is put into edebug-mode. + (let ((edebug-buffer-read-only buffer-read-only) + ;; match-data must be done in the outside buffer + (edebug-outside-match-data + (save-excursion + (set-buffer edebug-outside-buffer) + (match-data))) + + (edebug-depth (1+ edebug-depth)) + (edebug-recursion-depth (recursion-depth)) + edebug-entered ; bind locally to nil + edebug-backtrace-buffer ; each recursive edit gets its own + ;; The window configuration may be saved and restored + ;; during a recursive-edit + edebug-inside-windows + + (edebug-outside-map (current-local-map)) + (edebug-outside-standard-output standard-output) + (edebug-outside-standard-input standard-input) + + (edebug-outside-last-command-char last-command-char) + (edebug-outside-last-command last-command) + (edebug-outside-this-command this-command) + (edebug-outside-last-input-char last-input-char) +;; (edebug-outside-unread-command-char unread-command-char) + + ;; Declare the following local variables to protect global values. + ;; We could set these to the values for previous edebug call. + ;; But instead make it local, but use global value. + (last-command-char last-command-char) + (last-command last-command) + (this-command this-command) + (last-input-char last-input-char) + ;; Assume no edebug command sets unread-command-char. +;; (unread-command-char -1) + + (debug-on-error debug-on-error) + + ;; others?? + ) + + (if (and (eq edebug-mode 'go) + (not (memq edebug-arg-mode '(exit error)))) + (message "Break")) + (edebug-mode) + (if (boundp 'edebug-outside-debug-on-error) + (setq debug-on-error edebug-outside-debug-on-error)) + + (setq buffer-read-only t) + (unwind-protect + (recursive-edit) ; <<<<<<<<<< Recursive edit + + ;; Do the following, even if quit occurs. + (if edebug-backtrace-buffer + (kill-buffer edebug-backtrace-buffer)) + ;; Could be an option to keep eval display up. + (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) + + ;; Remember selected-window after recursive-edit. + (setq edebug-inside-window (selected-window)) + + (store-match-data edebug-outside-match-data) + + ;; Recursive edit may have changed buffers, + ;; so set it back before exiting let. + (if (buffer-name edebug-buffer) ; if it still exists + (progn + (set-buffer edebug-buffer) + (if (memq edebug-mode '(go Go-nonstop)) + (edebug-overlay-arrow)) + (setq buffer-read-only edebug-buffer-read-only) + (use-local-map edebug-outside-map) + ;; Remember current window-start for next visit. + (select-window edebug-window) + (if (eq edebug-buffer (window-buffer edebug-window)) + (setq edebug-window-start (window-start))) + (select-window edebug-inside-window) + )) + ))) + + +;;-------------------------- +;; Display related functions + +(defun edebug-adjust-window (old-start) + "Adjust window to fit as much as possible following point. +The display should prefer to start at OLD-START if point is not visible. +Return the new window-start." + (if (not (pos-visible-in-window-p)) + (progn + (set-window-start (selected-window) old-start) + (if (not (pos-visible-in-window-p)) + (let ((start (window-start)) + (pnt (point))) + (set-window-start + (selected-window) + (save-excursion + (forward-line + (if (< pnt start) -1 ; one line before + (- (/ (window-height) 2)) ; center the line + )) + (beginning-of-line) + (point))))))) + (window-start)) + + +(defconst edebug-arrow-alist + '((Continue-fast . ">") + (Trace-fast . ">") + (continue . ">") + (trace . "->") + (step . "=>") + (go . "<>") + (Go-nonstop . "..") ; not used + ) + "Association list of arrows for each edebug mode. +If you come up with arrows that make more sense, let me know.") + +(defun edebug-overlay-arrow () + "Set up the overlay arrow at beginning-of-line in current buffer. +The arrow string is derived from edebug-arrow-alist and edebug-mode." + (let* ((pos)) + (save-excursion + (beginning-of-line) + (setq pos (point))) + (setq overlay-arrow-string + (cdr (assq edebug-mode edebug-arrow-alist))) + (setq overlay-arrow-position (make-marker)) + (set-marker overlay-arrow-position pos (current-buffer)))) + + +(put 'edebug-outside-excursion 'edebug-form-hook + '(&rest form)) + +(defmacro edebug-outside-excursion (&rest body) + "Evaluate an expression list in the outside context. +Return the result of the last expression." + (` (save-excursion ; of current-buffer + (if edebug-save-windows + (progn + ;; After excursion, we will + ;; restore to current window configuration. + (setq edebug-inside-windows + (edebug-current-window-configuration)) + ;; Restore outside windows. + (edebug-set-window-configuration edebug-outside-windows))) + + (set-buffer edebug-buffer) + ;; Restore outside context. + (let ((edebug-inside-map (current-local-map)) + (last-command-char edebug-outside-last-command-char) + (last-command edebug-outside-last-command) + (this-command edebug-outside-this-command) +;; (unread-command-char edebug-outside-unread-command-char) + (last-input-char edebug-outside-last-input-char) + (overlay-arrow-position edebug-outside-o-a-p) + (overlay-arrow-string edebug-outside-o-a-s) + (cursor-in-echo-area edebug-outside-c-i-e-a) + (standard-output edebug-outside-standard-output) + (standard-input edebug-outside-standard-input) + (executing-macro edebug-outside-executing-macro) + ) + (unwind-protect + (save-restriction + (narrow-to-region edebug-outside-point-min + edebug-outside-point-max) + (save-excursion ; of edebug-buffer + (if edebug-save-point + (progn + (goto-char edebug-outside-edebug-point) + (if (mark-marker) + (set-marker (mark-marker) + edebug-outside-edebug-mark)) + )) + (use-local-map edebug-outside-map) + (store-match-data edebug-outside-match-data) + (select-window edebug-outside-window) + (set-buffer edebug-outside-buffer) + (goto-char edebug-outside-point) + (,@ body) + ) ; save-excursion + ) ; save-restriction + ;; Back to edebug-buffer. Restore rest of inside context. + (use-local-map edebug-inside-map) + (if edebug-save-windows + ;; Restore inside windows. + (edebug-set-window-configuration edebug-inside-windows)) + )) ; let + ))) + + +(defun edebug-toggle-save-windows () + "Toggle the edebug-save-windows variable. +Each time you toggle it, the inside and outside window configurations +become the same as the current configuration." + (interactive) + (if (setq edebug-save-windows (not edebug-save-windows)) + (setq edebug-inside-windows + (setq edebug-outside-windows + (edebug-current-window-configuration)))) + (message "Window saving is %s." + (if edebug-save-windows "on" "off"))) + + +(defun edebug-where () + "Show the debug windows and where we stopped in the program." + (interactive) + (if (not edebug-active) + (error "edebug is not active.")) + (edebug-pop-to-buffer edebug-buffer) + (goto-char edebug-point) ; from edebug + ) + +(defun edebug-view-outside () + "Change to the outside window configuration." + (interactive) + (if (not edebug-active) + (error "edebug is not active.")) + (setq edebug-inside-windows (edebug-current-window-configuration)) + (edebug-set-window-configuration edebug-outside-windows) + (goto-char edebug-outside-point) + (message "Window configuration outside of edebug. Return with %s" + (substitute-command-keys "\\<global-map>\\[edebug-where]"))) + + +(defun edebug-bounce-point () + "Bounce the point in the outside current buffer." + (interactive) + (if (not edebug-active) + (error "edebug is not active.")) + (save-excursion + ;; If the buffer's currently displayed, avoid the set-window-configuration. + (save-window-excursion + (edebug-pop-to-buffer edebug-outside-buffer) + ;; (edebug-sit-for 1) ; this shouldnt be necessary + (goto-char edebug-outside-point) + ;; (message "current buffer: %s" (current-buffer)) + (edebug-sit-for 1) + (edebug-pop-to-buffer edebug-buffer)))) + + + +;;-------------------------- +;; epoch related things + +(defvar edebug-epoch-running (and (boundp 'epoch::version) epoch::version) + "non-nil if epoch is running. +Windows are handled a little differently under epoch.") + + +(defun edebug-current-window-configuration () + "Return the current window or screen configuration." + (if edebug-epoch-running + (edebug-current-screen-configuration) + (current-window-configuration))) + + +(defun edebug-set-window-configuration (conf) + "Set the window or screen configuration to CONF." + (if edebug-epoch-running + (edebug-set-screen-configuration conf) + (set-window-configuration conf))) + + +(defun edebug-get-buffer-window (buffer) + (if edebug-epoch-running + (epoch::get-buffer-window buffer) + (get-buffer-window buffer))) + + +(defun edebug-pop-to-buffer (buffer) + "Like pop-to-buffer, but select a screen that buffer was shown in." + (let ((edebug-window (edebug-get-buffer-window buffer))) + (if edebug-window + (select-window edebug-window) + ;; It is not currently displayed, so find some place to display it. + (if edebug-epoch-running + ;; Select a screen that the buffer has been displayed in before + ;; or the current screen otherwise. + (select-screen + ;; allowed-screens in epoch 3.2, was called screens before that + (or (car (symbol-buffer-value 'allowed-screens buffer)) + (epoch::current-screen)))) + (if (one-window-p) + (split-window)) + (select-window (next-window)) + (set-window-buffer (selected-window) buffer) + (set-window-hscroll (selected-window) 0) + )) + ;; Selecting the window does not set the buffer. + (set-buffer buffer) + ) + + +(defun edebug-current-screen-configuration () + "Return an object recording the current configuration of Epoch screen-list. +The object is a list of pairs of the form (SCREEN . CONFIGURATION) +where SCREEN has window-configuration CONFIGURATION. The current +screen is the head of the list." + (let ((screen-list (epoch::screen-list 'unmapped)) + (current-screen (epoch::get-screen)) + (current-buffer (current-buffer)) + ) + ;; put current screen first + (setq screen-list (cons current-screen (delq current-screen screen-list))) + (prog1 + (mapcar (function + (lambda (screen) + (cons screen + (progn + (epoch::select-screen screen) + (current-window-configuration))))) + screen-list) + (epoch::select-screen current-screen) + (set-buffer current-buffer) + ))) + +(defun edebug-set-screen-configuration (sc) + "Set the window-configuration for all the screens in SC. +Set the current screen to be the head of SC." + (mapcar (function + (lambda (screen-conf) + (if (epoch::screen-p (car screen-conf)) ; still exist? + (progn + (epoch::select-screen (car screen-conf)) + (set-window-configuration (cdr screen-conf)))))) + sc) + (if (epoch::screen-p (car (car sc))) + (epoch::select-screen (car (car sc)))) + ) + + +(defun edebug-sit-for (arg) + (if edebug-epoch-running + (epoch::dispatch-events)) + (sit-for arg) +) + +(defun edebug-input-pending-p () + (if edebug-epoch-running + (epoch::dispatch-events)) + (input-pending-p) +) + + + +;;-------------------------- +;; breakpoint related functions + +(defun edebug-find-stop-point () + "Return (function . index) of the nearest edebug stop point." + (let* ((def-name (edebug-which-function)) + (edebug-data + (or (get def-name 'edebug) + (error + "%s must first be evaluated with edebug-defun." def-name))) + ;; pull out parts of edebug-data. + (edebug-func-mark (car edebug-data)) + (edebug-breakpoints (car (cdr edebug-data))) + + (offset-vector (car (cdr (cdr edebug-data)))) + (offset (- (save-excursion + (if (looking-at "[ \t]") + ;; skip backwards until non-whitespace, or bol + (skip-chars-backward " \t")) + (point)) + edebug-func-mark)) + len i) + ;; the offsets are in order so we can do a linear search + (setq len (length offset-vector)) + (setq i 0) + (while (and (< i len) (> offset (aref offset-vector i))) + (setq i (1+ i))) + (if (and (< i len) + (<= offset (aref offset-vector i))) + ;; return the relevant info + (cons def-name i) + (message "Point is not on an expression in %s." + def-name) + ))) + + +(defun edebug-next-breakpoint () + "Move point to the next breakpoint, or first if none past point." + (interactive) + (let ((edebug-stop-point (edebug-find-stop-point))) + (if edebug-stop-point + (let* ((def-name (car edebug-stop-point)) + (index (cdr edebug-stop-point)) + (edebug-data (get def-name 'edebug)) + + ;; pull out parts of edebug-data + (edebug-func-mark (car edebug-data)) + (edebug-breakpoints (car (cdr edebug-data))) + (offset-vector (car (cdr (cdr edebug-data)))) + breakpoint) + (if (not edebug-breakpoints) + (message "No breakpoints in this function.") + (let ((breaks edebug-breakpoints)) + (while (and breaks + (<= (car (car breaks)) index)) + (setq breaks (cdr breaks))) + (setq breakpoint + (if breaks + (car breaks) + ;; goto the first breakpoint + (car edebug-breakpoints))) + (goto-char (+ edebug-func-mark + (aref offset-vector (car breakpoint)))) + + (message (concat (if (car (cdr (cdr breakpoint))) + "Temporary " "") + (if (car (cdr breakpoint)) + (format "Condition: %s" + (prin1-to-string + (car (cdr breakpoint)))) + ""))) + )))))) + + +(defun edebug-modify-breakpoint (flag &optional condition temporary) + "Modify the breakpoint for the form at point or after it according +to FLAG: set if t, clear if nil. Then move to that point. +If CONDITION or TEMPORARY are non-nil, add those attributes to +the breakpoint. " + (let ((edebug-stop-point (edebug-find-stop-point))) + (if edebug-stop-point + (let* ((def-name (car edebug-stop-point)) + (index (cdr edebug-stop-point)) + (edebug-data (get def-name 'edebug)) + + ;; pull out parts of edebug-data + (edebug-func-mark (car edebug-data)) + (edebug-breakpoints (car (cdr edebug-data))) + (offset-vector (car (cdr (cdr edebug-data)))) + present) + ;; delete it either way + (setq present (assq index edebug-breakpoints)) + (setq edebug-breakpoints (delq present edebug-breakpoints)) + (if flag + (progn + ;; add it to the list and resort + (setq edebug-breakpoints + (edebug-sort-alist + (cons + (list index condition temporary) + edebug-breakpoints) '<)) + (message "Breakpoint set in %s." def-name)) + (if present + (message "Breakpoint unset in %s." def-name) + (message "No breakpoint here."))) + + (setcdr edebug-data + (cons edebug-breakpoints (cdr (cdr edebug-data)))) + (goto-char (+ edebug-func-mark (aref offset-vector index))) + )))) + +(defun edebug-set-breakpoint (arg) + "Set the breakpoint of nearest sexp. +With prefix argument, make it a temporary breakpoint." + (interactive "P") + (edebug-modify-breakpoint t nil arg)) + +(defun edebug-unset-breakpoint () + "Clear the breakpoint of nearest sexp." + (interactive) + (edebug-modify-breakpoint nil)) + +(defun edebug-set-conditional-breakpoint (arg condition) + "Set a conditional breakpoint at nearest sexp. +The condition is evaluated in the outside context. +With prefix argument, make it a temporary breakpoint." + (interactive "P\nxCondition: ") + (edebug-modify-breakpoint t condition arg)) + + +;;-------------------------- +;; Mode switching functions + +(defun edebug-set-mode (mode shortmsg msg) + "Set the edebug mode to MODE. +Display SHORTMSG, or MSG if not within edebug." + (interactive) + (setq edebug-mode mode) + (if (< 0 edebug-depth) + (if (eq (current-buffer) edebug-buffer) + (progn + (message shortmsg) + (exit-recursive-edit))) + (message msg))) + + +(defun edebug-step-through () + "Proceed to next debug step." + (interactive) + (edebug-set-mode 'step "" "edebug will stop before next eval.")) + +(defun edebug-go (arg) + "Go, evaluating until break. +With ARG set temporary break at stop point and go." + (interactive "P") + (if arg + (edebug-set-breakpoint t)) + (edebug-set-mode 'go "Go..." "edebug will go until break.")) + +(defun edebug-Go-nonstop () + "Go, evaluating without debugging." + (interactive) + (edebug-set-mode 'Go-nonstop "Go-Nonstop..." + "edebug will not stop at breaks.")) + +(defun edebug-forward-sexp (arg) + "Proceed from the current point to the end of the ARGth sexp ahead. +If there are not ARG sexps ahead, then do edebug-step-out." + (interactive "p") + (condition-case err + (let ((parse-sexp-ignore-comments t)) + ;; Call forward-sexp repeatedly until done or failure. + (forward-sexp arg) + (edebug-go t)) + (error + (edebug-step-out) + ))) + +(defun edebug-step-out () + "Proceed from the current point to the end of the containing sexp. +If there is no containing sexp that is not the top level defun, +go to the end of the last sexp, or if that is the same point, then step." + (interactive) + (condition-case err + (let ((parse-sexp-ignore-comments t)) + (up-list 1) + (save-excursion + ;; Is there still a containing expression? + (up-list 1)) + (edebug-go t)) + (error + ;; At top level - 1, so first check if there are more sexps at this level. + (let ((start-point (point))) +;; (up-list 1) + (down-list -1) + (if (= (point) start-point) + (edebug-step-through) ; No more at this level, so step. + (edebug-go t) + ))))) + + +(defun edebug-goto-here () + "Proceed to this stop point." + (interactive) + (edebug-go t) + ) + +(defun edebug-trace () + "Begin trace mode." + (interactive) + (edebug-set-mode 'trace "Tracing..." "edebug will trace with pause.")) + +(defun edebug-Trace-fast () + "Trace with no wait at each step." + (interactive) + (edebug-set-mode 'Trace-fast + "Trace fast..." "edebug will trace without pause.")) + +(defun edebug-continue () + "Begin continue mode." + (interactive) + (edebug-set-mode 'continue "Continue..." + "edebug will pause at breakpoints.")) + +(defun edebug-Continue-fast () + "Trace with no wait at each step." + (interactive) + (edebug-set-mode 'Continue-fast "Continue fast..." + "edebug will stop and go at breakpoints.")) + + +(defun edebug-step-in () + "Step into the function about to be called. +Do this before the arguments are evaluated since otherwise it will be +too late. One side effect of using edebug-step-in is that the next +time the function is called, edebug will be called there as well." + (interactive) + (if (not (eq 'enter edebug-arg-mode)) + (error "You must be in front of a function or macro call.")) + (let* ((func (car edebug-exp)) + (func-marker (get func 'edebug))) + (cond + ((markerp func-marker) + (save-excursion + (set-buffer (marker-buffer func-marker)) + (goto-char func-marker) + (edebug-defun))) + ((listp func-marker) + ;; its already been evaluated for edebug + nil) + (t (error "You must first evaluate %s in a buffer." func)))) + (exit-recursive-edit)) + + +;;(defun edebug-exit-out () +;; "Go until the current function exits." +;; (interactive) +;; (edebug-set-mode 'exiting "Exit...")) + + +(defun edebug-stop () + "Useful for exiting from trace loop." + (interactive) + (message "Stop")) + + +;;; The following initial mode setting definitions are not used yet. + +(defconst edebug-initial-mode-alist + '((edebug-Continue-fast . Continue-fast) + (edebug-Trace-fast . Trace-fast) + (edebug-continue . continue) + (edebug-trace . trace) + (edebug-go . go) + (edebug-step-through . step) + (edebug-Go-nonstop . Go-nonstop) + ) + "Association list between commands and the modes they set.") + + +(defun edebug-set-initial-mode () + "Ask for the initial mode of the enclosing function. +The mode is requested via the key that would be used to set the mode in +edebug-mode." + (interactive) + (let* ((this-function (edebug-which-function)) + (keymap (if (eq edebug-mode-map (current-local-map)) + edebug-mode-map)) + (old-mode (or (get this-function 'edebug-initial-mode) + edebug-initial-mode)) + (key (read-key-sequence + (format + "Change initial edebug mode for %s from %s (%s) to (enter key): " + this-function + old-mode + (where-is-internal + (car (rassq old-mode edebug-initial-mode-alist)) + keymap 'firstonly + )))) + (mode (cdr (assq (key-binding key) edebug-initial-mode-alist))) + ) + (if (and mode + (or (get this-function 'edebug-initial-mode) + (not (eq mode edebug-initial-mode)))) + (progn + (put this-function 'edebug-initial-mode mode) + (message "Initial mode for %s is now: %s" + this-function mode)) + (error "Key must map to one of the mode changing commands.") + ))) + + + +;;-------------------------- +;; Evaluation of expressions + +(defvar edebug-previous-result nil + "Last result returned from an expression.") + +(defun edebug-previous-result () + "Return the previous result." + (interactive) + (let ((print-escape-newlines t) + (print-length 20)) + (message "Result: %s" (prin1-to-string edebug-previous-result)))) + + +(defun edebug-eval (expr) + "Evaluate EXPR in the outside environment." + (if (not edebug-active) + (error "edebug is not active.")) + (edebug-outside-excursion + (eval expr))) + +(defun edebug-eval-expression (expr) + "Prompt and evaluate an expression in the outside environment. +Print result in minibuffer." + (interactive "xEval: ") + (prin1 (edebug-eval expr))) + +(defun edebug-eval-last-sexp () + "Evaluate sexp before point in the outside environment; +print value in minibuffer." + (interactive) + (prin1 (edebug-eval (edebug-last-sexp)))) + +(defun edebug-eval-print-last-sexp () + "Evaluate sexp before point in the outside environment; +print value into current buffer." + (interactive) + (let ((standard-output (current-buffer))) + (print + (condition-case err + (edebug-eval (edebug-last-sexp)) + (error (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err)))))))) + +;;;--------------------------------- +;;; edebug minor mode initialization + +(defvar edebug-mode 'step + "Current edebug mode set by user.") + +(defvar edebug-mode-map nil) +(if edebug-mode-map + nil + (progn + (setq edebug-mode-map (copy-keymap emacs-lisp-mode-map)) + ;; control + (define-key edebug-mode-map " " 'edebug-step-through) + (define-key edebug-mode-map "g" 'edebug-go) + (define-key edebug-mode-map "G" 'edebug-Go-nonstop) + (define-key edebug-mode-map "t" 'edebug-trace) + (define-key edebug-mode-map "T" 'edebug-Trace-fast) + (define-key edebug-mode-map "c" 'edebug-continue) + (define-key edebug-mode-map "C" 'edebug-Continue-fast) + + (define-key edebug-mode-map "f" 'edebug-forward-sexp) + (define-key edebug-mode-map "h" 'edebug-goto-here) + + (define-key edebug-mode-map "r" 'edebug-previous-result) + + (define-key edebug-mode-map "i" 'edebug-step-in) + (define-key edebug-mode-map "o" 'edebug-step-out) + +;; (define-key edebug-mode-map "m" 'edebug-set-initial-mode) + + (define-key edebug-mode-map "q" 'top-level) + (define-key edebug-mode-map "a" 'abort-recursive-edit) + (define-key edebug-mode-map "S" 'edebug-stop) + + ;; breakpoints + (define-key edebug-mode-map "b" 'edebug-set-breakpoint) + (define-key edebug-mode-map "u" 'edebug-unset-breakpoint) + (define-key edebug-mode-map "B" 'edebug-next-breakpoint) + (define-key edebug-mode-map "x" 'edebug-set-conditional-breakpoint) + + ;; evaluation + (define-key edebug-mode-map "e" 'edebug-eval-expression) + (define-key edebug-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) + (define-key edebug-mode-map "E" 'edebug-visit-eval-list) + + ;; views + (define-key edebug-mode-map "w" 'edebug-where) + (define-key edebug-mode-map "v" 'edebug-view-outside) + (define-key edebug-mode-map "p" 'edebug-bounce-point) + (define-key edebug-mode-map "W" 'edebug-toggle-save-windows) + + ;; misc + (define-key edebug-mode-map "?" 'edebug-help) + (define-key edebug-mode-map "d" 'edebug-backtrace) + + (define-key edebug-mode-map "-" 'negative-argument) + )) + + +(defvar global-edebug-prefix "\^XX" + "Prefix key for global edebug commands, available from any buffer.") + +(defvar global-edebug-map nil + "Global map of edebug commands, available from any buffer.") + +(if global-edebug-map + nil + (setq global-edebug-map (make-sparse-keymap)) + + (global-unset-key global-edebug-prefix) + (global-set-key global-edebug-prefix global-edebug-map) + +;; (define-key global-edebug-map "X" 'edebug-step-through) + (define-key global-edebug-map " " 'edebug-step-through) + (define-key global-edebug-map "g" 'edebug-go) + (define-key global-edebug-map "G" 'edebug-Go-nonstop) + (define-key global-edebug-map "t" 'edebug-trace) + (define-key global-edebug-map "T" 'edebug-Trace-fast) + (define-key global-edebug-map "c" 'edebug-continue) + (define-key global-edebug-map "C" 'edebug-Continue-fast) + +;; (define-key global-edebug-map "m" 'edebug-set-initial-mode) + (define-key global-edebug-map "b" 'edebug-set-breakpoint) + (define-key global-edebug-map "x" 'edebug-set-conditional-breakpoint) + (define-key global-edebug-map "u" 'edebug-unset-breakpoint) + (define-key global-edebug-map "w" 'edebug-where) + (define-key global-edebug-map "q" 'top-level) + ) + + +(defun edebug-help () + (interactive) + (describe-function 'edebug-mode)) + + +(defun edebug-mode () + "Mode for elisp buffers while in edebug. Under construction. + +There are both buffer local and global key bindings to several +functions. E.g. edebug-step-through is bound to +\\[edebug-step-through] in the debug buffer and +\\<global-map>\\[edebug-step-through] in any buffer. + +edebug buffer commands: +\\{edebug-mode-map} + +Global commands prefixed by global-edbug-prefix: +\\{global-edebug-map} + +Options: +edebug-all-defuns +edebug-eval-macro-args +edebug-stop-before-symbols +edebug-save-windows +edebug-save-point +edebug-save-buffer-points +edebug-initial-mode +edebug-trace +" + (use-local-map edebug-mode-map)) + + + +;;=============================================== +;; edebug eval list mode +;; A list of expressions and their evaluations is displayed +;; in edebug-eval-buffer + +(defvar edebug-eval-list nil + "List of expressions to evaluate.") + +;;(defvar edebug-eval-buffer "*edebug*" +;; "*Declared globally so edebug-eval-display can be called independent +;;of edebug (not implemented yet).") + + +(defun edebug-eval-result-list () + "Return a list of evaluations of edebug-eval-list" + ;; Assumes in outside environment. + (mapcar (function + (lambda (expr) + (condition-case err + (eval expr) + (error (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err)))) + ))) + edebug-eval-list)) + +(defun edebug-eval-display-list (edebug-eval-result-list) + ;; Assumes edebug-eval-buffer exists. + (let ((edebug-eval-list-temp edebug-eval-list) + (standard-output edebug-eval-buffer) + (edebug-display-line + (format ";%s\n" (make-string (- (window-width) 2) ?-)))) + (edebug-pop-to-buffer edebug-eval-buffer) + (erase-buffer) + (while edebug-eval-list-temp + (prin1 (car edebug-eval-list-temp)) (terpri) + (prin1 (car edebug-eval-result-list)) (terpri) + (princ edebug-display-line) + (setq edebug-eval-list-temp (cdr edebug-eval-list-temp)) + (setq edebug-eval-result-list (cdr edebug-eval-result-list))) + )) + +(defun edebug-create-eval-buffer () + (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer))) + (progn + (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) + (edebug-eval-mode)))) + +;; Should generalize this to be callable outside of edebug +;; with calls in user functions, e.g. (edebug-eval-display) + +(defun edebug-eval-display (edebug-eval-result-list) + "Display expressions and evaluations in EVAL-LIST. +It modifies the context by popping up the eval display." + (if edebug-eval-result-list + (progn + (edebug-create-eval-buffer) + (edebug-pop-to-buffer edebug-eval-buffer) + (edebug-eval-display-list edebug-eval-result-list) + ))) + +(defun edebug-eval-redisplay () + "Redisplay eval list in outside environment. +May only be called from within edebug-recursive-edit." + (edebug-create-eval-buffer) + (edebug-pop-to-buffer edebug-eval-buffer) + (edebug-outside-excursion + (edebug-eval-display-list (edebug-eval-result-list)) + )) + +(defun edebug-visit-eval-list () + (interactive) + (edebug-eval-redisplay) + (edebug-pop-to-buffer edebug-eval-buffer)) + + +(defun edebug-update-eval-list () + "Replace the evaluation list with the sexps now in the eval buffer." + (interactive) + (let ((starting-point (point)) + new-list) + (goto-char (point-min)) + ;; get the first expression + (edebug-skip-whitespace) + (if (not (eobp)) + (progn + (forward-sexp 1) + (setq new-list (cons (edebug-last-sexp) new-list)))) + + (while (re-search-forward "^;" nil t) + (forward-line 1) + (skip-chars-forward " \t\n\r") + (if (and (/= ?\; (following-char)) + (not (eobp))) + (progn + (forward-sexp 1) + (setq new-list (cons (edebug-last-sexp) new-list))))) + + (setq edebug-eval-list (nreverse new-list)) + (edebug-eval-redisplay) + (goto-char starting-point))) + + +(defun edebug-delete-eval-item () + "Delete the item under point and redisplay." + ;; could add arg to do repeatedly + (interactive) + (if (re-search-backward "^;" nil 'nofail) + (forward-line 1)) + (delete-region + (point) (progn (re-search-forward "^;" nil 'nofail) + (beginning-of-line) + (point))) + (edebug-update-eval-list)) + + + +(defvar edebug-eval-mode-map nil + "Keymap for edebug-eval-mode. Superset of lisp-interaction-mode.") + +(if edebug-eval-mode-map + nil + (setq edebug-eval-mode-map (copy-keymap lisp-interaction-mode-map)) + + (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where) + (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item) + (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list) + (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) + (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp) + ) + + +(defun edebug-eval-mode () + "Mode for data display buffer while in edebug. Under construction. +... ignore the following... +There are both buffer local and global key bindings to several +functions. E.g. edebug-step-through is bound to +\\[edebug-step-through] in the debug buffer and +\\<global-map>\\[edebug-step-through] in any buffer. + +Eval list buffer commands: +\\{edebug-eval-mode-map} + +Global commands prefixed by global-edbug-prefix: +\\{global-edebug-map} +" + (lisp-interaction-mode) + (setq major-mode 'edebug-eval-mode) + (setq mode-name "Edebug-Eval") + (use-local-map edebug-eval-mode-map)) + + +;;======================================== +;; Interface with standard debugger. + +(setq debugger 'edebug-debug) +;; (setq debugger 'debug) ; use the default + +;; Note that debug and its utilities must be byte-compiled to work, since +;; they depend on the backtrace looking a certain way. + +(defun edebug-debug (&rest debugger-args) + "Replacement for debug. +If an error or quit occurred and we are running an edebugged function, +show where we last were. Otherwise call debug normally." + (if (and edebug-backtrace ; anything active? + (eq (recursion-depth) edebug-recursion-depth) + ) + + ;; Where were we before the error occurred? + (let ((edebug-offset-index (car edebug-offset-indices)) + (edebug-arg-mode (car debugger-args)) + (edebug-exp (car (cdr debugger-args))) + edebug-break-data + edebug-break + (edebug-outside-debug-on-eror debug-on-error) + (debug-on-error nil)) + (edebug-display) + ) + + ;; Otherwise call debug normally. + ;; Still need to remove extraneous edebug calls from stack. + (apply 'debug debugger-args) + )) + + +(defun edebug-backtrace () + "Display a non-working backtrace. Better than nothing..." + (interactive) + (let ((old-buf (current-buffer))) + (if (not edebug-backtrace-buffer) + (setq edebug-backtrace-buffer + (let ((default-major-mode 'fundamental-mode)) + (generate-new-buffer "*Backtrace*")))) + (edebug-pop-to-buffer edebug-backtrace-buffer) + (erase-buffer) + (let ((standard-output (current-buffer)) + (print-escape-newlines t) + (print-length 50) + last-ok-point + ) + (setq truncate-lines t) + (backtrace) + + ;; Clean up the backtrace. + (goto-char (point-min)) + (delete-region + (point) + (progn + ;; Everything up to the first edebug is internal. + (re-search-forward "^ edebug(") + (forward-line 1) + (point))) + (forward-line 1) + (setq last-ok-point (point)) + + ;; Delete interspersed edebug internals. + (while (re-search-forward "^ edebug" nil t) + (if (looking-at "-enter") + ;; delete extraneous progn at top level of function body + (save-excursion + (goto-char last-ok-point) + (forward-line -1) + (setq last-ok-point (point)))) + (forward-line 1) + (delete-region last-ok-point (point)) + (forward-line 1) ; skip past the good line + (setq last-ok-point (point)) + ) + ) + (edebug-pop-to-buffer old-buf) + )) + + +;;======================================================================== +;; Trace display - append text to a buffer, and update display. +;;; e.g. +;;; (edebug-trace-display +;;; "*trace-point*" +;;; "saving: point = %s window-start = %s\n" +;;; (point) (window-start)) + +(defun edebug-trace-display (buf-name fmt &rest args) + "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible. +The buffer is created if it does not exist. +You must include newlines in FMT to break lines." + (let* ((selected-window (selected-window)) + (buffer (get-buffer-create buf-name)) + (buf-window)) + (edebug-pop-to-buffer buffer) + (save-excursion + (setq buf-window (selected-window)) + (set-buffer buffer) + (goto-char (point-max)) + (insert (apply 'format fmt args)) + (set-window-point buf-window (point)) + (forward-line (- 1 (window-height buf-window))) + (set-window-start buf-window (point)) +;; (edebug-sit-for 1) + (bury-buffer buffer) + ) + (select-window selected-window))) + +;;; edebug.el ends here