--- /dev/null
+;; Run gdb under Emacs
+;; Copyright (C) 1988 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.
+
+;; Author: W. Schelter, University of Texas
+;; wfs@rascal.ics.utexas.edu
+;; Rewritten by rms.
+
+;; Some ideas are due to Masanobu.
+
+;; Description of GDB interface:
+
+;; A facility is provided for the simultaneous display of the source code
+;; in one window, while using gdb to step through a function in the
+;; other. A small arrow in the source window, indicates the current
+;; line.
+
+;; Starting up:
+
+;; In order to use this facility, invoke the command GDB to obtain a
+;; shell window with the appropriate command bindings. You will be asked
+;; for the name of a file to run. Gdb will be invoked on this file, in a
+;; window named *gdb-foo* if the file is foo.
+
+;; M-s steps by one line, and redisplays the source file and line.
+
+;; You may easily create additional commands and bindings to interact
+;; with the display. For example to put the gdb command next on \M-n
+;; (def-gdb next "\M-n")
+
+;; This causes the emacs command gdb-next to be defined, and runs
+;; gdb-display-frame after the command.
+
+;; gdb-display-frame is the basic display function. It tries to display
+;; in the other window, the file and line corresponding to the current
+;; position in the gdb window. For example after a gdb-step, it would
+;; display the line corresponding to the position for the last step. Or
+;; if you have done a backtrace in the gdb buffer, and move the cursor
+;; into one of the frames, it would display the position corresponding to
+;; that frame.
+
+;; gdb-display-frame is invoked automatically when a filename-and-line-number
+;; appears in the output.
+
+
+(require 'shell)
+
+(defvar gdb-prompt-pattern "^(.*gdb[+]?) *"
+ "A regexp to recognize the prompt for gdb or gdb+.")
+
+(defvar gdb-mode-map nil
+ "Keymap for gdb-mode.")
+
+(if gdb-mode-map
+ nil
+ (setq gdb-mode-map (copy-keymap shell-mode-map))
+ (define-key gdb-mode-map "\C-l" 'gdb-refresh))
+
+(define-key ctl-x-map " " 'gdb-break)
+(define-key ctl-x-map "&" 'send-gdb-command)
+
+;;Of course you may use `def-gdb' with any other gdb command, including
+;;user defined ones.
+
+(defmacro def-gdb (name key &optional doc)
+ (let* ((fun (intern (format "gdb-%s" name)))
+ (cstr (list 'if '(not (= 1 arg))
+ (list 'format "%s %s" name 'arg)
+ name)))
+ (list 'progn
+ (list 'defun fun '(arg)
+ (or doc "")
+ '(interactive "p")
+ (list 'gdb-call cstr))
+ (list 'define-key 'gdb-mode-map key (list 'quote fun)))))
+
+(def-gdb "step" "\M-s" "Step one source line with display")
+(def-gdb "stepi" "\M-i" "Step one instruction with display")
+(def-gdb "next" "\M-n" "Step one source line (skip functions)")
+(def-gdb "cont" "\M-c" "Continue with display")
+
+(def-gdb "finish" "\C-c\C-f" "Finish executing current function")
+(def-gdb "up" "\M-u" "Go up N stack frames (numeric arg) with display")
+(def-gdb "down" "\M-d" "Go down N stack frames (numeric arg) with display")
+\f
+(defun gdb-mode ()
+ "Major mode for interacting with an inferior Gdb process.
+The following commands are available:
+
+\\{gdb-mode-map}
+
+\\[gdb-display-frame] displays in the other window
+the last line referred to in the gdb buffer.
+
+\\[gdb-step],\\[gdb-next], and \\[gdb-nexti] in the gdb window,
+call gdb to step,next or nexti and then update the other window
+with the current file and position.
+
+If you are in a source file, you may select a point to break
+at, by doing \\[gdb-break].
+
+Commands:
+Many commands are inherited from shell mode.
+Additionally we have:
+
+\\[gdb-display-frame] display frames file in other window
+\\[gdb-step] advance one line in program
+\\[gdb-next] advance one line in program (skip over calls).
+\\[send-gdb-command] used for special printing of an arg at the current point.
+C-x SPACE sets break point at current line."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'gdb-mode)
+ (setq mode-name "Inferior Gdb")
+ (setq mode-line-process '(": %s"))
+ (use-local-map gdb-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-local-variable 'gdb-last-frame)
+ (setq gdb-last-frame nil)
+ (make-local-variable 'gdb-last-frame-displayed-p)
+ (setq gdb-last-frame-displayed-p t)
+ (make-local-variable 'gdb-delete-prompt-marker)
+ (setq gdb-delete-prompt-marker nil)
+ (make-local-variable 'gdb-filter-accumulator)
+ (setq gdb-filter-accumulator nil)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern gdb-prompt-pattern)
+ (run-hooks 'shell-mode-hook 'gdb-mode-hook))
+
+(defvar current-gdb-buffer nil)
+
+(defvar gdb-command-name "gdb"
+ "Pathname for executing gdb.")
+
+(defun gdb (path)
+ "Run gdb on program FILE in buffer *gdb-FILE*.
+The directory containing FILE becomes the initial working directory
+and source-file directory for GDB. If you wish to change this, use
+the GDB commands `cd DIR' and `directory'."
+ (interactive "FRun gdb on file: ")
+ (setq path (expand-file-name path))
+ (let ((file (file-name-nondirectory path)))
+ (switch-to-buffer (concat "*gdb-" file "*"))
+ (setq default-directory (file-name-directory path))
+ (or (bolp) (newline))
+ (insert "Current directory is " default-directory "\n")
+ (make-shell (concat "gdb-" file) gdb-command-name nil "-fullname"
+ "-cd" default-directory file)
+ (gdb-mode)
+ (set-process-filter (get-buffer-process (current-buffer)) 'gdb-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer)) 'gdb-sentinel)
+ (gdb-set-buffer)))
+
+(defun gdb-set-buffer ()
+ (cond ((eq major-mode 'gdb-mode)
+ (setq current-gdb-buffer (current-buffer)))))
+\f
+;; This function is responsible for inserting output from GDB
+;; into the buffer.
+;; Aside from inserting the text, it notices and deletes
+;; each filename-and-line-number;
+;; that GDB prints to identify the selected frame.
+;; It records the filename and line number, and maybe displays that file.
+(defun gdb-filter (proc string)
+ (let ((inhibit-quit t))
+ (if gdb-filter-accumulator
+ (gdb-filter-accumulate-marker proc
+ (concat gdb-filter-accumulator string))
+ (gdb-filter-scan-input proc string))))
+
+(defun gdb-filter-accumulate-marker (proc string)
+ (setq gdb-filter-accumulator nil)
+ (if (> (length string) 1)
+ (if (= (aref string 1) ?\032)
+ (let ((end (string-match "\n" string)))
+ (if end
+ (progn
+ (let* ((first-colon (string-match ":" string 2))
+ (second-colon
+ (string-match ":" string (1+ first-colon))))
+ (setq gdb-last-frame
+ (cons (substring string 2 first-colon)
+ (string-to-int
+ (substring string (1+ first-colon)
+ second-colon)))))
+ (setq gdb-last-frame-displayed-p nil)
+ (gdb-filter-scan-input proc
+ (substring string (1+ end))))
+ (setq gdb-filter-accumulator string)))
+ (gdb-filter-insert proc "\032")
+ (gdb-filter-scan-input proc (substring string 1)))
+ (setq gdb-filter-accumulator string)))
+
+(defun gdb-filter-scan-input (proc string)
+ (if (equal string "")
+ (setq gdb-filter-accumulator nil)
+ (let ((start (string-match "\032" string)))
+ (if start
+ (progn (gdb-filter-insert proc (substring string 0 start))
+ (gdb-filter-accumulate-marker proc
+ (substring string start)))
+ (gdb-filter-insert proc string)))))
+
+(defun gdb-filter-insert (proc string)
+ (let ((moving (= (point) (process-mark proc)))
+ (output-after-point (< (point) (process-mark proc)))
+ (old-buffer (current-buffer))
+ start)
+ (set-buffer (process-buffer proc))
+ (unwind-protect
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark proc))
+ (setq start (point))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ (gdb-maybe-delete-prompt)
+ ;; Check for a filename-and-line number.
+ (gdb-display-frame
+ ;; Don't display the specified file
+ ;; unless (1) point is at or after the position where output appears
+ ;; and (2) this buffer is on the screen.
+ (or output-after-point
+ (not (get-buffer-window (current-buffer))))
+ ;; Display a file only when a new filename-and-line-number appears.
+ t))
+ (set-buffer old-buffer))
+ (if moving (goto-char (process-mark proc)))))
+
+(defun gdb-sentinel (proc msg)
+ (cond ((null (buffer-name (process-buffer proc)))
+ ;; buffer killed
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ (set-process-buffer proc nil))
+ ((memq (process-status proc) '(signal exit))
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ ;; Fix the mode line.
+ (setq mode-line-process
+ (concat ": "
+ (symbol-name (process-status proc))))
+ (let* ((obuf (current-buffer)))
+ ;; save-excursion isn't the right thing if
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+ ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+ (if (eobp)
+ (insert ?\n mode-name " " msg)
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n mode-name " " msg)))
+ ;; If buffer and mode line will show that the process
+ ;; is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (delete-process proc))
+ ;; Restore old buffer, but don't restore old point
+ ;; if obuf is the gdb buffer.
+ (set-buffer obuf))))))
+
+
+(defun gdb-refresh ()
+ "Fix up a possibly garbled display, and redraw the arrow."
+ (interactive)
+ (redraw-display)
+ (gdb-display-frame))
+
+(defun gdb-display-frame (&optional nodisplay noauto)
+ "Find, obey and delete the last filename-and-line marker from GDB.
+The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
+Obeying it means displaying in another window the specified file and line."
+ (interactive)
+ (gdb-set-buffer)
+ (and gdb-last-frame (not nodisplay)
+ (or (not gdb-last-frame-displayed-p) (not noauto))
+ (progn (gdb-display-line (car gdb-last-frame) (cdr gdb-last-frame))
+ (setq gdb-last-frame-displayed-p t))))
+
+;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
+;; and that its line LINE is visible.
+;; Put the overlay-arrow on the line LINE in that buffer.
+
+(defun gdb-display-line (true-file line)
+ (let* ((buffer (find-file-noselect true-file))
+ (window (display-buffer buffer t))
+ (pos))
+ (save-excursion
+ (set-buffer buffer)
+ (save-restriction
+ (widen)
+ (goto-line line)
+ (setq pos (point))
+ (setq overlay-arrow-string "=>")
+ (or overlay-arrow-position
+ (setq overlay-arrow-position (make-marker)))
+ (set-marker overlay-arrow-position (point) (current-buffer)))
+ (cond ((or (< pos (point-min)) (> pos (point-max)))
+ (widen)
+ (goto-char pos))))
+ (set-window-point window overlay-arrow-position)))
+\f
+(defun gdb-call (command)
+ "Invoke gdb COMMAND displaying source in other window."
+ (interactive)
+ (goto-char (point-max))
+ (setq gdb-delete-prompt-marker (point-marker))
+ (gdb-set-buffer)
+ (send-string (get-buffer-process current-gdb-buffer)
+ (concat command "\n")))
+
+(defun gdb-maybe-delete-prompt ()
+ (if (and gdb-delete-prompt-marker
+ (> (point-max) (marker-position gdb-delete-prompt-marker)))
+ (let (start)
+ (goto-char gdb-delete-prompt-marker)
+ (setq start (point))
+ (beginning-of-line)
+ (delete-region (point) start)
+ (setq gdb-delete-prompt-marker nil))))
+
+(defun gdb-break ()
+ "Set GDB breakpoint at this source line."
+ (interactive)
+ (let ((file-name (file-name-nondirectory buffer-file-name))
+ (line (save-restriction
+ (widen)
+ (1+ (count-lines 1 (point))))))
+ (send-string (get-buffer-process current-gdb-buffer)
+ (concat "break " file-name ":" line "\n"))))
+
+(defun gdb-read-address()
+ "Return a string containing the core-address found in the buffer at point."
+ (save-excursion
+ (let ((pt (dot)) found begin)
+ (setq found (if (search-backward "0x" (- pt 7) t)(dot)))
+ (cond (found (forward-char 2)(setq result
+ (buffer-substring found
+ (progn (re-search-forward "[^0-9a-f]")
+ (forward-char -1)
+ (dot)))))
+ (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1)
+ (dot)))
+ (forward-char 1)
+ (re-search-forward "[^0-9]")
+ (forward-char -1)
+ (buffer-substring begin (dot)))))))
+
+
+(defvar gdb-commands nil
+ "List of strings or functions used by send-gdb-command.
+It is for customization by you.")
+
+(defun send-gdb-command (arg)
+
+ "This command reads the number where the cursor is positioned. It
+ then inserts this ADDR at the end of the gdb buffer. A numeric arg
+ selects the ARG'th member COMMAND of the list gdb-print-command. If
+ COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise
+ (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\"
+ is a possible string to be a member of gdb-commands. "
+
+
+ (interactive "P")
+ (let (comm addr)
+ (if arg (setq comm (nth arg gdb-commands)))
+ (setq addr (gdb-read-address))
+ (if (eq (current-buffer) current-gdb-buffer)
+ (set-mark (point)))
+ (cond (comm
+ (setq comm
+ (if (stringp comm) (format comm addr) (funcall comm addr))))
+ (t (setq comm addr)))
+ (switch-to-buffer current-gdb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
--- /dev/null
+;; Rebindings to imitate Gosmacs.
+;; Copyright (C) 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.
+
+
+(defvar non-gosmacs-binding-alist nil)
+
+(defun set-gosmacs-bindings ()
+ "Rebind some keys globally to make GNU Emacs resemble Gosling Emacs.
+Use \\[set-gnu-bindings] to restore previous global bindings."
+ (interactive)
+ (setq non-gosmacs-binding-alist
+ (rebind-and-record
+ '(("\C-x\C-e" compile)
+ ("\C-x\C-f" save-buffers-kill-emacs)
+ ("\C-x\C-i" insert-file)
+ ("\C-x\C-m" save-some-buffers)
+ ("\C-x\C-n" next-error)
+ ("\C-x\C-o" switch-to-buffer)
+ ("\C-x\C-r" insert-file)
+ ("\C-x\C-u" undo)
+ ("\C-x\C-v" find-file-other-window)
+ ("\C-x\C-z" shrink-window)
+ ("\C-x!" shell-command)
+ ("\C-xd" delete-window)
+ ("\C-xn" gosmacs-next-window)
+ ("\C-xp" gosmacs-previous-window)
+ ("\C-xz" enlarge-window)
+ ("\C-z" scroll-one-line-up)
+ ("\e\C-c" save-buffers-kill-emacs)
+ ("\e!" line-to-top-of-window)
+ ("\e(" backward-paragraph)
+ ("\e)" forward-paragraph)
+ ("\e?" apropos)
+ ("\eh" delete-previous-word)
+ ("\ej" indent-sexp)
+ ("\eq" query-replace)
+ ("\er" replace-string)
+ ("\ez" scroll-one-line-down)
+ ("\C-_" suspend-emacs)))))
+
+(defun rebind-and-record (bindings)
+ "Establish many new global bindings and record the bindings replaced.
+Arg is an alist whose elements are (KEY DEFINITION).
+Value is a similar alist whose elements describe the same KEYs
+but each with the old definition that was replaced,"
+ (let (old)
+ (while bindings
+ (let* ((this (car bindings))
+ (key (car this))
+ (newdef (nth 1 this)))
+ (setq old (cons (list key (lookup-key global-map key)) old))
+ (global-set-key key newdef))
+ (setq bindings (cdr bindings)))
+ (nreverse old)))
+
+(defun set-gnu-bindings ()
+ "Restore the global bindings that were changed by \\[set-gosmacs-bindings]."
+ (interactive)
+ (rebind-and-record non-gosmacs-binding-alist))
+
+(defun gosmacs-previous-window ()
+ "Select the window above or to the left of the window now selected.
+From the window at the upper left corner, select the one at the lower right."
+ (interactive)
+ (select-window (previous-window)))
+
+(defun gosmacs-next-window ()
+ "Select the window below or to the right of the window now selected.
+From the window at the lower right corner, select the one at the upper left."
+ (interactive)
+ (select-window (next-window)))
+
+(defun scroll-one-line-up (&optional arg)
+ "Scroll the selected window up (forward in the text) one line (or N lines)."
+ (interactive "p")
+ (scroll-up (or arg 1)))
+
+(defun scroll-one-line-down (&optional arg)
+ "Scroll the selected window down (backward in the text) one line (or N)."
+ (interactive "p")
+ (scroll-down (or arg 1)))
+
+(defun line-to-top-of-window ()
+ "Scroll the selected window up so that the current line is at the top."
+ (interactive)
+ (recenter 0))
--- /dev/null
+;; Load this file to add a new level (starting at zero)
+;; to the Emacs version number recorded in version.el.
+;; Copyright (C) 1985 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.
+
+
+(insert-file-contents "lisp/version.el")
+
+(re-search-forward "emacs-version \"[0-9.]*")
+(insert ".0")
+
+;; Delete the share-link with the current version
+;; so that we do not alter the current version.
+(delete-file "lisp/version.el")
+(write-region (point-min) (point-max) "lisp/version.el" nil 'nomsg)
--- /dev/null
+;; Help commands for Emacs
+;; 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.
+
+
+(defvar help-map (make-sparse-keymap)
+ "Keymap for characters following the Help key.")
+
+(define-key global-map "\C-h" 'help-command)
+(fset 'help-command help-map)
+
+(define-key help-map "\C-h" 'help-for-help)
+(define-key help-map "?" 'help-for-help)
+
+(define-key help-map "\C-c" 'describe-copying)
+(define-key help-map "\C-d" 'describe-distribution)
+(define-key help-map "\C-w" 'describe-no-warranty)
+(define-key help-map "a" 'command-apropos)
+
+(define-key help-map "b" 'describe-bindings)
+
+(define-key help-map "c" 'describe-key-briefly)
+(define-key help-map "k" 'describe-key)
+
+(define-key help-map "d" 'describe-function)
+(define-key help-map "f" 'describe-function)
+
+(define-key help-map "i" 'info)
+
+(define-key help-map "l" 'view-lossage)
+
+(define-key help-map "m" 'describe-mode)
+
+(define-key help-map "\C-n" 'view-emacs-news)
+(define-key help-map "n" 'view-emacs-news)
+
+(define-key help-map "s" 'describe-syntax)
+
+(define-key help-map "t" 'help-with-tutorial)
+
+(define-key help-map "w" 'where-is)
+
+(define-key help-map "v" 'describe-variable)
+
+(defun help-with-tutorial ()
+ "Select the Emacs learn-by-doing tutorial."
+ (interactive)
+ (let ((file (expand-file-name "~/TUTORIAL")))
+ (delete-other-windows)
+ (if (get-file-buffer file)
+ (switch-to-buffer (get-file-buffer file))
+ (switch-to-buffer (create-file-buffer file))
+ (setq buffer-file-name file)
+ (setq default-directory (expand-file-name "~/"))
+ (setq auto-save-file-name nil)
+ (insert-file-contents (expand-file-name "TUTORIAL" exec-directory))
+ (goto-char (point-min))
+ (search-forward "\n<<")
+ (beginning-of-line)
+ (delete-region (point) (progn (end-of-line) (point)))
+ (newline (- (window-height (selected-window))
+ (count-lines (point-min) (point))
+ 6))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil))))
+
+(defun describe-key-briefly (key)
+ "Print the name of the function KEY invokes. KEY is a string."
+ (interactive "kDescribe key briefly: ")
+ (let ((defn (key-binding key)))
+ (if (or (null defn) (integerp defn))
+ (message "%s is undefined" (key-description key))
+ (message "%s runs the command %s"
+ (key-description key)
+ (if (symbolp defn) defn (prin1-to-string defn))))))
+
+(defun print-help-return-message (&optional function)
+ "Display or return message saying how to restore windows after help command.
+Computes a message and applies the argument FUNCTION to it.
+If FUNCTION is nil, applies `message' to it, thus printing it."
+ (and (not (get-buffer-window standard-output))
+ (funcall (or function 'message)
+ (substitute-command-keys
+ (if (one-window-p t)
+ (if pop-up-windows
+ "Type \\[delete-other-windows] to remove help window."
+ "Type \\[switch-to-buffer] RET to remove help window.")
+ "Type \\[switch-to-buffer-other-window] RET to restore old contents of help window.")))))
+
+(defun describe-key (key)
+ "Display documentation of the function KEY invokes. KEY is a string."
+ (interactive "kDescribe key: ")
+ (let ((defn (key-binding key)))
+ (if (or (null defn) (integerp defn))
+ (message "%s is undefined" (key-description key))
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 defn)
+ (princ ":\n")
+ (if (documentation defn)
+ (princ (documentation defn))
+ (princ "not documented"))
+ (print-help-return-message)))))
+
+(defun describe-mode ()
+ "Display documentation of current major mode."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ mode-name)
+ (princ " Mode:\n")
+ (princ (documentation major-mode))
+ (print-help-return-message)))
+
+(defun describe-distribution ()
+ "Display info on how to obtain the latest version of GNU Emacs."
+ (interactive)
+ (find-file-read-only
+ (expand-file-name "DISTRIB" exec-directory)))
+
+(defun describe-copying ()
+ "Display info on how you may redistribute copies of GNU Emacs."
+ (interactive)
+ (find-file-read-only
+ (expand-file-name "COPYING" exec-directory))
+ (goto-char (point-min)))
+
+(defun describe-no-warranty ()
+ "Display info on all the kinds of warranty Emacs does NOT have."
+ (interactive)
+ (describe-copying)
+ (let (case-fold-search)
+ (search-forward "NO WARRANTY")
+ (recenter 0)))
+
+(defun view-emacs-news ()
+ "Display info on recent changes to Emacs."
+ (interactive)
+ (find-file-read-only (expand-file-name "NEWS" exec-directory)))
+
+(defun view-lossage ()
+ "Display last 100 input keystrokes."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ (key-description (recent-keys)))
+ (save-excursion
+ (set-buffer standard-output)
+ (goto-char (point-min))
+ (while (progn (move-to-column 50) (not (eobp)))
+ (search-forward " " nil t)
+ (insert "\n")))
+ (print-help-return-message)))
+
+(defun help-for-help ()
+ "You have typed C-h, the help character. Type a Help option:
+
+A command-apropos. Give a substring, and see a list of commands
+ (functions interactively callable) that contain
+ that substring. See also the apropos command.
+B describe-bindings. Display table of all key bindings.
+C describe-key-briefly. Type a command key sequence;
+ it prints the function name that sequence runs.
+F describe-function. Type a function name and get documentation of it.
+I info. The info documentation reader.
+K describe-key. Type a command key sequence;
+ it displays the full documentation.
+L view-lossage. Shows last 100 characters you typed.
+M describe-mode. Print documentation of current major mode,
+ which describes the commands peculiar to it.
+N view-emacs-news. Shows emacs news file.
+S describe-syntax. Display contents of syntax table, plus explanations
+T help-with-tutorial. Select the Emacs learn-by-doing tutorial.
+V describe-variable. Type name of a variable;
+ it displays the variable's documentation and value.
+W where-is. Type command name; it prints which keystrokes
+ invoke that command.
+C-c print Emacs copying permission (General Public License).
+C-d print Emacs ordering information.
+C-n print news of recent Emacs changes.
+C-w print information on absence of warranty for GNU Emacs."
+ (interactive)
+ (message
+ "A B C F I K L M N S T V W C-c C-d C-n C-w. Type C-h again for more help: ")
+ (let ((char (read-char)))
+ (if (or (= char ?\C-h) (= char ??))
+ (save-window-excursion
+ (switch-to-buffer "*Help*")
+ (erase-buffer)
+ (insert (documentation 'help-for-help))
+ (goto-char (point-min))
+ (while (memq char '(?\C-h ?? ?\C-v ?\ ?\177 ?\M-v))
+ (if (memq char '(?\C-v ?\ ))
+ (scroll-up))
+ (if (memq char '(?\177 ?\M-v))
+ (scroll-down))
+ (message "A B C F I K L M N S T V W C-c C-d C-n C-w%s: "
+ (if (pos-visible-in-window-p (point-max))
+ "" " or Space to scroll"))
+ (let ((cursor-in-echo-area t))
+ (setq char (read-char))))))
+ (let ((defn (cdr (assq (downcase char) (cdr help-map)))))
+ (if defn (call-interactively defn) (ding)))))
+
+
+(defun function-called-at-point ()
+ (condition-case ()
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
+ (backward-up-list 1)
+ (forward-char 1)
+ (let (obj)
+ (setq obj (read (current-buffer)))
+ (and (symbolp obj) (fboundp obj) obj))))
+ (error nil)))
+
+(defun describe-function (function)
+ "Display the full documentation of FUNCTION (a symbol)."
+ (interactive
+ (let ((fn (function-called-at-point))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (completing-read (if fn
+ (format "Describe function (default %s): " fn)
+ "Describe function: ")
+ obarray 'fboundp t))
+ (list (if (equal val "")
+ fn (intern val)))))
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 function)
+ (princ ":
+")
+ (if (documentation function)
+ (princ (documentation function))
+ (princ "not documented"))
+ (print-help-return-message)))
+
+(defun variable-at-point ()
+ (condition-case ()
+ (save-excursion
+ (forward-sexp -1)
+ (skip-chars-forward "'")
+ (let ((obj (read (current-buffer))))
+ (and (symbolp obj) (boundp obj) obj)))
+ (error nil)))
+
+(defun describe-variable (variable)
+ "Display the full documentation of VARIABLE (a symbol)."
+ (interactive
+ (let ((v (variable-at-point))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (completing-read (if v
+ (format "Describe variable (default %s): " v)
+ "Describe variable: ")
+ obarray 'boundp t))
+ (list (if (equal val "")
+ v (intern val)))))
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 variable)
+ (princ "'s value is ")
+ (if (not (boundp variable))
+ (princ "void.")
+ (prin1 (symbol-value variable)))
+ (terpri) (terpri)
+ (princ "Documentation:")
+ (terpri)
+ (let ((doc (documentation-property variable 'variable-documentation)))
+ (if doc
+ (princ (substitute-command-keys doc))
+ (princ "not documented as a variable.")))
+ (print-help-return-message)))
+
+(defun command-apropos (string)
+ "Like apropos but lists only symbols that are names of commands
+\(interactively callable functions)."
+ (interactive "sCommand apropos (regexp): ")
+ (let ((message
+ (let ((standard-output (get-buffer-create "*Help*")))
+ (print-help-return-message 'identity))))
+ (apropos string 'commandp)
+ (and message (message message))))
--- /dev/null
+;; helper - utility help package for modes which want to provide help
+;; without relinquishing control, e.g. `electric' modes.
+
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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.
+
+
+(provide 'helper) ; hey, here's a helping hand.
+
+;; Bind this to a string for <blank> in "... Other keys <blank>".
+;; Helper-help uses this to construct help string when scrolling.
+;; Defaults to "return"
+(defvar Helper-return-blurb nil)
+
+;; Keymap implementation doesn't work too well for non-standard loops.
+;; But define it anyway for those who can use it. Non-standard loops
+;; will probably have to use Helper-help. You can't autoload the
+;; keymap either.
+
+
+(defvar Helper-help-map nil)
+(if Helper-help-map
+ nil
+ (setq Helper-help-map (make-keymap))
+ ;(fillarray Helper-help-map 'undefined)
+ (define-key Helper-help-map "m" 'Helper-describe-mode)
+ (define-key Helper-help-map "b" 'Helper-describe-bindings)
+ (define-key Helper-help-map "c" 'Helper-describe-key-briefly)
+ (define-key Helper-help-map "k" 'Helper-describe-key)
+ ;(define-key Helper-help-map "f" 'Helper-describe-function)
+ ;(define-key Helper-help-map "v" 'Helper-describe-variable)
+ (define-key Helper-help-map "?" 'Helper-help-options)
+ (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options)
+ (fset 'Helper-help-map Helper-help-map))
+
+(defun Helper-help-scroller ()
+ (let ((blurb (or (and (boundp 'Helper-return-blurb)
+ Helper-return-blurb)
+ "return")))
+ (save-window-excursion
+ (goto-char (window-start (selected-window)))
+ (if (get-buffer-window "*Help*")
+ (pop-to-buffer "*Help*")
+ (switch-to-buffer "*Help*"))
+ (goto-char (point-min))
+ (let ((continue t) state)
+ (while continue
+ (setq state (+ (* 2 (if (pos-visible-in-window-p (point-max)) 1 0))
+ (if (pos-visible-in-window-p (point-min)) 1 0)))
+ (message
+ (nth state
+ '("Space forward, Delete back. Other keys %s"
+ "Space scrolls forward. Other keys %s"
+ "Delete scrolls back. Other keys %s"
+ "Type anything to %s"))
+ blurb)
+ (setq continue (read-char))
+ (cond ((and (memq continue '(?\ ?\C-v)) (< state 2))
+ (scroll-up))
+ ((= continue ?\C-l)
+ (recenter))
+ ((and (= continue ?\177) (zerop (% state 2)))
+ (scroll-down))
+ (t (setq continue nil))))))))
+
+(defun Helper-help-options ()
+ "Describe help options."
+ (interactive)
+ (message "c (key briefly), m (mode), k (key), b (bindings)")
+ ;(message "c (key briefly), m (mode), k (key), v (variable), f (function)")
+ (sit-for 4))
+
+(defun Helper-describe-key-briefly (key)
+ "Briefly describe binding of KEYS."
+ (interactive "kDescribe key briefly: ")
+ (describe-key-briefly key)
+ (sit-for 4))
+
+(defun Helper-describe-key (key)
+ "Describe binding of KEYS."
+ (interactive "kDescribe key: ")
+ (save-window-excursion (describe-key key))
+ (Helper-help-scroller))
+
+(defun Helper-describe-function ()
+ "Describe a function. Name read interactively."
+ (interactive)
+ (save-window-excursion (call-interactively 'describe-function))
+ (Helper-help-scroller))
+
+(defun Helper-describe-variable ()
+ "Describe a variable. Name read interactively."
+ (interactive)
+ (save-window-excursion (call-interactively 'describe-variable))
+ (Helper-help-scroller))
+
+(defun Helper-describe-mode ()
+ "Describe the current mode."
+ (interactive)
+ (let ((name mode-name)
+ (documentation (documentation major-mode)))
+ (save-excursion
+ (set-buffer (get-buffer-create "*Help*"))
+ (erase-buffer)
+ (insert name " Mode\n" documentation)))
+ (Helper-help-scroller))
+
+(defun Helper-describe-bindings ()
+ "Describe local key bindings of current mode."
+ (interactive)
+ (message "Making binding list...")
+ (save-window-excursion (describe-bindings))
+ (Helper-help-scroller))
+
+(defun Helper-help ()
+ "Provide help for current mode."
+ (interactive)
+ (let ((continue t) c)
+ (while continue
+ (message "Help (Type ? for further options)")
+ (setq c (char-to-string (downcase (read-char))))
+ (setq c (lookup-key Helper-help-map c))
+ (cond ((eq c 'Helper-help-options)
+ (Helper-help-options))
+ ((commandp c)
+ (call-interactively c)
+ (setq continue nil))
+ (t
+ (ding)
+ (setq continue nil))))))
+
--- /dev/null
+;; Note: use
+;; (autoload 'icon-mode "icon" nil t)
+;; (setq auto-mode-alist (cons '("\\.icn$" . icon-mode) auto-mode-alist))
+;; if not permanently installed in your emacs
+
+;; Icon code editing commands for Emacs
+;; from c-mode.el 13-Apr-88 Chris Smith; bugs to convex!csmith
+;; Copyright (C) 1988 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.
+
+
+(defvar icon-mode-abbrev-table nil
+ "Abbrev table in use in Icon-mode buffers.")
+(define-abbrev-table 'icon-mode-abbrev-table ())
+
+(defvar icon-mode-map ()
+ "Keymap used in Icon mode.")
+(if icon-mode-map
+ ()
+ (setq icon-mode-map (make-sparse-keymap))
+ (define-key icon-mode-map "{" 'electric-icon-brace)
+ (define-key icon-mode-map "}" 'electric-icon-brace)
+ (define-key icon-mode-map "\e\C-h" 'mark-icon-function)
+ (define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun)
+ (define-key icon-mode-map "\e\C-e" 'end-of-icon-defun)
+ (define-key icon-mode-map "\e\C-q" 'indent-icon-exp)
+ (define-key icon-mode-map "\177" 'backward-delete-char-untabify)
+ (define-key icon-mode-map "\t" 'icon-indent-command))
+
+(defvar icon-mode-syntax-table nil
+ "Syntax table in use in Icon-mode buffers.")
+
+(if icon-mode-syntax-table
+ ()
+ (setq icon-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\\ "\\" icon-mode-syntax-table)
+ (modify-syntax-entry ?# "<" icon-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" icon-mode-syntax-table)
+ (modify-syntax-entry ?$ "." icon-mode-syntax-table)
+ (modify-syntax-entry ?/ "." icon-mode-syntax-table)
+ (modify-syntax-entry ?* "." icon-mode-syntax-table)
+ (modify-syntax-entry ?+ "." icon-mode-syntax-table)
+ (modify-syntax-entry ?- "." icon-mode-syntax-table)
+ (modify-syntax-entry ?= "." icon-mode-syntax-table)
+ (modify-syntax-entry ?% "." icon-mode-syntax-table)
+ (modify-syntax-entry ?< "." icon-mode-syntax-table)
+ (modify-syntax-entry ?> "." icon-mode-syntax-table)
+ (modify-syntax-entry ?& "." icon-mode-syntax-table)
+ (modify-syntax-entry ?| "." icon-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" icon-mode-syntax-table))
+
+(defconst icon-indent-level 4
+ "*Indentation of Icon statements with respect to containing block.")
+(defconst icon-brace-imaginary-offset 0
+ "*Imagined indentation of a Icon open brace that actually follows a statement.")
+(defconst icon-brace-offset 0
+ "*Extra indentation for braces, compared with other text in same context.")
+(defconst icon-continued-statement-offset 4
+ "*Extra indent for lines not starting new statements.")
+(defconst icon-continued-brace-offset 0
+ "*Extra indent for substatements that start with open-braces.
+This is in addition to icon-continued-statement-offset.")
+
+(defconst icon-auto-newline nil
+ "*Non-nil means automatically newline before and after braces,
+and after colons and semicolons, inserted in C code.")
+
+(defconst icon-tab-always-indent t
+ "*Non-nil means TAB in Icon mode should always reindent the current line,
+regardless of where in the line point is when the TAB command is used.")
+\f
+(defun icon-mode ()
+ "Major mode for editing Icon code.
+Expression and list commands understand all Icon brackets.
+Tab indents for Icon code.
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+\\{icon-mode-map}
+Variables controlling indentation style:
+ icon-tab-always-indent
+ Non-nil means TAB in Icon mode should always reindent the current line,
+ regardless of where in the line point is when the TAB command is used.
+ icon-auto-newline
+ Non-nil means automatically newline before and after braces
+ inserted in Icon code.
+ icon-indent-level
+ Indentation of Icon statements within surrounding block.
+ The surrounding block's indentation is the indentation
+ of the line on which the open-brace appears.
+ icon-continued-statement-offset
+ Extra indentation given to a substatement, such as the
+ then-clause of an if or body of a while.
+ icon-continued-brace-offset
+ Extra indentation given to a brace that starts a substatement.
+ This is in addition to icon-continued-statement-offset.
+ icon-brace-offset
+ Extra indentation for line if it starts with an open brace.
+ icon-brace-imaginary-offset
+ An open brace following other text is treated as if it were
+ this far to the right of the start of its line.
+
+Turning on Icon mode calls the value of the variable icon-mode-hook with no args,
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map icon-mode-map)
+ (setq major-mode 'icon-mode)
+ (setq mode-name "Icon")
+ (setq local-abbrev-table icon-mode-abbrev-table)
+ (set-syntax-table icon-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'icon-indent-line)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'comment-start)
+ (setq comment-start "# ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 32)
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "# *")
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'icon-comment-indent)
+ (run-hooks 'icon-mode-hook))
+\f
+;; This is used by indent-for-comment
+;; to decide how much to indent a comment in Icon code
+;; based on its context.
+(defun icon-comment-indent ()
+ (if (looking-at "^#")
+ 0 ;Existing comment at bol stays there.
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (1+ (current-column)) ;Else indent at comment column
+ comment-column)))) ; except leave at least one space.
+
+(defun electric-icon-brace (arg)
+ "Insert character and correct line's indentation."
+ (interactive "P")
+ (let (insertpos)
+ (if (and (not arg)
+ (eolp)
+ (or (save-excursion
+ (skip-chars-backward " \t")
+ (bolp))
+ (if icon-auto-newline
+ (progn (icon-indent-line) (newline) t)
+ nil)))
+ (progn
+ (insert last-command-char)
+ (icon-indent-line)
+ (if icon-auto-newline
+ (progn
+ (newline)
+ ;; (newline) may have done auto-fill
+ (setq insertpos (- (point) 2))
+ (icon-indent-line)))
+ (save-excursion
+ (if insertpos (goto-char (1+ insertpos)))
+ (delete-char -1))))
+ (if insertpos
+ (save-excursion
+ (goto-char insertpos)
+ (self-insert-command (prefix-numeric-value arg)))
+ (self-insert-command (prefix-numeric-value arg)))))
+\f
+(defun icon-indent-command (&optional whole-exp)
+ (interactive "P")
+ "Indent current line as Icon code, or in some cases insert a tab character.
+If icon-tab-always-indent is non-nil (the default), always indent current line.
+Otherwise, indent the current line only if point is at the left margin
+or in the line's indentation; otherwise insert a tab.
+
+A numeric argument, regardless of its value,
+means indent rigidly all the lines of the expression starting after point
+so that this line becomes properly indented.
+The relative indentation among the lines of the expression are preserved."
+ (if whole-exp
+ ;; If arg, always indent this line as Icon
+ ;; and shift remaining lines of expression the same amount.
+ (let ((shift-amt (icon-indent-line))
+ beg end)
+ (save-excursion
+ (if icon-tab-always-indent
+ (beginning-of-line))
+ (setq beg (point))
+ (forward-sexp 1)
+ (setq end (point))
+ (goto-char beg)
+ (forward-line 1)
+ (setq beg (point)))
+ (if (> end beg)
+ (indent-code-rigidly beg end shift-amt "#")))
+ (if (and (not icon-tab-always-indent)
+ (save-excursion
+ (skip-chars-backward " \t")
+ (not (bolp))))
+ (insert-tab)
+ (icon-indent-line))))
+
+(defun icon-indent-line ()
+ "Indent current line as Icon code.
+Return the amount the indentation changed by."
+ (let ((indent (calculate-icon-indent nil))
+ beg shift-amt
+ (case-fold-search nil)
+ (pos (- (point-max) (point))))
+ (beginning-of-line)
+ (setq beg (point))
+ (cond ((eq indent nil)
+ (setq indent (current-indentation)))
+ ((eq indent t)
+ (setq indent (calculate-icon-indent-within-comment)))
+ ((looking-at "[ \t]*#")
+ (setq indent 0))
+ (t
+ (skip-chars-forward " \t")
+ (if (listp indent) (setq indent (car indent)))
+ (cond ((and (looking-at "else\\b")
+ (not (looking-at "else\\s_")))
+ (setq indent (save-excursion
+ (icon-backward-to-start-of-if)
+ (current-indentation))))
+ ((or (= (following-char) ?})
+ (looking-at "end\\b"))
+ (setq indent (- indent icon-indent-level)))
+ ((= (following-char) ?{)
+ (setq indent (+ indent icon-brace-offset))))))
+ (skip-chars-forward " \t")
+ (setq shift-amt (- indent (current-column)))
+ (if (zerop shift-amt)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ (delete-region beg (point))
+ (indent-to indent)
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos))))
+ shift-amt))
+
+(defun calculate-icon-indent (&optional parse-start)
+ "Return appropriate indentation for current line as Icon code.
+In usual case returns an integer: the column to indent to.
+Returns nil if line starts inside a string, t if in a comment."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point))
+ (case-fold-search nil)
+ state
+ containing-sexp
+ toplevel)
+ (if parse-start
+ (goto-char parse-start)
+ (setq toplevel (beginning-of-icon-defun)))
+ (while (< (point) indent-point)
+ (setq parse-start (point))
+ (setq state (parse-partial-sexp (point) indent-point 0))
+ (setq containing-sexp (car (cdr state))))
+ (cond ((or (nth 3 state) (nth 4 state))
+ ;; return nil or t if should not change this line
+ (nth 4 state))
+ ((and containing-sexp
+ (/= (char-after containing-sexp) ?{))
+ ;; line is expression, not statement:
+ ;; indent to just after the surrounding open.
+ (goto-char (1+ containing-sexp))
+ (current-column))
+ (t
+ ;; Statement level. Is it a continuation or a new statement?
+ ;; Find previous non-comment character.
+ (if toplevel
+ (progn (icon-backward-to-noncomment (point-min))
+ (if (icon-is-continuation-line)
+ icon-continued-statement-offset 0))
+ (if (null containing-sexp)
+ (progn (beginning-of-icon-defun)
+ (setq containing-sexp (point))))
+ (goto-char indent-point)
+ (icon-backward-to-noncomment containing-sexp)
+ ;; Now we get the answer.
+ (if (icon-is-continuation-line)
+ ;; This line is continuation of preceding line's statement;
+ ;; indent icon-continued-statement-offset more than the
+ ;; first line of the statement.
+ (progn
+ (icon-backward-to-start-of-continued-exp containing-sexp)
+ (+ icon-continued-statement-offset (current-column)
+ (if (save-excursion (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (eq (following-char) ?{))
+ icon-continued-brace-offset 0)))
+ ;; This line starts a new statement.
+ ;; Position following last unclosed open.
+ (goto-char containing-sexp)
+ ;; Is line first statement after an open-brace?
+ (or
+ ;; If no, find that first statement and indent like it.
+ (save-excursion
+ (if (looking-at "procedure\\s ")
+ (forward-sexp 3)
+ (forward-char 1))
+ (while (progn (skip-chars-forward " \t\n")
+ (looking-at "#"))
+ ;; Skip over comments following openbrace.
+ (forward-line 1))
+ ;; The first following code counts
+ ;; if it is before the line we want to indent.
+ (and (< (point) indent-point)
+ (current-column)))
+ ;; If no previous statement,
+ ;; indent it relative to line brace is on.
+ ;; For open brace in column zero, don't let statement
+ ;; start there too. If icon-indent-level is zero,
+ ;; use icon-brace-offset + icon-continued-statement-offset instead.
+ ;; For open-braces not the first thing in a line,
+ ;; add in icon-brace-imaginary-offset.
+ (+ (if (and (bolp) (zerop icon-indent-level))
+ (+ icon-brace-offset icon-continued-statement-offset)
+ icon-indent-level)
+ ;; Move back over whitespace before the openbrace.
+ ;; If openbrace is not first nonwhite thing on the line,
+ ;; add the icon-brace-imaginary-offset.
+ (progn (skip-chars-backward " \t")
+ (if (bolp) 0 icon-brace-imaginary-offset))
+ ;; here we are
+ (current-indentation))))))))))
+
+(defun icon-is-continuation-line ()
+ (let* ((ch (preceding-char))
+ (ch-syntax (char-syntax ch)))
+ (if (eq ch-syntax ?w)
+ (assoc (buffer-substring
+ (progn (forward-word -1) (point))
+ (progn (forward-word 1) (point)))
+ '(("do") ("dynamic") ("else") ("initial") ("link")
+ ("local") ("of") ("static") ("then")))
+ (not (memq ch '(0 ?\; ?\} ?\{ ?\) ?\] ?\" ?\' ?\n))))))
+
+(defun icon-backward-to-noncomment (lim)
+ (let (opoint stop)
+ (while (not stop)
+ (skip-chars-backward " \t\n\f" lim)
+ (setq opoint (point))
+ (beginning-of-line)
+ (if (and (search-forward "#" opoint 'move)
+ (< lim (point)))
+ (forward-char -1)
+ (setq stop t)))))
+
+(defun icon-backward-to-start-of-continued-exp (lim)
+ (if (memq (preceding-char) '(?\) ?\]))
+ (forward-sexp -1))
+ (while (icon-is-continued-line)
+ (end-of-line 0))
+ (beginning-of-line)
+ (if (<= (point) lim)
+ (goto-char (1+ lim)))
+ (skip-chars-forward " \t"))
+
+(defun icon-is-continued-line ()
+ (save-excursion
+ (end-of-line 0)
+ (icon-is-continuation-line)))
+
+(defun icon-backward-to-start-of-if (&optional limit)
+ "Move to the start of the last ``unbalanced'' if."
+ (or limit (setq limit (save-excursion (beginning-of-icon-defun) (point))))
+ (let ((if-level 1)
+ (case-fold-search nil))
+ (while (not (zerop if-level))
+ (backward-sexp 1)
+ (cond ((looking-at "else\\b")
+ (setq if-level (1+ if-level)))
+ ((looking-at "if\\b")
+ (setq if-level (1- if-level)))
+ ((< (point) limit)
+ (setq if-level 0)
+ (goto-char limit))))))
+\f
+(defun mark-icon-function ()
+ "Put mark at end of Icon function, point at beginning."
+ (interactive)
+ (push-mark (point))
+ (end-of-icon-defun)
+ (push-mark (point))
+ (beginning-of-line 0)
+ (beginning-of-icon-defun))
+
+(defun beginning-of-icon-defun ()
+ "Go to the start of the enclosing procedure; return t if at top level."
+ (interactive)
+ (if (re-search-backward "^procedure\\s \\|^end[ \t\n]" (point-min) 'move)
+ (looking-at "e")
+ t))
+
+(defun end-of-icon-defun ()
+ (interactive)
+ (if (not (bobp)) (forward-char -1))
+ (re-search-forward "\\(\\s \\|^\\)end\\(\\s \\|$\\)" (point-max) 'move)
+ (forward-word -1)
+ (forward-line 1))
+\f
+(defun indent-icon-exp ()
+ "Indent each line of the Icon grouping following point."
+ (interactive)
+ (let ((indent-stack (list nil))
+ (contain-stack (list (point)))
+ (case-fold-search nil)
+ restart outer-loop-done inner-loop-done state ostate
+ this-indent last-sexp
+ at-else at-brace at-do
+ (opoint (point))
+ (next-depth 0))
+ (save-excursion
+ (forward-sexp 1))
+ (save-excursion
+ (setq outer-loop-done nil)
+ (while (and (not (eobp)) (not outer-loop-done))
+ (setq last-depth next-depth)
+ ;; Compute how depth changes over this line
+ ;; plus enough other lines to get to one that
+ ;; does not end inside a comment or string.
+ ;; Meanwhile, do appropriate indentation on comment lines.
+ (setq innerloop-done nil)
+ (while (and (not innerloop-done)
+ (not (and (eobp) (setq outer-loop-done t))))
+ (setq ostate state)
+ (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
+ nil nil state))
+ (setq next-depth (car state))
+ (if (and (car (cdr (cdr state)))
+ (>= (car (cdr (cdr state))) 0))
+ (setq last-sexp (car (cdr (cdr state)))))
+ (if (or (nth 4 ostate))
+ (icon-indent-line))
+ (if (or (nth 3 state))
+ (forward-line 1)
+ (setq innerloop-done t)))
+ (if (<= next-depth 0)
+ (setq outer-loop-done t))
+ (if outer-loop-done
+ nil
+ (if (/= last-depth next-depth)
+ (setq last-sexp nil))
+ (while (> last-depth next-depth)
+ (setq indent-stack (cdr indent-stack)
+ contain-stack (cdr contain-stack)
+ last-depth (1- last-depth)))
+ (while (< last-depth next-depth)
+ (setq indent-stack (cons nil indent-stack)
+ contain-stack (cons nil contain-stack)
+ last-depth (1+ last-depth)))
+ (if (null (car contain-stack))
+ (setcar contain-stack (or (car (cdr state))
+ (save-excursion (forward-sexp -1)
+ (point)))))
+ (forward-line 1)
+ (skip-chars-forward " \t")
+ (if (eolp)
+ nil
+ (if (and (car indent-stack)
+ (>= (car indent-stack) 0))
+ ;; Line is on an existing nesting level.
+ ;; Lines inside parens are handled specially.
+ (if (/= (char-after (car contain-stack)) ?{)
+ (setq this-indent (car indent-stack))
+ ;; Line is at statement level.
+ ;; Is it a new statement? Is it an else?
+ ;; Find last non-comment character before this line
+ (save-excursion
+ (setq at-else (looking-at "else\\W"))
+ (setq at-brace (= (following-char) ?{))
+ (icon-backward-to-noncomment opoint)
+ (if (icon-is-continuation-line)
+ ;; Preceding line did not end in comma or semi;
+ ;; indent this line icon-continued-statement-offset
+ ;; more than previous.
+ (progn
+ (icon-backward-to-start-of-continued-exp (car contain-stack))
+ (setq this-indent
+ (+ icon-continued-statement-offset (current-column)
+ (if at-brace icon-continued-brace-offset 0))))
+ ;; Preceding line ended in comma or semi;
+ ;; use the standard indent for this level.
+ (if at-else
+ (progn (icon-backward-to-start-of-if opoint)
+ (setq this-indent (current-indentation)))
+ (setq this-indent (car indent-stack))))))
+ ;; Just started a new nesting level.
+ ;; Compute the standard indent for this level.
+ (let ((val (calculate-icon-indent
+ (if (car indent-stack)
+ (- (car indent-stack))))))
+ (setcar indent-stack
+ (setq this-indent val))))
+ ;; Adjust line indentation according to its contents
+ (if (or (= (following-char) ?})
+ (looking-at "end\\b"))
+ (setq this-indent (- this-indent icon-indent-level)))
+ (if (= (following-char) ?{)
+ (setq this-indent (+ this-indent icon-brace-offset)))
+ ;; Put chosen indentation into effect.
+ (or (= (current-column) this-indent)
+ (progn
+ (delete-region (point) (progn (beginning-of-line) (point)))
+ (indent-to this-indent)))
+ ;; Indent any comment following the text.
+ (or (looking-at comment-start-skip)
+ (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t)
+ (progn (indent-for-comment) (beginning-of-line))))))))))
--- /dev/null
+;; Load this file to increment the recorded Emacs version number.
+;; 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.
+
+
+(insert-file-contents "../lisp/version.el")
+
+(re-search-forward "emacs-version \"[^\"]*[0-9]+\"")
+(forward-char -1)
+(save-excursion
+ (save-restriction
+ (narrow-to-region (point)
+ (progn (skip-chars-backward "0-9") (point)))
+ (goto-char (point-min))
+ (let ((version (read (current-buffer))))
+ (delete-region (point-min) (point-max))
+ (prin1 (1+ version) (current-buffer)))))
+(skip-chars-backward "^\"")
+(message "New Emacs version will be %s"
+ (buffer-substring (point)
+ (progn (skip-chars-forward "^\"") (point))))
+
+
+(write-region (point-min) (point-max) "../lisp/version.el" nil 'nomsg)
+(erase-buffer)
+(set-buffer-modified-p nil)
+
+(kill-emacs)
--- /dev/null
+;; Indentation commands for Emacs
+;; Copyright (C) 1985 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.
+
+
+;Now in loaddefs.el
+;(defvar indent-line-function
+; 'indent-to-left-margin
+; "Function to indent current line.")
+
+(defun indent-according-to-mode ()
+ "Indent line in proper way for current major mode."
+ (interactive)
+ (funcall indent-line-function))
+
+(defun indent-for-tab-command ()
+ "Indent line in proper way for current major mode."
+ (interactive)
+ (if (eq indent-line-function 'indent-to-left-margin)
+ (insert-tab)
+ (funcall indent-line-function)))
+
+(defun insert-tab ()
+ (if abbrev-mode
+ (expand-abbrev))
+ (if indent-tabs-mode
+ (insert ?\t)
+ (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))
+
+(defun indent-rigidly (start end arg)
+ "Indent all lines starting in the region sideways by ARG columns.
+Called from a program, takes three arguments, START, END and ARG."
+ (interactive "r\np")
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp) (forward-line 1))
+ (while (< (point) end)
+ (let ((indent (current-indentation)))
+ (delete-region (point) (progn (skip-chars-forward " \t") (point)))
+ (or (eolp)
+ (indent-to (max 0 (+ indent arg)) 0)))
+ (forward-line 1))
+ (move-marker end nil)))
+
+;; This is the default indent-line-function,
+;; used in Fundamental Mode, Text Mode, etc.
+(defun indent-to-left-margin ()
+ (or (= (current-indentation) left-margin)
+ (let (epos)
+ (save-excursion
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (skip-chars-forward " \t")
+ (point)))
+ (indent-to left-margin)
+ (setq epos (point)))
+ (if (< (point) epos)
+ (goto-char epos)))))
+
+(defvar indent-region-function nil
+ "Function which is short cut to indent each line in region with Tab.
+nil means really call Tab on each line.")
+
+(defun indent-region (start end arg)
+ "Indent each nonblank line in the region.
+With no argument, indent each line with Tab.
+With argument COLUMN, indent each line to that column.
+Called from a program, takes three args: START, END and COLUMN."
+ (interactive "r\nP")
+ (if (null arg)
+ (if indent-region-function
+ (funcall indent-region-function start end)
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp) (forward-line 1))
+ (while (< (point) end)
+ (funcall indent-line-function)
+ (forward-line 1))
+ (move-marker end nil)))
+ (setq arg (prefix-numeric-value arg))
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp) (forward-line 1))
+ (while (< (point) end)
+ (delete-region (point) (progn (skip-chars-forward " \t") (point)))
+ (or (eolp)
+ (indent-to arg 0))
+ (forward-line 1))
+ (move-marker end nil))))
+
+(defun indent-relative-maybe ()
+ "Indent a new line like previous nonblank line."
+ (interactive)
+ (indent-relative t))
+
+(defun indent-relative (&optional unindented-ok)
+ "Space out to under next indent point in previous nonblank line.
+An indent point is a non-whitespace character following whitespace.
+If the previous nonblank line has no indent points beyond
+the column point starts at, tab-to-tab-stop is done instead."
+ (interactive "P")
+ (if abbrev-mode (expand-abbrev))
+ (let ((start-column (current-column))
+ indent)
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-backward "^[^\n]" nil t)
+ (let ((end (save-excursion (forward-line 1) (point))))
+ (move-to-column start-column)
+ ;; Is start-column inside a tab on this line?
+ (if (> (current-column) start-column)
+ (backward-char 1))
+ (or (looking-at "[ \t]")
+ unindented-ok
+ (skip-chars-forward "^ \t" end))
+ (skip-chars-forward " \t" end)
+ (or (= (point) end) (setq indent (current-column))))))
+ (if indent
+ (let ((opoint (point-marker)))
+ (delete-region (point) (progn (skip-chars-backward " \t") (point)))
+ (indent-to indent 0)
+ (if (> opoint (point))
+ (goto-char opoint))
+ (move-marker opoint nil))
+ (tab-to-tab-stop))))
+
+(defvar tab-stop-list
+ '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120)
+ "*List of tab stop positions used by tab-to-tab-stops.")
+
+(defvar edit-tab-stops-map nil "Keymap used in edit-tab-stops.")
+(if edit-tab-stops-map
+ nil
+ (setq edit-tab-stops-map (make-sparse-keymap))
+ (define-key edit-tab-stops-map "\C-x\C-s" 'edit-tab-stops-note-changes)
+ (define-key edit-tab-stops-map "\C-c\C-c" 'edit-tab-stops-note-changes))
+
+(defvar edit-tab-stops-buffer nil
+ "Buffer whose tab stops are being edited--in case
+the variable tab-stop-list is local in that buffer.")
+
+(defun edit-tab-stops ()
+ "Edit the tab stops used by tab-to-tab-stop.
+Creates a buffer *Tab Stops* containing text describing the tab stops.
+A colon indicates a column where there is a tab stop.
+You can add or remove colons and then do C-c C-c to make changes take effect."
+ (interactive)
+ (setq edit-tab-stops-buffer (current-buffer))
+ (switch-to-buffer (get-buffer-create "*Tab Stops*"))
+ (use-local-map edit-tab-stops-map)
+ (make-local-variable 'indent-tabs-mode)
+ (setq indent-tabs-mode nil)
+ (overwrite-mode 1)
+ (setq truncate-lines t)
+ (erase-buffer)
+ (let ((tabs tab-stop-list))
+ (while tabs
+ (indent-to (car tabs) 0)
+ (insert ?:)
+ (setq tabs (cdr tabs))))
+ (let ((count 0))
+ (insert ?\n)
+ (while (< count 8)
+ (insert (+ count ?0))
+ (insert " ")
+ (setq count (1+ count)))
+ (insert ?\n)
+ (while (> count 0)
+ (insert "0123456789")
+ (setq count (1- count))))
+ (insert "\nTo install changes, type C-c C-c")
+ (goto-char (point-min)))
+
+(defun edit-tab-stops-note-changes ()
+ "Put edited tab stops into effect."
+ (interactive)
+ (let (tabs)
+ (save-excursion
+ (goto-char 1)
+ (end-of-line)
+ (while (search-backward ":" nil t)
+ (setq tabs (cons (current-column) tabs))))
+ (bury-buffer (prog1 (current-buffer)
+ (switch-to-buffer edit-tab-stops-buffer)))
+ (setq tab-stop-list tabs))
+ (message "Tab stops installed"))
+
+(defun tab-to-tab-stop ()
+ "Insert spaces or tabs to next defined tab-stop column.
+The variable tab-stop-list is a list of columns at which there are tab stops.
+Use \\[edit-tab-stops] to edit them interactively."
+ (interactive)
+ (if abbrev-mode (expand-abbrev))
+ (let ((tabs tab-stop-list))
+ (while (and tabs (>= (current-column) (car tabs)))
+ (setq tabs (cdr tabs)))
+ (if tabs
+ (indent-to (car tabs))
+ (insert ? ))))
+
+(define-key global-map "\t" 'indent-for-tab-command)
+(define-key esc-map "\034" 'indent-region)
+(define-key ctl-x-map "\t" 'indent-rigidly)
+(define-key esc-map "i" 'tab-to-tab-stop)
--- /dev/null
+;; Info package for Emacs -- could use a "create node" feature.
+;; 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.
+
+(provide 'info)
+
+(defvar Info-history nil
+ "List of info nodes user has visited.
+Each element of list is a list (FILENAME NODENAME BUFFERPOS).")
+
+(defvar Info-enable-edit nil
+ "Non-nil means the \\[Info-edit] command in Info can edit the current node.")
+
+(defvar Info-enable-active-nodes t
+ "Non-nil allows Info to execute Lisp code associated with nodes.
+The Lisp code is executed when the node is selected.")
+
+(defvar Info-directory nil
+ "Default directory for Info documentation files.")
+
+(defvar Info-current-file nil
+ "Info file that Info is now looking at, or nil.")
+
+(defvar Info-current-subfile nil
+ "Info subfile that is actually in the *info* buffer now,
+or nil if current info file is not split into subfiles.")
+
+(defvar Info-current-node nil
+ "Name of node that Info is now looking at, or nil.")
+
+(defvar Info-tag-table-marker (make-marker)
+ "Marker pointing at beginning of current Info file's tag table.
+Marker points nowhere if file has no tag table.")
+
+(defun info ()
+ "Enter Info, the documentation browser."
+ (interactive)
+ (if (get-buffer "*info*")
+ (switch-to-buffer "*info*")
+ (Info-directory)))
+
+;; Go to an info node specified as separate filename and nodename.
+;; no-going-back is non-nil if recovering from an error in this function;
+;; it says do not attempt further (recursive) error recovery.
+(defun Info-find-node (filename nodename &optional no-going-back)
+ ;; Convert filename to lower case if not found as specified.
+ ;; Expand it.
+ (if filename
+ (let (temp)
+ (setq filename (substitute-in-file-name filename))
+ (setq temp (expand-file-name filename
+ ;; Use Info's default dir
+ ;; unless the filename starts with `./'.
+ (if (not (string-match "^\\./" filename))
+ Info-directory)))
+ (if (file-exists-p temp)
+ (setq filename temp)
+ (setq temp (expand-file-name (downcase filename) Info-directory))
+ (if (file-exists-p temp)
+ (setq filename temp)
+ (error "Info file %s does not exist"
+ (expand-file-name filename Info-directory))))))
+ ;; Record the node we are leaving.
+ (if (and Info-current-file (not no-going-back))
+ (setq Info-history
+ (cons (list Info-current-file Info-current-node (point))
+ Info-history)))
+ ;; Go into info buffer.
+ (switch-to-buffer "*info*")
+ (or (eq major-mode 'Info-mode)
+ (Info-mode))
+ (widen)
+ (setq Info-current-node nil)
+ (unwind-protect
+ (progn
+ ;; Switch files if necessary
+ (or (null filename)
+ (equal Info-current-file filename)
+ (let ((buffer-read-only nil))
+ (setq Info-current-file nil
+ Info-current-subfile nil)
+ (erase-buffer)
+ (insert-file-contents filename t)
+ (set-buffer-modified-p nil)
+ (setq default-directory (file-name-directory filename))
+ ;; See whether file has a tag table. Record the location if yes.
+ (set-marker Info-tag-table-marker nil)
+ (goto-char (point-max))
+ (forward-line -8)
+ (or (equal nodename "*")
+ (not (search-forward "\^_\nEnd tag table\n" nil t))
+ (let (pos)
+ ;; We have a tag table. Find its beginning.
+ ;; Is this an indirect file?
+ (search-backward "\nTag table:\n")
+ (setq pos (point))
+ (if (save-excursion
+ (forward-line 2)
+ (looking-at "(Indirect)\n"))
+ ;; It is indirect. Copy it to another buffer
+ ;; and record that the tag table is in that buffer.
+ (save-excursion
+ (let ((buf (current-buffer)))
+ (set-buffer (get-buffer-create " *info tag table*"))
+ (setq case-fold-search t)
+ (erase-buffer)
+ (insert-buffer-substring buf)
+ (set-marker Info-tag-table-marker
+ (match-end 0))))
+ (set-marker Info-tag-table-marker pos))))
+ (setq Info-current-file
+ (file-name-sans-versions buffer-file-name))))
+ (if (equal nodename "*")
+ (progn (setq Info-current-node nodename)
+ (Info-set-mode-line))
+ ;; Search file for a suitable node.
+ ;; First get advice from tag table if file has one.
+ ;; Also, if this is an indirect info file,
+ ;; read the proper subfile into this buffer.
+ (let ((guesspos (point-min)))
+ (if (marker-position Info-tag-table-marker)
+ (save-excursion
+ (set-buffer (marker-buffer Info-tag-table-marker))
+ (goto-char Info-tag-table-marker)
+ (if (search-forward (concat "Node: " nodename "\177") nil t)
+ (progn
+ (setq guesspos (read (current-buffer)))
+ ;; If this is an indirect file,
+ ;; determine which file really holds this node
+ ;; and read it in.
+ (if (not (eq (current-buffer) (get-buffer "*info*")))
+ (setq guesspos
+ (Info-read-subfile guesspos))))
+ (error "No such node: \"%s\"" nodename))))
+ (goto-char (max (point-min) (- guesspos 1000))))
+ ;; Now search from our advised position (or from beg of buffer)
+ ;; to find the actual node.
+ (let ((regexp (concat "Node: *" (regexp-quote nodename) " *[,\t\n]")))
+ (catch 'foo
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point)))
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (throw 'foo t))))
+ (error "No such node: %s" nodename)))
+ (Info-select-node)))
+ ;; If we did not finish finding the specified node,
+ ;; go back to the previous one.
+ (or Info-current-node no-going-back
+ (let ((hist (car Info-history)))
+ (setq Info-history (cdr Info-history))
+ (Info-find-node (nth 0 hist) (nth 1 hist) t)
+ (goto-char (nth 2 hist)))))
+ (goto-char (point-min)))
+
+(defun Info-read-subfile (nodepos)
+ (set-buffer (marker-buffer Info-tag-table-marker))
+ (goto-char (point-min))
+ (search-forward "\n\^_")
+ (let (lastfilepos
+ lastfilename)
+ (forward-line 2)
+ (catch 'foo
+ (while (not (looking-at "\^_"))
+ (if (not (eolp))
+ (let ((beg (point))
+ thisfilepos thisfilename)
+ (search-forward ": ")
+ (setq thisfilename (buffer-substring beg (- (point) 2)))
+ (setq thisfilepos (read (current-buffer)))
+ (if (> thisfilepos nodepos)
+ (throw 'foo t))
+ (setq lastfilename thisfilename)
+ (setq lastfilepos thisfilepos)))))
+ (set-buffer (get-buffer "*info*"))
+ (or (equal Info-current-subfile lastfilename)
+ (let ((buffer-read-only nil))
+ (setq buffer-file-name nil)
+ (widen)
+ (erase-buffer)
+ (insert-file-contents lastfilename)
+ (set-buffer-modified-p nil)
+ (setq Info-current-subfile lastfilename)))
+ (goto-char (point-min))
+ (search-forward "\n\^_")
+ (+ (- nodepos lastfilepos) (point))))
+
+;; Select the info node that point is in.
+(defun Info-select-node ()
+ (save-excursion
+ ;; Find beginning of node.
+ (search-backward "\n\^_")
+ (forward-line 2)
+ ;; Get nodename spelled as it is in the node.
+ (re-search-forward "Node:[ \t]*")
+ (setq Info-current-node
+ (buffer-substring (point)
+ (progn
+ (skip-chars-forward "^,\t\n")
+ (point))))
+ (Info-set-mode-line)
+ ;; Find the end of it, and narrow.
+ (beginning-of-line)
+ (let (active-expression)
+ (narrow-to-region (point)
+ (if (re-search-forward "\n[\^_\f]" nil t)
+ (prog1
+ (1- (point))
+ (if (looking-at "[\n\^_\f]*execute: ")
+ (progn
+ (goto-char (match-end 0))
+ (setq active-expression
+ (read (current-buffer))))))
+ (point-max)))
+ (if Info-enable-active-nodes (eval active-expression)))))
+
+(defun Info-set-mode-line ()
+ (setq mode-line-buffer-identification
+ (concat
+ "Info: ("
+ (if Info-current-file
+ (file-name-nondirectory Info-current-file)
+ "")
+ ")"
+ (or Info-current-node ""))))
+\f
+;; Go to an info node specified with a filename-and-nodename string
+;; of the sort that is found in pointers in nodes.
+
+(defun Info-goto-node (nodename)
+ "Go to info node named NAME. Give just NODENAME or (FILENAME)NODENAME."
+ (interactive "sGoto node: ")
+ (let (filename)
+ (string-match "\\s *\\((\\s *\\([^\t)]*\\)\\s *)\\s *\\|\\)\\(.*\\)"
+ nodename)
+ (setq filename (if (= (match-beginning 1) (match-end 1))
+ ""
+ (substring nodename (match-beginning 2) (match-end 2)))
+ nodename (substring nodename (match-beginning 3) (match-end 3)))
+ (let ((trim (string-match "\\s *\\'" filename)))
+ (if trim (setq filename (substring filename 0 trim))))
+ (let ((trim (string-match "\\s *\\'" nodename)))
+ (if trim (setq nodename (substring nodename 0 trim))))
+ (Info-find-node (if (equal filename "") nil filename)
+ (if (equal nodename "") "Top" nodename))))
+\f
+(defvar Info-last-search nil
+ "Default regexp for Info S command to search for.")
+
+(defun Info-search (regexp)
+ "Search for REGEXP, starting from point, and select node it's found in."
+ (interactive "sSearch (regexp): ")
+ (if (equal regexp "")
+ (setq regexp Info-last-search)
+ (setq Info-last-search regexp))
+ (let ((found ()) current
+ (onode Info-current-node)
+ (ofile Info-current-file)
+ (opoint (point))
+ (osubfile Info-current-subfile))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if (null Info-current-subfile)
+ (progn (re-search-forward regexp) (setq found (point)))
+ (condition-case err
+ (progn (re-search-forward regexp) (setq found (point)))
+ (search-failed nil)))))
+ (if (not found) ;can only happen in subfile case -- else would have erred
+ (unwind-protect
+ (let ((list ()))
+ (set-buffer (marker-buffer Info-tag-table-marker))
+ (goto-char (point-min))
+ (search-forward "\n\^_\nIndirect:")
+ (save-restriction
+ (narrow-to-region (point)
+ (progn (search-forward "\n\^_")
+ (1- (point))))
+ (goto-char (point-min))
+ (search-forward (concat "\n" osubfile ": "))
+ (beginning-of-line)
+ (while (not (eobp))
+ (re-search-forward "\\(^.*\\): [0-9]+$")
+ (goto-char (+ (match-end 1) 2))
+ (setq list (cons (cons (read (current-buffer))
+ (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ list))
+ (goto-char (1+ (match-end 0))))
+ (setq list (nreverse list)
+ current (car (car list))
+ list (cdr list)))
+ (while list
+ (message "Searching subfile %s..." (cdr (car list)))
+ (Info-read-subfile (car (car list)))
+ (setq list (cdr list))
+ (goto-char (point-min))
+ (if (re-search-forward regexp nil t)
+ (setq found (point) list ())))
+ (if found
+ (message "")
+ (signal 'search-failed (list regexp))))
+ (if (not found)
+ (progn (Info-read-subfile opoint)
+ (goto-char opoint)
+ (Info-select-node)))))
+ (widen)
+ (goto-char found)
+ (Info-select-node)
+ (or (and (equal onode Info-current-node)
+ (equal ofile Info-current-file))
+ (setq Info-history (cons (list ofile onode opoint)
+ Info-history)))))
+\f
+(defun Info-extract-pointer (name &optional errorname)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line 1)
+ (if (re-search-backward (concat name ":") nil t)
+ nil
+ (error (concat "Node has no " (capitalize (or errorname name)))))
+ (goto-char (match-end 0))
+ (Info-following-node-name)))
+
+(defun Info-following-node-name (&optional allowedchars)
+ (skip-chars-forward " \t")
+ (buffer-substring
+ (point)
+ (progn
+ (while (looking-at (concat "[" (or allowedchars "^,\t\n") "]"))
+ (skip-chars-forward (concat (or allowedchars "^,\t\n") "("))
+ (if (looking-at "(")
+ (skip-chars-forward "^)")))
+ (skip-chars-backward " ")
+ (point))))
+
+(defun Info-next ()
+ "Go to the next node of this node."
+ (interactive)
+ (Info-goto-node (Info-extract-pointer "next")))
+
+(defun Info-prev ()
+ "Go to the previous node of this node."
+ (interactive)
+ (Info-goto-node (Info-extract-pointer "prev[ious]*" "previous")))
+
+(defun Info-up ()
+ "Go to the superior node of this node."
+ (interactive)
+ (Info-goto-node (Info-extract-pointer "up")))
+
+(defun Info-last ()
+ "Go back to the last node visited."
+ (interactive)
+ (or Info-history
+ (error "This is the first Info node you looked at"))
+ (let (filename nodename opoint)
+ (setq filename (car (car Info-history)))
+ (setq nodename (car (cdr (car Info-history))))
+ (setq opoint (car (cdr (cdr (car Info-history)))))
+ (setq Info-history (cdr Info-history))
+ (Info-find-node filename nodename)
+ (setq Info-history (cdr Info-history))
+ (goto-char opoint)))
+
+(defun Info-directory ()
+ "Go to the Info directory node."
+ (interactive)
+ (Info-find-node "dir" "top"))
+\f
+(defun Info-follow-reference (footnotename)
+ "Follow cross reference named NAME to the node it refers to.
+NAME may be an abbreviation of the reference name."
+ (interactive
+ (let ((completion-ignore-case t)
+ completions str i)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "\\*note[ \n\t]*\\([^:]*\\):" nil t)
+ (setq str (buffer-substring
+ (match-beginning 1)
+ (1- (point))))
+ (setq i 0)
+ (while (setq i (string-match "[ \n\t]+" str i))
+ (setq str (concat (substring str 0 i) " "
+ (substring str (match-end 0))))
+ (setq i (1+ i)))
+ (setq completions
+ (cons (cons str nil)
+ completions))))
+ (if completions
+ (list (completing-read "Follow reference named: " completions nil t))
+ (error "No cross-references in this node"))))
+ (let (target beg i (str (concat "\\*note " footnotename)))
+ (while (setq i (string-match " " str i))
+ (setq str (concat (substring str 0 i) "[ \t\n]+" (substring str (1+ i))))
+ (setq i (+ i 6)))
+ (save-excursion
+ (goto-char (point-min))
+ (or (re-search-forward str nil t)
+ (error "No cross-reference named %s" footnotename))
+ (goto-char (+ (match-beginning 0) 5))
+ (setq target (Info-extract-menu-node-name "Bad format cross reference")))
+ (while (setq i (string-match "[ \t\n]+" target i))
+ (setq target (concat (substring target 0 i) " "
+ (substring target (match-end 0))))
+ (setq i (+ i 1)))
+ (Info-goto-node target)))
+
+(defun Info-extract-menu-node-name (&optional errmessage)
+ (skip-chars-forward " \t\n")
+ (let ((beg (point))
+ str i)
+ (skip-chars-forward "^:")
+ (forward-char 1)
+ (setq str
+ (if (looking-at ":")
+ (buffer-substring beg (1- (point)))
+ (skip-chars-forward " \t\n")
+ (Info-following-node-name "^.,\t\n")))
+ (while (setq i (string-match "\n" str i))
+ (aset str i ?\ ))
+ str))
+
+(defun Info-menu-item-sequence (list)
+ (while list
+ (Info-menu-item (car list))
+ (setq list (cdr list))))
+
+(defun Info-menu (menu-item)
+ "Go to node for menu item named (or abbreviated) NAME."
+ (interactive
+ (let ((completions '())
+ ;; If point is within a menu item, use that item as the default
+ (default nil)
+ (p (point))
+ (last nil))
+ (save-excursion
+ (goto-char (point-min))
+ (if (not (search-forward "\n* menu:" nil t))
+ (error "No menu in this node"))
+ (while (re-search-forward
+ "\n\\* \\([^:\t\n]*\\):" nil t)
+ (if (and (null default)
+ (prog1 (if last (< last p) nil)
+ (setq last (match-beginning 0)))
+ (<= p last))
+ (setq default (car (car completions))))
+ (setq completions (cons (cons (buffer-substring
+ (match-beginning 1)
+ (match-end 1))
+ (match-beginning 1))
+ completions)))
+ (if (and (null default) last
+ (< last p)
+ (<= p (progn (end-of-line) (point))))
+ (setq default (car (car completions)))))
+ (let ((item nil))
+ (while (null item)
+ (setq item (let ((completion-ignore-case t))
+ (completing-read (if default
+ (format "Menu item (default %s): "
+ default)
+ "Menu item: ")
+ completions nil t)))
+ ;; we rely on the bug (which RMS won't change for his own reasons)
+ ;; that ;; completing-read accepts an input of "" even when the
+ ;; require-match argument is true and "" is not a valid possibility
+ (if (string= item "")
+ (if default
+ (setq item default)
+ ;; ask again
+ (setq item nil))))
+ (list item))))
+ (Info-goto-node (Info-extract-menu-item menu-item)))
+
+(defun Info-extract-menu-item (menu-item)
+ (save-excursion
+ (goto-char (point-min))
+ (or (search-forward "\n* menu:" nil t)
+ (error "No menu in this node"))
+ (or (search-forward (concat "\n* " menu-item ":") nil t)
+ (search-forward (concat "\n* " menu-item) nil t)
+ (error "No such item in menu"))
+ (beginning-of-line)
+ (forward-char 2)
+ (Info-extract-menu-node-name)))
+
+(defun Info-extract-menu-counting (count)
+ (save-excursion
+ (goto-char (point-min))
+ (or (search-forward "\n* menu:" nil t)
+ (error "No menu in this node"))
+ (or (search-forward "\n* " nil t count)
+ (error "Too few items in menu"))
+ (Info-extract-menu-node-name)))
+
+(defun Info-first-menu-item ()
+ "Go to the node of the first menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 1)))
+
+(defun Info-second-menu-item ()
+ "Go to the node of the second menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 2)))
+
+(defun Info-third-menu-item ()
+ "Go to the node of the third menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 3)))
+
+(defun Info-fourth-menu-item ()
+ "Go to the node of the fourth menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 4)))
+
+(defun Info-fifth-menu-item ()
+ "Go to the node of the fifth menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 5)))
+
+(defun Info-exit ()
+ "Exit Info by selecting some other buffer."
+ (interactive)
+ (switch-to-buffer (prog1 (other-buffer (current-buffer))
+ (bury-buffer (current-buffer)))))
+
+(defun Info-undefined ()
+ "Make command be undefined in Info."
+ (interactive)
+ (ding))
+
+(defun Info-help ()
+ "Enter the Info tutorial."
+ (interactive)
+ (Info-find-node "info"
+ (if (< (window-height) 23)
+ "Help-Small-Screen"
+ "Help")))
+
+(defun Info-summary ()
+ "Display a brief summary of all Info commands."
+ (interactive)
+ (save-window-excursion
+ (switch-to-buffer "*Help*")
+ (erase-buffer)
+ (insert (documentation 'Info-mode))
+ (goto-char (point-min))
+ (let (ch flag)
+ (while (progn (setq flag (not (pos-visible-in-window-p (point-max))))
+ (message (if flag "Type Space to see more"
+ "Type Space to return to Info"))
+ (if (/= ?\ (setq ch (read-char)))
+ (progn (setq unread-command-char ch) nil)
+ flag))
+ (scroll-up)))))
+\f
+(defvar Info-mode-map nil
+ "Keymap containing Info commands.")
+(if Info-mode-map
+ nil
+ (setq Info-mode-map (make-keymap))
+ (suppress-keymap Info-mode-map)
+ (define-key Info-mode-map "." 'beginning-of-buffer)
+ (define-key Info-mode-map " " 'scroll-up)
+ (define-key Info-mode-map "1" 'Info-first-menu-item)
+ (define-key Info-mode-map "2" 'Info-second-menu-item)
+ (define-key Info-mode-map "3" 'Info-third-menu-item)
+ (define-key Info-mode-map "4" 'Info-fourth-menu-item)
+ (define-key Info-mode-map "5" 'Info-fifth-menu-item)
+ (define-key Info-mode-map "6" 'undefined)
+ (define-key Info-mode-map "7" 'undefined)
+ (define-key Info-mode-map "8" 'undefined)
+ (define-key Info-mode-map "9" 'undefined)
+ (define-key Info-mode-map "0" 'undefined)
+ (define-key Info-mode-map "?" 'Info-summary)
+ (define-key Info-mode-map "b" 'beginning-of-buffer)
+ (define-key Info-mode-map "d" 'Info-directory)
+ (define-key Info-mode-map "e" 'Info-edit)
+ (define-key Info-mode-map "f" 'Info-follow-reference)
+ (define-key Info-mode-map "g" 'Info-goto-node)
+ (define-key Info-mode-map "h" 'Info-help)
+ (define-key Info-mode-map "l" 'Info-last)
+ (define-key Info-mode-map "m" 'Info-menu)
+ (define-key Info-mode-map "n" 'Info-next)
+ (define-key Info-mode-map "p" 'Info-prev)
+ (define-key Info-mode-map "q" 'Info-exit)
+ (define-key Info-mode-map "s" 'Info-search)
+ (define-key Info-mode-map "u" 'Info-up)
+ (define-key Info-mode-map "\177" 'scroll-down))
+
+(defun Info-mode ()
+ "Info mode provides commands for browsing through the Info documentation tree.
+Documentation in Info is divided into \"nodes\", each of which
+discusses one topic and contains references to other nodes
+which discuss related topics. Info has commands to follow
+the references and show you other nodes.
+
+h Invoke the Info tutorial.
+
+Selecting other nodes:
+n Move to the \"next\" node of this node.
+p Move to the \"previous\" node of this node.
+u Move \"up\" from this node.
+m Pick menu item specified by name (or abbreviation).
+ Picking a menu item causes another node to be selected.
+f Follow a cross reference. Reads name of reference.
+l Move to the last node you were at.
+
+Moving within a node:
+Space scroll forward a page. DEL scroll backward.
+b Go to beginning of node.
+
+Advanced commands:
+q Quit Info: reselect previously selected buffer.
+e Edit contents of selected node.
+1 Pick first item in node's menu.
+2, 3, 4, 5 Pick second ... fifth item in node's menu.
+g Move to node specified by name.
+ You may include a filename as well, as (FILENAME)NODENAME.
+s Search through this Info file for specified regexp,
+ and select the node in which the next occurrence is found."
+ (kill-all-local-variables)
+ (setq major-mode 'Info-mode)
+ (setq mode-name "Info")
+ (use-local-map Info-mode-map)
+ (set-syntax-table text-mode-syntax-table)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (setq case-fold-search t)
+ (setq buffer-read-only t)
+ (make-local-variable 'Info-current-file)
+ (make-local-variable 'Info-current-subfile)
+ (make-local-variable 'Info-current-node)
+ (make-local-variable 'Info-tag-table-marker)
+ (make-local-variable 'Info-history)
+ (Info-set-mode-line))
+
+(defvar Info-edit-map nil
+ "Local keymap used within `e' command of Info.")
+(if Info-edit-map
+ nil
+ (setq Info-edit-map (copy-keymap text-mode-map))
+ (define-key Info-edit-map "\C-c\C-c" 'Info-cease-edit))
+
+(defun Info-edit-mode ()
+ "Major mode for editing the contents of an Info node.
+Like text mode with the addition of Info-cease-edit
+which returns to Info mode for browsing.
+\\{Info-edit-map}"
+ )
+
+(defun Info-edit ()
+ "Edit the contents of this Info node.
+Allowed only if variable Info-enable-edit is non-nil."
+ (interactive)
+ (or Info-enable-edit
+ (error "Editing info nodes is not enabled"))
+ (use-local-map Info-edit-map)
+ (setq major-mode 'Info-edit-mode)
+ (setq mode-name "Info Edit")
+ (kill-local-variable 'mode-line-buffer-identification)
+ (setq buffer-read-only nil)
+ ;; Make mode line update.
+ (set-buffer-modified-p (buffer-modified-p))
+ (message (substitute-command-keys
+ "Editing: Type \\[Info-cease-edit] to return to info")))
+
+(defun Info-cease-edit ()
+ "Finish editing Info node; switch back to Info proper."
+ (interactive)
+ ;; Do this first, so nothing has changed if user C-g's at query.
+ (and (buffer-modified-p)
+ (y-or-n-p "Save the file? ")
+ (save-buffer))
+ (use-local-map Info-mode-map)
+ (setq major-mode 'Info-mode)
+ (setq mode-name "Info")
+ (Info-set-mode-line)
+ (setq buffer-read-only t)
+ ;; Make mode line update.
+ (set-buffer-modified-p (buffer-modified-p))
+ (and (marker-position Info-tag-table-marker)
+ (buffer-modified-p)
+ (message "Tags may have changed. Use Info-tagify if necessary")))
--- /dev/null
+;; Info support functions package for Emacs
+;; Copyright (C) 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.
+
+(require 'info)
+
+(defun Info-tagify ()
+ "Create or update Info-file tag table in current buffer."
+ (interactive)
+ ;; Save and restore point and restrictions.
+ ;; save-restrictions would not work
+ ;; because it records the old max relative to the end.
+ ;; We record it relative to the beginning.
+ (let ((omin (point-min))
+ (omax (point-max))
+ (nomax (= (point-max) (1+ (buffer-size))))
+ (opoint (point)))
+ (unwind-protect
+ (progn
+ (widen)
+ (goto-char (point-min))
+ (if (search-forward "\^_\nIndirect:\n" nil t)
+ (message "Cannot tagify split info file")
+ (let ((regexp "Node:[ \t]*\\([^,\n\t]\\)*[,\t\n]")
+ (case-fold-search t)
+ list)
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point)))
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (setq list
+ (cons (list (buffer-substring
+ (match-beginning 1)
+ (match-end 1))
+ beg)
+ list)))))
+ (goto-char (point-max))
+ (forward-line -8)
+ (let ((buffer-read-only nil))
+ (if (search-forward "\^_\nEnd tag table\n" nil t)
+ (let ((end (point)))
+ (search-backward "\nTag table:\n")
+ (beginning-of-line)
+ (delete-region (point) end)))
+ (goto-char (point-max))
+ (insert "\^_\f\nTag table:\n")
+ (move-marker Info-tag-table-marker (point))
+ (setq list (nreverse list))
+ (while list
+ (insert "Node: " (car (car list)) ?\177)
+ (princ (car (cdr (car list))) (current-buffer))
+ (insert ?\n)
+ (setq list (cdr list)))
+ (insert "\^_\nEnd tag table\n")))))
+ (goto-char opoint)
+ (narrow-to-region omin (if nomax (1+ (buffer-size))
+ (min omax (point-max)))))))
+\f
+(defun Info-split ()
+ "Split an info file into an indirect file plus bounded-size subfiles.
+Each subfile will be up to 50000 characters plus one node.
+
+To use this command, first visit a large Info file that has a tag table.
+The buffer is modified into a (small) indirect info file
+which should be saved in place of the original visited file.
+
+The subfiles are written in the same directory the original file is in,
+with names generated by appending `-' and a number to the original file name.
+
+The indirect file still functions as an Info file, but it contains
+just the tag table and a directory of subfiles."
+ (interactive)
+ (if (< (buffer-size) 70000)
+ (error "This is too small to be worth splitting"))
+ (goto-char (point-min))
+ (search-forward "\^_")
+ (forward-char -1)
+ (let ((start (point))
+ (chars-deleted 0)
+ subfiles
+ (subfile-number 1)
+ (case-fold-search t)
+ (filename (file-name-sans-versions buffer-file-name)))
+ (goto-char (point-max))
+ (forward-line -8)
+ (setq buffer-read-only nil)
+ (or (search-forward "\^_\nEnd tag table\n" nil t)
+ (error "Tag table required; use M-x Info-tagify"))
+ (search-backward "\nTag table:\n")
+ (if (looking-at "\nTag table:\n\^_")
+ (error "Tag table is just a skeleton; use M-x Info-tagify"))
+ (beginning-of-line)
+ (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (goto-char (point-min))
+ (while (< (1+ (point)) (point-max))
+ (goto-char (min (+ (point) 50000) (point-max)))
+ (search-forward "\^_" nil 'move)
+ (setq subfiles
+ (cons (list (+ start chars-deleted)
+ (concat (file-name-nondirectory filename)
+ (format "-%d" subfile-number)))
+ subfiles))
+ ;; Put a newline at end of split file, to make Unix happier.
+ (insert "\n")
+ (write-region (point-min) (point)
+ (concat filename (format "-%d" subfile-number)))
+ (delete-region (1- (point)) (point))
+ ;; Back up over the final ^_.
+ (forward-char -1)
+ (setq chars-deleted (+ chars-deleted (- (point) start)))
+ (delete-region start (point))
+ (setq subfile-number (1+ subfile-number))))
+ (while subfiles
+ (goto-char start)
+ (insert (nth 1 (car subfiles))
+ (format ": %d" (car (car subfiles)))
+ "\n")
+ (setq subfiles (cdr subfiles)))
+ (goto-char start)
+ (insert "\^_\nIndirect:\n")
+ (search-forward "\nTag Table:\n")
+ (insert "(Indirect)\n")))
+\f
+(defun Info-validate ()
+ "Check current buffer for validity as an Info file.
+Check that every node pointer points to an existing node."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (search-forward "\nTag table:\n(Indirect)\n" nil t)
+ (error "Don't yet know how to validate indirect info files: \"%s\""
+ (buffer-name (current-buffer))))
+ (goto-char (point-min))
+ (let ((allnodes '(("*")))
+ (regexp "Node:[ \t]*\\([^,\n\t]*\\)[,\t\n]")
+ (case-fold-search t)
+ (tags-losing nil)
+ (lossages ()))
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point)))
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (let ((name (downcase
+ (buffer-substring
+ (match-beginning 1)
+ (progn
+ (goto-char (match-end 1))
+ (skip-chars-backward " \t")
+ (point))))))
+ (if (assoc name allnodes)
+ (setq lossages
+ (cons (list name "Duplicate node-name" nil)
+ lossages))
+ (setq allnodes
+ (cons (list name
+ (progn
+ (end-of-line)
+ (and (re-search-backward
+ "prev[ious]*:" beg t)
+ (progn
+ (goto-char (match-end 0))
+ (downcase
+ (Info-following-node-name)))))
+ beg)
+ allnodes)))))))
+ (goto-char (point-min))
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point))
+ thisnode next)
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (save-restriction
+ (search-forward "\n\^_" nil 'move)
+ (narrow-to-region beg (point))
+ (setq thisnode (downcase
+ (buffer-substring
+ (match-beginning 1)
+ (progn
+ (goto-char (match-end 1))
+ (skip-chars-backward " \t")
+ (point)))))
+ (end-of-line)
+ (and (search-backward "next:" nil t)
+ (setq next (Info-validate-node-name "invalid Next"))
+ (assoc next allnodes)
+ (if (equal (car (cdr (assoc next allnodes)))
+ thisnode)
+ ;; allow multiple `next' pointers to one node
+ (let ((tem lossages))
+ (while tem
+ (if (and (equal (car (cdr (car tem)))
+ "should have Previous")
+ (equal (car (car tem))
+ next))
+ (setq lossages (delq (car tem) lossages)))
+ (setq tem (cdr tem))))
+ (setq lossages
+ (cons (list next
+ "should have Previous"
+ thisnode)
+ lossages))))
+ (end-of-line)
+ (if (re-search-backward "prev[ious]*:" nil t)
+ (Info-validate-node-name "invalid Previous"))
+ (end-of-line)
+ (if (search-backward "up:" nil t)
+ (Info-validate-node-name "invalid Up"))
+ (if (re-search-forward "\n* Menu:" nil t)
+ (while (re-search-forward "\n\\* " nil t)
+ (Info-validate-node-name
+ (concat "invalid menu item "
+ (buffer-substring (point)
+ (save-excursion
+ (skip-chars-forward "^:")
+ (point))))
+ (Info-extract-menu-node-name))))
+ (goto-char (point-min))
+ (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t)
+ (goto-char (+ (match-beginning 0) 5))
+ (skip-chars-forward " \n")
+ (Info-validate-node-name
+ (concat "invalid reference "
+ (buffer-substring (point)
+ (save-excursion
+ (skip-chars-forward "^:")
+ (point))))
+ (Info-extract-menu-node-name "Bad format cross-reference")))))))
+ (setq tags-losing (not (Info-validate-tags-table)))
+ (if (or lossages tags-losing)
+ (with-output-to-temp-buffer " *problems in info file*"
+ (while lossages
+ (princ "In node \"")
+ (princ (car (car lossages)))
+ (princ "\", ")
+ (let ((tem (nth 1 (car lossages))))
+ (cond ((string-match "\n" tem)
+ (princ (substring tem 0 (match-beginning 0)))
+ (princ "..."))
+ (t
+ (princ tem))))
+ (if (nth 2 (car lossages))
+ (progn
+ (princ ": ")
+ (let ((tem (nth 2 (car lossages))))
+ (cond ((string-match "\n" tem)
+ (princ (substring tem 0 (match-beginning 0)))
+ (princ "..."))
+ (t
+ (princ tem))))))
+ (terpri)
+ (setq lossages (cdr lossages)))
+ (if tags-losing (princ "\nTags table must be recomputed\n")))
+ ;; Here if info file is valid.
+ ;; If we already made a list of problems, clear it out.
+ (save-excursion
+ (if (get-buffer " *problems in info file*")
+ (progn
+ (set-buffer " *problems in info file*")
+ (kill-buffer (current-buffer)))))
+ (message "File appears valid"))))))
+
+(defun Info-validate-node-name (kind &optional name)
+ (if name
+ nil
+ (goto-char (match-end 0))
+ (skip-chars-forward " \t")
+ (if (= (following-char) ?\()
+ nil
+ (setq name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^,\t\n")
+ (skip-chars-backward " ")
+ (point))))))
+ (if (null name)
+ nil
+ (setq name (downcase name))
+ (or (and (> (length name) 0) (= (aref name 0) ?\())
+ (assoc name allnodes)
+ (setq lossages
+ (cons (list thisnode kind name) lossages))))
+ name)
+
+(defun Info-validate-tags-table ()
+ (goto-char (point-min))
+ (if (not (search-forward "\^_\nEnd tag table\n" nil t))
+ t
+ (not (catch 'losing
+ (let* ((end (match-beginning 0))
+ (start (progn (search-backward "\nTag table:\n")
+ (1- (match-end 0))))
+ tem)
+ (setq tem allnodes)
+ (while tem
+ (goto-char start)
+ (or (equal (car (car tem)) "*")
+ (search-forward (concat "Node: "
+ (car (car tem))
+ "\177")
+ end t)
+ (throw 'losing 'x))
+ (setq tem (cdr tem)))
+ (goto-char (1+ start))
+ (while (looking-at ".*Node: \\(.*\\)\177\\([0-9]+\\)$")
+ (setq tem (downcase (buffer-substring
+ (match-beginning 1)
+ (match-end 1))))
+ (setq tem (assoc tem allnodes))
+ (if (or (not tem)
+ (< 1000 (progn
+ (goto-char (match-beginning 2))
+ (setq tem (- (car (cdr (cdr tem)))
+ (read (current-buffer))))
+ (if (> tem 0) tem (- tem)))))
+ (throw 'losing 'y)))
+ (forward-line 1))
+ (or (looking-at "End tag table\n")
+ (throw 'losing 'z))
+ nil))))
+\f
+(defun batch-info-validate ()
+ "Runs Info-validate on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
+ (if (not noninteractive)
+ (error "batch-info-validate may only be used -batch."))
+ (let ((version-control t)
+ (auto-save-default nil)
+ (find-file-run-dired nil)
+ (kept-old-versions 259259)
+ (kept-new-versions 259259))
+ (let ((error 0)
+ file
+ (files ()))
+ (while command-line-args-left
+ (setq file (expand-file-name (car command-line-args-left)))
+ (cond ((not (file-exists-p file))
+ (message ">> %s does not exist!" file)
+ (setq error 1
+ command-line-args-left (cdr command-line-args-left)))
+ ((file-directory-p file)
+ (setq command-line-args-left (nconc (directory-files file)
+ (cdr command-line-args-left))))
+ (t
+ (setq files (cons file files)
+ command-line-args-left (cdr command-line-args-left)))))
+ (while files
+ (setq file (car files)
+ files (cdr files))
+ (let ((lose nil))
+ (condition-case err
+ (progn
+ (if buffer-file-name (kill-buffer (current-buffer)))
+ (find-file file)
+ (buffer-flush-undo (current-buffer))
+ (set-buffer-modified-p nil)
+ (fundamental-mode)
+ (let ((case-fold-search nil))
+ (goto-char (point-max))
+ (cond ((search-backward "\n\^_\^L\nTag table:\n" nil t)
+ (message "%s already tagified" file))
+ ((< (point-max) 30000)
+ (message "%s too small to bother tagifying" file))
+ (t
+ (message "Tagifying %s..." file)
+ (Info-tagify)
+ (message "Tagifying %s...done" file))))
+ (let ((loss-name " *problems in info file*"))
+ (message "Checking validity of info file %s..." file)
+ (if (get-buffer loss-name)
+ (kill-buffer loss-name))
+ (Info-validate)
+ (if (not (get-buffer loss-name))
+ nil ;(message "Checking validity of info file %s... OK" file)
+ (message "----------------------------------------------------------------------")
+ (message ">> PROBLEMS IN INFO FILE %s" file)
+ (save-excursion
+ (set-buffer loss-name)
+ (princ (buffer-substring (point-min) (point-max))))
+ (message "----------------------------------------------------------------------")
+ (setq error 1 lose t)))
+ (if (and (buffer-modified-p)
+ (not lose))
+ (progn (message "Saving modified %s" file)
+ (save-buffer))))
+ (error (message ">> Error: %s" (prin1-to-string err))))))
+ (kill-emacs error))))
--- /dev/null
+;; Incremental search
+;; 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.
+
+; in loaddefs.el
+;(defvar search-last-string ""
+; "Last string search for by a search command.
+;This does not include direct calls to the primitive search functions,
+;and does not include searches that are aborted.")
+;(defvar search-last-regexp ""
+; "Last string searched for by a regexp search command.
+;This does not include direct calls to the primitive search functions,
+;and does not include searches that are aborted.")
+;
+;(defconst search-repeat-char ?\C-s
+; "Character to repeat incremental search forwards.")
+;(defconst search-reverse-char ?\C-r
+; "Character to repeat incremental search backwards.")
+;(defconst search-exit-char ?\e
+; "Character to exit incremental search.")
+;(defconst search-delete-char ?\177
+; "Character to delete from incremental search string.")
+;(defconst search-quote-char ?\C-q
+; "Character to quote special characters for incremental search.")
+;(defconst search-yank-word-char ?\C-w
+; "Character to pull next word from buffer into search string.")
+;(defconst search-yank-line-char ?\C-y
+; "Character to pull rest of line from buffer into search string.")
+;(defconst search-exit-option t
+; "Non-nil means random control characters terminate incremental search.")
+;
+;(defvar search-slow-window-lines 1
+; "*Number of lines in slow search display windows.")
+;(defconst search-slow-speed 1200
+; "*Highest terminal speed at which to use \"slow\" style incremental search.
+;This is the style where a one-line window is created to show the line
+;that the search has reached.")
+
+;; This function does all the work of incremental search.
+;; The functions attached to ^R and ^S are trivial,
+;; merely calling this one, but they are always loaded by default
+;; whereas this file can optionally be autoloadable.
+;; This is the only entry point in this file.
+
+(defun isearch (forward &optional regexp)
+ (let ((search-string "")
+ (search-message "")
+ (cmds nil)
+ (success t)
+ (wrapped nil)
+ (barrier (point))
+ adjusted
+ (invalid-regexp nil)
+ (slow-terminal-mode (and (<= (baud-rate) search-slow-speed)
+ (> (window-height)
+ (* 4 search-slow-window-lines))))
+ (other-end nil) ;Start of last match if fwd, end if backwd.
+ (small-window nil) ;if t, using a small window
+ (found-point nil) ;to restore point from a small window
+ ;; This is the window-start value found by the search.
+ (found-start nil)
+ (opoint (point))
+ (inhibit-quit t)) ;Prevent ^G from quitting immediately.
+ (isearch-push-state)
+ (save-window-excursion
+ (catch 'search-done
+ (while t
+ (or (>= unread-command-char 0)
+ (progn
+ (or (input-pending-p)
+ (isearch-message))
+ (if (and slow-terminal-mode
+ (not (or small-window (pos-visible-in-window-p))))
+ (progn
+ (setq small-window t)
+ (setq found-point (point))
+ (move-to-window-line 0)
+ (let ((window-min-height 1))
+ (split-window nil (if (< search-slow-window-lines 0)
+ (1+ (- search-slow-window-lines))
+ (- (window-height)
+ (1+ search-slow-window-lines)))))
+ (if (< search-slow-window-lines 0)
+ (progn (vertical-motion (- 1 search-slow-window-lines))
+ (set-window-start (next-window) (point))
+ (set-window-hscroll (next-window)
+ (window-hscroll))
+ (set-window-hscroll (selected-window) 0))
+ (other-window 1))
+ (goto-char found-point)))))
+ (let ((char (if quit-flag
+ ?\C-g
+ (read-char))))
+ (setq quit-flag nil adjusted nil)
+ ;; Meta character means exit search.
+ (cond ((and (>= char 128)
+ search-exit-option)
+ (setq unread-command-char char)
+ (throw 'search-done t))
+ ((eq char search-exit-char)
+ ;; Esc means exit search normally.
+ ;; Except, if first thing typed, it means do nonincremental
+ (if (= 0 (length search-string))
+ (nonincremental-search forward regexp))
+ (throw 'search-done t))
+ ((= char ?\C-g)
+ ;; ^G means the user tried to quit.
+ (ding)
+ (discard-input)
+ (if success
+ ;; If search is successful, move back to starting point
+ ;; and really do quit.
+ (progn (goto-char opoint)
+ (signal 'quit nil))
+ ;; If search is failing, rub out until it is once more
+ ;; successful.
+ (while (not success) (isearch-pop))))
+ ((or (eq char search-repeat-char)
+ (eq char search-reverse-char))
+ (if (eq forward (eq char search-repeat-char))
+ ;; C-s in forward or C-r in reverse.
+ (if (equal search-string "")
+ ;; If search string is empty, use last one.
+ (setq search-string
+ (if regexp
+ search-last-regexp search-last-string)
+ search-message
+ (mapconcat 'text-char-description
+ search-string ""))
+ ;; If already have what to search for, repeat it.
+ (or success
+ (progn (goto-char (if forward (point-min) (point-max)))
+ (setq wrapped t))))
+ ;; C-s in reverse or C-r in forward, change direction.
+ (setq forward (not forward)))
+ (setq barrier (point)) ; For subsequent \| if regexp.
+ (setq success t)
+ (or (equal search-string "")
+ (isearch-search))
+ (isearch-push-state))
+ ((= char search-delete-char)
+ ;; Rubout means discard last input item and move point
+ ;; back. If buffer is empty, just beep.
+ (if (null (cdr cmds))
+ (ding)
+ (isearch-pop)))
+ (t
+ (cond ((or (eq char search-yank-word-char)
+ (eq char search-yank-line-char))
+ ;; ^W means gobble next word from buffer.
+ ;; ^Y means gobble rest of line from buffer.
+ (let ((word (save-excursion
+ (and (not forward) other-end
+ (goto-char other-end))
+ (buffer-substring
+ (point)
+ (save-excursion
+ (if (eq char search-yank-line-char)
+ (end-of-line)
+ (forward-word 1))
+ (point))))))
+ (if regexp
+ (setq word (regexp-quote word)))
+ (setq search-string (concat search-string word)
+ search-message
+ (concat search-message
+ (mapconcat 'text-char-description
+ word "")))))
+ ;; Any other control char =>
+ ;; unread it and exit the search normally.
+ ((and search-exit-option
+ (/= char search-quote-char)
+ (or (= char ?\177)
+ (and (< char ? ) (/= char ?\t) (/= char ?\r))))
+ (setq unread-command-char char)
+ (throw 'search-done t))
+ (t
+ ;; Any other character => add it to the
+ ;; search string and search.
+ (cond ((= char search-quote-char)
+ (setq char (read-quoted-char
+ (isearch-message t))))
+ ((= char ?\r)
+ ;; unix braindeath
+ (setq char ?\n)))
+ (setq search-string (concat search-string
+ (char-to-string char))
+ search-message (concat search-message
+ (text-char-description char)))))
+ (if (and (not success)
+ ;; unsuccessful regexp search may become
+ ;; successful by addition of characters which
+ ;; make search-string valid
+ (not regexp))
+ nil
+ ;; If a regexp search may have been made more
+ ;; liberal, retreat the search start.
+ ;; Go back to place last successful search started
+ ;; or to the last ^S/^R (barrier), whichever is nearer.
+ (and regexp success cmds
+ (cond ((memq char '(?* ??))
+ (setq adjusted t)
+ (let ((cs (nth (if forward
+ 5 ; other-end
+ 2) ; saved (point)
+ (car (cdr cmds)))))
+ ;; (car cmds) is after last search;
+ ;; (car (cdr cmds)) is from before it.
+ (setq cs (or cs barrier))
+ (goto-char
+ (if forward
+ (max cs barrier)
+ (min cs barrier)))))
+ ((eq char ?\|)
+ (setq adjusted t)
+ (goto-char barrier))))
+ ;; In reverse regexp search, adding a character at
+ ;; the end may cause zero or many more chars to be
+ ;; matched, in the string following point.
+ ;; Allow all those possibiities without moving point as
+ ;; long as the match does not extend past search origin.
+ (if (and regexp (not forward) (not adjusted)
+ (condition-case ()
+ (looking-at search-string)
+ (error nil))
+ (<= (match-end 0) (min opoint barrier)))
+ (setq success t invalid-regexp nil
+ other-end (match-end 0))
+ ;; Not regexp, not reverse, or no match at point.
+ (if (and other-end (not adjusted))
+ (goto-char (if forward other-end
+ (min opoint barrier (1+ other-end)))))
+ (isearch-search)))
+ (isearch-push-state))))))
+ (setq found-start (window-start (selected-window)))
+ (setq found-point (point)))
+ (if (> (length search-string) 0)
+ (if regexp
+ (setq search-last-regexp search-string)
+ (setq search-last-string search-string)))
+ ;; If there was movement, mark the starting position.
+ ;; Maybe should test difference between and set mark iff > threshold.
+ (if (/= (point) opoint)
+ (push-mark opoint)
+ (message ""))
+ (if small-window
+ (goto-char found-point)
+ ;; Exiting the save-window-excursion clobbers this; restore it.
+ (set-window-start (selected-window) found-start t))))
+
+(defun isearch-message (&optional c-q-hack ellipsis)
+ ;; If about to search, and previous search regexp was invalid,
+ ;; check that it still is. If it is valid now,
+ ;; let the message we display while searching say that it is valid.
+ (and invalid-regexp ellipsis
+ (condition-case ()
+ (progn (re-search-forward search-string (point) t)
+ (setq invalid-regexp nil))
+ (error nil)))
+ ;; If currently failing, display no ellipsis.
+ (or success (setq ellipsis nil))
+ (let ((m (concat (if success "" "failing ")
+ (if wrapped "wrapped ")
+ (if regexp "regexp " "")
+ "I-search"
+ (if forward ": " " backward: ")
+ search-message
+ (if c-q-hack "^Q" "")
+ (if invalid-regexp
+ (concat " [" invalid-regexp "]")
+ ""))))
+ (aset m 0 (upcase (aref m 0)))
+ (let ((cursor-in-echo-area ellipsis))
+ (if c-q-hack m (message "%s" m)))))
+
+(defun isearch-pop ()
+ (setq cmds (cdr cmds))
+ (let ((cmd (car cmds)))
+ (setq search-string (car cmd)
+ search-message (car (cdr cmd))
+ success (nth 3 cmd)
+ forward (nth 4 cmd)
+ other-end (nth 5 cmd)
+ invalid-regexp (nth 6 cmd)
+ wrapped (nth 7 cmd)
+ barrier (nth 8 cmd))
+ (goto-char (car (cdr (cdr cmd))))))
+
+(defun isearch-push-state ()
+ (setq cmds (cons (list search-string search-message (point)
+ success forward other-end invalid-regexp
+ wrapped barrier)
+ cmds)))
+
+(defun isearch-search ()
+ (isearch-message nil t)
+ (condition-case lossage
+ (let ((inhibit-quit nil))
+ (if regexp (setq invalid-regexp nil))
+ (setq success
+ (funcall
+ (if regexp
+ (if forward 're-search-forward 're-search-backward)
+ (if forward 'search-forward 'search-backward))
+ search-string nil t))
+ (if success
+ (setq other-end
+ (if forward (match-beginning 0) (match-end 0)))))
+ (quit (setq unread-command-char ?\C-g)
+ (setq success nil))
+ (invalid-regexp (setq invalid-regexp (car (cdr lossage)))
+ (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
+ invalid-regexp)
+ (setq invalid-regexp "incomplete input"))))
+ (if success
+ nil
+ ;; Ding if failed this time after succeeding last time.
+ (and (nth 3 (car cmds))
+ (ding))
+ (goto-char (nth 2 (car cmds)))))
+
+;; This is called from incremental-search
+;; if the first input character is the exit character.
+;; The interactive-arg-reader uses free variables `forward' and `regexp'
+;; which are bound by `incremental-search'.
+
+;; We store the search string in `search-string'
+;; which has been bound already by `incremental-search'
+;; so that, when we exit, it is copied into `search-last-string'.
+
+(defun nonincremental-search (forward regexp)
+ (let (message char function string inhibit-quit)
+ (let ((cursor-in-echo-area t))
+ ;; Prompt assuming not word search,
+ (setq message (if regexp
+ (if forward "Regexp search: "
+ "Regexp search backward: ")
+ (if forward "Search: " "Search backward: ")))
+ (message "%s" message)
+ ;; Read 1 char and switch to word search if it is ^W.
+ (setq char (read-char)))
+ (if (eq char search-yank-word-char)
+ (setq message (if forward "Word search: " "Word search backward: "))
+ ;; Otherwise let that 1 char be part of the search string.
+ (setq unread-command-char char))
+ (setq function
+ (if (eq char search-yank-word-char)
+ (if forward 'word-search-forward 'word-search-backward)
+ (if regexp
+ (if forward 're-search-forward 're-search-backward)
+ (if forward 'search-forward 'search-backward))))
+ ;; Read the search string with corrected prompt.
+ (setq string (read-string message))
+ ;; Empty means use default.
+ (if (= 0 (length string))
+ (setq string search-last-string)
+ ;; Set last search string now so it is set even if we fail.
+ (setq search-last-string string))
+ ;; Since we used the minibuffer, we should be available for redo.
+ (setq command-history (cons (list function string) command-history))
+ ;; Go ahead and search.
+ (funcall function string)))
--- /dev/null
+;;Additions to shell mode for use with kermit, etc.
+;;Feb 1988, Jeff Norden - jeff@colgate.csnet
+;; Copyright (C) 1988 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.
+
+(require 'shell)
+
+;; I'm not sure, but I think somebody asked about running kermit under shell
+;; mode a while ago. Anyway, here is some code that I find useful. The result
+;; is that I can log onto machines with primitive operating systems (VMS and
+;; ATT system V :-), and still have the features of shell-mode available for
+;; command history, etc. It's also handy to be able to run a file transfer in
+;; an emacs window. The transfer is in the "background", but you can also
+;; monitor or stop it easily.
+
+;; The ^\ key is bound to a function for sending escape sequences to kermit,
+;; and ^C^Q can be used to send any control characters needed thru to the
+;; system you connect to. A more serious problem is that some brain-dead
+;; systems will not recognize a ^J as an end-of-line character. So LFD is
+;; bound to a new function which acts just like CR usually does in shell-mode,
+;; but a ^M is sent as an end-of-line. Funcions are also provied to swap the
+;; bindings of CR and LFD. I've also included a filter which will clean out
+;; any ^M's or ^@'s that get typed at you, but I don't really recommend it.
+;; There doesn't seem to be an acceptably fast way to do this via emacs-lisp.
+;; Invoking kermit by the command " kermit | tr -d '\015' " seems to work
+;; better (on my system anyway).
+
+;; Here's how I've been using this setup. We have several machines connected
+;; thru a fairly stupid terminal switch. If I want to connect to unix system,
+;; then I use the LFD key to talk to the switch, and ignore any ^M's in the
+;; buffer, and do a " stty -echo nl " after I log in. Then the only real
+;; differnce from being in local shell-mode is that it is you need to to type
+;; ^C^Q^C to send an interrupt, and ^C^Q^Z for a stop signal, etc. (since ^C^C
+;; just generates a local stop signal, which kermit ignores).
+;; To connect to a VMS system, I use a shell script to invoke kermit thru the
+;; tr filter, do "M-X kermit-send-cr", and then tell VMS that I'm on a half-duplex
+;; terminal.
+
+;; Some caveats:
+;; 1) Kermit under shell mode is a real pain if you don't have pty's. I
+;; recently discovered this on our 3b2/400. When kermit can't find a tty, it
+;; assumes it is supposed to be in remote mode. So the simple command "kermit"
+;; won't work in shell mode on such a system. You can get around this by using
+;; the -c (connect) command line option, which means you also have to specify a
+;; line and baud on the command line, as in "kermit -l /dev/tty53 -b 9600 -c".
+;; However, this will cause kermit to exit when the connection is closed. So
+;; in order to do a file transfer, you have to think ahead and and add -r
+;; (receive) to the command line. This means that you can't use the server
+;; feature. The only fix I can see is to muck around with the source code for
+;; kermit, although this problably wouldn't be too hard. What is needed is an
+;; option to force kermit to be local, to use stdin and stdout for interactive
+;; speech, and to forget about cbreak mode.
+
+;; 2) The "clean-filter" can be a troublesome item. The main problem arises if
+;; you are running a program under shell-mode which is doing periodic output,
+;; and you then try to switch to another buffer. I came across this while
+;; running kermit file transfers - kermit prints a dot each time a packet is
+;; received. Since emacs is interrupted each time a dot is printed, it becomes
+;; impossible to edit the other buffer. If you hit a key while the filter code
+;; is running, that character will wind up in the *shell* buffer instead of the
+;; current one! So you need to be careful to turn the filter off before
+;; leaving the buffer if a program is still running. In fact, you can't even
+;; use "M-x clean-shell-off" to do this, because you won't be able to type
+;; "clean-shell-off" in the minibuffer!! So you need to have this command
+;; bound to a keystroke.
+
+;; Please let me know if any bugs turn up.
+;; Feb 1988, Jeff Norden - jeff@colgate.csnet
+
+(defvar kermit-esc-char "\C-\\" "*Kermit's escape char")
+
+(defun kermit-esc ()
+ "For sending escape sequences to a kermit running in shell mode."
+ (interactive)
+ (process-send-string
+ (get-buffer-process (current-buffer))
+ (concat kermit-esc-char (char-to-string (read-char)))))
+
+(defun kermit-send-char ()
+ "Send an arbitrary character to a program in shell mode."
+ (interactive)
+ (process-send-string
+ (get-buffer-process (current-buffer))
+ (char-to-string (read-char))))
+
+(define-key shell-mode-map "\C-\\" 'kermit-esc)
+(define-key shell-mode-map "\C-c\C-q" 'kermit-send-char)
+;; extra bindings for folks suffering form ^S/^Q braindamage:
+(define-key shell-mode-map "\C-c\\" 'kermit-esc)
+
+(defun shell-send-input-cr ()
+ "Like \\[shell-send-input] but end the line with carriage-return."
+ (interactive)
+ (end-of-line)
+ (if (eobp)
+ (progn
+ (move-marker last-input-start
+ (process-mark (get-buffer-process (current-buffer))))
+ (insert ?\n)
+ (move-marker last-input-end (point)))
+ (beginning-of-line)
+ (re-search-forward shell-prompt-pattern nil t)
+ (let ((copy (buffer-substring (point)
+ (progn (forward-line 1) (point)))))
+ (goto-char (point-max))
+ (move-marker last-input-start (point))
+ (insert copy)
+ (move-marker last-input-end (point))))
+ (condition-case ()
+ (save-excursion
+ (goto-char last-input-start)
+ (shell-set-directory))
+ (error (funcall shell-set-directory-error-hook)))
+ (let ((process (get-buffer-process (current-buffer))))
+ (process-send-region process last-input-start (- last-input-end 1))
+ (process-send-string process "\r")
+ (set-marker (process-mark process) (point))))
+
+;; This is backwards of what makes sense, but ...
+(define-key shell-mode-map "\n" 'shell-send-input-cr)
+
+(defun kermit-default-cr ()
+ "Make RETURN end the line with carriage-return and LFD end it with a newline.
+This is useful for talking to other systems on which carriage-return
+is the normal way to end a line."
+ (interactive)
+ (define-key shell-mode-map "\r" 'shell-send-input-cr)
+ (define-key shell-mode-map "\n" 'shell-send-input))
+
+(defun kermit-default-nl ()
+ "Make RETURN end the line with a newline char. This is the default state.
+In this state, use LFD to send a line and end it with a carriage-return."
+ (interactive)
+ (define-key shell-mode-map "\n" 'shell-send-input-cr)
+ (define-key shell-mode-map "\r" 'shell-send-input))
+
+;; This filter works, but I don't especially recommend it.
+(defun kermit-clean-filter (process string)
+ "A process filter which deletes all ^M's and ^@'s from the output."
+ (set-buffer (process-buffer process))
+ (let
+ ((firstpos (string-match "[^\C-@\r]+" string))
+ (buffermark (process-mark process))
+ (oldpt (point))
+ (newstring '"")
+ goback)
+ (while firstpos
+ (setq newstring
+ (concat newstring (substring string firstpos (match-end 0))))
+ (setq firstpos (string-match "[^\C-@\r]+" string (match-end 0))))
+ (goto-char (marker-position buffermark))
+ (setq goback (< oldpt (point)))
+ (insert newstring)
+ (set-marker buffermark (point))
+ (if goback (goto-char oldpt))))
+
+(defun kermit-clean-on ()
+ "Delete all null characters and ^M's from the kermit output.
+Note that another (perhaps better) way to do this is to use the
+command `kermit | tr -d '\\015''."
+ (interactive)
+ (set-process-filter (get-buffer-process (current-buffer))
+ 'kermit-clean-filter))
+
+(defun kermit-clean-off ()
+ "Cancel a previous kermit-clean-shell-on command"
+ (interactive)
+ (set-process-filter (get-buffer-process (current-buffer)) nil))
+
+
--- /dev/null
+;; Terminal-independent keypad and function key bindings.
+;; Copyright (C) 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.
+
+
+;; These keys are handled by a two-level process.
+;; The first level, terminal-dependent, maps input sequences
+;; into the function keys that they represent.
+;; The second level, terminal-independent but customized by users,
+;; map function keys into meanings.
+
+;; This file takes care of the second level of mapping.
+;; The first, terminal-dependent, level is handled by the
+;; terminal-specific files term/*.el.
+
+;; The second-level mapping is done by a keymap, function-keymap.
+;; Here we document the meanings of the "characters" defined by
+;; function-keymap.
+
+;; What do these letters mean?
+;; When we say that ``a stands for the clear-all-tabs key'',
+;; we mean that you should attach to the letter `a' in function-keymap
+;; whatever command you want to be executed when you type the
+;; clear-all-tabs key on any terminal. The terminal-dependent
+;; files will attempt to make this work. If a terminal has no
+;; clear-all-tabs key that can be recognized, it makes no difference
+;; what binding you give to `a' in function-keymap.
+
+;; a -- clear all tabs key
+;; c -- erase key
+;; d -- down-arrow
+;; e -- enter key
+;; f -- find key or search key
+;; h -- home-position key
+;; k -- delete key or remove key.
+;; l -- left-arrow
+;; p -- portrait mode
+;; q -- landscape mode
+;; r -- right-arrow
+;; s -- select key
+;; t -- clear tab this column key
+;; u -- up-arrow
+;; x -- do key
+;; ? -- help
+
+;; - -- keypad key labelled `-'.
+;; . -- keypad key labelled `.'.
+;; , -- keypad key labelled `,'.
+;; 0 ... 9 -- keypad key labelled with that digit,
+;; but only if that key is not also an arrow key.
+
+;; C-@, C-a, ... C-x -- numbered function keys 0 through 24.
+;; These are used for function keys with no labels but numbers,
+;; and may also be used for function keys with labels
+;; that we have not defined letters for.
+
+;; A -- insert line key
+;; C -- clear screen key
+;; D -- delete character key.
+;; E -- clear to end of line key
+;; F -- scroll forward key
+;; H -- home-down
+;; I -- insert character key
+;; If there is just an "insert" key, it should be this.
+;; L -- delete line key
+;; M -- exit insert mode key
+;; N -- next page key
+;; P -- previous page key
+;; R -- scroll reverse key
+;; S -- clear to end of screen key
+;; T -- set tab this column key
+
+(defun keypad-default (char definition)
+ (or (lookup-key function-keymap char)
+ (define-key function-keymap char definition)))
+
+;; Here are the standard command meanings we give to the various
+;; function key names. Because this file is loaded after the user's
+;; init file, we are careful to avoid overriding any definitions
+;; already stored in function-keymap by the init file or (less often)
+;; by the terminal-specific term/*.el file.
+
+(keypad-default "l" 'backward-char)
+(keypad-default "r" 'forward-char)
+(keypad-default "D" 'delete-char)
+(keypad-default "u" 'previous-line)
+(keypad-default "d" 'next-line)
+(keypad-default "N" 'scroll-up)
+(keypad-default "P" 'scroll-down)
+(keypad-default "C" 'recenter)
+(keypad-default "?" 'help-for-help)
+(keypad-default "s" 'set-mark-command)
+(keypad-default "k" 'kill-region)
+(keypad-default "f" 're-search-forward)
+
+(keypad-default "\C-a" 'beginning-of-line)
+(keypad-default "\C-b" 'end-of-line)
+(keypad-default "\C-c" 'isearch-forward)
+(keypad-default "\C-d" 'kill-line)
+
+(keypad-default "." 'delete-char)
+(keypad-default "0" 'yank)
+(keypad-default "e" 'open-line)
+(keypad-default "1" 'backward-word)
+(keypad-default "3" 'forward-word)
+(keypad-default "7" 'backward-paragraph)
+(keypad-default "9" 'forward-paragraph)
+(keypad-default "h" 'move-to-window-line)
+
+(defun setup-terminal-keymap (map translations)
+ "Set up keymap MAP to forward to function-keymap according to TRANSLATIONS.
+TRANSLATIONS is an alist; each element of it looks like (FROMSTRING . TOCHAR).
+For each such pair, we define the key sequence FROMSTRING in MAP
+to forward to the definition of character TOCHAR in function-keymap.
+\"Forwarding\" means that subsequent redefinition of TOCHAR in
+function-keymap will be seen automatically in MAP as well.
+
+This function is used by files term/*.el to set up the mapping from the
+escape sequences sent by function keys on particular terminals (FROMSTRINGs)
+into Emacs standard function key slots (TOCHARs).
+An actual definition (such as a symbol) may be given in place of TOCHAR.
+Generally, MAP is a prefix keymap which will be attached to a key
+that is the common prefix sent by all function keys (often ESC O or ESC [)."
+ (while translations
+ (define-key map (car (car translations))
+ (if (numberp (cdr (car translations)))
+ (cons function-keymap (cdr (car translations)))
+ (cdr (car translations))))
+ (setq translations (cdr translations))))
+
+(defun function-key-sequence (char)
+ "Return key sequence for function key that on this terminal
+translates into slot CHAR in function-keymap.
+Or return nil if there is none."
+ (car (where-is-internal (cons function-keymap char) (current-local-map))))
+
+(provide 'keypad)
--- /dev/null
+;; Emacs side of ledit interface
+;; Copyright (C) 1985 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.
+
+
+;;; To do:
+;;; o lisp -> emacs side of things (grind-definition and find-definition)
+
+(defvar ledit-mode-map nil)
+
+(defconst ledit-zap-file (concat "/tmp/" (getenv "USER") ".l1")
+ "File name for data sent to Lisp by Ledit.")
+(defconst ledit-read-file (concat "/tmp/" (getenv "USER") ".l2")
+ "File name for data sent to Ledit by Lisp.")
+(defconst ledit-compile-file
+ (concat "/tmp/" (getenv "USER") ".l4")
+ "File name for data sent to Lisp compiler by Ledit.")
+(defconst ledit-buffer "*LEDIT*"
+ "Name of buffer in which Ledit accumulates data to send to Lisp.")
+;These are now in loaddefs.el
+;(defconst ledit-save-files t
+; "*Non-nil means Ledit should save files before transferring to Lisp.")
+;(defconst ledit-go-to-lisp-string "%?lisp"
+; "*Shell commands to execute to resume Lisp job.")
+;(defconst ledit-go-to-liszt-string "%?liszt"
+; "*Shell commands to execute to resume Lisp compiler job.")
+
+(defun ledit-save-defun ()
+ "Save the current defun in the ledit buffer"
+ (interactive)
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (append-to-buffer ledit-buffer (point) end))
+ (message "Current defun saved for Lisp")))
+
+(defun ledit-save-region (beg end)
+ "Save the current region in the ledit buffer"
+ (interactive "r")
+ (append-to-buffer ledit-buffer beg end)
+ (message "Region saved for Lisp"))
+
+(defun ledit-zap-defun-to-lisp ()
+ "Carry the current defun to lisp"
+ (interactive)
+ (ledit-save-defun)
+ (ledit-go-to-lisp))
+
+(defun ledit-zap-defun-to-liszt ()
+ "Carry the current defun to liszt"
+ (interactive)
+ (ledit-save-defun)
+ (ledit-go-to-liszt))
+
+(defun ledit-zap-region-to-lisp (beg end)
+ "Carry the current region to lisp"
+ (interactive "r")
+ (ledit-save-region beg end)
+ (ledit-go-to-lisp))
+
+(defun ledit-go-to-lisp ()
+ "Suspend Emacs and restart a waiting Lisp job."
+ (interactive)
+ (if ledit-save-files
+ (save-some-buffers))
+ (if (get-buffer ledit-buffer)
+ (save-excursion
+ (set-buffer ledit-buffer)
+ (goto-char (point-min))
+ (write-region (point-min) (point-max) ledit-zap-file)
+ (erase-buffer)))
+ (suspend-emacs ledit-go-to-lisp-string)
+ (load ledit-read-file t t))
+
+(defun ledit-go-to-liszt ()
+ "Suspend Emacs and restart a waiting Liszt job."
+ (interactive)
+ (if ledit-save-files
+ (save-some-buffers))
+ (if (get-buffer ledit-buffer)
+ (save-excursion
+ (set-buffer ledit-buffer)
+ (goto-char (point-min))
+ (insert "(declare (macros t))\n")
+ (write-region (point-min) (point-max) ledit-compile-file)
+ (erase-buffer)))
+ (suspend-emacs ledit-go-to-liszt-string)
+ (load ledit-read-file t t))
+
+(defun ledit-setup ()
+ "Set up key bindings for the Lisp / Emacs interface"
+ (if (not ledit-mode-map)
+ (progn (setq ledit-mode-map (make-sparse-keymap))
+ (lisp-mode-commands ledit-mode-map)))
+ (define-key ledit-mode-map "\e\^d" 'ledit-save-defun)
+ (define-key ledit-mode-map "\e\^r" 'ledit-save-region)
+ (define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp)
+ (define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt))
+
+(ledit-setup)
+
+(defun ledit-mode ()
+ "Major mode for editing text and stuffing it to a Lisp job.
+Like Lisp mode, plus these special commands:
+ M-C-d -- record defun at or after point
+ for later transmission to Lisp job.
+ M-C-r -- record region for later transmission to Lisp job.
+ C-x z -- transfer to Lisp job and transmit saved text.
+ M-C-c -- transfer to Liszt (Lisp compiler) job
+ and transmit saved text.
+\\{ledit-mode-map}
+To make Lisp mode automatically change to Ledit mode,
+do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
+ (interactive)
+ (lisp-mode)
+ (ledit-from-lisp-mode))
+
+(defun ledit-from-lisp-mode ()
+ (use-local-map ledit-mode-map)
+ (setq mode-name "Ledit")
+ (setq major-mode 'ledit-mode)
+ (run-hooks 'ledit-mode-hook))
--- /dev/null
+;; Conway's `Life' for GNU Emacs
+;; Copyright (C) 1988 Free Software Foundation, Inc.
+;; Contributed by Kyle Jones, talos!kjones@uunet.uu.net
+
+;; 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.
+
+(provide 'life)
+
+(defconst life-patterns
+ [("@@@" " @@" "@@@")
+ ("@@@ @@@" "@@ @@ " "@@@ @@@")
+ ("@@@ @@@" "@@ @@" "@@@ @@@")
+ ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")
+ ("@@@@@@@@@@")
+ (" @@@@@@@@@@ "
+ " @@@@@@@@@@ "
+ " @@@@@@@@@@ "
+ "@@@@@@@@@@ "
+ "@@@@@@@@@@ ")
+ ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@")
+ ("@ @" "@ @" "@ @"
+ "@ @" "@ @" "@ @"
+ "@ @" "@ @" "@ @"
+ "@ @" "@ @" "@ @"
+ "@ @" "@ @" "@ @")
+ ("@@ " " @@ " " @@ "
+ " @@ " " @@ " " @@ "
+ " @@ " " @@ " " @@ "
+ " @@ " " @@ " " @@ "
+ " @@ " " @@ " " @@ "
+ " @@")
+ ("@@@@@@@@@" "@ @ @" "@ @@@@@ @" "@ @ @ @" "@@@ @@@"
+ "@ @ @ @" "@ @@@@@ @" "@ @ @" "@@@@@@@@@")]
+ "Vector of rectangles containing some Life startup patterns.")
+
+;; Macros are used macros for manifest constants instead of variables
+;; because the compiler will convert them to constants, which should
+;; eval faster than symbols.
+;;
+;; The (require) wrapping forces the compiler to eval these macros at
+;; compile time. This would not be necessary if we did not use macros
+;; inside of macros, which the compiler doesn't seem to check for.
+;;
+;; Don't change any of the life-* macro constants unless you thoroughly
+;; understand the `life-grim-reaper' function.
+(require
+ (progn
+ (defmacro life-life-char () ?@)
+ (defmacro life-death-char () (1+ (life-life-char)))
+ (defmacro life-birth-char () 3)
+ (defmacro life-void-char () ?\ )
+
+ (defmacro life-life-string () (char-to-string (life-life-char)))
+ (defmacro life-death-string () (char-to-string (life-death-char)))
+ (defmacro life-birth-string () (char-to-string (life-birth-char)))
+ (defmacro life-void-string () (char-to-string (life-void-char)))
+ (defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]"))
+
+ ;; try to optimize the (goto-char (point-min)) & (goto-char (point-max))
+ ;; idioms. This depends on goto-char's not griping if we underrshoot
+ ;; or overshoot beginning or end of buffer.
+ (defmacro goto-beginning-of-buffer () '(goto-char 1))
+ (defmacro maxint () (lsh (lsh (lognot 0) 1) -1))
+ (defmacro goto-end-of-buffer () '(goto-char (maxint)))
+
+ (defmacro increment (variable) (list 'setq variable (list '1+ variable)))
+ 'life))
+
+;; list of numbers that tell how many characters to move to get to
+;; each of a cell's eight neighbors.
+(defconst life-neighbor-deltas nil)
+
+;; window display always starts here. Easier to deal with than
+;; (scroll-up) and (scroll-down) when trying to center the display.
+(defconst life-window-start nil)
+
+;; For mode line
+(defconst life-current-generation nil)
+;; Sadly, mode-line-format won't display numbers.
+(defconst life-generation-string nil)
+
+(defun abs (n) (if (< n 0) (- n) n))
+
+(defun life (&optional sleeptime)
+ "Run Conway's Life simulation.
+The starting pattern is randomly selected. Prefix arg (optional first arg
+non-nil from a program) is the number of seconds to sleep between
+generations (this defaults to 1)."
+ (interactive "p")
+ (or sleeptime (setq sleeptime 1))
+ (life-setup)
+ (life-display-generation sleeptime)
+ (while t
+ (let ((inhibit-quit t))
+ (life-grim-reaper)
+ (life-expand-plane-if-needed)
+ (life-increment-generation)
+ (life-display-generation sleeptime))))
+
+(fset 'life-mode 'life)
+(put 'life-mode 'mode-class 'special)
+
+(random t)
+
+(defun life-setup ()
+ (let (n)
+ (switch-to-buffer (get-buffer-create "*Life*") t)
+ (erase-buffer)
+ (kill-all-local-variables)
+ (setq case-fold-search nil
+ mode-name "Life"
+ major-mode 'life-mode
+ truncate-lines t
+ life-current-generation 0
+ life-generation-string "0"
+ mode-line-buffer-identification '("Life: generation "
+ life-generation-string)
+ fill-column (1- (window-width))
+ life-window-start 1)
+ (buffer-flush-undo (current-buffer))
+ ;; stuff in the random pattern
+ (life-insert-random-pattern)
+ ;; make sure (life-life-char) is used throughout
+ (goto-beginning-of-buffer)
+ (while (re-search-forward (life-not-void-regexp) nil t)
+ (replace-match (life-life-string) t t))
+ ;; center the pattern horizontally
+ (goto-beginning-of-buffer)
+ (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2))
+ (while (not (eobp))
+ (indent-to n)
+ (forward-line))
+ ;; center the pattern vertically
+ (setq n (/ (- (1- (window-height))
+ (count-lines (point-min) (point-max)))
+ 2))
+ (goto-beginning-of-buffer)
+ (newline n)
+ (goto-end-of-buffer)
+ (newline n)
+ ;; pad lines out to fill-column
+ (goto-beginning-of-buffer)
+ (while (not (eobp))
+ (end-of-line)
+ (indent-to fill-column)
+ (move-to-column fill-column)
+ (delete-region (point) (progn (end-of-line) (point)))
+ (forward-line))
+ ;; expand tabs to spaces
+ (untabify (point-min) (point-max))
+ ;; before starting be sure the automaton has room to grow
+ (life-expand-plane-if-needed)
+ ;; compute initial neighbor deltas
+ (life-compute-neighbor-deltas)))
+
+(defun life-compute-neighbor-deltas ()
+ (setq life-neighbor-deltas
+ (list -1 (- fill-column)
+ (- (1+ fill-column)) (- (+ 2 fill-column))
+ 1 fill-column (1+ fill-column)
+ (+ 2 fill-column))))
+
+(defun life-insert-random-pattern ()
+ (insert-rectangle
+ (elt life-patterns (% (abs (random)) (length life-patterns))))
+ (insert ?\n))
+
+(defun life-increment-generation ()
+ (increment life-current-generation)
+ (setq life-generation-string (int-to-string life-current-generation)))
+
+(defun life-grim-reaper ()
+ ;; Clear the match information. Later we check to see if it
+ ;; is still clear, if so then all the cells have died.
+ (store-match-data nil)
+ (goto-beginning-of-buffer)
+ ;; For speed declare all local variable outside the loop.
+ (let (point char pivot living-neighbors list)
+ (while (search-forward (life-life-string) nil t)
+ (setq list life-neighbor-deltas
+ living-neighbors 0
+ pivot (1- (point)))
+ (while list
+ (setq point (+ pivot (car list))
+ char (char-after point))
+ (cond ((eq char (life-void-char))
+ (subst-char-in-region point (1+ point)
+ (life-void-char) 1 t))
+ ((< char 3)
+ (subst-char-in-region point (1+ point) char (1+ char) t))
+ ((< char 9)
+ (subst-char-in-region point (1+ point) char 9 t))
+ ((>= char (life-life-char))
+ (increment living-neighbors)))
+ (setq list (cdr list)))
+ (if (memq living-neighbors '(2 3))
+ ()
+ (subst-char-in-region pivot (1+ pivot)
+ (life-life-char) (life-death-char) t))))
+ (if (null (match-beginning 0))
+ (life-extinct-quit))
+ (subst-char-in-region 1 (point-max) 9 (life-void-char) t)
+ (subst-char-in-region 1 (point-max) 1 (life-void-char) t)
+ (subst-char-in-region 1 (point-max) 2 (life-void-char) t)
+ (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t)
+ (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t))
+
+(defun life-expand-plane-if-needed ()
+ (catch 'done
+ (goto-beginning-of-buffer)
+ (while (not (eobp))
+ ;; check for life at beginning or end of line. If found at
+ ;; either end, expand at both ends,
+ (cond ((or (eq (following-char) (life-life-char))
+ (eq (progn (end-of-line) (preceding-char)) (life-life-char)))
+ (goto-beginning-of-buffer)
+ (while (not (eobp))
+ (insert (life-void-char))
+ (end-of-line)
+ (insert (life-void-char))
+ (forward-char))
+ (setq fill-column (+ 2 fill-column))
+ (scroll-left 1)
+ (life-compute-neighbor-deltas)
+ (throw 'done t)))
+ (forward-line)))
+ (goto-beginning-of-buffer)
+ ;; check for life within the first two lines of the buffer.
+ ;; If present insert two lifeless lines at the beginning..
+ (cond ((search-forward (life-life-string)
+ (+ (point) fill-column fill-column 2) t)
+ (goto-beginning-of-buffer)
+ (insert-char (life-void-char) fill-column)
+ (insert ?\n)
+ (insert-char (life-void-char) fill-column)
+ (insert ?\n)
+ (setq life-window-start (+ life-window-start fill-column 1))))
+ (goto-end-of-buffer)
+ ;; check for life within the last two lines of the buffer.
+ ;; If present insert two lifeless lines at the end.
+ (cond ((search-backward (life-life-string)
+ (- (point) fill-column fill-column 2) t)
+ (goto-end-of-buffer)
+ (insert-char (life-void-char) fill-column)
+ (insert ?\n)
+ (insert-char (life-void-char) fill-column)
+ (insert ?\n)
+ (setq life-window-start (+ life-window-start fill-column 1)))))
+
+(defun life-display-generation (sleeptime)
+ (goto-char life-window-start)
+ (recenter 0)
+ (sit-for sleeptime))
+
+(defun life-extinct-quit ()
+ (life-display-generation 0)
+ (signal 'life-extinct nil))
+
+(put 'life-extinct 'error-conditions '(life-extinct quit))
+(put 'life-extinct 'error-message "All life has perished")
+
+
--- /dev/null
+;; Lisp mode, and its idiosyncratic commands.
+;; Copyright (C) 1985 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.
+
+
+(defvar lisp-mode-syntax-table nil "")
+(defvar emacs-lisp-mode-syntax-table nil "")
+(defvar lisp-mode-abbrev-table nil "")
+
+(if (not emacs-lisp-mode-syntax-table)
+ (let ((i 0))
+ (setq emacs-lisp-mode-syntax-table (make-syntax-table))
+ (while (< i ?0)
+ (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i (1+ ?9))
+ (while (< i ?A)
+ (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i (1+ ?Z))
+ (while (< i ?a)
+ (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i (1+ ?z))
+ (while (< i 128)
+ (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table)
+ (setq i (1+ i)))
+ (modify-syntax-entry ? " " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\t " " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\n "> " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\f "> " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\; "< " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?` "' " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?' "' " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?, "' " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?. "' " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?# "' " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\" "\" " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\\ "\\ " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\( "() " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\) ")( " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\[ "(] " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\] ")[ " emacs-lisp-mode-syntax-table)))
+
+(define-abbrev-table 'lisp-mode-abbrev-table ())
+
+(defun lisp-mode-variables (lisp-syntax)
+ (cond (lisp-syntax
+ (if (not lisp-mode-syntax-table)
+ (progn (setq lisp-mode-syntax-table
+ (copy-syntax-table emacs-lisp-mode-syntax-table))
+ (modify-syntax-entry ?\| "\" "
+ lisp-mode-syntax-table)
+ (modify-syntax-entry ?\[ "_ "
+ lisp-mode-syntax-table)
+ (modify-syntax-entry ?\] "_ "
+ lisp-mode-syntax-table)))
+ (set-syntax-table lisp-mode-syntax-table)))
+ (setq local-abbrev-table lisp-mode-abbrev-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'lisp-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start ";")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip ";+ *")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'lisp-comment-indent))
+
+(defun lisp-mode-commands (map)
+ (define-key map "\e\C-q" 'indent-sexp)
+ (define-key map "\177" 'backward-delete-char-untabify)
+ (define-key map "\t" 'lisp-indent-line))
+\f
+(defvar emacs-lisp-mode-map () "")
+(if emacs-lisp-mode-map
+ ()
+ (setq emacs-lisp-mode-map (make-sparse-keymap))
+ (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun)
+ (lisp-mode-commands emacs-lisp-mode-map))
+
+(defun emacs-lisp-mode ()
+ "Major mode for editing Lisp code to run in Emacs.
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs. Semicolons start comments.
+\\{emacs-lisp-mode-map}
+Entry to this mode calls the value of emacs-lisp-mode-hook
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map emacs-lisp-mode-map)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (setq major-mode 'emacs-lisp-mode)
+ (setq mode-name "Emacs-Lisp")
+ (lisp-mode-variables nil)
+ (run-hooks 'emacs-lisp-mode-hook))
+
+(defvar lisp-mode-map ())
+(if lisp-mode-map
+ ()
+ (setq lisp-mode-map (make-sparse-keymap))
+ (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun)
+ (define-key lisp-mode-map "\C-c\C-l" 'run-lisp)
+ (lisp-mode-commands lisp-mode-map))
+
+(defun lisp-mode ()
+ "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp.
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs. Semicolons start comments.
+\\{lisp-mode-map}
+Note that `run-lisp' may be used either to start an inferior Lisp job
+or to switch back to an existing one.
+
+Entry to this mode calls the value of lisp-mode-hook
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map lisp-mode-map)
+ (setq major-mode 'lisp-mode)
+ (setq mode-name "Lisp")
+ (lisp-mode-variables t)
+ (set-syntax-table lisp-mode-syntax-table)
+ (run-hooks 'lisp-mode-hook))
+
+;; This will do unless shell.el is loaded.
+(defun lisp-send-defun nil
+ "Send the current defun to the Lisp process made by M-x run-lisp."
+ (interactive)
+ (error "Process lisp does not exist"))
+
+(defvar lisp-interaction-mode-map ())
+(if lisp-interaction-mode-map
+ ()
+ (setq lisp-interaction-mode-map (make-sparse-keymap))
+ (lisp-mode-commands lisp-interaction-mode-map)
+ (define-key lisp-interaction-mode-map "\e\C-x" 'eval-defun)
+ (define-key lisp-interaction-mode-map "\n" 'eval-print-last-sexp))
+
+(defun lisp-interaction-mode ()
+ "Major mode for typing and evaluating Lisp forms.
+Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression
+before point, and prints its value into the buffer, advancing point.
+
+Commands:
+Delete converts tabs to spaces as it moves back.
+Paragraphs are separated only by blank lines. Semicolons start comments.
+\\{lisp-interaction-mode-map}
+Entry to this mode calls the value of lisp-interaction-mode-hook
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map lisp-interaction-mode-map)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (setq major-mode 'lisp-interaction-mode)
+ (setq mode-name "Lisp Interaction")
+ (lisp-mode-variables nil)
+ (run-hooks 'lisp-interaction-mode-hook))
+
+(defun eval-print-last-sexp (arg)
+ "Evaluate sexp before point; print value into current buffer."
+ (interactive "P")
+ (eval-region
+ (let ((stab (syntax-table)))
+ (unwind-protect
+ (save-excursion
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (forward-sexp -1)
+ (point))
+ (set-syntax-table stab)))
+ (point)
+ (current-buffer)))
+\f
+(defun eval-last-sexp (arg)
+ "Evaluate sexp before point; print value in minibuffer.
+With argument, print output into current buffer."
+ (interactive "P")
+ (eval-region
+ (let ((stab (syntax-table)))
+ (unwind-protect
+ (save-excursion
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (forward-sexp -1)
+ (point))
+ (set-syntax-table stab)))
+ (point)
+ (if arg (current-buffer) t)))
+
+(defun eval-defun (arg)
+ "Evaluate defun that point is in or before.
+Print value in minibuffer.
+With argument, insert value in current buffer after the defun."
+ (interactive "P")
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (eval-region (point) end
+ (if arg (current-buffer) t)))))
+\f
+(defun lisp-comment-indent ()
+ (if (looking-at ";;;")
+ (current-column)
+ (if (looking-at ";;")
+ (let ((tem (calculate-lisp-indent)))
+ (if (listp tem) (car tem) tem))
+ (skip-chars-backward " \t")
+ (max (if (bolp) 0 (1+ (current-column)))
+ comment-column))))
+
+(defconst lisp-indent-offset nil "")
+(defconst lisp-indent-hook 'lisp-indent-hook "")
+
+(defun lisp-indent-line (&optional whole-exp)
+ "Indent current line as Lisp code.
+With argument, indent any additional lines of the same expression
+rigidly along with this one."
+ (interactive "P")
+ (let ((indent (calculate-lisp-indent)) shift-amt beg end
+ (pos (- (point-max) (point))))
+ (beginning-of-line)
+ (setq beg (point))
+ (skip-chars-forward " \t")
+ (if (looking-at ";;;")
+ ;; Don't alter indentation of a ;;; comment line.
+ nil
+ (if (and (looking-at ";") (not (looking-at ";;")))
+ ;; Single-semicolon comment lines should be indented
+ ;; as comment lines, not as code.
+ (progn (indent-for-comment) (forward-char -1))
+ (if (listp indent) (setq indent (car indent)))
+ (setq shift-amt (- indent (current-column)))
+ (if (zerop shift-amt)
+ nil
+ (delete-region beg (point))
+ (indent-to indent)))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ ;; If desired, shift remaining lines of expression the same amount.
+ (and whole-exp (not (zerop shift-amt))
+ (save-excursion
+ (goto-char beg)
+ (forward-sexp 1)
+ (setq end (point))
+ (goto-char beg)
+ (forward-line 1)
+ (setq beg (point))
+ (> end beg))
+ (indent-code-rigidly beg end shift-amt)))))
+
+(defun calculate-lisp-indent (&optional parse-start)
+ "Return appropriate indentation for current line as Lisp code.
+In usual case returns an integer: the column to indent to.
+Can instead return a list, whose car is the column to indent to.
+This means that following lines at the same level of indentation
+should not necessarily be indented the same way.
+The second element of the list is the buffer position
+of the start of the containing expression."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point))
+ state paren-depth
+ ;; setting this to a number inhibits calling hook
+ (desired-indent nil)
+ (retry t)
+ last-sexp containing-sexp)
+ (if parse-start
+ (goto-char parse-start)
+ (beginning-of-defun))
+ ;; Find outermost containing sexp
+ (while (< (point) indent-point)
+ (setq state (parse-partial-sexp (point) indent-point 0)))
+ ;; Find innermost containing sexp
+ (while (and retry
+ state
+ (> (setq paren-depth (elt state 0)) 0))
+ (setq retry nil)
+ (setq last-sexp (elt state 2))
+ (setq containing-sexp (elt state 1))
+ ;; Position following last unclosed open.
+ (goto-char (1+ containing-sexp))
+ ;; Is there a complete sexp since then?
+ (if (and last-sexp (> last-sexp (point)))
+ ;; Yes, but is there a containing sexp after that?
+ (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
+ (if (setq retry (car (cdr peek))) (setq state peek)))))
+ (if retry
+ nil
+ ;; Innermost containing sexp found
+ (goto-char (1+ containing-sexp))
+ (if (not last-sexp)
+ ;; indent-point immediately follows open paren.
+ ;; Don't call hook.
+ (setq desired-indent (current-column))
+ ;; Find the start of first element of containing sexp.
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (cond ((looking-at "\\s(")
+ ;; First element of containing sexp is a list.
+ ;; Indent under that list.
+ )
+ ((> (save-excursion (forward-line 1) (point))
+ last-sexp)
+ ;; This is the first line to start within the containing sexp.
+ ;; It's almost certainly a function call.
+ (if (= (point) last-sexp)
+ ;; Containing sexp has nothing before this line
+ ;; except the first element. Indent under that element.
+ nil
+ ;; Skip the first element, find start of second (the first
+ ;; argument of the function call) and indent under.
+ (progn (forward-sexp 1)
+ (parse-partial-sexp (point) last-sexp 0 t)))
+ (backward-prefix-chars))
+ (t
+ ;; Indent beneath first sexp on same line as last-sexp.
+ ;; Again, it's almost certainly a function call.
+ (goto-char last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (backward-prefix-chars)))))
+ ;; Point is at the point to indent under unless we are inside a string.
+ ;; Call indentation hook except when overriden by lisp-indent-offset
+ ;; or if the desired indentation has already been computed.
+ (let ((normal-indent (current-column)))
+ (cond ((elt state 3)
+ ;; Inside a string, don't change indentation.
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (current-column))
+ ((and (integerp lisp-indent-offset) containing-sexp)
+ ;; Indent by constant offset
+ (goto-char containing-sexp)
+ (+ normal-indent lisp-indent-offset))
+ (desired-indent)
+ ((and (boundp 'lisp-indent-hook)
+ lisp-indent-hook
+ (not retry))
+ (or (funcall lisp-indent-hook indent-point state)
+ normal-indent))
+ (t
+ normal-indent))))))
+
+(defun lisp-indent-hook (indent-point state)
+ (let ((normal-indent (current-column)))
+ (goto-char (1+ (elt state 1)))
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (if (and (elt state 2)
+ (not (looking-at "\\sw\\|\\s_")))
+ ;; car of form doesn't seem to be a a symbol
+ (progn
+ (if (not (> (save-excursion (forward-line 1) (point))
+ last-sexp))
+ (progn (goto-char last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point) last-sexp 0 t)))
+ ;; Indent under the list or under the first sexp on the
+ ;; same line as last-sexp. Note that first thing on that
+ ;; line has to be complete sexp since we are inside the
+ ;; innermost containing sexp.
+ (backward-prefix-chars)
+ (current-column))
+ (let ((function (buffer-substring (point)
+ (progn (forward-sexp 1) (point))))
+ method)
+ (setq method (get (intern-soft function) 'lisp-indent-hook))
+ (cond ((or (eq method 'defun)
+ (and (null method)
+ (> (length function) 3)
+ (string-match "\\`def" function)))
+ (lisp-indent-defform state indent-point))
+ ((integerp method)
+ (lisp-indent-specform method state
+ indent-point normal-indent))
+ (method
+ (funcall method state indent-point)))))))
+
+(defconst lisp-body-indent 2 "")
+
+(defun lisp-indent-specform (count state indent-point normal-indent)
+ (let ((containing-form-start (elt state 1))
+ (i count)
+ body-indent containing-form-column)
+ ;; Move to the start of containing form, calculate indentation
+ ;; to use for non-distinguished forms (> count), and move past the
+ ;; function symbol. lisp-indent-hook guarantees that there is at
+ ;; least one word or symbol character following open paren of containing
+ ;; form.
+ (goto-char containing-form-start)
+ (setq containing-form-column (current-column))
+ (setq body-indent (+ lisp-body-indent containing-form-column))
+ (forward-char 1)
+ (forward-sexp 1)
+ ;; Now find the start of the last form.
+ (parse-partial-sexp (point) indent-point 1 t)
+ (while (and (< (point) indent-point)
+ (condition-case ()
+ (progn
+ (setq count (1- count))
+ (forward-sexp 1)
+ (parse-partial-sexp (point) indent-point 1 t))
+ (error nil))))
+ ;; Point is sitting on first character of last (or count) sexp.
+ (if (> count 0)
+ ;; A distinguished form. If it is the first or second form use double
+ ;; lisp-body-indent, else normal indent. With lisp-body-indent bound
+ ;; to 2 (the default), this just happens to work the same with if as
+ ;; the older code, but it makes unwind-protect, condition-case,
+ ;; with-output-to-temp-buffer, et. al. much more tasteful. The older,
+ ;; less hacked, behavior can be obtained by replacing below with
+ ;; (list normal-indent containing-form-start).
+ (if (<= (- i count) 1)
+ (list (+ containing-form-column (* 2 lisp-body-indent))
+ containing-form-start)
+ (list normal-indent containing-form-start))
+ ;; A non-distinguished form. Use body-indent if there are no
+ ;; distinguished forms and this is the first undistinguished form,
+ ;; or if this is the first undistinguished form and the preceding
+ ;; distinguished form has indentation at least as great as body-indent.
+ (if (or (and (= i 0) (= count 0))
+ (and (= count 0) (<= body-indent normal-indent)))
+ body-indent
+ normal-indent))))
+
+(defun lisp-indent-defform (state indent-point)
+ (goto-char (car (cdr state)))
+ (forward-line 1)
+ (if (> (point) (car (cdr (cdr state))))
+ (progn
+ (goto-char (car (cdr state)))
+ (+ lisp-body-indent (current-column)))))
+
+\f
+;; (put 'progn 'lisp-indent-hook 0), say, causes progn to be indented
+;; like defun if the first form is placed on the next line, otherwise
+;; it is indented like any other form (i.e. forms line up under first).
+
+(put 'lambda 'lisp-indent-hook 'defun)
+(put 'progn 'lisp-indent-hook 0)
+(put 'prog1 'lisp-indent-hook 1)
+(put 'save-excursion 'lisp-indent-hook 0)
+(put 'save-window-excursion 'lisp-indent-hook 0)
+(put 'save-restriction 'lisp-indent-hook 0)
+(put 'let 'lisp-indent-hook 1)
+(put 'let* 'lisp-indent-hook 1)
+(put 'while 'lisp-indent-hook 1)
+(put 'if 'lisp-indent-hook 2)
+(put 'catch 'lisp-indent-hook 1)
+(put 'condition-case 'lisp-indent-hook 2)
+(put 'unwind-protect 'lisp-indent-hook 1)
+(put 'with-output-to-temp-buffer 'lisp-indent-hook 1)
+
+(defun indent-sexp ()
+ "Indent each line of the list starting just after point."
+ (interactive)
+ (let ((indent-stack (list nil)) (next-depth 0) bol
+ outer-loop-done inner-loop-done state this-indent)
+ ;; Get error now if we don't have a complete sexp after point.
+ (save-excursion (forward-sexp 1))
+ (save-excursion
+ (setq outer-loop-done nil)
+ (while (not outer-loop-done)
+ (setq last-depth next-depth
+ inner-loop-done nil)
+ ;; Parse this line so we can learn the state
+ ;; to indent the next line.
+ ;; This inner loop goes through only once
+ ;; unless a line ends inside a string.
+ (while (and (not inner-loop-done)
+ (not (setq outer-loop-done (eobp))))
+ (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
+ nil nil state))
+ (setq next-depth (car state))
+ ;; If the line contains a comment other than the sort
+ ;; that is indented like code,
+ ;; indent it now with indent-for-comment.
+ ;; Comments indented like code are right already.
+ ;; In any case clear the in-comment flag in the state
+ ;; because parse-partial-sexp never sees the newlines.
+ (if (car (nthcdr 4 state))
+ (progn (indent-for-comment)
+ (end-of-line)
+ (setcar (nthcdr 4 state) nil)))
+ ;; If this line ends inside a string,
+ ;; go straight to next line, remaining within the inner loop,
+ ;; and turn off the \-flag.
+ (if (car (nthcdr 3 state))
+ (progn
+ (forward-line 1)
+ (setcar (nthcdr 5 state) nil))
+ (setq inner-loop-done t)))
+ (if (or outer-loop-done (setq outer-loop-done (<= next-depth 0)))
+ nil
+ (while (> last-depth next-depth)
+ (setq indent-stack (cdr indent-stack)
+ last-depth (1- last-depth)))
+ (while (< last-depth next-depth)
+ (setq indent-stack (cons nil indent-stack)
+ last-depth (1+ last-depth)))
+ ;; Now go to the next line and indent it according
+ ;; to what we learned from parsing the previous one.
+ (forward-line 1)
+ (setq bol (point))
+ (skip-chars-forward " \t")
+ ;; But not if the line is blank, or just a comment
+ ;; (except for double-semi comments; indent them as usual).
+ (if (or (eobp) (looking-at "[;\n]"))
+ nil
+ (if (and (car indent-stack)
+ (>= (car indent-stack) 0))
+ (setq this-indent (car indent-stack))
+ (let ((val (calculate-lisp-indent
+ (if (car indent-stack) (- (car indent-stack))))))
+ (if (integerp val)
+ (setcar indent-stack
+ (setq this-indent val))
+ (setcar indent-stack (- (car (cdr val))))
+ (setq this-indent (car val)))))
+ (if (/= (current-column) this-indent)
+ (progn (delete-region bol (point))
+ (indent-to this-indent)))))))))
+\f
+(defun indent-code-rigidly (start end arg &optional nochange-regexp)
+ "Indent all lines of code, starting in the region, sideways by ARG columns.
+Does not affect lines starting inside comments or strings,
+assuming that the start of the region is not inside them.
+Called from a program, takes args START, END, COLUMNS and NOCHANGE-REGEXP.
+The last is a regexp which, if matched at the beginning of a line,
+means don't indent that line."
+ (interactive "r\np")
+ (let (state)
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp)
+ (setq state (parse-partial-sexp (point)
+ (progn
+ (forward-line 1) (point))
+ nil nil state)))
+ (while (< (point) end)
+ (or (car (nthcdr 3 state))
+ (and nochange-regexp
+ (looking-at nochange-regexp))
+ ;; If line does not start in string, indent it
+ (let ((indent (current-indentation)))
+ (delete-region (point) (progn (skip-chars-forward " \t") (point)))
+ (or (eolp)
+ (indent-to (max 0 (+ indent arg)) 0))))
+ (setq state (parse-partial-sexp (point)
+ (progn
+ (forward-line 1) (point))
+ nil nil state))))))
+
--- /dev/null
+;; Lisp editing commands for Emacs
+;; 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.
+
+
+(defun forward-sexp (&optional arg)
+ "Move forward across one balanced expression.
+With argument, do this that many times."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
+ (if (< arg 0) (backward-prefix-chars)))
+
+(defun backward-sexp (&optional arg)
+ "Move backward across one balanced expression.
+With argument, do this that many times."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (forward-sexp (- arg)))
+
+(defun mark-sexp (arg)
+ "Set mark ARG sexps from point."
+ (interactive "p")
+ (push-mark
+ (save-excursion
+ (forward-sexp arg)
+ (point))))
+
+(defun forward-list (&optional arg)
+ "Move forward across one balanced group of parentheses.
+With argument, do this that many times."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))
+
+(defun backward-list (&optional arg)
+ "Move backward across one balanced group of parentheses.
+With argument, do this that many times."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (forward-list (- arg)))
+
+(defun down-list (arg)
+ "Move forward down one level of parentheses.
+With argument, do this that many times.
+A negative argument means move backward but still go down a level."
+ (interactive "p")
+ (let ((inc (if (> arg 0) 1 -1)))
+ (while (/= arg 0)
+ (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
+ (setq arg (- arg inc)))))
+
+(defun backward-up-list (arg)
+ "Move backward out of one level of parentheses.
+With argument, do this that many times.
+A negative argument means move forward but still to a less deep spot."
+ (interactive "p")
+ (up-list (- arg)))
+
+(defun up-list (arg)
+ "Move forward out of one level of parentheses.
+With argument, do this that many times.
+A negative argument means move backward but still to a less deep spot."
+ (interactive "p")
+ (let ((inc (if (> arg 0) 1 -1)))
+ (while (/= arg 0)
+ (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
+ (setq arg (- arg inc)))))
+
+(defun kill-sexp (arg)
+ "Kill the syntactic expression following the cursor.
+With argument, kill that many expressions after (or before) the cursor."
+ (interactive "p")
+ (let ((opoint (point)))
+ (forward-sexp arg)
+ (kill-region opoint (point))))
+
+(defun backward-kill-sexp (arg)
+ "Kill the syntactic expression preceding the cursor.
+With argument, kill that many expressions before (or after) the cursor."
+ (interactive "p")
+ (kill-sexp (- arg)))
+\f
+(defun beginning-of-defun (&optional arg)
+ "Move backward to next beginning-of-defun.
+With argument, do this that many times.
+Returns t unless search stops due to end of buffer."
+ (interactive "p")
+ (and arg (< arg 0) (forward-char 1))
+ (and (re-search-backward "^\\s(" nil 'move (or arg 1))
+ (progn (beginning-of-line) t)))
+
+(defun buffer-end (arg)
+ (if (> arg 0) (point-max) (point-min)))
+
+(defun end-of-defun (&optional arg)
+ "Move forward to next end of defun.
+An end of a defun is found by moving forward from the beginning of one."
+ (interactive "p")
+ (if (or (null arg) (= arg 0)) (setq arg 1))
+ (let ((first t))
+ (while (and (> arg 0) (< (point) (point-max)))
+ (let ((pos (point)) npos)
+ (while (progn
+ (if (and first
+ (progn
+ (forward-char 1)
+ (beginning-of-defun 1)))
+ nil
+ (or (bobp) (forward-char -1))
+ (beginning-of-defun -1))
+ (setq first nil)
+ (forward-list 1)
+ (skip-chars-forward " \t")
+ (if (looking-at "[;\n]")
+ (forward-line 1))
+ (<= (point) pos))))
+ (setq arg (1- arg)))
+ (while (< arg 0)
+ (let ((pos (point)))
+ (beginning-of-defun 1)
+ (forward-sexp 1)
+ (forward-line 1)
+ (if (>= (point) pos)
+ (if (beginning-of-defun 2)
+ (progn
+ (forward-list 1)
+ (skip-chars-forward " \t")
+ (if (looking-at "[;\n]")
+ (forward-line 1)))
+ (goto-char (point-min)))))
+ (setq arg (1+ arg)))))
+
+(defun mark-defun ()
+ "Put mark at end of defun, point at beginning."
+ (interactive)
+ (push-mark (point))
+ (end-of-defun)
+ (push-mark (point))
+ (beginning-of-defun)
+ (re-search-backward "^\n" (- (point) 1) t))
+
+(defun insert-parentheses (arg)
+ "Put parentheses around next ARG sexps. Leave point after open-paren.
+No argument is equivalent to zero: just insert () and leave point between."
+ (interactive "P")
+;Install these commented-out lines for version 19.
+; (if arg (skip-chars-forward " \t")
+; (or (memq (char-syntax (preceding-char)) '(?\ ?> ?\( ))
+; (insert " ")))
+ (insert ?\()
+ (save-excursion
+ (if arg
+ (forward-sexp (prefix-numeric-value arg)))
+ (insert ?\))
+; (or (memq (char-syntax (following-char)) '(?\ ?> ?\( ))
+; (insert " "))
+ ))
+
+(defun move-past-close-and-reindent ()
+ "Move past next ), delete indentation before it, then indent after it."
+ (interactive)
+ (up-list 1)
+ (forward-char -1)
+ (while (save-excursion ; this is my contribution
+ (let ((before-paren (point)))
+ (back-to-indentation)
+ (= (point) before-paren)))
+ (delete-indentation))
+ (forward-char 1)
+ (newline-and-indent))
+\f
+(defun lisp-complete-symbol ()
+ "Perform completion on Lisp symbol preceding point.
+That symbol is compared against the symbols that exist
+and any additional characters determined by what is there
+are inserted.
+If the symbol starts just after an open-parenthesis,
+only symbols with function definitions are considered.
+Otherwise, all symbols with function definitions, values
+or properties are considered."
+ (interactive)
+ (let* ((end (point))
+ (buffer-syntax (syntax-table))
+ (beg (unwind-protect
+ (save-excursion
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (backward-sexp 1)
+ (while (= (char-syntax (following-char)) ?\')
+ (forward-char 1))
+ (point))
+ (set-syntax-table buffer-syntax)))
+ (pattern (buffer-substring beg end))
+ (predicate
+ (if (eq (char-after (1- beg)) ?\()
+ 'fboundp
+ (function (lambda (sym)
+ (or (boundp sym) (fboundp sym)
+ (symbol-plist sym))))))
+ (completion (try-completion pattern obarray predicate)))
+ (cond ((eq completion t))
+ ((null completion)
+ (message "Can't find completion for \"%s\"" pattern)
+ (ding))
+ ((not (string= pattern completion))
+ (delete-region beg end)
+ (insert completion))
+ (t
+ (message "Making completion list...")
+ (let ((list (all-completions pattern obarray predicate)))
+ (or (eq predicate 'fboundp)
+ (let (new)
+ (while list
+ (setq new (cons (if (fboundp (intern (car list)))
+ (list (car list) " <f>")
+ (car list))
+ new))
+ (setq list (cdr list)))
+ (setq list (nreverse new))))
+ (with-output-to-temp-buffer " *Completions*"
+ (display-completion-list list)))
+ (message "Making completion list...%s" "done")))))
--- /dev/null
+;; Define standard autoloads and keys of other files, for Emacs.
+;; Copyright (C) 1985, 1986, 1987 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.
+
+;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+;;; Special formatting conventions are used in this file!
+;;;
+;;; a backslash-newline is used at the beginning of a documentation string
+;;; when that string should be stored in the file etc/DOCnnn, not in core.
+;;;
+;;; Such strings read into Lisp as numbers (during the pure-loading phase).
+;;;
+;;; But you must obey certain rules to make sure the string is understood
+;;; and goes into etc/DOCnnn properly. Otherwise, the string will not go
+;;; anywhere!
+;;;
+;;; The doc string must appear in the standard place in a call to
+;;; defun, autoload, defvar or defconst. No Lisp macros are recognized.
+;;; The open-paren starting the definition must appear in column 0.
+;;;
+;;; In defvar and defconst, there is an additional rule:
+;;; The double-quote that starts the string must be on the same
+;;; line as the defvar or defconst.
+;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+;; Know which function the debugger is!
+(setq debugger 'debug)
+
+(defconst mode-line-buffer-identification (purecopy '("Emacs: %17b")) "\
+Mode-line control for identifying the buffer being displayed.
+Its default value is \"Emacs: %17b\". Major modes that edit things
+other than ordinary files may change this (e.g. Info, Dired,...)")
+
+(make-variable-buffer-local 'mode-line-buffer-identification)
+
+(defconst mode-line-process nil "\
+Mode-line control for displaying info on process status.
+Normally nil in most modes, since there is no process to display.")
+
+(make-variable-buffer-local 'mode-line-process)
+
+(defconst mode-line-modified (purecopy '("--%1*%1*-")) "\
+Mode-line control for displaying whether current buffer is modified.")
+
+(make-variable-buffer-local 'mode-line-modified)
+
+(setq-default mode-line-format
+ (list (purecopy "")
+ 'mode-line-modified
+ 'mode-line-buffer-identification
+ (purecopy " ")
+ 'global-mode-string
+ (purecopy " %[(")
+ 'mode-name 'minor-mode-alist "%n" 'mode-line-process
+ (purecopy ")%]----")
+ (purecopy '(-3 . "%p"))
+ (purecopy "-%-")))
+
+(defvar minor-mode-alist nil "\
+Alist saying how to show minor modes in the mode line.
+Each element looks like (VARIABLE STRING);
+STRING is included in the mode line iff VARIABLE's value is non-nil.")
+(setq minor-mode-alist (mapcar 'purecopy
+ '((abbrev-mode " Abbrev")
+ (overwrite-mode " Ovwrt")
+ (auto-fill-hook " Fill")
+ ;; not really a minor mode...
+ (defining-kbd-macro " Def"))))
+
+(defconst function-keymap (make-sparse-keymap) "\
+Keymap containing definitions of keypad and function keys.")
+
+;; These variables are used by autoloadable packages.
+;; They are defined here so that they do not get overridden
+;; by the loading of those packages.
+
+(defconst paragraph-start "^[ \t\n\f]" "\
+*Regexp for beginning of a line that starts OR separates paragraphs.")
+(defconst paragraph-separate "^[ \t\f]*$" "\
+*Regexp for beginning of a line that separates paragraphs.
+If you change this, you may have to change paragraph-start also.")
+
+(defconst sentence-end (purecopy "[.?!][]\"')}]*\\($\\|\t\\| \\)[ \t\n]*") "\
+*Regexp describing the end of a sentence.
+All paragraph boundaries also end sentences, regardless.")
+
+(defconst page-delimiter "^\014" "\
+*Regexp describing line-beginnings that separate pages.")
+
+(defconst case-replace t "\
+*Non-nil means query-replace should preserve case in replacements.")
+
+;; indent.el may not be autoloading, but it still loses
+;; if lisp-mode is ever called before this defvar is done.
+(defvar indent-line-function 'indent-to-left-margin "\
+Function to indent current line.")
+
+(defconst only-global-abbrevs nil "\
+*t means user plans to use global abbrevs only.
+Makes the commands to define mode-specific abbrevs define global ones instead.")
+
+;; Names in directory that end in one of these
+;; are ignored in completion,
+;; making it more likely you will get a unique match.
+(setq completion-ignored-extensions
+ (if (eq system-type 'vax-vms)
+ '(".obj" ".elc" ".exe" ".bin" ".lbin"
+ ".dvi" ".toc" ".log" ".aux"
+ ".lof" ".brn" ".rnt" ".mem" ".lni" ".lis"
+ ".olb" ".tlb" ".mlb" ".hlb" ".glo" ".idx" ".lot")
+ '(".o" ".elc" "~" ".bin" ".lbin" ".fasl"
+ ".dvi" ".toc" ".log" ".aux"
+ ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot")))
+
+(defvar compile-command "make -k" "\
+*Last shell command used to do a compilation; default for next compilation.")
+
+(defvar dired-listing-switches "-al" "\
+*Switches passed to ls for Dired. MUST contain the `l' option.
+MUST NOT contain the `F, `s' or `i'' option.")
+
+(defconst lpr-switches nil "\
+*List of strings to pass as extra switch args to lpr when it is invoked.")
+
+(defvar tags-file-name nil "\
+*File name of tag table.
+To switch to a new tag table, setting this variable is sufficient.
+Use the `etags' program to make a tag table file.")
+
+(defconst shell-prompt-pattern "^[^#$%>]*[#$%>] *" "\
+*Regexp used by Newline command in shell mode to match subshell prompts.
+Anything from beginning of line up to the end of what this pattern matches
+is deemed to be prompt, and is not reexecuted.")
+
+(defconst ledit-save-files t "\
+*Non-nil means Ledit should save files before transferring to Lisp.")
+(defconst ledit-go-to-lisp-string "%?lisp" "\
+*Shell commands to execute to resume Lisp job.")
+(defconst ledit-go-to-liszt-string "%?liszt" "\
+*Shell commands to execute to resume Lisp compiler job.")
+
+(defconst display-time-day-and-date nil "\
+*Non-nil means M-x display-time should display day and date as well as time.")
+
+;;; Determine mode according to filename
+
+(defvar auto-mode-alist nil "\
+Alist of filename patterns vs corresponding major mode functions.
+Each element looks like (REGEXP . FUNCTION).
+Visiting a file whose name matches REGEXP causes FUNCTION to be called.")
+(setq auto-mode-alist (mapcar 'purecopy
+ '(("\\.text$" . text-mode)
+ ("\\.c$" . c-mode)
+ ("\\.h$" . c-mode)
+ ("\\.tex$" . TeX-mode)
+ ("\\.el$" . emacs-lisp-mode)
+ ("\\.scm$" . scheme-mode)
+ ("\\.l$" . lisp-mode)
+ ("\\.lisp$" . lisp-mode)
+ ("\\.f$" . fortran-mode)
+ ("\\.mss$" . scribe-mode)
+ ("\\.pl$" . prolog-mode)
+;;; Less common extensions come here
+;;; so more common ones above are found faster.
+ ("\\.TeX$" . TeX-mode)
+ ("\\.sty$" . LaTeX-mode)
+ ("\\.bbl$" . LaTeX-mode)
+ ("\\.bib$" . text-mode)
+ ("\\.article$" . text-mode)
+ ("\\.letter$" . text-mode)
+ ("\\.texinfo$" . texinfo-mode)
+ ("\\.lsp$" . lisp-mode)
+ ("\\.prolog$" . prolog-mode)
+ ;; Mailer puts message to be edited in /tmp/Re.... or Message
+ ("^/tmp/Re" . text-mode)
+ ;; some news reader is reported to use this
+ ("^/tmp/fol/" . text-mode)
+ ("/Message[0-9]*$" . text-mode)
+ ("\\.y$" . c-mode)
+ ("\\.cc$" . c-mode)
+ ("\\.scm.[0-9]*$" . scheme-mode)
+ ;; .emacs following a directory delimiter
+ ;; in either Unix or VMS syntax.
+ ("[]>:/]\\..*emacs" . emacs-lisp-mode)
+ ("\\.ml$" . lisp-mode))))
+
+(make-variable-buffer-local 'indent-tabs-mode)
+
+(defvar ctl-x-4-map (make-keymap) "\
+Keymap for subcommands of C-x 4")
+
+;; Reduce total amount of space we must allocate during this function
+;; that we will not need to keep permanently.
+(garbage-collect)
+\f
+;; Autoload random libraries.
+;; Alphabetical order by library name.
+
+(autoload 'add-change-log-entry "add-log"
+ "\
+Find change log file 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.
+Optional third arg OTHER-WINDOW non-nil means visit in other window."
+ t)
+
+(define-key ctl-x-4-map "a" 'add-change-log-entry-other-window)
+
+(autoload 'add-change-log-entry-other-window "add-log"
+ "\
+Find change log file in other window, and add an entry for today."
+ t)
+
+(autoload '\` "backquote"
+ "\
+\(` FORM) Expands to a form that will generate FORM.
+FORM is `almost quoted' -- see backquote.el for a description."
+ nil t)
+
+(autoload 'byte-compile-file "bytecomp"
+ "\
+Compile a file of Lisp code named FILENAME into a file of byte code.
+The output file's name is made by appending \"c\" to the end of FILENAME."
+ t)
+
+(autoload 'byte-recompile-directory "bytecomp"
+ "\
+Recompile every .el file in DIRECTORY that needs recompilation.
+This is if a .elc file exists but is older than the .el file.
+If the .elc file does not exist, offer to compile the .el file
+only if a prefix argument has been specified."
+ t)
+
+(autoload 'batch-byte-compile "bytecomp"
+ "\
+Runs byte-compile-file on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
+ nil)
+
+(autoload 'calendar "cal"
+ "\
+Display three-month calendar in another window.
+The three months appear side by side, with the current month in the middle
+surrounded by the previous and next months. The cursor is put on today's date.
+
+An optional prefix argument ARG causes the calendar displayed to be
+ARG months in the future if ARG is positive or in the past if ARG is
+negative; in this case the cursor goes on the first day of the month.
+
+The Gregorian calendar is assumed.
+
+After preparing the calendar window, the hooks calendar-hook are run
+when the calendar is for the current month--that is, the was no prefix
+argument. If the calendar is for a future or past month--that is, there
+was a prefix argument--the hooks offset-calendar-hook are run. Thus, for
+example, setting calendar-hooks to 'star-date will cause today's date to be
+replaced by asterisks to highlight it in the window."
+ t)
+
+(autoload 'list-command-history "chistory"
+ "\
+List history of commands typed to minibuffer.
+The number of commands listed is controlled by list-command-history-max.
+Calls value of list-command-history-filter (if non-nil) on each history
+element to judge if that element should be excluded from the list.
+
+The buffer is left in Command History mode."
+ t)
+
+(autoload 'command-history-mode "chistory"
+ "\
+Major mode for examining commands from command-history.
+The number of commands listed is controlled by list-command-history-max.
+The command history is filtered by list-command-history-filter if non-nil.
+
+Like Emacs-Lisp Mode except that characters do not insert themselves and
+Digits provide prefix arguments. Tab does not indent.
+\\{command-history-map}
+Calls the value of command-history-hook if that is non-nil
+The Command History listing is recomputed each time this mode is
+invoked."
+ t)
+
+(autoload 'repeat-matching-complex-command "chistory"
+ "\
+Edit and re-evaluate complex command with name matching PATTERN.
+Matching occurrences are displayed, most recent first, until you
+select a form for evaluation. If PATTERN is empty (or nil), every form
+in the command history is offered. The form is placed in the minibuffer
+for editing and the result is evaluated."
+ t)
+
+
+(autoload 'common-lisp-indent-hook "cl-indent")
+
+(autoload 'compare-windows "compare-w"
+ "\
+Compare text in current window with text in next window.
+Compares the text starting at point in each window,
+moving over text in each one as far as they match."
+ t)
+
+(autoload 'compile "compile"
+ "\
+Compile the program including the current buffer. Default: run `make'.
+Runs COMMAND, a shell command, in a separate process asynchronously
+with output going to the buffer *compilation*.
+You can then use the command \\[next-error] to find the next error message
+and move to the source code that caused it."
+ t)
+
+(autoload 'grep "compile"
+ "\
+Run grep, with user-specified args, and collect output in a buffer.
+While grep runs asynchronously, you can use the \\[next-error] command
+to find the text that grep hits refer to."
+ t)
+
+(define-key ctl-x-map "`" 'next-error)
+
+(autoload 'next-error "compile"
+ "\
+Visit next compilation error message and corresponding source code.
+This operates on the output from the \\[compile] command.
+If all preparsed error messages have been processed,
+the error message buffer is checked for new ones.
+A non-nil argument (prefix arg, if interactive)
+means reparse the error message buffer and start at the first error."
+ t)
+
+(define-key esc-map "/" 'dabbrev-expand)
+
+(autoload 'dabbrev-expand "dabbrev"
+ "\
+Expand previous word \"dynamically\".
+Expands to the most recent, preceding word for which this is a prefix.
+If no suitable preceding word is found, words following point are considered.
+
+A positive prefix argument, N, says to take the Nth backward DISTINCT
+possibility. A negative argument says search forward. The variable
+dabbrev-backward-only may be used to limit the direction of search to
+backward if set non-nil.
+
+If the cursor has not moved from the end of the previous expansion and
+no argument is given, replace the previously-made expansion
+with the next possible expansion not yet tried."
+ t)
+
+(autoload 'debug "debug"
+ "\
+Enter debugger. Returns if user says \"continue\".
+Arguments are mainly for use when this is called
+ from the internals of the evaluator.
+You may call with no args, or you may
+ pass nil as the first arg and any other args you like.
+ In that case, the list of args after the first will
+ be printed into the backtrace buffer.")
+
+(autoload 'cancel-debug-on-entry "debug"
+ "\
+Undoes effect of debug-on-entry on FUNCTION."
+ t)
+
+(autoload 'debug-on-entry "debug"
+ "\
+Request FUNCTION to invoke debugger each time it is called.
+If the user continues, FUNCTION's execution proceeds.
+Works by modifying the definition of FUNCTION,
+which must be written in Lisp, not predefined.
+Use `cancel-debug-on-entry' to cancel the effect of this command.
+Redefining FUNCTION also does that."
+ t)
+
+(define-key ctl-x-map "d" 'dired)
+
+(autoload 'dired "dired"
+ "\
+\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it.
+Dired displays a list of files in DIRNAME.
+You can move around in it with the usual commands.
+You can flag files for deletion with C-d
+and then delete them by typing `x'.
+Type `h' after entering dired for more info."
+ t)
+
+(define-key ctl-x-4-map "d" 'dired-other-window)
+
+(autoload 'dired-other-window "dired"
+ "\
+\"Edit\" directory DIRNAME. Like \\[dired] but selects in another window."
+ t)
+
+(autoload 'dired-noselect "dired"
+ "\
+Like M-x dired but returns the dired buffer as value, does not select it.")
+
+(autoload 'dissociated-press "dissociate"
+ "\
+Dissociate the text of the current buffer.
+Output goes in buffer named *Dissociation*,
+which is redisplayed each time text is added to it.
+Every so often the user must say whether to continue.
+If ARG is positive, require ARG chars of continuity.
+If ARG is negative, require -ARG words of continuity.
+Default is 2."
+ t)
+
+(autoload 'doctor "doctor"
+ "\
+Switch to *doctor* buffer and start giving psychotherapy."
+ t)
+
+(autoload 'disassemble "disass"
+ "\
+Print disassembled code for OBJECT on (optional) STREAM.
+OBJECT can be a function name, lambda expression or any function object
+returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will
+compile it (but not redefine it)."
+ t)
+
+(autoload 'electric-buffer-list "ebuff-menu"
+ "\
+Vaguely like ITS lunar select buffer;
+combining typeoutoid buffer listing with menuoid buffer selection.
+
+This pops up a buffer describing the set of emacs buffers.
+If the very next character typed is a space then the buffer list
+ window disappears.
+
+Otherwise, one may move around in the buffer list window, marking
+ buffers to be selected, saved or deleted.
+
+To exit and select a new buffer, type Space when the cursor is on the
+ appropriate line of the buffer-list window.
+
+Other commands are much like those of buffer-menu-mode.
+
+Calls value of electric-buffer-menu-mode-hook on entry if non-nil.
+
+\\{electric-buffer-menu-mode-map}"
+ t)
+
+
+(autoload 'electric-command-history "echistory"
+ "\
+Major mode for examining and redoing commands from command-history.
+The number of command listed is controlled by list-command-history-max.
+The command history is filtered by list-command-history-filter if non-nil.
+Combines typeout Command History list window with menu like selection
+of an expression from the history for re-evaluation in the *original* buffer.
+
+The history displayed is filtered by list-command-history-filter if non-nil.
+
+This pops up a window with the Command History listing. If the very
+next character typed is Space, the listing is killed and the previous
+window configuration is restored. Otherwise, you can browse in the
+Command History with Return moving down and Delete moving up, possibly
+selecting an expression to be redone with Space or quitting with `Q'.
+
+Like Emacs-Lisp Mode except that characters do not insert themselves and
+Tab and linefeed do not indent. Instead these commands are provided:
+Space or ! edit then evaluate current line in history inside
+ the ORIGINAL buffer which invoked this mode.
+ The previous window configuration is restored
+ unless the invoked command changes it.
+C-c C-c, C-], Q Quit and restore previous window configuration.
+LFD, RET Move to the next line in the history.
+DEL Move to the previous line in the history.
+? Provides a complete list of commands.
+
+Calls the value of electric-command-history-hook if that is non-nil
+The Command History listing is recomputed each time this mode is invoked."
+ t)
+
+(autoload 'edt-emulation-on "edt"
+ "\
+Begin emulating DEC's EDT editor.
+Certain keys are rebound; including nearly all keypad keys.
+Use \\[edt-emulation-off] to undo all rebindings except the keypad keys.
+Note that this function does not work if called directly from the .emacs file.
+Instead, the .emacs file should do (setq term-setup-hook 'edt-emulation-on)
+Then this function will be called at the time when it will work."
+ t)
+
+(autoload 'fortran-mode "fortran"
+ "\
+Major mode for editing fortran code.
+Tab indents the current fortran line correctly.
+`do' statements must not share a common `continue'.
+
+Type `;?' or `;\\[help-command]' to display a list of built-in abbrevs for Fortran keywords.
+
+Variables controlling indentation style and extra features:
+
+ comment-start
+ Normally nil in Fortran mode. If you want to use comments
+ starting with `!', set this to the string \"!\".
+ fortran-do-indent
+ Extra indentation within do blocks. (default 3)
+ fortran-if-indent
+ Extra indentation within if blocks. (default 3)
+ fortran-continuation-indent
+ Extra indentation appled to continuation statements. (default 5)
+ fortran-comment-line-column
+ Amount of indentation for text within full-line comments. (default 6)
+ fortran-comment-indent-style
+ nil means don't change indentation of text in full-line comments,
+ fixed means indent that text at column fortran-comment-line-column
+ relative means indent at fortran-comment-line-column beyond the
+ indentation for a line of code.
+ Default value is fixed.
+ fortran-comment-indent-char
+ Character to be inserted instead of space for full-line comment
+ indentation. (default is a space)
+ fortran-minimum-statement-indent
+ Minimum indentation for fortran statements. (default 6)
+ fortran-line-number-indent
+ Maximum indentation for line numbers. A line number will get
+ less than this much indentation if necessary to avoid reaching
+ column 5. (default 1)
+ fortran-check-all-num-for-matching-do
+ Non-nil causes all numbered lines to be treated as possible 'continue'
+ statements. (default nil)
+ fortran-continuation-char
+ character to be inserted in column 5 of a continuation line.
+ (default $)
+ fortran-comment-region
+ String inserted by \\[fortran-comment-region] at start of each line in
+ region. (default \"c$$$\")
+ fortran-electric-line-number
+ Non-nil causes line number digits to be moved to the correct column
+ as typed. (default t)
+ fortran-startup-message
+ Set to nil to inhibit message first time fortran-mode is used.
+
+Turning on Fortran mode calls the value of the variable fortran-mode-hook
+with no args, if that value is non-nil.
+\\{fortran-mode-map}"
+ t)
+
+(autoload 'ftp-find-file "ftp"
+ "\
+FTP to HOST to get FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with
+ a colon character separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ t)
+
+(autoload 'ftp-write-file "ftp"
+ "\
+FTP to HOST to write FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with colon
+separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ t)
+\f
+(autoload 'gdb "gdb"
+ "\
+Run gdb on program FILE in buffer *gdb-FILE*.
+The directory containing FILE becomes the initial working directory
+and source-file directory for GDB. If you wish to change this, use
+the GDB commands `cd DIR' and `directory'."
+ t)
+
+(autoload 'set-gosmacs-bindings "gosmacs"
+ "\
+Rebind some keys globally to make GNU Emacs resemble Gosling Emacs.
+Use \\[set-gnu-bindings] to restore previous global bindings."
+ t)
+
+(autoload 'hanoi "hanoi"
+ "\
+Towers of Hanoi diversion. Argument is number of rings."
+ t)
+
+(autoload 'Helper-help "helper"
+ "\
+Provide help for current mode."
+ t)
+
+(autoload 'Helper-describe-bindings "helper"
+ "\
+Describe local key bindings of current mode."
+ t)
+
+(autoload 'info "info"
+ "\
+Enter Info, the documentation browser."
+ t)
+
+(autoload 'Info-tagify "informat"
+ "\
+Create or update Info-file tag table in current buffer."
+ t)
+
+(autoload 'Info-validate "informat"
+ "\
+Check current buffer for validity as an Info file.
+Check that every node pointer points to an existing node."
+ t)
+
+(autoload 'Info-split "informat"
+ "\
+Split an info file into an indirect file plus bounded-size subfiles.
+Each subfile will be up to 50000 characters plus one node.
+
+To use this command, first visit a large Info file that has a tag table.
+The buffer is modified into a (small) indirect info file
+which should be saved in place of the original visited file.
+
+The subfiles are written in the same directory the original file is in,
+with names generated by appending `-' and a number to the original file name.
+
+The indirect file still functions as an Info file, but it contains
+just the tag table and a directory of subfiles."
+ t)
+
+(autoload 'batch-info-validate "informat"
+ "\
+Runs Info-validate on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
+ nil)
+
+(autoload 'ledit-mode "ledit"
+ "\
+Major mode for editing text and stuffing it to a Lisp job.
+Like Lisp mode, plus these special commands:
+ M-C-d -- record defun at or after point
+ for later transmission to Lisp job.
+ M-C-r -- record region for later transmission to Lisp job.
+ C-x z -- transfer to Lisp job and transmit saved text.
+ M-C-c -- transfer to Liszt (Lisp compiler) job
+ and transmit saved text.
+\\{ledit-mode-map}
+To make Lisp mode automatically change to Ledit mode,
+do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
+ t)
+
+(autoload 'ledit-from-lisp-mode "ledit")
+
+(autoload 'lpr-buffer "lpr"
+ "\
+Print buffer contents as with Unix command `lpr'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'print-buffer "lpr"
+ "\
+Print buffer contents as with Unix command `lpr -p'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'lpr-region "lpr"
+ "\
+Print region contents as with Unix command `lpr'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'print-region "lpr"
+ "\
+Print region contents as with Unix command `lpr -p'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'insert-kbd-macro "macros"
+ "\
+Insert in buffer the definition of kbd macro NAME, as Lisp code.
+Second argument KEYS non-nil means also record the keys it is on.
+ (This is the prefix argument, when calling interactively.)
+
+This Lisp code will, when executed, define the kbd macro with the
+same definition it has now. If you say to record the keys,
+the Lisp code will also rebind those keys to the macro.
+Only global key bindings are recorded since executing this Lisp code
+always makes global bindings.
+
+To save a kbd macro, visit a file of Lisp code such as your ~/.emacs,
+use this command, and then save the file."
+ t)
+
+(define-key ctl-x-map "q" 'kbd-macro-query)
+
+(autoload 'kbd-macro-query "macros"
+ "\
+Query user during kbd macro execution.
+With prefix argument, enters recursive edit,
+ reading keyboard commands even within a kbd macro.
+ You can give different commands each time the macro executes.
+Without prefix argument, reads a character. Your options are:
+ Space -- execute the rest of the macro.
+ DEL -- skip the rest of the macro; start next repetition.
+ C-d -- skip rest of the macro and don't repeat it any more.
+ C-r -- enter a recursive edit, then on exit ask again for a character
+ C-l -- redisplay screen and ask again."
+ t)
+
+(autoload 'name-last-kbd-macro "macros"
+ "\
+Assign a name to the last keyboard macro defined.
+One arg, a symbol, which is the name to define.
+The symbol's function definition becomes the keyboard macro string.
+Such a \"function\" cannot be called from Lisp, but it is a valid command
+definition for the editor command loop."
+ t)
+
+(autoload 'make-command-summary "makesum"
+ "\
+Make a summary of current key bindings in the buffer *Summary*.
+Previous contents of that buffer are killed first."
+ t)
+
+(autoload 'define-mail-alias "mailalias"
+ "\
+Define NAME as a mail-alias that translates to DEFINITION."
+ t)
+
+(autoload 'manual-entry "man"
+ "\
+Display the Unix manual entry for TOPIC.
+TOPIC is either the title of the entry, or has the form TITLE(SECTION)
+where SECTION is the desired section of the manual, as in `tty(4)'."
+ t)
+
+(autoload 'mh-rmail "mh-e"
+ "\
+Inc(orporate) new mail (no arg) or scan a MH mail box (arg given).
+This front end uses the MH mail system, which uses different conventions
+from the usual mail system."
+ t)
+
+(autoload 'mh-smail "mh-e"
+ "\
+Send mail using the MH mail system."
+ t)
+
+(autoload 'convert-mocklisp-buffer "mlconvert"
+ "\
+Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run."
+ t)
+
+(autoload 'modula-2-mode "modula2"
+ "\
+This is a mode intended to support program development in Modula-2.
+All control constructs of Modula-2 can be reached by typing
+Control-C followed by the first character of the construct.
+\\{m2-mode-map}
+ Control-c b begin Control-c c case
+ Control-c d definition Control-c e else
+ Control-c f for Control-c h header
+ Control-c i if Control-c m module
+ Control-c l loop Control-c o or
+ Control-c p procedure Control-c Control-w with
+ Control-c r record Control-c s stdio
+ Control-c t type Control-c u until
+ Control-c v var Control-c w while
+ Control-c x export Control-c y import
+ Control-c { begin-comment Control-c } end-comment
+ Control-c Control-z suspend-emacs Control-c Control-t toggle
+ Control-c Control-c compile Control-x ` next-error
+ Control-c Control-l link
+
+ m2-indent controls the number of spaces for each indentation.
+ m2-compile-command holds the command to compile a Modula-2 program.
+ m2-link-command holds the command to link a Modula-2 program."
+ t)
+
+(setq disabled-command-hook 'disabled-command-hook)
+
+(autoload 'disabled-command-hook "novice")
+(autoload 'enable-command "novice"
+ "\
+Allow COMMAND to be executed without special confirmation from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions." t)
+
+(autoload 'disable-command "novice"
+ "\
+Require special confirmation to execute COMMAND from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions." t)
+
+(autoload 'nroff-mode "nroff-mode"
+ "\
+Major mode for editing text intended for nroff to format.
+\\{nroff-mode-map}
+Turning on Nroff mode runs text-mode-hook, then nroff-mode-hook.
+Also, try nroff-electric-mode, for automatically inserting
+closing requests for requests that are used in matched pairs."
+ t)
+
+(autoload 'list-options "options"
+ "\
+Display a list of Emacs user options, with values and documentation."
+ t)
+
+(autoload 'edit-options "options"
+ "\
+Edit a list of Emacs user option values.
+Selects a buffer containing such a list,
+in which there are commands to set the option values.
+Type \\[describe-mode] in that buffer for a list of commands."
+ t)
+
+(autoload 'outline-mode "outline"
+ "\
+Set major mode for editing outlines with selective display.
+Headings are lines which start with asterisks: one for major headings,
+two for subheadings, etc. Lines not starting with asterisks are body lines.
+
+Body text or subheadings under a heading can be made temporarily
+invisible, or visible again. Invisible lines are attached to the end
+of the heading, so they move with it, if the line is killed and yanked
+back. A heading with text hidden under it is marked with an ellipsis (...).
+
+Commands:
+C-c C-n outline-next-visible-heading move by visible headings
+C-c C-p outline-previous-visible-heading
+C-c C-f outline-forward-same-level similar but skip subheadings
+C-c C-b outline-backward-same-level
+C-c C-u outline-up-heading move from subheading to heading
+
+Meta-x hide-body make all text invisible (not headings).
+Meta-x show-all make everything in buffer visible.
+
+The remaining commands are used when point is on a heading line.
+They apply to some of the body or subheadings of that heading.
+C-c C-h hide-subtree make body and subheadings invisible.
+C-c C-s show-subtree make body and subheadings visible.
+C-c C-i show-children make direct subheadings visible.
+ No effect on body, or subheadings 2 or more levels down.
+ With arg N, affects subheadings N levels down.
+M-x hide-entry make immediately following body invisible.
+M-x show-entry make it visible.
+M-x hide-leaves make body under heading and under its subheadings invisible.
+ The subheadings remain visible.
+M-x show-branches make all subheadings at all levels visible.
+
+The variable outline-regexp can be changed to control what is a heading.
+A line is a heading if outline-regexp matches something at the
+beginning of the line. The longer the match, the deeper the level.
+
+Turning on outline mode calls the value of text-mode-hook and then of
+outline-mode-hook, if they are non-nil."
+ t)
+
+(autoload 'edit-picture "picture"
+ "\
+Switch to Picture mode, in which a quarter-plane screen model is used.
+Printing characters replace instead of inserting themselves with motion
+afterwards settable by these commands:
+ C-c < Move left after insertion.
+ C-c > Move right after insertion.
+ C-c ^ Move up after insertion.
+ C-c . Move down after insertion.
+ C-c ` Move northwest (nw) after insertion.
+ C-c ' Move northeast (ne) after insertion.
+ C-c / Move southwest (sw) after insertion.
+ C-c \\ Move southeast (se) after insertion.
+The current direction is displayed in the mode line. The initial
+direction is right. Whitespace is inserted and tabs are changed to
+spaces when required by movement. You can move around in the buffer
+with these commands:
+ C-p Move vertically to SAME column in previous line.
+ C-n Move vertically to SAME column in next line.
+ C-e Move to column following last non-whitespace character.
+ C-f Move right inserting spaces if required.
+ C-b Move left changing tabs to spaces if required.
+ C-c C-f Move in direction of current picture motion.
+ C-c C-b Move in opposite direction of current picture motion.
+ Return Move to beginning of next line.
+You can edit tabular text with these commands:
+ M-Tab Move to column beneath (or at) next interesting charecter.
+ `Indents' relative to a previous line.
+ Tab Move to next stop in tab stop list.
+ C-c Tab Set tab stops according to context of this line.
+ With ARG resets tab stops to default (global) value.
+ See also documentation of variable picture-tab-chars
+ which defines \"interesting character\". You can manually
+ change the tab stop list with command \\[edit-tab-stops].
+You can manipulate text with these commands:
+ C-d Clear (replace) ARG columns after point without moving.
+ C-c C-d Delete char at point - the command normally assigned to C-d.
+ Delete Clear (replace) ARG columns before point, moving back over them.
+ C-k Clear ARG lines, advancing over them. The cleared
+ text is saved in the kill ring.
+ C-o Open blank line(s) beneath current line.
+You can manipulate rectangles with these commands:
+ C-c C-k Clear (or kill) a rectangle and save it.
+ C-c C-w Like C-c C-k except rectangle is saved in named register.
+ C-c C-y Overlay (or insert) currently saved rectangle at point.
+ C-c C-x Like C-c C-y except rectangle is taken from named register.
+ \\[copy-rectangle-to-register] Copies a rectangle to a register.
+ \\[advertised-undo] Can undo effects of rectangle overlay commands
+ commands if invoked soon enough.
+You can return to the previous mode with:
+ C-c C-c Which also strips trailing whitespace from every line.
+ Stripping is suppressed by supplying an argument.
+
+Entry to this mode calls the value of edit-picture-hook if non-nil.
+
+Note that Picture mode commands will work outside of Picture mode, but
+they are not defaultly assigned to keys."
+ t)
+
+(fset 'picture-mode 'edit-picture)
+
+(autoload 'prolog-mode "prolog"
+ "\
+Major mode for editing Prolog code for Prologs.
+Blank lines and `%%...' separate paragraphs. `%'s start comments.
+Commands:
+\\{prolog-mode-map}
+Entry to this mode calls the value of prolog-mode-hook
+if that value is non-nil."
+ t)
+
+(autoload 'run-prolog "prolog"
+ "\
+Run an inferior Prolog process, input and output via buffer *prolog*."
+ t)
+
+
+(autoload 'clear-rectangle "rect"
+ "\
+Blank out rectangle with corners at point and mark.
+The text previously in the region is overwritten by the blanks."
+ t)
+
+(autoload 'delete-rectangle "rect"
+ "\
+Delete (don't save) text in rectangle with point and mark as corners.
+The same range of columns is deleted in each line
+starting with the line where the region begins
+and ending with the line where the region ends."
+ t)
+
+(autoload 'delete-extract-rectangle "rect"
+ "\
+Return and delete contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle.")
+
+(autoload 'extract-rectangle "rect"
+ "\
+Return contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle.")
+
+(autoload 'insert-rectangle "rect"
+ "\
+Insert text of RECTANGLE with upper left corner at point.
+RECTANGLE's first line is inserted at point,
+its second line is inserted at a point vertically under point, etc.
+RECTANGLE should be a list of strings.")
+
+(autoload 'kill-rectangle "rect"
+ "\
+Delete rectangle with corners at point and mark; save as last killed one.
+Calling from program, supply two args START and END, buffer positions.
+But in programs you might prefer to use delete-extract-rectangle."
+ t)
+
+(autoload 'open-rectangle "rect"
+ "\
+Blank out rectangle with corners at point and mark, shifting text right.
+The text previously in the region is not overwritten by the blanks,
+but insted winds up to the right of the rectangle."
+ t)
+
+(autoload 'yank-rectangle "rect"
+ "\
+Yank the last killed rectangle with upper left corner at point."
+ t)
+\f
+(autoload 'rnews "rnews"
+ "\
+Read USENET news for groups for which you are a member and add or
+delete groups.
+You can reply to articles posted and send articles to any group.
+
+Type \\[describe-mode] once reading news to get a list of rnews commands."
+ t)
+
+(autoload 'news-post-news "rnewspost"
+ "\
+Begin editing a new USENET news article to be posted.
+Type \\[describe-mode] once editing the article to get a list of commands."
+ t)
+(fset 'sendnews 'news-post-news)
+(fset 'postnews 'news-post-news)
+
+(autoload 'rmail "rmail"
+ "\
+Read and edit incoming mail.
+Moves messages into file named by rmail-file-name (a babyl format file)
+ and edits that file in RMAIL Mode.
+Type \\[describe-mode] once editing that file, for a list of RMAIL commands.
+
+May be called with filename as argument;
+then performs rmail editing on that file,
+but does not copy any new mail into the file."
+ t)
+
+(autoload 'rmail-input "rmail"
+ "\
+Run RMAIL on file FILENAME."
+ t)
+
+(defconst rmail-dont-reply-to-names nil "\
+*A regular expression specifying names to prune in replying to messages.
+nil means don't reply to yourself.")
+
+(defvar rmail-default-dont-reply-to-names "info-" "\
+A regular expression specifying part of the value of the default value of
+the variable `rmail-dont-reply-to-names', for when the user does not set
+`rmail-dont-reply-to-names' explicitly. (The other part of the default
+value is the user's name.)
+It is useful to set this variable in the site customisation file.")
+
+(defconst rmail-primary-inbox-list nil "\
+*List of files which are inboxes for user's primary mail file ~/RMAIL.
+`nil' means the default, which is (\"~/mbox\" \"/usr/spool/mail/$USER\")
+(the second name varies depending on the operating system).")
+
+(defconst rmail-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^[a-z-]*message-id:\\|^summary-line:\\|^errors-to:" "\
+*Gubbish header fields one would rather not see.")
+
+(defvar rmail-delete-after-output nil "\
+*Non-nil means automatically delete a message that is copied to a file.")
+
+;;; Others are in paths.el.
+\f
+(autoload 'run-scheme "xscheme"
+ "\
+Run an inferior Scheme process.
+Output goes to the buffer `*scheme*'.
+With argument, asks for a command line."
+ t)
+
+(autoload 'scheme-mode "scheme"
+ "\
+Major mode for editing Scheme code.
+Editing commands are similar to those of lisp-mode.
+
+In addition, if an inferior Scheme process is running, some additional
+commands will be defined, for evaluating expressions and controlling
+the interpreter, and the state of the process will be displayed in the
+modeline of all Scheme buffers. The names of commands that interact
+with the Scheme process start with \"xscheme-\". For more information
+see the documentation for xscheme-interaction-mode.
+
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs. Semicolons start comments.
+\\{scheme-mode-map}
+Entry to this mode calls the value of scheme-mode-hook
+if that value is non-nil."
+ t)
+
+(autoload 'scribe-mode "scribe"
+ "\
+Major mode for editing files of Scribe (a text formatter) source.
+Scribe-mode is similar text-mode, with a few extra commands added.
+\\{scribe-mode-map}
+
+Interesting variables:
+
+scribe-fancy-paragraphs
+ Non-nil makes Scribe mode use a different style of paragraph separation.
+
+scribe-electric-quote
+ Non-nil makes insert of double quote use `` or '' depending on context.
+
+scribe-electric-parenthesis
+ Non-nil makes an open-parenthesis char (one of `([<{')
+ automatically insert its close if typed after an @Command form."
+ t)
+
+;; Useful to set in site-init.el
+(defconst send-mail-function 'sendmail-send-it "\
+Function to call to send the current buffer as mail.
+The headers are delimited by a string found in mail-header-separator.")
+
+(defconst mail-self-blind nil "\
+*Non-nil means insert BCC to self in messages to be sent.
+This is done when the message is initialized,
+so you can remove or alter the BCC field to override the default.")
+
+(defconst mail-interactive nil "\
+*Non-nil means when sending a message wait for and display errors.
+nil means let mailer mail back a message to report errors.")
+
+(defconst mail-yank-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^remailed\\|^received:\\|^[a-z-]*message-id:\\|^summary-line:\\|^to:\\|^cc:\\|^subject:\\|^in-reply-to:\\|^return-path:" "\
+Delete these headers from old message when it's inserted in a reply.")
+
+(defconst mail-header-separator "--text follows this line--" "\
+*Line used to separate headers from text in messages being composed.")
+
+(defconst mail-archive-file-name nil "\
+*Name of file to write all outgoing messages in, or nil for none.")
+
+(defvar mail-aliases t "\
+Alias of mail address aliases,
+or t meaning should be initialized from .mailrc.")
+
+(autoload 'mail-other-window "sendmail"
+ "\
+Like `mail' command, but display mail buffer in another window."
+ t)
+
+(autoload 'mail "sendmail"
+ "\
+Edit a message to be sent. Argument means resume editing (don't erase).
+Returns with message buffer selected; value t if message freshly initialized.
+While editing message, type C-c C-c to send the message and exit.
+
+Various special commands starting with C-c are available in sendmail mode
+to move to message header fields:
+\\{mail-mode-map}
+
+If mail-self-blind is non-nil, a BCC to yourself is inserted
+when the message is initialized.
+
+If mail-default-reply-to is non-nil, it should be an address (a string);
+a Reply-to: field with that address is inserted.
+
+If mail-archive-file-name is non-nil, an FCC field with that file name
+is inserted.
+
+If mail-setup-hook is bound, its value is called with no arguments
+after the message is initialized. It can add more default fields.
+
+When calling from a program, the second through fifth arguments
+ TO, SUBJECT, IN-REPLY-TO and CC specify if non-nil
+ the initial contents of those header fields.
+ These arguments should not have final newlines.
+The sixth argument REPLYBUFFER is a buffer whose contents
+ should be yanked if the user types C-c C-y."
+ t)
+
+(define-key ctl-x-4-map "m" 'mail-other-window)
+(define-key ctl-x-map "m" 'mail)
+
+;; used in mail-utils
+(defvar mail-use-rfc822 nil "\
+*If non-nil, use a full, hairy RFC822 parser on mail addresses.
+Otherwise, (the default) use a smaller, somewhat faster and
+often-correct parser.")
+
+\f
+(autoload 'server-start "server"
+ "\
+Allow this Emacs process to be a server for client processes.
+This starts a server communications subprocess through which
+client \"editors\" can send your editing commands to this Emacs job.
+To use the server, set up the program `etc/emacsclient' in the
+Emacs distribution as your standard \"editor\".
+
+Prefix arg means just kill any existing server communications subprocess."
+ t)
+
+(autoload 'run-lisp "shell"
+ "\
+Run an inferior Lisp process, input and output via buffer *lisp*."
+ t)
+
+(autoload 'shell "shell"
+ "\
+Run an inferior shell, with I/O through buffer *shell*.
+If buffer exists but shell process is not running, make new shell.
+Program used comes from variable explicit-shell-file-name,
+ or (if that is nil) from the ESHELL environment variable,
+ or else from SHELL if there is no ESHELL.
+If a file ~/.emacs_SHELLNAME exists, it is given as initial input
+ (Note that this may lose due to a timing error if the shell
+ discards input when it starts up.)
+The buffer is put in shell-mode, giving commands for sending input
+and controlling the subjobs of the shell. See shell-mode.
+See also variable shell-prompt-pattern.
+
+The shell file name (sans directories) is used to make a symbol name
+such as `explicit-csh-arguments'. If that symbol is a variable,
+its value is used as a list of arguments when invoking the shell.
+Otherwise, one argument `-i' is passed to the shell.
+
+Note that many people's .cshrc files unconditionally clear the prompt.
+If yours does, you will probably want to change it."
+ t)
+
+(autoload 'sort-lines "sort"
+ "\
+Sort lines in region alphabetically; argument means descending order.
+Called from a program, there are three arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ t)
+
+(autoload 'sort-paragraphs "sort"
+ "\
+Sort paragraphs in region alphabetically; argument means descending order.
+Called from a program, there are three arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ t)
+
+(autoload 'sort-pages "sort"
+ "\
+Sort pages in region alphabetically; argument means descending order.
+Called from a program, there are three arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ t)
+
+(autoload 'sort-numeric-fields "sort"
+ "\
+Sort lines in region numerically by the ARGth field of each line.
+Fields are separated by whitespace and numbered from 1 up.
+Specified field must contain a number in each line of the region.
+With a negative arg, sorts by the -ARG'th field, in reverse order.
+Called from a program, there are three arguments:
+FIELD, BEG and END. BEG and END specify region to sort."
+ t)
+
+(autoload 'sort-fields "sort"
+ "\
+Sort lines in region lexicographically by the ARGth field of each line.
+Fields are separated by whitespace and numbered from 1 up.
+With a negative arg, sorts by the -ARG'th field, in reverse order.
+Called from a program, there are three arguments:
+FIELD, BEG and END. BEG and END specify region to sort."
+ t)
+
+(autoload 'sort-columns "sort"
+ "\
+Sort lines in region alphabetically by a certain range of columns.
+For the purpose of this command, the region includes
+the entire line that point is in and the entire line the mark is in.
+The column positions of point and mark bound the range of columns to sort on.
+A prefix argument means sort into reverse order.
+
+Note that sort-columns uses the sort utility program and therefore
+cannot work on text containing TAB characters. Use M-x untabify
+to convert tabs to spaces before sorting."
+ t)
+
+(autoload 'sort-regexp-fields "sort"
+ "\
+Sort the region lexicographically as specifed by RECORD-REGEXP and KEY.
+RECORD-REGEXP specifies the textual units which should be sorted.
+ For example, to sort lines RECORD-REGEXP would be \"^.*$\"
+KEY specifies the part of each record (ie each match for RECORD-REGEXP)
+ is to be used for sorting.
+ If it is \"\\digit\" then the digit'th \"\\(...\\)\" match field from
+ RECORD-REGEXP is used.
+ If it is \"\\&\" then the whole record is used.
+ Otherwise, it is a regular-expression for which to search within the record.
+If a match for KEY is not found within a record then that record is ignored.
+
+With a negative prefix arg sorts in reverse order.
+
+For example: to sort lines in the region by the first word on each line
+ starting with the letter \"f\",
+ RECORD-REGEXP would be \"^.*$\" and KEY \"\\<f\\w*\\>\""
+ t)
+
+\f
+(autoload 'spell-buffer "spell"
+ "\
+Check spelling of every word in the buffer.
+For each incorrect word, you are asked for the correct spelling
+and then put into a query-replace to fix some or all occurrences.
+If you do not want to change a word, just give the same word
+as its \"correct\" spelling; then the query replace is skipped."
+ t)
+
+(autoload 'spell-region "spell"
+ "\
+Like spell-buffer but applies only to region.
+From program, applies from START to END."
+ t)
+
+(define-key esc-map "$" 'spell-word)
+(autoload 'spell-word "spell"
+ "\
+Check spelling of word at or before point.
+If it is not correct, ask user for the correct spelling
+and query-replace the entire buffer to substitute it."
+ t)
+
+(autoload 'spell-string "spell"
+ "\
+Check spelling of string supplied as argument."
+ t)
+
+(autoload 'untabify "tabify"
+ "\
+Convert all tabs in region to multiple spaces, preserving columns.
+The variable tab-width controls the action."
+ t)
+
+(autoload 'tabify "tabify"
+ "\
+Convert multiple spaces in region to tabs when possible.
+A group of spaces is partially replaced by tabs
+when this can be done without changing the column they end at.
+The variable tab-width controls the action."
+ t)
+
+(define-key esc-map "." 'find-tag)
+
+(autoload 'find-tag "tags"
+ "\
+Find tag (in current tag table) whose name contains TAGNAME.
+ Selects the buffer that the tag is contained in
+and puts point at its definition.
+ If TAGNAME is a null string, the expression in the buffer
+around or before point is used as the tag name.
+ If second arg NEXT is non-nil (interactively, with prefix arg),
+searches for the next tag in the tag table
+that matches the tagname used in the previous find-tag.
+
+See documentation of variable tags-file-name."
+ t)
+
+(define-key ctl-x-4-map "." 'find-tag-other-window)
+
+(autoload 'find-tag-other-window "tags"
+ "\
+Find tag (in current tag table) whose name contains TAGNAME.
+ Selects the buffer that the tag is contained in in another window
+and puts point at its definition.
+ If TAGNAME is a null string, the expression in the buffer
+around or before point is used as the tag name.
+ If second arg NEXT is non-nil (interactively, with prefix arg),
+searches for the next tag in the tag table
+that matches the tagname used in the previous find-tag.
+
+See documentation of variable tags-file-name."
+ t)
+
+(autoload 'list-tags "tags"
+ "\
+Display list of tags in file FILE.
+FILE should not contain a directory spec
+unless it has one in the tag table."
+ t)
+
+(autoload 'next-file "tags"
+ "\
+Select next file among files in current tag table.
+Non-nil argument (prefix arg, if interactive)
+initializes to the beginning of the list of files in the tag table."
+ t)
+
+(autoload 'tags-apropos "tags"
+ "\
+Display list of all tags in tag table REGEXP matches."
+ t)
+
+(define-key esc-map "," 'tags-loop-continue)
+(autoload 'tags-loop-continue "tags"
+ "\
+Continue last \\[tags-search] or \\[tags-query-replace] command.
+Used noninteractively with non-nil argument
+to begin such a command. See variable tags-loop-form."
+ t)
+
+(autoload 'tag-table-files "tags"
+ "\
+Return a list of files in the current tag table.
+File names returned are absolute.")
+
+(autoload 'tags-query-replace "tags"
+ "\
+Query-replace-regexp FROM with TO through all files listed in tag table.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+If you exit (C-G or ESC), you can resume the query-replace
+with the command \\[tags-loop-continue].
+
+See documentation of variable tags-file-name."
+ t)
+
+(autoload 'tags-search "tags"
+ "\
+Search through all files listed in tag table for match for REGEXP.
+Stops when a match is found.
+To continue searching for next match, use command \\[tags-loop-continue].
+
+See documentation of variable tags-file-name."
+ t)
+
+(autoload 'visit-tags-table "tags"
+ "\
+Tell tags commands to use tag table file FILE.
+FILE should be the name of a file created with the `etags' program.
+A directory name is ok too; it means file TAGS in that directory."
+ t)
+
+(autoload 'telnet "telnet"
+ "\
+Open a network login connection to host named HOST (a string).
+Communication with HOST is recorded in a buffer *HOST-telnet*.
+Normally input is edited in Emacs and sent a line at a time."
+ t)
+
+(autoload 'terminal-emulator "terminal"
+ "\
+Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS.
+ARGS is a list of argument-strings. Remaining arguments are WIDTH and HEIGHT.
+BUFFER's contents are made an image of the display generated by that program,
+and any input typed when BUFFER is the current Emacs buffer is sent to that
+program an keyboard input.
+
+Interactively, BUFFER defaults to \"*terminal*\" and PROGRAM and ARGS
+are parsed from an input-string using your usual shell.
+WIDTH and HEIGHT are determined from the size of the current window
+-- WIDTH will be one less than the window's width, HEIGHT will be its height.
+
+To switch buffers and leave the emulator, or to give commands
+to the emulator itself (as opposed to the program running under it),
+type Control-^. The following character is an emulator command.
+Type Control-^ twice to send it to the subprogram.
+This escape character may be changed using the variable `terminal-escape-char'.
+
+`Meta' characters may not currently be sent through the terminal emulator.
+
+Here is a list of some of the variables which control the behaviour
+of the emulator -- see their documentation for more information:
+terminal-escape-char, terminal-scrolling, terminal-more-processing,
+terminal-redisplay-interval.
+
+This function calls the value of terminal-mode-hook if that exists
+and is non-nil after the terminal buffer has been set up and the
+subprocess started.
+
+Presently with `termcap' only; if somebody sends us code to make this
+work with `terminfo' we will try to use it."
+ t)
+
+(autoload 'latex-mode "tex-mode"
+ "\
+Major mode for editing files of input for LaTeX.
+Makes $ and } display the characters they match.
+Makes \" insert `` when it seems to be the beginning of a quotation,
+and '' when it appears to be the end; it inserts \" only after a \\.
+
+Use \\[TeX-region] to run LaTeX on the current region, plus the preamble
+copied from the top of the file (containing \\documentstyle, etc.),
+running LaTeX under a special subshell. \\[TeX-buffer] does the whole buffer.
+\\[TeX-print] prints the .dvi file made by either of these.
+
+Use \\[validate-TeX-buffer] to check buffer for paragraphs containing
+mismatched $'s or braces.
+
+Special commands:
+\\{TeX-mode-map}
+
+Mode variables:
+TeX-directory
+ Directory in which to create temporary files for TeX jobs
+ run by \\[TeX-region] or \\[TeX-buffer].
+TeX-dvi-print-command
+ Command string used by \\[TeX-print] to print a .dvi file.
+TeX-show-queue-command
+ Command string used by \\[TeX-show-print-queue] to show the print
+ queue that \\[TeX-print] put your job on.
+
+Entering LaTeX mode calls the value of text-mode-hook,
+then the value of TeX-mode-hook, and then the value
+of LaTeX-mode-hook."
+ t)
+
+(autoload 'plain-tex-mode "tex-mode"
+ "\
+Major mode for editing files of input for plain TeX.
+Makes $ and } display the characters they match.
+Makes \" insert `` when it seems to be the beginning of a quotation,
+and '' when it appears to be the end; it inserts \" only after a \\.
+
+Use \\[TeX-region] to run TeX on the current region, plus a \"header\"
+copied from the top of the file (containing macro definitions, etc.),
+running TeX under a special subshell. \\[TeX-buffer] does the whole buffer.
+\\[TeX-print] prints the .dvi file made by either of these.
+
+Use \\[validate-TeX-buffer] to check buffer for paragraphs containing
+mismatched $'s or braces.
+
+Special commands:
+\\{TeX-mode-map}
+
+Mode variables:
+TeX-directory
+ Directory in which to create temporary files for TeX jobs
+ run by \\[TeX-region] or \\[TeX-buffer].
+TeX-dvi-print-command
+ Command string used by \\[TeX-print] to print a .dvi file.
+TeX-show-queue-command
+ Command string used by \\[TeX-show-print-queue] to show the print
+ queue that \\[TeX-print] put your job on.
+
+Entering plain-TeX mode calls the value of text-mode-hook,
+then the value of TeX-mode-hook, and then the value
+of plain-TeX-mode-hook."
+ t)
+
+(autoload 'tex-mode "tex-mode"
+ "\
+Major mode for editing files of input for TeX or LaTeX.
+Trys to intuit whether this file is for plain TeX or LaTeX and
+calls plain-tex-mode or latex-mode. If it cannot be determined
+(e.g., there are no commands in the file), the value of
+TeX-default-mode is used."
+ t)
+
+(fset 'TeX-mode 'tex-mode)
+(fset 'plain-TeX-mode 'plain-tex-mode)
+(fset 'LaTeX-mode 'latex-mode)
+
+(autoload 'texinfo-mode "texinfo"
+ "\
+Major mode for editing texinfo files.
+These are files that are input for TEX and also to be turned
+into Info files by \\[texinfo-format-buffer].
+These files must be written in a very restricted and
+modified version of TEX input format.
+
+As for editing commands, like text-mode except for syntax table,
+which is set up so expression commands skip texinfo bracket groups."
+ t)
+
+(autoload 'texinfo-format-buffer "texinfmt"
+ "\
+Process the current buffer as texinfo code, into an Info file.
+The Info file output is generated in a buffer
+visiting the Info file names specified in the @setfilename command.
+
+Non-nil argument (prefix, if interactive) means don't make tag table
+and don't split the file if large. You can use Info-tagify and
+Info-split to do these manually."
+ t)
+
+(autoload 'texinfo-format-region "texinfmt"
+ "\
+Convert the the current region of the Texinfo file to Info format.
+This lets you see what that part of the file will look like in Info.
+The command is bound to \\[texinfo-format-region]. The text that is
+converted to Info is stored in a temporary buffer."
+ t)
+
+(autoload 'batch-texinfo-format "texinfmt"
+ "\
+Runs texinfo-format-buffer on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke
+ \"emacs -batch -funcall batch-texinfo-format $docs/ ~/*.texinfo\"."
+ nil)
+
+(autoload 'display-time "time"
+ "\
+Display current time and load level in mode line of each buffer.
+Updates automatically every minute.
+If display-time-day-and-date is non-nil, the current day and date
+are displayed as well."
+ t)
+
+(autoload 'underline-region "underline"
+ "\
+Underline all nonblank characters in the region.
+Works by overstriking underscores.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ t)
+
+(autoload 'ununderline-region "underline"
+ "\
+Remove all underlining (overstruck underscores) in the region.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ t)
+
+(autoload 'ask-user-about-lock "userlock"
+ "\
+Ask user what to do when he wants to edit FILE but it is locked by USER.
+This function has a choice of three things to do:
+ do (signal 'buffer-file-locked (list FILE USER))
+ to refrain from editing the file
+ return t (grab the lock on the file)
+ return nil (edit the file even though it is locked).
+You can rewrite it to use any criterion you like to choose which one to do."
+ nil)
+
+(autoload 'ask-user-about-supersession-threat "userlock"
+ "\
+Ask a user who is about to modify an obsolete buffer what to do.
+This function has two choices: it can return, in which case the modification
+of the buffer will proceed, or it can (signal 'file-supersession (file)),
+in which case the proposed buffer modification will not be made.
+You can rewrite this to use any criterion you like to choose which one to do."
+ nil)
+
+(autoload 'vi-mode "vi"
+ "\
+Major mode that acts like the `vi' editor.
+The purpose of this mode is to provide you the combined power of vi (namely,
+the \"cross product\" effect of commands and repeat last changes) and Emacs.
+
+This command redefines nearly all keys to look like vi commands.
+It records the previous major mode, and any vi command for input
+\(`i', `a', `s', etc.) switches back to that mode.
+Thus, ordinary Emacs (in whatever major mode you had been using)
+is \"input\" mode as far as vi is concerned.
+
+To get back into vi from \"input\" mode, you must issue this command again.
+Therefore, it is recommended that you assign it to a key.
+
+Major differences between this mode and real vi :
+
+* Limitations and unsupported features
+ - Search patterns with line offset (e.g. /pat/+3 or /pat/z.) are
+ not supported.
+ - Ex commands are not implemented; try ':' to get some hints.
+ - No line undo (i.e. the 'U' command), but multi-undo is a standard feature.
+
+* Modifications
+ - The stopping positions for some point motion commands (word boundary,
+ pattern search) are slightly different from standard 'vi'.
+ Also, no automatic wrap around at end of buffer for pattern searching.
+ - Since changes are done in two steps (deletion then insertion), you need
+ to undo twice to completely undo a change command. But this is not needed
+ for undoing a repeated change command.
+ - No need to set/unset 'magic', to search for a string with regular expr
+ in it just put a prefix arg for the search commands. Replace cmds too.
+ - ^R is bound to incremental backward search, so use ^L to redraw screen.
+
+* Extensions
+ - Some standard (or modified) Emacs commands were integrated, such as
+ incremental search, query replace, transpose objects, and keyboard macros.
+ - In command state, ^X links to the 'ctl-x-map', and ESC can be linked to
+ esc-map or set undefined. These can give you the full power of Emacs.
+ - See vi-com-map for those keys that are extensions to standard vi, e.g.
+ `vi-name-last-change-or-macro', `vi-verify-spelling', `vi-locate-def',
+ `vi-mark-region', and 'vi-quote-words'. Some of them are quite handy.
+ - Use \\[vi-switch-mode] to switch among different modes quickly.
+
+Syntax table and abbrevs while in vi mode remain as they were in Emacs."
+ t)
+
+(autoload 'view-file "view"
+ "\
+View FILE in View mode, returning to previous buffer when done.
+The usual Emacs commands are not available; instead,
+a special set of commands (mostly letters and punctuation)
+are defined for moving around in the buffer.
+Space scrolls forward, Delete scrolls backward.
+For list of all View commands, type ? or h while viewing.
+
+Calls the value of view-hook if that is non-nil."
+ t)
+
+(autoload 'view-buffer "view"
+ "\
+View BUFFER in View mode, returning to previous buffer when done.
+The usual Emacs commands are not available; instead,
+a special set of commands (mostly letters and punctuation)
+are defined for moving around in the buffer.
+Space scrolls forward, Delete scrolls backward.
+For list of all View commands, type ? or h while viewing.
+
+Calls the value of view-hook if that is non-nil."
+ t)
+
+(autoload 'view-mode "view"
+ "\
+Major mode for viewing text but not editing it.
+Letters do not insert themselves. Instead these commands are provided.
+Most commands take prefix arguments. Commands dealing with lines
+default to \"scroll size\" lines (initially size of window).
+Search commands default to a repeat count of one.
+M-< or < move to beginning of buffer.
+M-> or > move to end of buffer.
+C-v or Space scroll forward lines.
+M-v or DEL scroll backward lines.
+CR or LF scroll forward one line (backward with prefix argument).
+z like Space except set number of lines for further
+ scrolling commands to scroll by.
+C-u and Digits provide prefix arguments. `-' denotes negative argument.
+= prints the current line number.
+g goes to line given by prefix argument.
+/ or M-C-s searches forward for regular expression
+\\ or M-C-r searches backward for regular expression.
+n searches forward for last regular expression.
+p searches backward for last regular expression.
+C-@ or . set the mark.
+x exchanges point and mark.
+C-s or s do forward incremental search.
+C-r or r do reverse incremental search.
+@ or ' return to mark and pops mark ring.
+ Mark ring is pushed at start of every
+ successful search and when jump to line to occurs.
+ The mark is set on jump to buffer start or end.
+? or h provide help message (list of commands).
+C-h provides help (list of commands or description of a command).
+C-n moves down lines vertically.
+C-p moves upward lines vertically.
+C-l recenters the screen.
+q or C-c exit view-mode and return to previous buffer.
+
+Entry to this mode calls the value of view-hook if non-nil.
+\\{view-mode-map}")
+
+(autoload 'vip-mode "vip"
+ "\
+Begin emulating the vi editor. This is distinct from `vi-mode'.
+This emulator has different capabilities from the `vi-mode' emulator.
+See the text at the beginning of the source file .../lisp/vip.el
+in the Emacs distribution."
+ t)
+
+(autoload 'yow "yow"
+ "\
+Return or display a Zippy quotation" t)
+(autoload 'psychoanalyze-pinhead "yow"
+ "\
+Zippy goes to the analyst." t)
+
+\f
+(define-key esc-map "\C-f" 'forward-sexp)
+(define-key esc-map "\C-b" 'backward-sexp)
+(define-key esc-map "\C-u" 'backward-up-list)
+(define-key esc-map "\C-@" 'mark-sexp)
+(define-key esc-map "\C-d" 'down-list)
+(define-key esc-map "\C-k" 'kill-sexp)
+(define-key esc-map "\C-n" 'forward-list)
+(define-key esc-map "\C-p" 'backward-list)
+(define-key esc-map "\C-a" 'beginning-of-defun)
+(define-key esc-map "\C-e" 'end-of-defun)
+(define-key esc-map "\C-h" 'mark-defun)
+(define-key esc-map "(" 'insert-parentheses)
+(define-key esc-map ")" 'move-past-close-and-reindent)
+(define-key esc-map "\t" 'lisp-complete-symbol)
+
+(define-key ctl-x-map "\C-e" 'eval-last-sexp)
+\f
+(define-key ctl-x-map "/" 'point-to-register)
+(define-key ctl-x-map "j" 'register-to-point)
+(define-key ctl-x-map "x" 'copy-to-register)
+(define-key ctl-x-map "g" 'insert-register)
+(define-key ctl-x-map "r" 'copy-rectangle-to-register)
+
+(define-key esc-map "q" 'fill-paragraph)
+(define-key esc-map "g" 'fill-region)
+(define-key ctl-x-map "." 'set-fill-prefix)
+\f
+(define-key esc-map "[" 'backward-paragraph)
+(define-key esc-map "]" 'forward-paragraph)
+(define-key esc-map "h" 'mark-paragraph)
+(define-key esc-map "a" 'backward-sentence)
+(define-key esc-map "e" 'forward-sentence)
+(define-key esc-map "k" 'kill-sentence)
+(define-key ctl-x-map "\177" 'backward-kill-sentence)
+
+(define-key ctl-x-map "[" 'backward-page)
+(define-key ctl-x-map "]" 'forward-page)
+(define-key ctl-x-map "\C-p" 'mark-page)
+(put 'narrow-to-region 'disabled t)
+(define-key ctl-x-map "p" 'narrow-to-page)
+(put 'narrow-to-page 'disabled t)
+(define-key ctl-x-map "l" 'count-lines-page)
+\f
+(defun isearch-forward ()
+ "\
+Do incremental search forward.
+As you type characters, they add to the search string and are found.
+Type Delete to cancel characters from end of search string.
+Type ESC to exit, leaving point at location found.
+Type C-s to search again forward, C-r to search again backward.
+Type C-w to yank word from buffer onto end of search string and search for it.
+Type C-y to yank rest of line onto end of search string, etc.
+Type C-q to quote control character to search for it.
+Other control and meta characters terminate the search
+ and are then executed normally.
+The above special characters are mostly controlled by parameters;
+ do M-x apropos on search-.*-char to find them.
+C-g while searching or when search has failed
+ cancels input back to what has been found successfully.
+C-g when search is successful aborts and moves point to starting point."
+ (interactive)
+ (isearch t))
+
+(defun isearch-forward-regexp ()
+ "\
+Do incremental search forward for regular expression.
+Like ordinary incremental search except that your input
+is treated as a regexp. See \\[isearch-forward] for more info."
+ (interactive)
+ (isearch t t))
+
+(defun isearch-backward ()
+ "\
+Do incremental search backward.
+See \\[isearch-forward] for more information."
+ (interactive)
+ (isearch nil))
+
+(defun isearch-backward-regexp ()
+ "\
+Do incremental search backward for regular expression.
+Like ordinary incremental search except that your input
+is treated as a regexp. See \\[isearch-forward] for more info."
+ (interactive)
+ (isearch nil t))
+
+(defvar search-last-string "" "\
+Last string search for by a non-regexp search command.
+This does not include direct calls to the primitive search functions,
+and does not include searches that are aborted.")
+
+(defvar search-last-regexp "" "\
+Last string searched for by a regexp search command.
+This does not include direct calls to the primitive search functions,
+and does not include searches that are aborted.")
+
+(defconst search-repeat-char ?\C-s "\
+*Character to repeat incremental search forwards.")
+(defconst search-reverse-char ?\C-r "\
+*Character to repeat incremental search backwards.")
+(defconst search-exit-char ?\e "\
+*Character to exit incremental search.")
+(defconst search-delete-char ?\177 "\
+*Character to delete from incremental search string.")
+(defconst search-quote-char ?\C-q "\
+*Character to quote special characters for incremental search.")
+(defconst search-yank-word-char ?\C-w "\
+*Character to pull next word from buffer into search string.")
+(defconst search-yank-line-char ?\C-y "\
+*Character to pull rest of line from buffer into search string.")
+(defconst search-exit-option t "\
+*Non-nil means random control characters terminate incremental search.")
+
+(defvar search-slow-window-lines 1 "\
+*Number of lines in slow search display windows.
+These are the short windows used during incremental search on slow terminals.
+Negative means put the slow search window at the top (normally it's at bottom)
+and the value is minus the number of lines.")
+
+(defvar search-slow-speed 1200 "\
+*Highest terminal speed at which to use \"slow\" style incremental search.
+This is the style where a one-line window is created to show the line
+that the search has reached.")
+
+(autoload 'isearch "isearch")
+
+(define-key global-map "\C-s" 'isearch-forward)
+(define-key global-map "\C-r" 'isearch-backward)
+(define-key esc-map "\C-s" 'isearch-forward-regexp)
+\f
+(defun query-replace (from-string to-string &optional arg)
+ "\
+Replace some occurrences of FROM-STRING with TO-STRING.
+As each match is found, the user must type a character saying
+what to do with it. For directions, type \\[help-command] at that time.
+
+Preserves case in each replacement if case-replace and case-fold-search
+are non-nil and FROM-STRING has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries."
+ (interactive "sQuery replace: \nsQuery replace %s with: \nP")
+ (perform-replace from-string to-string t nil arg)
+ (message "Done"))
+
+(defun query-replace-regexp (regexp to-string &optional arg)
+ "\
+Replace some things after point matching REGEXP with TO-STRING.
+As each match is found, the user must type a character saying
+what to do with it. For directions, type \\[help-command] at that time.
+
+Preserves case in each replacement if case-replace and case-fold-search
+are non-nil and REGEXP has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries.
+In TO-STRING, \\& means insert what matched REGEXP,
+and \\=\\<n> means insert what matched <n>th \\(...\\) in REGEXP."
+ (interactive "sQuery replace regexp: \nsQuery replace regexp %s with: \nP")
+ (perform-replace regexp to-string t t arg)
+ (message "Done"))
+
+(defun replace-string (from-string to-string &optional delimited)
+ "\
+Replace occurrences of FROM-STRING with TO-STRING.
+Preserve case in each match if case-replace and case-fold-search
+are non-nil and FROM-STRING has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries."
+ (interactive "sReplace string: \nsReplace string %s with: \nP")
+ (perform-replace from-string to-string nil nil delimited)
+ (message "Done"))
+
+(defun replace-regexp (regexp to-string &optional delimited)
+ "\
+Replace things after point matching REGEXP with TO-STRING.
+Preserve case in each match if case-replace and case-fold-search
+are non-nil and REGEXP has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries.
+In TO-STRING, \\& means insert what matched REGEXP,
+and \\=\\<n> means insert what matched <n>th \\(...\\) in REGEXP."
+ (interactive "sReplace regexp: \nsReplace regexp %s with: \nP")
+ (perform-replace regexp to-string nil t delimited)
+ (message "Done"))
+
+(define-key esc-map "%" 'query-replace)
+
+(autoload 'perform-replace "replace")
+\f
+(define-key ctl-x-map "\C-a" 'add-mode-abbrev)
+(define-key ctl-x-map "\+" 'add-global-abbrev)
+(define-key ctl-x-map "\C-h" 'inverse-add-mode-abbrev)
+(define-key ctl-x-map "\-" 'inverse-add-global-abbrev)
+(define-key esc-map "'" 'abbrev-prefix-mark)
+(define-key ctl-x-map "'" 'expand-abbrev)
--- /dev/null
+;Load up standardly loaded Lisp files for Emacs.
+;; This is loaded into a bare Emacs to make a dumpable one.
+;; 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.
+
+
+(load "subr")
+(garbage-collect)
+(load "loaddefs.el") ;Don't get confused if someone compiled loaddefs by mistake.
+(garbage-collect)
+(load "simple")
+(garbage-collect)
+(load "help")
+(garbage-collect)
+(load "files")
+(garbage-collect)
+(load "indent")
+(load "window")
+(load "paths.el") ;Don't get confused if someone compiled paths by mistake.
+(garbage-collect)
+(load "startup")
+(load "lisp")
+(garbage-collect)
+(load "page")
+(load "register")
+(garbage-collect)
+(load "paragraphs")
+(load "lisp-mode")
+(garbage-collect)
+(load "text-mode")
+(load "fill")
+(garbage-collect)
+(load "c-mode")
+(garbage-collect)
+(load "isearch")
+(garbage-collect)
+(load "replace")
+(if (eq system-type 'vax-vms)
+ (progn
+ (garbage-collect)
+ (load "vmsproc")))
+(garbage-collect)
+(load "abbrev")
+(garbage-collect)
+(load "buff-menu")
+(if (eq system-type 'vax-vms)
+ (progn
+ (garbage-collect)
+ (load "vms-patch")))
+
+;If you want additional libraries to be preloaded and their
+;doc strings kept in the DOC file rather than in core,
+;you may load them with a "site-load.el" file.
+;But you must also cause them to be scanned when the DOC file
+;is generated. For VMS, you must edit ../etc/makedoc.com.
+;For other systems, you must edit ../src/ymakefile.
+(if (load "site-load" t)
+ (garbage-collect))
+
+(load "version.el") ;Don't get confused if someone compiled version.el by mistake.
+
+;; Note: all compiled Lisp files loaded above this point
+;; must be among the ones parsed by make-docfile
+;; to construct DOC. Any that are not processed
+;; for DOC will not have doc strings in the dumped Emacs.
+
+(message "Finding pointers to doc strings...")
+(if (fboundp 'dump-emacs)
+ (let ((name emacs-version))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (copy-file (expand-file-name "../etc/DOC")
+ (concat (expand-file-name "../etc/DOC-") name)
+ t)
+ (Snarf-documentation (concat "DOC-" name)))
+ (Snarf-documentation "DOC"))
+(message "Finding pointers to doc strings...done")
+
+;Note: You can cause additional libraries to be preloaded
+;by writing a site-init.el that loads them.
+;See also "site-load" above.
+(load "site-init" t)
+(garbage-collect)
+
+(if (or (equal (nth 3 command-line-args) "dump")
+ (equal (nth 4 command-line-args) "dump"))
+ (if (eq system-type 'vax-vms)
+ (progn
+ (message "Dumping data as file temacs.dump")
+ (dump-emacs "temacs.dump" "temacs")
+ (kill-emacs))
+ (if (fboundp 'dump-emacs-data)
+ ;; Handle the IBM RS/6000, and perhaps eventually other machines.
+ (progn
+ ;; This strange nesting is so that the variable `name'
+ ;; is not bound when the data is dumped.
+ (message "Dumping data as file ../etc/EMACS-DATA")
+ (dump-emacs-data "../etc/EMACS-DATA")
+ (kill-emacs))
+ (let ((name (concat "emacs-" emacs-version)))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (message "Dumping under names xemacs and %s" name))
+ (condition-case ()
+ (delete-file "xemacs")
+ (file-error nil))
+ (dump-emacs "xemacs" "temacs")
+ ;; Recompute NAME now, so that it isn't set when we dump.
+ (let ((name (concat "emacs-" emacs-version)))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (add-name-to-file "xemacs" name t))
+ (kill-emacs))))
+
+;; Avoid error if user loads some more libraries now.
+(setq purify-flag nil)
+
+;; For machines with CANNOT_DUMP defined in config.h,
+;; this file must be loaded each time Emacs is run.
+;; So run the startup code now.
+
+(or (fboundp 'dump-emacs)
+ (eval top-level))
--- /dev/null
+;; Print Emacs buffer on line printer.
+;; Copyright (C) 1985, 1988 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.
+
+
+;(defconst lpr-switches nil
+; "*List of strings to pass as extra switch args to lpr when it is invoked.")
+
+(defvar lpr-command (if (eq system-type 'usg-unix-v)
+ "lp" "lpr")
+ "Shell command for printing a file")
+
+(defun lpr-buffer ()
+ "Print buffer contents as with Unix command `lpr'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ (interactive)
+ (print-region-1 (point-min) (point-max) lpr-switches))
+
+(defun print-buffer ()
+ "Print buffer contents as with Unix command `lpr -p'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ (interactive)
+ (print-region-1 (point-min) (point-max) (cons "-p" lpr-switches)))
+
+(defun lpr-region (start end)
+ "Print region contents as with Unix command `lpr'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ (interactive "r")
+ (print-region-1 start end lpr-switches))
+
+(defun print-region (start end)
+ "Print region contents as with Unix command `lpr -p'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ (interactive "r")
+ (print-region-1 start end (cons "-p" lpr-switches)))
+
+(defun print-region-1 (start end switches)
+ (let ((name (concat (buffer-name) " Emacs buffer"))
+ (width tab-width))
+ (save-excursion
+ (message "Spooling...")
+ (if (/= tab-width 8)
+ (let ((oldbuf (current-buffer)))
+ (set-buffer (get-buffer-create " *spool temp*"))
+ (widen) (erase-buffer)
+ (insert-buffer-substring oldbuf start end)
+ (setq tab-width width)
+ (untabify (point-min) (point-max))
+ (setq start (point-min) end (point-max))))
+ (apply 'call-process-region
+ (nconc (list start end lpr-command
+ nil nil nil)
+ (nconc (and (eq system-type 'berkeley-unix)
+ (list "-J" name "-T" name))
+ switches)))
+ (message "Spooling...done"))))
--- /dev/null
+;; Non-primitive commands for keyboard macros.
+;; Copyright (C) 1985, 1986, 1987 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.
+
+
+(defun name-last-kbd-macro (symbol)
+ "Assign a name to the last keyboard macro defined.
+One arg, a symbol, which is the name to define.
+The symbol's function definition becomes the keyboard macro string.
+Such a \"function\" cannot be called from Lisp, but it is a valid command
+definition for the editor command loop."
+ (interactive "SName for last kbd macro: ")
+ (or last-kbd-macro
+ (error "No keyboard macro defined"))
+ (and (fboundp symbol)
+ (not (stringp (symbol-function symbol)))
+ (error "Function %s is already defined and not a keyboard macro."
+ symbol))
+ (fset symbol last-kbd-macro))
+
+(defun insert-kbd-macro (macroname &optional keys)
+ "Insert in buffer the definition of kbd macro NAME, as Lisp code.
+Second argument KEYS non-nil means also record the keys it is on.
+ (This is the prefix argument, when calling interactively.)
+
+This Lisp code will, when executed, define the kbd macro with the
+same definition it has now. If you say to record the keys,
+the Lisp code will also rebind those keys to the macro.
+Only global key bindings are recorded since executing this Lisp code
+always makes global bindings.
+
+To save a kbd macro, visit a file of Lisp code such as your ~/.emacs,
+use this command, and then save the file."
+ (interactive "CInsert kbd macro (name): \nP")
+ (insert "(fset '")
+ (prin1 macroname (current-buffer))
+ (insert "\n ")
+ (prin1 (symbol-function macroname) (current-buffer))
+ (insert ")\n")
+ (if keys
+ (let ((keys (where-is-internal macroname nil)))
+ (while keys
+ (insert "(global-set-key ")
+ (prin1 (car keys) (current-buffer))
+ (insert " '")
+ (prin1 macroname (current-buffer))
+ (insert ")\n")
+ (setq keys (cdr keys))))))
+
+(defun kbd-macro-query (flag)
+ "Query user during kbd macro execution.
+With prefix argument, enters recursive edit,
+ reading keyboard commands even within a kbd macro.
+ You can give different commands each time the macro executes.
+Without prefix argument, reads a character. Your options are:
+ Space -- execute the rest of the macro.
+ DEL -- skip the rest of the macro; start next repetition.
+ C-d -- skip rest of the macro and don't repeat it any more.
+ C-r -- enter a recursive edit, then on exit ask again for a character
+ C-l -- redisplay screen and ask again."
+ (interactive "P")
+ (or executing-macro
+ defining-kbd-macro
+ (error "Not defining or executing kbd macro"))
+ (if flag
+ (let (executing-macro defining-kbd-macro)
+ (recursive-edit))
+ (if (not executing-macro)
+ nil
+ (let ((loop t))
+ (while loop
+ (let ((char (let ((executing-macro nil)
+ (defining-kbd-macro nil))
+ (message "Proceed with macro? (Space, DEL, C-d, C-r or C-l) ")
+ (read-char))))
+ (cond ((= char ? )
+ (setq loop nil))
+ ((= char ?\177)
+ (setq loop nil)
+ (setq executing-macro ""))
+ ((= char ?\C-d)
+ (setq loop nil)
+ (setq executing-macro t))
+ ((= char ?\C-l)
+ (recenter nil))
+ ((= char ?\C-r)
+ (let (executing-macro defining-kbd-macro)
+ (recursive-edit))))))))))
--- /dev/null
+;; Utility functions used both by rmail and rnews
+;; Copyright (C) 1985 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.
+
+
+(provide 'mail-utils)
+
+;; should be in loaddefs
+(defvar mail-use-rfc822 nil
+ "*If non-nil, use a full, hairy RFC822 parser on mail addresses.
+Otherwise, (the default) use a smaller, somewhat faster and
+often-correct parser.")
+
+(defun mail-string-delete (string start end)
+ "Returns a string containing all of STRING except the part
+from START (inclusive) to END (exclusive)."
+ (if (null end) (substring string 0 start)
+ (concat (substring string 0 start)
+ (substring string end nil))))
+
+(defun mail-strip-quoted-names (address)
+ "Delete comments and quoted strings in an address list ADDRESS.
+Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
+Return a modified address list."
+ (if mail-use-rfc822
+ (progn (require 'rfc822)
+ (mapconcat 'identity (rfc822-addresses address) ", "))
+ (let (pos)
+ (string-match "\\`[ \t\n]*" address)
+ ;; strip surrounding whitespace
+ (setq address (substring address
+ (match-end 0)
+ (string-match "[ \t\n]*\\'" address
+ (match-end 0))))
+ ;; strip rfc822 comments
+ (while (setq pos (string-match
+ ;; This doesn't hack rfc822 nested comments
+ ;; `(xyzzy (foo) whinge)' properly. Big deal.
+ "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
+ address))
+ (setq address
+ (mail-string-delete address
+ pos (match-end 0))))
+ ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
+ (setq pos 0)
+ (while (setq pos (string-match
+ "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
+ address pos))
+ ;; If the next thing is "@", we have "foo bar"@host. Leave it.
+ (if (and (> (length address) (match-end 0))
+ (= (aref address (match-end 0)) ?@))
+ (setq pos (match-end 0))
+ (setq address
+ (mail-string-delete address
+ pos (match-end 0)))))
+ ;; Retain only part of address in <> delims, if there is such a thing.
+ (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
+ address))
+ (let ((junk-beg (match-end 1))
+ (junk-end (match-beginning 2))
+ (close (match-end 0)))
+ (setq address (mail-string-delete address (1- close) close))
+ (setq address (mail-string-delete address junk-beg junk-end))))
+ address)))
+
+(or (and (boundp 'rmail-default-dont-reply-to-names)
+ (not (null rmail-default-dont-reply-to-names)))
+ (setq rmail-default-dont-reply-to-names "info-"))
+
+; rmail-dont-reply-to-names is defined in loaddefs
+(defun rmail-dont-reply-to (userids)
+ "Returns string of mail addresses USERIDS sans any recipients
+that start with matches for rmail-dont-reply-to-names.
+Usenet paths ending in an element that matches are removed also."
+ (if (null rmail-dont-reply-to-names)
+ (setq rmail-dont-reply-to-names
+ (concat (if rmail-default-dont-reply-to-names
+ (concat rmail-default-dont-reply-to-names "\\|")
+ "")
+ (concat (regexp-quote
+ (or (getenv "USER") (getenv "LOGNAME")
+ (user-login-name)))
+ "\\>"))))
+ (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
+ rmail-dont-reply-to-names
+ "\\)"))
+ (case-fold-search t)
+ pos epos)
+ (while (setq pos (string-match match userids))
+ (if (> pos 0) (setq pos (1+ pos)))
+ (setq epos
+ (if (string-match "[ \t\n,]+" userids (match-end 0))
+ (match-end 0)
+ (length userids)))
+ (setq userids
+ (mail-string-delete
+ userids pos epos)))
+ ;; get rid of any trailing commas
+ (if (setq pos (string-match "[ ,\t\n]*\\'" userids))
+ (setq userids (substring userids 0 pos)))
+ ;; remove leading spaces. they bother me.
+ (if (string-match "\\s *" userids)
+ (substring userids (match-end 0))
+ userids)))
+\f
+(defun mail-fetch-field (field-name &optional last all)
+ "Return the value of the header field FIELD.
+The buffer is expected to be narrowed to just the headers of the message.
+If 2nd arg LAST is non-nil, use the last such field if there are several.
+If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((case-fold-search t)
+ (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
+ (goto-char (point-min))
+ (if all
+ (let ((value ""))
+ (while (re-search-forward name nil t)
+ (let ((opoint (point)))
+ (while (progn (forward-line 1)
+ (looking-at "[ \t]")))
+ (setq value (concat value
+ (if (string= value "") "" ", ")
+ (buffer-substring opoint (1- (point)))))))
+ (and (not (string= value "")) value))
+ (if (re-search-forward name nil t)
+ (progn
+ (if last (while (re-search-forward name nil t)))
+ (let ((opoint (point)))
+ (while (progn (forward-line 1)
+ (looking-at "[ \t]")))
+ (buffer-substring opoint (1- (point))))))))))
+\f
+;; Parse a list of tokens separated by commas.
+;; It runs from point to the end of the visible part of the buffer.
+;; Whitespace before or after tokens is ignored,
+;; but whitespace within tokens is kept.
+(defun mail-parse-comma-list ()
+ (let (accumulated
+ beg)
+ (skip-chars-forward " ")
+ (while (not (eobp))
+ (setq beg (point))
+ (skip-chars-forward "^,")
+ (skip-chars-backward " ")
+ (setq accumulated
+ (cons (buffer-substring beg (point))
+ accumulated))
+ (skip-chars-forward "^,")
+ (skip-chars-forward ", "))
+ accumulated))
+
+(defun mail-comma-list-regexp (labels)
+ (let (pos)
+ (setq pos (or (string-match "[^ \t]" labels) 0))
+ ;; Remove leading and trailing whitespace.
+ (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
+ ;; Change each comma to \|, and flush surrounding whitespace.
+ (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
+ (setq labels
+ (concat (substring labels 0 pos)
+ "\\|"
+ (substring labels (match-end 0))))))
+ labels)
--- /dev/null
+;; Expand mailing address aliases defined in ~/.mailrc.
+;; Copyright (C) 1985, 1987 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.
+
+
+;; Called from sendmail-send-it, or similar functions,
+;; only if some mail aliases are defined.
+(defun expand-mail-aliases (beg end)
+ "Expand all mail aliases in suitable header fields found between BEG and END.
+Suitable header fields are To, Cc and Bcc."
+ (if (eq mail-aliases t)
+ (progn (setq mail-aliases nil) (build-mail-aliases)))
+ (goto-char beg)
+ (setq end (set-marker (make-marker) end))
+ (let ((case-fold-search nil))
+ (while (let ((case-fold-search t))
+ (re-search-forward "^\\(to\\|cc\\|bcc\\):" end t))
+ (skip-chars-forward " \t")
+ (let ((beg1 (point))
+ end1 pos epos seplen
+ ;; DISABLED-ALIASES records aliases temporarily disabled
+ ;; while we scan text that resulted from expanding those aliases.
+ ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
+ ;; is where to reenable the alias (expressed as number of chars
+ ;; counting from END1).
+ (disabled-aliases nil))
+ (re-search-forward "^[^ \t]" end 'move)
+ (beginning-of-line)
+ (skip-chars-backward " \t\n")
+ (setq end1 (point-marker))
+ (goto-char beg1)
+ (while (< (point) end1)
+ (setq pos (point))
+ ;; Reenable any aliases which were disabled for ranges
+ ;; that we have passed out of.
+ (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
+ (setq disabled-aliases (cdr disabled-aliases)))
+ ;; EPOS gets position of end of next name;
+ ;; SEPLEN gets length of whitespace&separator that follows it.
+ (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
+ (setq epos (match-beginning 0)
+ seplen (- (point) epos))
+ (setq epos (marker-position end1) seplen 0))
+ (let (translation
+ (string (buffer-substring pos epos)))
+ (if (and (not (assoc string disabled-aliases))
+ (setq translation
+ (cdr (assoc string mail-aliases))))
+ (progn
+ ;; This name is an alias. Disable it.
+ (setq disabled-aliases (cons (cons string (- end1 epos))
+ disabled-aliases))
+ ;; Replace the alias with its expansion
+ ;; then rescan the expansion for more aliases.
+ (goto-char pos)
+ (insert translation)
+ (delete-region (point) (+ (point) (- epos pos)))
+ (goto-char pos))
+ ;; Name is not an alias. Skip to start of next name.
+ (goto-char epos)
+ (forward-char seplen))))
+ (set-marker end1 nil)))
+ (set-marker end nil)))
+
+;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
+(defun build-mail-aliases (&optional file)
+ "Read mail aliases from ~/.mailrc and set mail-aliases."
+ (setq file (expand-file-name (or file "~/.mailrc")))
+ (let ((buffer nil)
+ (obuf (current-buffer)))
+ (unwind-protect
+ (progn
+ (setq buffer (generate-new-buffer "mailrc"))
+ (buffer-flush-undo buffer)
+ (set-buffer buffer)
+ (cond ((get-file-buffer file)
+ (insert (save-excursion
+ (set-buffer (get-file-buffer file))
+ (buffer-substring (point-min) (point-max)))))
+ ((not (file-exists-p file)))
+ (t (insert-file-contents file)))
+ ;; Don't lose if no final newline.
+ (goto-char (point-max))
+ (or (eq (preceding-char) ?\n) (newline))
+ (goto-char (point-min))
+ ;; handle "\\\n" continuation lines
+ (while (not (eobp))
+ (end-of-line)
+ (if (= (preceding-char) ?\\)
+ (progn (delete-char -1) (delete-char 1) (insert ?\ ))
+ (forward-char 1)))
+ (goto-char (point-min))
+ (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
+ (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
+ (re-search-forward "[^ \t]+")
+ (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
+ (start (progn (skip-chars-forward " \t") (point))))
+ (end-of-line)
+ (define-mail-alias
+ name
+ (buffer-substring start (point)))))
+ mail-aliases)
+ (if buffer (kill-buffer buffer))
+ (set-buffer obuf))))
+
+;; Always autoloadable in case the user wants to define aliases
+;; interactively or in .emacs.
+(defun define-mail-alias (name definition)
+ "Define NAME as a mail-alias that translates to DEFINITION."
+ (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
+ ;; Read the defaults first, if we have not done so.
+ (if (eq mail-aliases t)
+ (progn
+ (setq mail-aliases nil)
+ (if (file-exists-p "~/.mailrc")
+ (build-mail-aliases))))
+ (let (tem)
+ ;; ~/.mailrc contains addresses separated by spaces.
+ ;; mailers should expect addresses separated by commas.
+ (while (setq tem (string-match "[^ \t,][ \t,]+" definition tem))
+ (if (= (match-end 0) (length definition))
+ (setq definition (substring definition 0 (1+ tem)))
+ (setq definition (concat (substring definition
+ 0 (1+ tem))
+ ", "
+ (substring definition (match-end 0))))
+ (setq tem (+ 3 tem))))
+ (setq tem (assoc name mail-aliases))
+ (if tem
+ (rplacd tem definition)
+ (setq mail-aliases (cons (cons name definition) mail-aliases)))))
--- /dev/null
+;; Generate key binding summary for Emacs
+;; Copyright (C) 1985 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.
+
+
+(defun make-command-summary ()
+ "Make a summary of current key bindings in the buffer *Summary*.
+Previous contents of that buffer are killed first."
+ (interactive)
+ (message "Making command summary...")
+ ;; This puts a description of bindings in a buffer called *Help*.
+ (save-window-excursion
+ (describe-bindings))
+ (with-output-to-temp-buffer "*Summary*"
+ (save-excursion
+ (let ((cur-mode mode-name))
+ (set-buffer standard-output)
+ (erase-buffer)
+ (insert-buffer-substring "*Help*")
+ (goto-char (point-min))
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (while (search-forward " " nil t)
+ (replace-match " "))
+ (goto-char (point-min))
+ (while (search-forward "-@ " nil t)
+ (replace-match "-SP"))
+ (goto-char (point-min))
+ (while (search-forward " .. ~ " nil t)
+ (replace-match "SP .. ~"))
+ (goto-char (point-min))
+ (while (search-forward "C-?" nil t)
+ (replace-match "DEL"))
+ (goto-char (point-min))
+ (while (search-forward "C-i" nil t)
+ (replace-match "TAB"))
+ (goto-char (point-min))
+ (if (re-search-forward "^Local Bindings:" nil t)
+ (progn
+ (forward-char -1)
+ (insert " for " cur-mode " Mode")
+ (while (search-forward "??\n" nil t)
+ (delete-region (point)
+ (progn
+ (forward-line -1)
+ (point))))))
+ (goto-char (point-min))
+ (insert "Emacs command summary, " (substring (current-time-string) 0 10)
+ ".\n")
+ ;; Delete "key binding" and underlining of dashes.
+ (delete-region (point) (progn (forward-line 2) (point)))
+ (forward-line 1) ;Skip blank line
+ (while (not (eobp))
+ (let ((beg (point)))
+ (or (re-search-forward "^$" nil t)
+ (goto-char (point-max)))
+ (double-column beg (point))
+ (forward-line 1)))
+ (goto-char (point-min)))))
+ (message "Making command summary...done"))
+
+(defun double-column (start end)
+ (interactive "r")
+ (let (half cnt
+ line lines nlines
+ (from-end (- (point-max) end)))
+ (setq nlines (count-lines start end))
+ (if (<= nlines 1)
+ nil
+ (setq half (/ (1+ nlines) 2))
+ (goto-char start)
+ (save-excursion
+ (forward-line half)
+ (while (< half nlines)
+ (setq half (1+ half))
+ (setq line (buffer-substring (point) (save-excursion (end-of-line) (point))))
+ (setq lines (cons line lines))
+ (delete-region (point) (progn (forward-line 1) (point)))))
+ (setq lines (nreverse lines))
+ (while lines
+ (end-of-line)
+ (indent-to 41)
+ (insert (car lines))
+ (forward-line 1)
+ (setq lines (cdr lines))))
+ (goto-char (- (point-max) from-end))))
--- /dev/null
+;; Read in and display parts of Unix manual.
+;; 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.
+
+(defun manual-entry (topic &optional section)
+ "Display the Unix manual entry for TOPIC.
+TOPIC is either the title of the entry, or has the form TITLE(SECTION)
+where SECTION is the desired section of the manual, as in `tty(4)'."
+ (interactive "sManual entry (topic): ")
+ (if (and (null section)
+ (string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
+ (setq section (substring topic (match-beginning 2)
+ (match-end 2))
+ topic (substring topic (match-beginning 1)
+ (match-end 1))))
+ (with-output-to-temp-buffer "*Manual Entry*"
+ (buffer-flush-undo standard-output)
+ (save-excursion
+ (set-buffer standard-output)
+ (message "Looking for formatted entry for %s%s..."
+ topic (if section (concat "(" section ")") ""))
+ (let ((dirlist manual-formatted-dirlist)
+ (case-fold-search nil)
+ name)
+ (if (and section (or (file-exists-p
+ (setq name (concat manual-formatted-dir-prefix
+ (substring section 0 1)
+ "/"
+ topic "." section)))
+ (file-exists-p
+ (setq name (concat manual-formatted-dir-prefix
+ section
+ "/"
+ topic "." section)))))
+ (insert-man-file name)
+ (while dirlist
+ (let* ((dir (car dirlist))
+ (name1 (concat dir "/" topic "."
+ (or section
+ (substring
+ dir
+ (1+ (or (string-match "\\.[^./]*$" dir)
+ -2))))))
+ completions)
+ (if (file-exists-p name1)
+ (insert-man-file name1)
+ (condition-case ()
+ (progn
+ (setq completions (file-name-all-completions
+ (concat topic "." (or section ""))
+ dir))
+ (while completions
+ (insert-man-file (concat dir "/" (car completions)))
+ (setq completions (cdr completions))))
+ (file-error nil)))
+ (goto-char (point-max)))
+ (setq dirlist (cdr dirlist)))))
+
+ (if (= (buffer-size) 0)
+ (progn
+ (message "No formatted entry, invoking man %s%s..."
+ (if section (concat section " ") "") topic)
+ (if section
+ (call-process manual-program nil t nil section topic)
+ (call-process manual-program nil t nil topic))
+ (if (< (buffer-size) 80)
+ (progn
+ (goto-char (point-min))
+ (end-of-line)
+ (error (buffer-substring 1 (point)))))))
+
+ (message "Cleaning manual entry for %s..." topic)
+ (nuke-nroff-bs)
+ (set-buffer-modified-p nil)
+ (message ""))))
+
+;; Hint: BS stands form more things than "back space"
+(defun nuke-nroff-bs ()
+ (interactive "*")
+ ;; Nuke underlining and overstriking (only by the same letter)
+ (goto-char (point-min))
+ (while (search-forward "\b" nil t)
+ (let* ((preceding (char-after (- (point) 2)))
+ (following (following-char)))
+ (cond ((= preceding following)
+ ;; x\bx
+ (delete-char -2))
+ ((= preceding ?\_)
+ ;; _\b
+ (delete-char -2))
+ ((= following ?\_)
+ ;; \b_
+ (delete-region (1- (point)) (1+ (point)))))))
+
+ ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
+ (goto-char (point-min))
+ (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$" nil t)
+ (replace-match ""))
+
+ ;; Nuke footers: "Printed 12/3/85 27 April 1981 1"
+ ;; Sun appear to be on drugz:
+ ;; "Sun Release 3.0\ eB\ f Last change: 1 February 1985 1"
+ ;; HP are even worse!
+ ;; " Hewlett-Packard -1- (printed 12/31/99)" FMHWA12ID!!
+ ;; System V (well WICATs anyway):
+ ;; "Page 1 (printed 7/24/85)"
+ ;; Who is administering PCP to these corporate bozos?
+ (goto-char (point-min))
+ (while (re-search-forward
+ (cond ((eq system-type 'hpux)
+ "^[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*$")
+ ((eq system-type 'usg-unix-v)
+ "^ *Page [0-9]*.*(printed [0-9/]*)$")
+ (t
+ "^\\(Printed\\|Sun Release\\) [0-9].*[0-9]$"))
+ nil t)
+ (replace-match ""))
+
+ ;; Crunch blank lines
+ (goto-char (point-min))
+ (while (re-search-forward "\n\n\n\n*" nil t)
+ (replace-match "\n\n"))
+
+ ;; Nuke blanks lines at start.
+ (goto-char (point-min))
+ (skip-chars-forward "\n")
+ (delete-region (point-min) (point)))
+
+
+(defun insert-man-file (name)
+ ;; Insert manual file (unpacked as necessary) into buffer
+ (if (or (equal (substring name -2) ".Z")
+ (string-match "/cat[0-9][a-z]?\\.Z/" name))
+ (call-process "zcat" name t nil)
+ (if (equal (substring name -2) ".z")
+ (call-process "pcat" nil t nil name)
+ (insert-file-contents name))))
--- /dev/null
+;; Lisp interface between GNU Emacs and MEDIT package. Emacs under MDL.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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.
+
+
+;; >> This package depends on two MDL packages: MEDIT and FORKS which
+;; >> can be obtained from the public (network) library at mit-ajax.
+
+(require 'mim-mode)
+
+(defconst medit-zap-file (concat "/tmp/" (getenv "USER") ".medit.mud")
+ "File name for data sent to MDL by Medit.")
+(defconst medit-buffer "*MEDIT*"
+ "Name of buffer in which Medit accumulates data to send to MDL.")
+(defconst medit-save-files t
+ "If non-nil, Medit offers to save files on return to MDL.")
+
+(defun medit-save-define ()
+ "Mark the previous or surrounding toplevel object to be sent back to MDL."
+ (interactive)
+ (save-excursion
+ (beginning-of-DEFINE)
+ (let ((start (point)))
+ (forward-mim-object 1)
+ (append-to-buffer medit-buffer start (point))
+ (goto-char start)
+ (message (buffer-substring start (progn (end-of-line) (point)))))))
+
+(defun medit-save-region (start end)
+ "Mark the current region to be sent to back to MDL."
+ (interactive "r")
+ (append-to-buffer medit-buffer start end)
+ (message "Current region saved for MDL."))
+
+(defun medit-save-buffer ()
+ "Mark the current buffer to be sent back to MDL."
+ (interactive)
+ (append-to-buffer medit-buffer (point-min) (point-max))
+ (message "Current buffer saved for MDL."))
+
+(defun medit-zap-define-to-mdl ()
+ "Return to MDL with surrounding or previous toplevel MDL object."
+ (indetarctive)
+ (medit-save-defun)
+ (medit-go-to-mdl))
+
+(defun medit-zap-region-mdl (start end)
+ "Return to MDL with current region."
+ (interactive)
+ (medit-save-region start end)
+ (medit-go-to-mdl))
+
+(defun medit-zap-buffer ()
+ "Return to MDL with current buffer."
+ (interactive)
+ (medit-save-buffer)
+ (medit-go-to-mdl))
+
+(defun medit-goto-mdl ()
+ "Return from Emacs to superior MDL, sending saved code.
+Optionally, offers to save changed files."
+ (interactive)
+ (let ((buffer (get-buffer medit-buffer)))
+ (if buffer
+ (save-excursion
+ (set-buffer buffer)
+ (if (buffer-modified-p buffer)
+ (write-region (point-min) (point-max) medit-zap-file))
+ (set-buffer-modified-p nil)
+ (erase-buffer)))
+ (if medit-save-files (save-some-buffers))
+ ;; Note could handle parallel fork by giving argument "%xmdl". Then
+ ;; mdl would have to invoke with "%emacs".
+ (suspend-emacs)))
+
+(defconst medit-mode-map nil)
+(if (not medit-mode-map)
+ (progn
+ (setq medit-mode-map (copy-alist mim-mode-map))
+ (define-key medit-mode-map "\e\z" 'medit-save-define)
+ (define-key medit-mode-map "\e\^z" 'medit-save-buffer)
+ (define-key medit-mode-map "\^xz" 'medit-goto-mdl)
+ (define-key medit-mode-map "\^xs" 'medit-zap-buffer)))
+
+(defconst medit-mode-hook (and (boundp 'mim-mode-hook) mim-mode-hook) "")
+(setq mim-mode-hook '(lambda () (medit-mode)))
+
+(defun medit-mode (&optional state)
+ "Major mode for editing text and returning it to a superior MDL.
+Like Mim mode, plus these special commands:
+\\{medit-mode-map}"
+ (interactive)
+ (use-local-map medit-mode-map)
+ (run-hooks 'medit-mode-hook)
+ (setq major-mode 'medit-mode)
+ (setq mode-name "Medit"))
+
+(mim-mode)
+
+
--- /dev/null
+;;; mh-e.el (Version: 3.7 for GNU Emacs Version 18 and MH.5 and MH.6)
+
+(defvar mh-e-RCS-id)
+(setq mh-e-RCS-id "$Header: /var/home/larus/lib/emacs/RCS/mh-e.el,v 3.1 90/09/28 15:47:58 larus Exp Locker: larus $")
+(provide 'mh-e)
+
+;;; Copyright (C) 1985-89 Free Software Foundation
+;;; Author: James Larus (larus@ginger.Berkeley.EDU or ucbvax!larus)
+;;; Please send suggestions and corrections to the above address.
+;;;
+;;; This file contains mh-e, a GNU Emacs front end to the MH mail system.
+
+;; 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.
+
+
+;;; Original version for Gosling emacs by Brian Reid, Stanford, 1982.
+;;; Modified by James Larus, BBN, July 1984 and UCB, 1984 & 1985.
+;;; Rewritten for GNU Emacs, James Larus 1985. larus@ginger.berkeley.edu
+;;; Modified by Stephen Gildea 1988. gildea@bbn.com
+
+
+;;; NB. MH must have been compiled with the MHE compiler flag or several
+;;; features necessary mh-e will be missing from MH commands, specifically
+;;; the -build switch to repl and forw.
+
+\f
+
+;;; Constants:
+
+;;; Set for local environment:
+;;;* These are now in paths.el.
+;;;(defvar mh-progs "/usr/new/mh/" "Directory containing MH commands.")
+;;;(defvar mh-lib "/usr/new/lib/mh/" "Directory of MH library.")
+
+(defvar mh-redist-full-contents t
+ "Non-nil if the `dist' command needs whole letter for redistribution.
+This is the case when `send' is compiled with the BERK option.")
+
+
+;;; Hooks:
+
+(defvar mh-folder-mode-hook nil
+ "Invoked in mh-folder-mode on a new folder.")
+
+(defvar mh-letter-mode-hook nil
+ "Invoked in mh-letter-mode on a new letter.")
+
+(defvar mh-compose-letter-function nil
+ "Invoked in mh-compose-and-send-mail on a draft letter.
+It is passed three arguments: TO recipients, SUBJECT, and CC recipients.")
+
+(defvar mh-before-send-letter-hook nil
+ "Invoked at the beginning of the \\[mh-send-letter] command.")
+
+(defvar mh-inc-folder-hook nil
+ "Invoked after incorporating mail into a folder with \\[mh-inc-folder].")
+
+(defvar mh-quit-hook nil
+ "Invoked after quitting mh-e with \\[mh-quit].")
+
+
+(defvar mh-ins-string nil
+ "Temporarily set by mh-insert-prefix prior to running mh-yank-hooks.")
+
+(defvar mh-yank-hooks
+ '(lambda ()
+ (save-excursion
+ (goto-char (point))
+ (or (bolp) (forward-line 1))
+ (while (< (point) (mark))
+ (insert mh-ins-string)
+ (forward-line 1))))
+ "Hook to run citation function. Expects POINT and MARK to be set to
+the region to cite.")
+
+
+;;; Personal preferences:
+
+(defvar mh-clean-message-header nil
+ "*Non-nil means clean headers of messages that are displayed or inserted.
+The variables mh-visible-headers and mh-invisible-headers control what is
+removed.")
+
+(defvar mh-visible-headers nil
+ "*If non-nil, contains a regexp specifying the headers to keep when cleaning.
+Only used if mh-clean-message-header is non-nil. Setting this variable
+overrides mh-invisible-headers.")
+
+(defvar mhl-formfile nil
+ "*Name of format file to be used by mhl to show messages.
+A value of T means use the default format file.
+Nil means don't use mhl to format messages.")
+
+(defvar mh-lpr-command-format "lpr -p -J '%s'"
+ "*Format for Unix command that prints a message.
+The string should be a Unix command line, with the string '%s' where
+the job's name (folder and message number) should appear. The message text
+is piped to this command.")
+
+(defvar mh-print-background nil
+ "*Print messages in the background if non-nil.
+WARNING: do not delete the messages until printing is finished;
+otherwise, your output may be truncated.")
+
+(defvar mh-summary-height 4
+ "*Number of lines in summary window.")
+
+(defvar mh-recenter-summary-p nil
+ "*Recenter summary window when the show window is toggled off if non-nil.")
+
+(defvar mh-ins-buf-prefix ">> "
+ "*String to put before each non-blank line of a yanked or inserted message.
+Used when the message is inserted in an outgoing letter.")
+
+(defvar mh-do-not-confirm nil
+ "*Non-nil means do not prompt for confirmation before some commands.
+Only affects certain innocuous commands.")
+
+(defvar mh-bury-show-buffer t
+ "*Non-nil means that the displayed show buffer for a folder is buried.")
+
+(defvar mh-delete-yanked-msg-window nil
+ "*Controls window display when a message is yanked by \\[mh-yank-cur-msg].
+If non-nil, yanking the current message into a draft letter deletes any
+windows displaying the message.")
+
+(defvar mh-yank-from-start-of-msg t
+ "*Controls which part of a message is yanked by \\[mh-yank-cur-msg].
+If non-nil, include the entire message. If the symbol `body, then yank the
+message minus the header. If nil, yank only the portion of the message
+following the point. If the show buffer has a region, this variable is
+ignored.")
+
+(defvar mh-reply-default-reply-to nil
+ "*Sets the person or persons to whom a reply will be sent.
+If nil, prompt for recipient. If non-nil, then \\[mh-reply] will use this
+value and it should be one of \"from\", \"to\", or \"cc\".")
+
+(defvar mh-recursive-folders nil
+ "*If non-nil, then commands which operate on folders do so recursively.")
+
+
+;;; Parameterize mh-e to work with different scan formats. The defaults work
+;;; the standard MH scan listings.
+
+(defvar mh-cmd-note 4
+ "Offset to insert notation.")
+
+(defvar mh-note-repl "-"
+ "String whose first character is used to notate replied to messages.")
+
+(defvar mh-note-forw "F"
+ "String whose first character is used to notate forwarded messages.")
+
+(defvar mh-note-dist "R"
+ "String whose first character is used to notate redistributed messages.")
+
+(defvar mh-good-msg-regexp "^....[^D^]"
+ "Regexp specifiying the scan lines that are 'good' messages.")
+
+(defvar mh-deleted-msg-regexp "^....D"
+ "Regexp matching scan lines of deleted messages.")
+
+(defvar mh-refiled-msg-regexp "^....\\^"
+ "Regexp matching scan lines of refiled messages.")
+
+(defvar mh-valid-scan-line "^ *[0-9]"
+ "Regexp matching scan lines for messages (not error messages).")
+
+(defvar mh-msg-number-regexp "^ *\\([0-9]+\\)"
+ "Regexp to find the number of a message in a scan line.
+The message's number must be surrounded with \\( \\)")
+
+(defvar mh-msg-search-regexp "^[^0-9]*%d[^0-9]"
+ "Format string containing a regexp matching the scan listing for a message.
+The desired message's number will be an argument to format.")
+
+(defvar mh-flagged-scan-msg-regexp "^....\\D\\|^....\\^\\|^....\\+\\|^.....%"
+ "Regexp matching flagged scan lines.
+Matches lines marked as deleted, refiled, in a sequence, or the cur message.")
+
+(defvar mh-cur-scan-msg-regexp "^....\\+"
+ "Regexp matching scan line for the cur message.")
+
+(defvar mh-show-buffer-mode-line-buffer-id "{%%b} %s/%d"
+ "Format string to produce mode-line-buffer-id for show buffers.
+First argument is folder name. Second is message number.")
+
+(defvar mh-partial-folder-mode-line-annotation "select"
+ "Annotation when displaying part of a folder.
+The string is displayed after the folder's name. NIL for no annotation.")
+
+
+;;; Real constants:
+
+(defvar mh-invisible-headers
+ "^Received: \\|^Message-Id: \\|^Remailed-\\|^Via: \\|^Mail-from: \\|^Return-Path: \\|^In-Reply-To: \\|^Resent-"
+ "Regexp matching lines in a message header that are not to be shown.
+If mh-visible-headers is non-nil, it is used instead to specify what to keep.")
+
+(defvar mh-rejected-letter-start "^ ----- Unsent message follows -----$"
+ "Regexp specifying the beginning of the wrapper around a returned letter.
+This wrapper is generated by the mail system when rejecting a letter.")
+
+(defvar mh-to-field-choices '((?t . "To:") (?s . "Subject:") (?c . "Cc:")
+ (?b . "Bcc:") (?f . "Fcc:"))
+ "A-list of (character . field name) strings for mh-to-field.")
+
+
+;;; Global variables:
+
+(defvar mh-user-path ""
+ "User's mail folder.")
+
+(defvar mh-last-destination nil
+ "Destination of last refile or write command.")
+
+(defvar mh-folder-mode-map (make-keymap)
+ "Keymap for MH folders.")
+
+(defvar mh-letter-mode-map (copy-keymap text-mode-map)
+ "Keymap for composing mail.")
+
+(defvar mh-pick-mode-map (make-sparse-keymap)
+ "Keymap for searching folder.")
+
+(defvar mh-letter-mode-syntax-table nil
+ "Syntax table used while in mh-e letter mode.")
+
+(if mh-letter-mode-syntax-table
+ ()
+ (setq mh-letter-mode-syntax-table
+ (make-syntax-table text-mode-syntax-table))
+ (set-syntax-table mh-letter-mode-syntax-table)
+ (modify-syntax-entry ?% "." mh-letter-mode-syntax-table))
+
+(defvar mh-folder-list nil
+ "List of folder names for completion.")
+
+(defvar mh-draft-folder nil
+ "Name of folder containing draft messages.
+NIL means do not use draft folder.")
+
+(defvar mh-unseen-seq nil
+ "Name of the unseen sequence.")
+
+(defvar mh-previous-window-config nil
+ "Window configuration before mh-e command.")
+
+(defvar mh-previous-seq nil
+ "Name of the sequence to which a message was last added.")
+
+
+;;; Macros and generic functions:
+
+(defmacro mh-push (v l)
+ (list 'setq l (list 'cons v l)))
+
+
+(defmacro mh-when (pred &rest body)
+ (list 'cond (cons pred body)))
+
+
+(defmacro with-mh-folder-updating (save-modification-flag-p &rest body)
+ ;; Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG-P) &body BODY).
+ ;; Execute BODY, which can modify the folder buffer without having to
+ ;; worry about file locking or the read-only flag, and return its result.
+ ;; If SAVE-MODIFICATION-FLAG-P is non-nil, the buffer's modification
+ ;; flag is unchanged, otherwise it is cleared.
+ (setq save-modification-flag-p (car save-modification-flag-p)) ; CL style
+ (` (let ((folder-updating-mod-flag (buffer-modified-p)))
+ (prog1
+ (let ((buffer-read-only nil)
+ (buffer-file-name nil)) ; don't let the buffer get locked
+ (,@ body))
+ (, (if save-modification-flag-p
+ '(mh-set-folder-modified-p folder-updating-mod-flag)
+ '(mh-set-folder-modified-p nil)))))))
+
+
+(defun mh-mapc (func list)
+ (while list
+ (funcall func (car list))
+ (setq list (cdr list))))
+
+\f
+
+;;; Entry points:
+
+(defun mh-rmail (&optional arg)
+ "Inc(orporate) new mail (no arg) or scan a MH mail box (arg given).
+This front end uses the MH mail system, which uses different conventions
+from the usual mail system."
+ (interactive "P")
+ (mh-find-path)
+ (if arg
+ (call-interactively 'mh-visit-folder)
+ (mh-inc-folder)))
+
+
+(defun mh-smail ()
+ "Compose and send mail with the MH mail system."
+ (interactive)
+ (mh-find-path)
+ (call-interactively 'mh-send))
+
+
+(defun mh-smail-other-window ()
+ "Compose and send mail in other window with the MH mail system."
+ (interactive)
+ (mh-find-path)
+ (call-interactively 'mh-send-other-window))
+
+\f
+
+;;; User executable mh-e commands:
+
+(defun mh-burst-digest ()
+ "Burst apart the current message, which should be a digest.
+The message is replaced by its table of contents and the letters from the
+digest are inserted into the folder after that message."
+ (interactive)
+ (let ((digest (mh-get-msg-num t)))
+ (mh-process-or-undo-commands mh-current-folder)
+ (mh-set-folder-modified-p t) ; lock folder while bursting
+ (message "Bursting digest...")
+ (mh-exec-cmd "burst" mh-current-folder digest "-inplace")
+ (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
+ (message "Bursting digest...done")))
+
+
+(defun mh-copy-msg (prefix-provided msg-or-seq dest)
+ "Copy specified MESSAGE(s) to another FOLDER without deleting them.
+Default is the displayed message. If (optional) prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Copy" t)
+ (mh-get-msg-num t))
+ (mh-prompt-for-folder "Copy to" "" t)))
+ (mh-exec-cmd "refile" msg-or-seq "-link" "-src" mh-current-folder dest)
+ (if prefix-provided
+ (mh-notate-seq msg-or-seq ?C mh-cmd-note)
+ (mh-notate msg-or-seq ?C mh-cmd-note)))
+
+
+(defun mh-delete-msg (msg-or-seq)
+ "Mark the specified MESSAGE(s) for subsequent deletion and move to the next.
+Default is the displayed message. If (optional) prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list (if current-prefix-arg
+ (mh-read-seq-default "Delete" t)
+ (mh-get-msg-num t))))
+ (if (numberp msg-or-seq)
+ (mh-delete-a-msg msg-or-seq)
+ (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))
+ (mh-next-msg))
+
+
+(defun mh-delete-msg-no-motion (msg-or-seq)
+ "Mark the specified MESSAGE(s) for subsequent deletion.
+Default is the displayed message. If (optional) prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list (if current-prefix-arg
+ (mh-read-seq-default "Delete" t)
+ (mh-get-msg-num t))))
+ (if (numberp msg-or-seq)
+ (mh-delete-a-msg msg-or-seq)
+ (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq)))
+
+
+(defun mh-delete-msg-from-seq (prefix-provided msg-or-seq &optional from-seq)
+ "Delete MESSAGE (default: displayed message) from SEQUENCE.
+If (optional) prefix argument provided, then delete all messages from a
+sequence."
+ (interactive (let ((argp current-prefix-arg))
+ (list argp
+ (if argp
+ (mh-read-seq-default "Delete" t)
+ (mh-get-msg-num t))
+ (if (not argp)
+ (mh-read-seq-default "Delete from" t)))))
+ (if prefix-provided
+ (mh-remove-seq msg-or-seq)
+ (mh-remove-msg-from-seq msg-or-seq from-seq)))
+
+
+(defun mh-edit-again (msg)
+ "Clean-up a draft or a message previously sent and make it resendable."
+ (interactive (list (mh-get-msg-num t)))
+ (let* ((from-folder mh-current-folder)
+ (config (current-window-configuration))
+ (draft
+ (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
+ (find-file (mh-msg-filename msg))
+ (rename-buffer (format "draft-%d" msg))
+ (buffer-name))
+ (t
+ (mh-read-draft "clean-up" (mh-msg-filename msg) nil)))))
+ (mh-clean-msg-header (point-min)
+ "^Date:\\|^Received:\\|^Message-Id:\\|^From:"
+ nil)
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
+ config)))
+
+
+(defun mh-execute-commands ()
+ "Process outstanding delete and refile requests."
+ (interactive)
+ (if mh-narrowed-to-seq (mh-widen))
+ (mh-process-commands mh-current-folder)
+ (mh-set-scan-mode)
+ (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency
+ (mh-make-folder-mode-line)
+ t) ; return t for write-file-hooks
+
+
+(defun mh-extract-rejected-mail (msg)
+ "Extract a letter returned by the mail system and make it resendable.
+Default is the displayed message."
+ (interactive (list (mh-get-msg-num t)))
+ (let ((from-folder mh-current-folder)
+ (config (current-window-configuration))
+ (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil)))
+ (goto-char (point-min))
+ (cond ((re-search-forward mh-rejected-letter-start nil t)
+ (forward-char 1)
+ (delete-region (point-min) (point))
+ (mh-clean-msg-header (point-min)
+ "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:"
+ nil))
+ (t
+ (message "Does not appear to be a rejected letter.")))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (mh-compose-and-send-mail draft "" from-folder msg (mh-get-field "To")
+ (mh-get-field "From") (mh-get-field "cc")
+ nil nil config)))
+
+
+(defun mh-first-msg ()
+ "Move to the first message."
+ (interactive)
+ (goto-char (point-min)))
+
+
+(defun mh-forward (prefix-provided msg-or-seq to cc)
+ "Forward MESSAGE(s) (default: displayed message).
+If (optional) prefix argument provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Forward" t)
+ (mh-get-msg-num t))
+ (read-string "To: ")
+ (read-string "Cc: ")))
+ (let* ((folder mh-current-folder)
+ (config (current-window-configuration))
+ ;; forw always leaves file in "draft" since it doesn't have -draft
+ (draft-name (expand-file-name "draft" mh-user-path))
+ (draft (cond ((or (not (file-exists-p draft-name))
+ (y-or-n-p "The file 'draft' exists. Discard it? "))
+ (mh-exec-cmd "forw"
+ "-build" mh-current-folder msg-or-seq)
+ (prog1
+ (mh-read-draft "" draft-name t)
+ (mh-insert-fields "To:" to "Cc:" cc)
+ (set-buffer-modified-p nil)))
+ (t
+ (mh-read-draft "" draft-name nil)))))
+ (goto-char (point-min))
+ (re-search-forward "^------- Forwarded Message")
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (let* ((subject (save-excursion (mh-get-field "From:")))
+ (trim (string-match "<" subject))
+ (forw-subject (save-excursion (mh-get-field "Subject:"))))
+ (if trim
+ (setq subject (substring subject 0 (1- trim))))
+ (widen)
+ (save-excursion
+ (mh-insert-fields "Subject:" (format "[%s: %s]" subject forw-subject)))
+ (delete-other-windows)
+ (if prefix-provided
+ (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)
+ (mh-add-msgs-to-seq msg-or-seq 'forwarded t))
+ (mh-compose-and-send-mail draft "" folder msg-or-seq
+ to subject cc
+ mh-note-forw "Forwarded:"
+ config))))
+
+
+(defun mh-goto-msg (number &optional no-error-if-no-message dont-show)
+ "Position the cursor at message NUMBER.
+Non-nil second argument means do not signal an error if message does not exist.
+Non-nil third argument means not to show the message.
+Return non-nil if cursor is at message."
+ (interactive "NMessage number? ")
+ (let ((cur-msg (mh-get-msg-num nil))
+ (starting-place (point))
+ (msg-pattern (mh-msg-search-pat number)))
+ (cond ((cond ((and cur-msg (= cur-msg number)) t)
+ ((and cur-msg
+ (< cur-msg number)
+ (re-search-forward msg-pattern nil t)) t)
+ ((and cur-msg
+ (> cur-msg number)
+ (re-search-backward msg-pattern nil t)) t)
+ (t ; Do thorough search of buffer
+ (goto-char (point-max))
+ (re-search-backward msg-pattern nil t)))
+ (beginning-of-line)
+ (if (not dont-show) (mh-maybe-show number))
+ t)
+ (t
+ (goto-char starting-place)
+ (if (not no-error-if-no-message)
+ (error "No message %d" number))
+ nil))))
+
+
+(defun mh-inc-folder (&optional maildrop-name)
+ "Inc(orporate) new mail into +inbox.
+Optional prefix argument specifies an alternate maildrop from the default.
+If this is given, mail is incorporated into the current folder, rather
+than +inbox. Run mh-inc-folder-hook after incorporating new mail."
+ (interactive (list (if current-prefix-arg
+ (expand-file-name
+ (read-file-name "inc mail from file: "
+ mh-user-path)))))
+ (let ((config (current-window-configuration)))
+ (if (not maildrop-name)
+ (cond ((not (get-buffer "+inbox"))
+ (mh-make-folder "+inbox")
+ (setq mh-previous-window-config config))
+ ((not (eq (current-buffer) (get-buffer "+inbox")))
+ (switch-to-buffer "+inbox")
+ (setq mh-previous-window-config config)))))
+ (mh-get-new-mail maildrop-name)
+ (run-hooks 'mh-inc-folder-hook))
+
+
+(defun mh-kill-folder ()
+ "Remove the current folder."
+ (interactive)
+ (if (or mh-do-not-confirm
+ (yes-or-no-p (format "Remove folder %s? " mh-current-folder)))
+ (let ((folder mh-current-folder))
+ (mh-set-folder-modified-p t) ; lock folder to kill it
+ (mh-exec-cmd-daemon "rmf" folder)
+ (mh-remove-folder-from-folder-list folder)
+ (message "Folder %s removed" folder)
+ (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain
+ (kill-buffer mh-show-buffer)
+ (kill-buffer folder))
+ (message "Folder not removed")))
+
+
+(defun mh-last-msg ()
+ "Move to the last message."
+ (interactive)
+ (goto-char (point-max))
+ (while (and (not (bobp)) (looking-at "^$"))
+ (forward-line -1)))
+
+
+(defun mh-list-folders ()
+ "List mail folders."
+ (interactive)
+ (with-output-to-temp-buffer " *mh-temp*"
+ (save-excursion
+ (switch-to-buffer " *mh-temp*")
+ (erase-buffer)
+ (message "Listing folders...")
+ (mh-exec-cmd-output "folders" t)
+ (goto-char (point-min))
+ (message "Listing folders...done"))))
+
+
+(defun mh-msg-is-in-seq (msg)
+ "Display the sequences that contain MESSAGE (default: displayed message)."
+ (interactive (list (mh-get-msg-num t)))
+ (message "Message %d is in sequences: %s"
+ msg
+ (mapconcat 'concat
+ (mh-list-to-string (mh-seq-containing-msg msg))
+ " ")))
+
+
+(defun mh-narrow-to-seq (seq)
+ "Restrict display of this folder to just messages in a sequence.
+Reads which sequence. Use \\[mh-widen] to undo this command."
+ (interactive (list (mh-read-seq "Narrow to" t)))
+ (let ((eob (point-max)))
+ (with-mh-folder-updating (t)
+ (cond ((mh-seq-to-msgs seq)
+ (mh-copy-seq-to-point seq eob)
+ (narrow-to-region eob (point-max))
+ (mh-make-folder-mode-line (symbol-name seq))
+ (mh-recenter nil)
+ (setq mh-narrowed-to-seq seq))
+ (t
+ (error "No messages in sequence `%s'" (symbol-name seq)))))))
+
+
+(defun mh-next-undeleted-msg (&optional arg)
+ "Move to next undeleted message in window."
+ (interactive "P")
+ (forward-line (prefix-numeric-value arg))
+ (setq mh-next-direction 'forward)
+ (cond ((re-search-forward mh-good-msg-regexp nil 0 arg)
+ (beginning-of-line)
+ (mh-maybe-show))
+ (t
+ (forward-line -1)
+ (if (get-buffer mh-show-buffer)
+ (delete-windows-on mh-show-buffer)))))
+
+
+(defun mh-pack-folder (range)
+ "Renumber the messages of a folder to be 1..n.
+First, offer to execute any outstanding commands for the current folder.
+If (optional) prefix argument provided, prompt for the range of messages
+to display after packing. Otherwise, show the entire folder."
+ (interactive (list (if current-prefix-arg
+ (mh-read-msg-range
+ "Range to scan after packing [all]? ")
+ "all")))
+ (mh-pack-folder-1 range)
+ (mh-goto-cur-msg)
+ (message "Packing folder...done"))
+
+
+(defun mh-pipe-msg (prefix-provided command)
+ "Pipe the current message through the given shell COMMAND.
+If (optional) prefix argument is provided, send the entire message.
+Otherwise just send the message's body."
+ (interactive
+ (list current-prefix-arg (read-string "Shell command on message: ")))
+ (save-excursion
+ (set-buffer mh-show-buffer)
+ (goto-char (point-min))
+ (if (not prefix-provided) (search-forward "\n\n"))
+ (shell-command-on-region (point) (point-max) command nil)))
+
+
+(defun mh-refile-msg (prefix-provided msg-or-seq dest)
+ "Refile MESSAGE(s) (default: displayed message) in FOLDER.
+If (optional) prefix argument provided, then prompt for message sequence."
+ (interactive
+ (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Refile" t)
+ (mh-get-msg-num t))
+ (intern
+ (mh-prompt-for-folder "Destination"
+ (if (eq 'refile (car mh-last-destination))
+ (symbol-name (cdr mh-last-destination))
+ "")
+ t))))
+ (setq mh-last-destination (cons 'refile dest))
+ (if prefix-provided
+ (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq dest)
+ (mh-refile-a-msg msg-or-seq dest))
+ (mh-next-msg))
+
+
+(defun mh-refile-or-write-again (msg)
+ "Re-execute the last refile or write command on the given MESSAGE.
+Default is the displayed message. Use the same folder or file as the
+previous refile or write command."
+ (interactive (list (mh-get-msg-num t)))
+ (if (null mh-last-destination)
+ (error "No previous refile or write"))
+ (cond ((eq (car mh-last-destination) 'refile)
+ (mh-refile-a-msg msg (cdr mh-last-destination))
+ (message "Destination folder: %s" (cdr mh-last-destination)))
+ (t
+ (mh-write-msg-to-file msg (cdr mh-last-destination))
+ (message "Destination: %s" (cdr mh-last-destination))))
+ (mh-next-msg))
+
+
+(defun mh-reply (prefix-provided msg)
+ "Reply to a MESSAGE (default: displayed message).
+If (optional) prefix argument provided, then include the message in the reply
+using filter mhl.reply in your MH directory."
+ (interactive (list current-prefix-arg (mh-get-msg-num t)))
+ (let ((minibuffer-help-form
+ "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
+ (let ((reply-to (or mh-reply-default-reply-to
+ (completing-read "Reply to whom: "
+ '(("from") ("to") ("cc") ("all"))
+ nil
+ t)))
+ (folder mh-current-folder)
+ (show-buffer mh-show-buffer)
+ (config (current-window-configuration)))
+ (message "Composing a reply...")
+ (cond ((or (equal reply-to "from") (equal reply-to ""))
+ (apply 'mh-exec-cmd
+ "repl" "-build"
+ "-nodraftfolder" mh-current-folder
+ msg
+ "-nocc" "all"
+ (if prefix-provided
+ (list "-filter" "mhl.reply"))))
+ ((equal reply-to "to")
+ (apply 'mh-exec-cmd
+ "repl" "-build"
+ "-nodraftfolder" mh-current-folder
+ msg
+ "-cc" "to"
+ (if prefix-provided
+ (list "-filter" "mhl.reply"))))
+ ((or (equal reply-to "cc") (equal reply-to "all"))
+ (apply 'mh-exec-cmd
+ "repl" "-build"
+ "-nodraftfolder" mh-current-folder
+ msg
+ "-cc" "all" "-nocc" "me"
+ (if prefix-provided
+ (list "-filter" "mhl.reply")))))
+
+ (let ((draft (mh-read-draft "reply"
+ (expand-file-name "reply" mh-user-path)
+ t)))
+ (delete-other-windows)
+ (set-buffer-modified-p nil)
+
+ (let ((to (mh-get-field "To:"))
+ (subject (mh-get-field "Subject:"))
+ (cc (mh-get-field "Cc:")))
+ (goto-char (point-min))
+ (mh-goto-header-end 1)
+ (if (not prefix-provided)
+ (mh-display-msg msg folder))
+ (mh-add-msgs-to-seq msg 'answered t)
+ (message "Composing a reply...done")
+ (mh-compose-and-send-mail draft "" folder msg to subject cc
+ mh-note-repl "Replied:" config))))))
+
+
+(defun mh-quit ()
+ "Restore the previous window configuration, if one exists.
+Finish by running mh-quit-hook."
+ (interactive)
+ (if mh-previous-window-config
+ (set-window-configuration mh-previous-window-config))
+ (run-hooks 'mh-quit-hook))
+
+
+(defun mh-page-digest ()
+ "Advance displayed message to next digested message."
+ (interactive)
+ (save-excursion
+ (mh-show-message-in-other-window)
+ ;; Go to top of screen (in case user moved point).
+ (move-to-window-line 0)
+ (let ((case-fold-search nil))
+ ;; Search for blank line and then for From:
+ (mh-when (not (and (search-forward "\n\n" nil t)
+ (search-forward "From:" nil t)))
+ (other-window -1)
+ (error "No more messages")))
+ ;; Go back to previous blank line, then forward to the first non-blank.
+ (search-backward "\n\n" nil t)
+ (forward-line 2)
+ (mh-recenter 0)
+ (other-window -1)))
+
+
+(defun mh-page-digest-backwards ()
+ "Back up displayed message to previous digested message."
+ (interactive)
+ (save-excursion
+ (mh-show-message-in-other-window)
+ ;; Go to top of screen (in case user moved point).
+ (move-to-window-line 0)
+ (let ((case-fold-search nil))
+ (beginning-of-line)
+ (mh-when (not (and (search-backward "\n\n" nil t)
+ (search-backward "From:" nil t)))
+ (other-window -1)
+ (error "No more messages")))
+ ;; Go back to previous blank line, then forward to the first non-blank.
+ (search-backward "\n\n" nil t)
+ (forward-line 2)
+ (mh-recenter 0)
+ (other-window -1)))
+
+
+(defun mh-page-msg (&optional arg)
+ "Page the displayed message forwards.
+Scrolls ARG lines or a full screen if no argument is supplied."
+ (interactive "P")
+ (scroll-other-window arg))
+
+
+(defun mh-previous-page (&optional arg)
+ "Page the displayed message backwards.
+Scrolls ARG lines or a full screen if no argument is supplied."
+ (interactive "P")
+ (save-excursion
+ (mh-show-message-in-other-window)
+ (unwind-protect
+ (scroll-down arg)
+ (other-window -1))))
+
+
+(defun mh-previous-undeleted-msg (&optional arg)
+ "Move to previous undeleted message in window."
+ (interactive "p")
+ (setq mh-next-direction 'backward)
+ (beginning-of-line)
+ (cond ((re-search-backward mh-good-msg-regexp nil 0 arg)
+ (mh-maybe-show))
+ (t
+ (if (get-buffer mh-show-buffer)
+ (delete-windows-on mh-show-buffer)))))
+
+
+(defun mh-print-msg (prefix-provided msg-or-seq)
+ "Print MESSAGE(s) (default: displayed message) on a line printer.
+If (optional) prefix argument provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (reverse (mh-seq-to-msgs
+ (mh-read-seq-default "Print" t)))
+ (mh-get-msg-num t))))
+ (if prefix-provided
+ (message "Printing sequence...")
+ (message "Printing message..."))
+ (let ((print-command
+ (if prefix-provided
+ (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s"
+ (mapconcat (function (lambda (msg) msg)) msg-or-seq " ")
+ (expand-file-name "mhl" mh-lib)
+ (if (stringp mhl-formfile)
+ (format "-form %s" mhl-formfile)
+ "")
+ (mh-msg-filenames msg-or-seq)
+ (format mh-lpr-command-format
+ (if prefix-provided
+ (format "Sequence from %s" mh-current-folder)
+ (format "%s/%d" mh-current-folder
+ msg-or-seq))))
+ (format "%s -nobell -clear %s %s | %s"
+ (expand-file-name "mhl" mh-lib)
+ (mh-msg-filename msg-or-seq)
+ (if (stringp mhl-formfile)
+ (format "-form %s" mhl-formfile)
+ "")
+ (format mh-lpr-command-format
+ (if prefix-provided
+ (format "Sequence from %s" mh-current-folder)
+ (format "%s/%d" mh-current-folder
+ msg-or-seq)))))))
+ (if mh-print-background
+ (mh-exec-cmd-daemon shell-file-name "-c" print-command)
+ (call-process shell-file-name nil nil nil "-c" print-command))
+ (if prefix-provided
+ (mh-notate-seq msg-or-seq ?P mh-cmd-note)
+ (mh-notate msg-or-seq ?P mh-cmd-note))
+ (mh-add-msgs-to-seq msg-or-seq 'printed t)
+ (if prefix-provided
+ (message "Printing sequence...done")
+ (message "Printing message...done"))))
+
+
+(defun mh-put-msg-in-seq (prefix-provided from to)
+ "Add MESSAGE(s) (default: displayed message) to SEQUENCE.
+If (optional) prefix argument provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-seq-to-msgs
+ (mh-read-seq-default "Add messages from" t))
+ (mh-get-msg-num t))
+ (mh-read-seq-default "Add to" nil)))
+ (setq mh-previous-seq to)
+ (mh-add-msgs-to-seq from to))
+
+
+(defun mh-rescan-folder (range)
+ "Rescan a folder after optionally processing the outstanding commands.
+If (optional) prefix argument is provided, prompt for the range of
+messages to display. Otherwise show the entire folder."
+ (interactive (list (if current-prefix-arg
+ (mh-read-msg-range "Range to scan [all]? ")
+ nil)))
+ (setq mh-next-direction 'forward)
+ (mh-scan-folder mh-current-folder (or range "all")))
+
+
+(defun mh-redistribute (to cc msg)
+ "Redistribute a letter.
+Depending on how your copy of MH was compiled, you may need to change the
+setting of the variable mh-redist-full-contents. See its documentation."
+ (interactive (list (read-string "Redist-To: ")
+ (read-string "Redist-Cc: ")
+ (mh-get-msg-num t)))
+ (save-window-excursion
+ (let ((folder mh-current-folder)
+ (draft (mh-read-draft "redistribution"
+ (if mh-redist-full-contents
+ (mh-msg-filename msg)
+ nil)
+ nil)))
+ (mh-goto-header-end 0)
+ (insert "Resent-To: " to "\n")
+ (if (not (equal cc "")) (insert "Resent-cc: " cc "\n"))
+ (mh-clean-msg-header (point-min)
+ "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
+ nil)
+ (save-buffer)
+ (message "Redistributing...")
+ (if mh-redist-full-contents
+ (call-process "/bin/sh" nil 0 nil "-c"
+ (format "mhdist=1 mhaltmsg=%s %s -push %s"
+ (buffer-file-name)
+ (expand-file-name "send" mh-progs)
+ (buffer-file-name)))
+ (call-process "/bin/sh" nil 0 nil "-c"
+ (format "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s"
+ (mh-msg-filename msg folder)
+ (expand-file-name "send" mh-progs)
+ (buffer-file-name))))
+ (mh-annotate-msg msg folder mh-note-dist
+ "-component" "Resent:"
+ "-text" (format "\"%s %s\"" to cc))
+ (kill-buffer draft)
+ (message "Redistributing...done"))))
+
+
+(defun mh-write-msg-to-file (msg file)
+ "Append MESSAGE to the end of a FILE."
+ (interactive
+ (list (mh-get-msg-num t)
+ (let ((default-dir (if (eq 'write (car mh-last-destination))
+ (file-name-directory (cdr mh-last-destination))
+ default-directory)))
+ (read-file-name "Save message in file: " default-dir
+ (expand-file-name "mail.out" default-dir)))))
+ (let ((file-name (mh-msg-filename msg))
+ (output-file (mh-expand-file-name file)))
+ (setq mh-last-destination (cons 'write file))
+ (save-excursion
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer)
+ (insert-file-contents file-name)
+ (append-to-file (point-min) (point-max) output-file))))
+
+
+(defun mh-search-folder (folder)
+ "Search FOLDER for messages matching a pattern."
+ (interactive (list (mh-prompt-for-folder "Search"
+ mh-current-folder
+ t)))
+ (switch-to-buffer-other-window "pick-pattern")
+ (if (or (zerop (buffer-size))
+ (not (y-or-n-p "Reuse pattern? ")))
+ (mh-make-pick-template)
+ (message ""))
+ (setq mh-searching-folder folder))
+
+
+(defun mh-send (to cc subject)
+ "Compose and send a letter."
+ (interactive "sTo: \nsCc: \nsSubject: ")
+ (let ((config (current-window-configuration)))
+ (delete-other-windows)
+ (mh-send-sub to cc subject config)))
+
+
+(defun mh-send-other-window (to cc subject)
+ "Compose and send a letter in another window.."
+ (interactive "sTo: \nsCc: \nsSubject: ")
+ (let ((pop-up-windows t))
+ (mh-send-sub to cc subject (current-window-configuration))))
+
+
+(defun mh-send-sub (to cc subject config)
+ "Do the real work of composing and sending a letter.
+Expects the TO, CC, and SUBJECT fields as arguments.
+CONFIG is the window configuration before sending mail."
+ (let ((folder mh-current-folder)
+ (msg-num (mh-get-msg-num nil)))
+ (message "Composing a message...")
+ (let ((draft (mh-read-draft
+ "message"
+ (if (file-exists-p
+ (expand-file-name "components" mh-user-path))
+ (expand-file-name "components" mh-user-path)
+ (if (file-exists-p
+ (expand-file-name "components" mh-lib))
+ (expand-file-name "components" mh-lib)
+ (error "Can't find components file")))
+ nil)))
+ (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
+ (set-buffer-modified-p nil)
+ (goto-char (point-max))
+ (message "Composing a message...done")
+ (mh-compose-and-send-mail draft "" folder msg-num
+ to subject cc
+ nil nil config))))
+
+
+(defun mh-show (&optional msg)
+ "Show MESSAGE (default: displayed message).
+Forces a two-window display with the folder window on top (size
+mh-summary-height) and the show buffer below it."
+ (interactive)
+ (if (not msg)
+ (setq msg (mh-get-msg-num t)))
+ (setq mh-showing t)
+ (mh-set-mode-name "mh-e show")
+ (if (not (eql (next-window (minibuffer-window)) (selected-window)))
+ (delete-other-windows)) ; force ourself to the top window
+ (let ((folder mh-current-folder))
+ (mh-show-message-in-other-window)
+ (mh-display-msg msg folder))
+ (other-window -1)
+ (shrink-window (- (window-height) mh-summary-height))
+ (mh-recenter nil)
+ (if (not (memq msg mh-seen-list)) (mh-push msg mh-seen-list)))
+
+
+(defun mh-sort-folder ()
+ "Sort the messages in the current folder by date."
+ (interactive "")
+ (mh-process-or-undo-commands mh-current-folder)
+ (setq mh-next-direction 'forward)
+ (mh-set-folder-modified-p t) ; lock folder while sorting
+ (message "Sorting folder...")
+ (mh-exec-cmd "sortm" mh-current-folder)
+ (message "Sorting folder...done")
+ (mh-scan-folder mh-current-folder "all"))
+
+
+(defun mh-toggle-showing ()
+ "Toggle the scanning mode/showing mode of displaying messages."
+ (interactive)
+ (if mh-showing
+ (mh-set-scan-mode)
+ (mh-show)))
+
+
+(defun mh-undo (prefix-provided msg-or-seq)
+ "Undo the deletion or refile of the specified MESSAGE(s).
+Default is the displayed message. If (optional) prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Undo" t)
+ (mh-get-msg-num t))))
+
+ (cond (prefix-provided
+ (mh-mapc (function mh-undo-msg) (mh-seq-to-msgs msg-or-seq)))
+ ((or (looking-at mh-deleted-msg-regexp)
+ (looking-at mh-refiled-msg-regexp))
+ (mh-undo-msg (mh-get-msg-num t)))
+ (t
+ (error "Nothing to undo")))
+ ;; update the mh-refile-list so mh-outstanding-commands-p will work
+ (mh-mapc (function
+ (lambda (elt)
+ (if (not (mh-seq-to-msgs elt))
+ (setq mh-refile-list (delq elt mh-refile-list)))))
+ mh-refile-list)
+
+ (if (not (mh-outstanding-commands-p))
+ (mh-set-folder-modified-p nil)))
+
+
+(defun mh-undo-msg (msg)
+ ;; Undo the deletion or refile of one MESSAGE.
+ (cond ((memq msg mh-delete-list)
+ (setq mh-delete-list (delq msg mh-delete-list))
+ (mh-remove-msg-from-seq msg 'deleted t)
+ (mh-notate msg ? mh-cmd-note))
+ (t
+ (mh-mapc (function (lambda (dest)
+ (mh-remove-msg-from-seq msg dest t)))
+ mh-refile-list)
+ (mh-notate msg ? mh-cmd-note))))
+
+
+(defun mh-undo-folder (&rest ignore)
+ "Undo all commands in current folder."
+ (interactive "")
+ (cond ((or mh-do-not-confirm
+ (yes-or-no-p "Undo all commands in folder? "))
+ (setq mh-delete-list nil
+ mh-refile-list nil
+ mh-seq-list nil
+ mh-next-direction 'forward)
+ (with-mh-folder-updating (nil)
+ (mh-unmark-all-headers t)))
+ (t
+ (message "Commands not undone.")
+ (sit-for 2))))
+
+
+(defun mh-visit-folder (folder &optional range)
+ "Visit FOLDER and display RANGE of messages."
+ (interactive (list (mh-prompt-for-folder "Visit" "+inbox" t)
+ (mh-read-msg-range "Range [all]? ")))
+ (let ((config (current-window-configuration)))
+ (mh-scan-folder folder (or range "all"))
+ (setq mh-previous-window-config config)))
+
+
+(defun mh-widen ()
+ "Remove restrictions from the current folder, thereby showing all messages."
+ (interactive "")
+ (with-mh-folder-updating (t)
+ (delete-region (point-min) (point-max))
+ (widen)
+ (mh-make-folder-mode-line))
+ (setq mh-narrowed-to-seq nil))
+
+\f
+
+;;; Support routines.
+
+(defun mh-delete-a-msg (msg)
+ ;; Delete the MESSAGE.
+ (save-excursion
+ (mh-goto-msg msg nil t)
+ (if (looking-at mh-refiled-msg-regexp)
+ (error "Message %d is refiled. Undo refile before deleting." msg))
+ (if (looking-at mh-deleted-msg-regexp)
+ nil
+ (mh-set-folder-modified-p t)
+ (mh-push msg mh-delete-list)
+ (mh-add-msgs-to-seq msg 'deleted t)
+ (mh-notate msg ?D mh-cmd-note))))
+
+
+(defun mh-refile-a-msg (msg destination)
+ ;; Refile MESSAGE in FOLDER.
+ (save-excursion
+ (mh-goto-msg msg nil t)
+ (cond ((looking-at mh-deleted-msg-regexp)
+ (error "Message %d is deleted. Undo delete before moving." msg))
+ ((looking-at mh-refiled-msg-regexp)
+ (if (y-or-n-p
+ (format "Message %d already refiled. Copy to %s as well? "
+ msg destination))
+ (mh-exec-cmd "refile" (mh-get-msg-num t) "-link"
+ "-src" mh-current-folder
+ (symbol-name destination))
+ (message "Message not copied.")))
+ (t
+ (mh-set-folder-modified-p t)
+ (if (not (memq destination mh-refile-list))
+ (mh-push destination mh-refile-list))
+ (if (not (memq msg (mh-seq-to-msgs destination)))
+ (mh-add-msgs-to-seq msg destination t))
+ (mh-notate msg ?^ mh-cmd-note)))))
+
+
+(defun mh-display-msg (msg-num folder)
+ ;; Display message NUMBER of FOLDER.
+ (set-buffer folder)
+ ;; Bind variables in folder buffer in case they are local
+ (let ((formfile mhl-formfile)
+ (clean-message-header mh-clean-message-header)
+ (invisible-headers mh-invisible-headers)
+ (visible-headers mh-visible-headers)
+ (msg-filename (mh-msg-filename msg-num))
+ (show-buffer mh-show-buffer)
+ (folder mh-current-folder))
+ (if (not (file-exists-p msg-filename))
+ (error "Message %d does not exist" msg-num))
+ (switch-to-buffer show-buffer)
+ (if mh-bury-show-buffer (bury-buffer (current-buffer)))
+ (mh-when (not (equal msg-filename buffer-file-name))
+ ;; Buffer does not yet contain message.
+ (clear-visited-file-modtime)
+ (unlock-buffer)
+ (setq buffer-file-name nil) ; no locking during setup
+ (erase-buffer)
+ (if formfile
+ (if (stringp formfile)
+ (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+ "-form" formfile msg-filename)
+ (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+ msg-filename))
+ (insert-file-contents msg-filename))
+ (goto-char (point-min))
+ (cond (clean-message-header
+ (mh-clean-msg-header (point-min)
+ invisible-headers
+ visible-headers)
+ (goto-char (point-min)))
+ (t
+ (let ((case-fold-search t))
+ (re-search-forward
+ "^To:\\|^From:\\|^Subject:\\|^Date:" nil t)
+ (beginning-of-line)
+ (mh-recenter 0))))
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name msg-filename)
+ (set-mark nil)
+ (setq mode-line-buffer-identification
+ (list (format mh-show-buffer-mode-line-buffer-id
+ folder msg-num))))))
+
+
+(defun mh-invalidate-show-buffer ()
+ ;; Invalidate the show buffer so we must update it to use it.
+ (if (get-buffer mh-show-buffer)
+ (save-excursion
+ (set-buffer mh-show-buffer)
+ (setq buffer-file-name nil))))
+
+
+(defun mh-show-message-in-other-window ()
+ (switch-to-buffer-other-window mh-show-buffer)
+ (if mh-bury-show-buffer (bury-buffer (current-buffer))))
+
+
+(defun mh-clean-msg-header (start invisible-headers visible-headers)
+ ;; Flush extraneous lines in a message header, from the given POINT to the
+ ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a
+ ;; regular expression specifying the lines to display, otherwise
+ ;; INVISIBLE-HEADERS contains a regular expression specifying lines to
+ ;; delete from the header.
+ (let ((case-fold-search t))
+ (save-restriction
+ (goto-char start)
+ (if (search-forward "\n\n" nil t)
+ (backward-char 2))
+ (narrow-to-region start (point))
+ (goto-char (point-min))
+ (if visible-headers
+ (while (< (point) (point-max))
+ (beginning-of-line)
+ (cond ((looking-at visible-headers)
+ (forward-line 1)
+ (while (looking-at "^[ \t]+") (forward-line 1)))
+ (t
+ (mh-delete-line 1)
+ (while (looking-at "^[ \t]+")
+ (beginning-of-line)
+ (mh-delete-line 1)))))
+ (while (re-search-forward invisible-headers nil t)
+ (beginning-of-line)
+ (mh-delete-line 1)
+ (while (looking-at "^[ \t]+")
+ (beginning-of-line)
+ (mh-delete-line 1))))
+ (unlock-buffer))))
+
+
+(defun mh-delete-line (lines)
+ ;; Delete version of kill-line.
+ (delete-region (point) (save-excursion (forward-line lines) (point))))
+
+
+(defun mh-read-draft (use initial-contents delete-contents-file)
+ ;; Read draft file into a draft buffer and make that buffer the current one.
+ ;; USE is a message used for prompting about the intended use of the message.
+ ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL
+ ;; if buffer should not be modified. Delete the initial-contents file if
+ ;; DELETE-CONTENTS-FILE flag is set.
+ ;; Returns the draft folder's name.
+ ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is
+ ;; used each time and saved in the draft folder. The draft file can then be
+ ;; reused.
+ (cond (mh-draft-folder
+ (let ((orig-default-dir default-directory))
+ (pop-to-buffer (find-file-noselect (mh-new-draft-name) t))
+ (rename-buffer (format "draft-%s" (buffer-name)))
+ (setq default-directory orig-default-dir)))
+ (t
+ (let ((draft-name (expand-file-name "draft" mh-user-path)))
+ (pop-to-buffer "draft") ; Create if necessary
+ (if (buffer-modified-p)
+ (if (y-or-n-p "Draft has been modified; kill anyway? ")
+ (set-buffer-modified-p nil)
+ (error "Draft preserved")))
+ (setq buffer-file-name draft-name)
+ (clear-visited-file-modtime)
+ (unlock-buffer)
+ (mh-when (and (file-exists-p draft-name)
+ (not (equal draft-name initial-contents)))
+ (insert-file-contents draft-name)
+ (delete-file draft-name)))))
+ (mh-when (and initial-contents
+ (or (zerop (buffer-size))
+ (not (y-or-n-p
+ (format "A draft exists. Use for %s? " use)))))
+ (erase-buffer)
+ (insert-file-contents initial-contents)
+ (if delete-contents-file (delete-file initial-contents)))
+ (auto-save-mode 1)
+ (if mh-draft-folder
+ (save-buffer)) ; Do not reuse draft name
+ (buffer-name))
+
+
+(defun mh-new-draft-name ()
+ ;; Returns the pathname of folder for draft messages.
+ (save-excursion
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer)
+ (mh-exec-cmd-output "mhpath" nil mh-draft-folder "new")
+ (buffer-substring (point) (1- (mark)))))
+
+
+(defun mh-next-msg ()
+ ;; Move backward or forward to the next undeleted message in the buffer.
+ (if (eq mh-next-direction 'forward)
+ (mh-next-undeleted-msg 1)
+ (mh-previous-undeleted-msg 1)))
+
+
+(defun mh-set-scan-mode ()
+ ;; Display the scan listing buffer, but do not show a message.
+ (if (get-buffer mh-show-buffer)
+ (delete-windows-on mh-show-buffer))
+ (mh-set-mode-name "mh-e scan")
+ (setq mh-showing nil)
+ (if mh-recenter-summary-p
+ (mh-recenter nil)))
+
+
+(defun mh-maybe-show (&optional msg)
+ ;; If in showing mode, then display the message pointed to by the cursor.
+ (if mh-showing (mh-show msg)))
+
+
+(defun mh-set-mode-name (mode-name-string)
+ ;; Set the mode-name and ensure that the mode line is updated.
+ (setq mode-name mode-name-string)
+ ;; Force redisplay of all buffers' mode lines to be considered.
+ (save-excursion (set-buffer (other-buffer)))
+ (set-buffer-modified-p (buffer-modified-p)))
+
+\f
+
+;;; The folder data abstraction.
+
+(defvar mh-current-folder nil "Name of current folder, a string.")
+(defvar mh-show-buffer nil "Buffer that displays mesage for this folder.")
+(defvar mh-folder-filename nil "Full path of directory for this folder.")
+(defvar mh-showing nil "If non-nil, show the message in a separate window.")
+(defvar mh-next-seq-num nil "Index of free sequence id.")
+(defvar mh-delete-list nil "List of msg numbers to delete.")
+(defvar mh-refile-list nil "List of folder names in mh-seq-list.")
+(defvar mh-seq-list nil "Alist of (seq . msgs) numbers.")
+(defvar mh-seen-list nil "List of displayed messages.")
+(defvar mh-next-direction 'forward "Direction to move to next message.")
+(defvar mh-narrowed-to-seq nil "Sequence display is narrowed to.")
+(defvar mh-first-msg-num nil "Number of first msg in buffer.")
+(defvar mh-last-msg-num nil "Number of last msg in buffer.")
+
+
+(defun mh-make-folder (name)
+ ;; Create and initialize a new mail folder called NAME and make it the
+ ;; current folder.
+ (switch-to-buffer name)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq buffer-read-only t)
+ (mh-folder-mode)
+ (mh-set-folder-modified-p nil)
+ (setq buffer-file-name mh-folder-filename)
+ (mh-set-mode-name "mh-e scan"))
+
+
+;;; Don't use this mode when creating buffers if default-major-mode is nil.
+(put 'mh-folder-mode 'mode-class 'special)
+
+(defun mh-folder-mode ()
+ "Major mode for \"editing\" an MH folder scan listing.
+Messages can be marked for refiling and deletion. However, both actions
+are deferred until you request execution with \\[mh-execute-commands].
+\\{mh-folder-mode-map}
+ A prefix argument (\\[universal-argument]) to delete, refile, list, or undo
+applies the action to a message sequence.
+
+Variables controlling mh-e operation are (defaults in parentheses):
+
+ mh-bury-show-buffer (t)
+ Non-nil means that the buffer used to display message is buried.
+ It will never be offered as the default other buffer.
+
+ mh-clean-message-header (nil)
+ Non-nil means remove header lines matching the regular expression
+ specified in mh-invisible-headers from messages.
+
+ mh-visible-headers (nil)
+ If non-nil, it contains a regexp specifying the headers that are shown in
+ a message if mh-clean-message-header is non-nil. Setting this variable
+ overrides mh-invisible-headers.
+
+ mh-do-not-confirm (nil)
+ Non-nil means do not prompt for confirmation before executing some
+ non-recoverable commands such as mh-kill-folder and mh-undo-folder.
+
+ mhl-formfile (nil)
+ Name of format file to be used by mhl to show messages.
+ A value of T means use the default format file.
+ Nil means don't use mhl to format messages.
+
+ mh-lpr-command-format (\"lpr -p -J '%s'\")
+ Format for command used to print a message on a system printer.
+
+ mh-recenter-summary-p (nil)
+ If non-nil, then the scan listing is recentered when the window displaying
+ a messages is toggled off.
+
+ mh-summary-height (4)
+ Number of lines in the summary window.
+
+ mh-ins-buf-prefix (\">> \")
+ String to insert before each non-blank line of a message as it is
+ inserted in a draft letter.
+
+The value of mh-folder-mode-hook is called when a new folder is set up."
+
+ (kill-all-local-variables)
+ (use-local-map mh-folder-mode-map)
+ (setq major-mode 'mh-folder-mode)
+ (mh-set-mode-name "mh-e folder")
+ (make-local-vars
+ 'mh-current-folder (buffer-name) ; Name of folder, a string
+ 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs
+ 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/"
+ (file-name-as-directory (mh-expand-file-name (buffer-name)))
+ 'mh-showing nil ; Show message also?
+ 'mh-next-seq-num 0 ; Index of free sequence id
+ 'mh-delete-list nil ; List of msgs nums to delete
+ 'mh-refile-list nil ; List of folder names in mh-seq-list
+ 'mh-seq-list nil ; Alist of (seq . msgs) nums
+ 'mh-seen-list nil ; List of displayed messages
+ 'mh-next-direction 'forward ; Direction to move to next message
+ 'mh-narrowed-to-seq nil ; Sequence display is narrowed to
+ 'mh-first-msg-num nil ; Number of first msg in buffer
+ 'mh-last-msg-num nil ; Number of last msg in buffer
+ 'mh-previous-window-config nil) ; Previous window configuration
+ (auto-save-mode -1)
+ (setq buffer-offer-save t)
+ (make-local-variable 'write-file-hooks)
+ (setq write-file-hooks '(mh-execute-commands))
+ (make-local-variable 'revert-buffer-function)
+ (setq revert-buffer-function 'mh-undo-folder)
+ (run-hooks 'mh-folder-mode-hook))
+
+
+(defun make-local-vars (&rest pairs)
+ ;; Take VARIABLE-VALUE pairs and makes local variables initialized to the
+ ;; value.
+ (while pairs
+ (make-variable-buffer-local (car pairs))
+ (set (car pairs) (car (cdr pairs)))
+ (setq pairs (cdr (cdr pairs)))))
+
+
+(defun mh-scan-folder (folder range)
+ ;; Scan the FOLDER over the RANGE. Return in the folder's buffer.
+ (cond ((null (get-buffer folder))
+ (mh-make-folder folder))
+ (t
+ (mh-process-or-undo-commands folder)
+ (switch-to-buffer folder)))
+ (mh-regenerate-headers range)
+ (mh-when (zerop (buffer-size))
+ (if (equal range "all")
+ (message "Folder %s is empty" folder)
+ (message "No messages in %s, range %s" folder range))
+ (sit-for 5))
+ (mh-goto-cur-msg))
+
+
+(defun mh-regenerate-headers (range)
+ ;; Replace buffer with scan of its contents over range RANGE.
+ (let ((folder mh-current-folder))
+ (message "Scanning %s..." folder)
+ (with-mh-folder-updating (nil)
+ (erase-buffer)
+ (mh-exec-cmd-output "scan" nil
+ "-noclear" "-noheader"
+ "-width" (window-width)
+ folder range)
+ (goto-char (point-min))
+ (cond ((looking-at "scan: no messages in")
+ (keep-lines mh-valid-scan-line)) ; Flush random scan lines
+ ((looking-at "scan: ")) ; Keep error messages
+ (t
+ (keep-lines mh-valid-scan-line))) ; Flush random scan lines
+ (mh-delete-seq-locally 'cur) ; To pick up new one
+ (setq mh-seq-list (mh-read-folder-sequences folder nil))
+ (mh-notate-user-sequences)
+ (mh-make-folder-mode-line (if (equal range "all")
+ nil
+ mh-partial-folder-mode-line-annotation)))
+ (message "Scanning %s...done" folder)))
+
+
+(defun mh-get-new-mail (maildrop-name)
+ ;; Read new mail from a maildrop into the current buffer.
+ ;; Return T if there was new mail, NIL otherwise. Return in the current
+ ;; buffer.
+ (let ((point-before-inc (point))
+ (folder mh-current-folder)
+ (return-value t))
+ (with-mh-folder-updating (t)
+ (message (if maildrop-name
+ (format "inc %s -file %s..." folder maildrop-name)
+ (format "inc %s..." folder)))
+ (mh-unmark-all-headers nil)
+ (setq mh-next-direction 'forward)
+ (goto-char (point-max))
+ (let ((start-of-inc (point)))
+ (if maildrop-name
+ (mh-exec-cmd-output "inc" nil folder
+ "-file" (expand-file-name maildrop-name)
+ "-width" (window-width)
+ "-truncate")
+ (mh-exec-cmd-output "inc" nil
+ "-width" (window-width)))
+ (message
+ (if maildrop-name
+ (format "inc %s -file %s...done" folder maildrop-name)
+ (format "inc %s...done" folder)))
+ (goto-char start-of-inc)
+ (cond ((looking-at "inc: no mail")
+ (keep-lines mh-valid-scan-line) ; Flush random scan lines
+ (goto-char point-before-inc)
+ (message "No new mail%s%s" (if maildrop-name " in " "")
+ (if maildrop-name maildrop-name "")))
+ ((re-search-forward "^inc:" nil t) ; Error messages
+ (error "inc error"))
+ (t
+ (mh-delete-seq-locally 'cur) ; To pick up new one
+ (setq mh-seq-list (mh-read-folder-sequences folder t))
+ (mh-notate-user-sequences)
+ (keep-lines mh-valid-scan-line)
+ (mh-make-folder-mode-line)
+ (mh-goto-cur-msg)
+ (setq return-value t))))
+ return-value)))
+
+
+(defun mh-make-folder-mode-line (&optional annotation)
+ ;; Set the fields of the mode line for a folder buffer.
+ ;; The optional ANNOTATION string is displayed after the folder's name.
+ (save-excursion
+ (mh-first-msg)
+ (setq mh-first-msg-num (mh-get-msg-num nil))
+ (mh-last-msg)
+ (setq mh-last-msg-num (mh-get-msg-num nil))
+ (let ((lines (count-lines (point-min) (point-max))))
+ (setq mode-line-buffer-identification
+ (list (format "{%%b%s} %d msg%s"
+ (if annotation (format "/%s" annotation) "")
+ lines
+ (if (zerop lines)
+ "s"
+ (if (> lines 1)
+ (format "s (%d-%d)" mh-first-msg-num
+ mh-last-msg-num)
+ (format " (%d)" mh-first-msg-num)))))))))
+
+
+(defun mh-unmark-all-headers (remove-all-flags)
+ ;; Remove all '+' flags from the headers, and if called with a non-nil
+ ;; argument, remove all 'D', '^' and '%' flags too.
+ ;; Optimized for speed (i.e., no regular expressions).
+ (save-excursion
+ (let ((case-fold-search nil)
+ (last-line (- (point-max) mh-cmd-note))
+ char)
+ (mh-first-msg)
+ (while (<= (point) last-line)
+ (forward-char mh-cmd-note)
+ (setq char (following-char))
+ (if (or (and remove-all-flags
+ (or (eql char ?D)
+ (eql char ?^)
+ (eql char ?%)))
+ (eql char ?+))
+ (progn
+ (delete-char 1)
+ (insert " ")))
+ (forward-line)))))
+
+
+(defun mh-goto-cur-msg ()
+ ;; Position the cursor at the current message.
+ (let ((cur-msg (car (mh-seq-to-msgs 'cur))))
+ (cond ((and cur-msg
+ (mh-goto-msg cur-msg t nil))
+ (mh-notate nil ?+ mh-cmd-note)
+ (mh-recenter 0)
+ (mh-maybe-show cur-msg))
+ (t
+ (mh-last-msg)
+ (message "No current message")))))
+
+
+(defun mh-pack-folder-1 (range)
+ ;; Close and pack the current folder.
+ (mh-process-or-undo-commands mh-current-folder)
+ (message "Packing folder...")
+ (mh-set-folder-modified-p t) ; lock folder while packing
+ (save-excursion
+ (mh-exec-cmd-quiet " *mh-temp*" "folder" mh-current-folder "-pack"))
+ (mh-regenerate-headers range))
+
+
+(defun mh-process-or-undo-commands (folder)
+ ;; If FOLDER has outstanding commands, then either process or discard them.
+ (set-buffer folder)
+ (if (mh-outstanding-commands-p)
+ (if (or mh-do-not-confirm
+ (y-or-n-p
+ "Process outstanding deletes and refiles (or lose them)? "))
+ (mh-process-commands folder)
+ (mh-undo-folder))
+ (mh-invalidate-show-buffer)))
+
+
+(defun mh-process-commands (folder)
+ ;; Process outstanding commands for the folder FOLDER.
+ (message "Processing deletes and refiles for %s..." folder)
+ (set-buffer folder)
+ (with-mh-folder-updating (nil)
+ ;; Update the unseen sequence if it exists
+ (if (and mh-seen-list (mh-seq-to-msgs mh-unseen-seq))
+ (mh-undefine-sequence mh-unseen-seq mh-seen-list))
+
+ ;; Then refile messages
+ (mh-mapc
+ (function
+ (lambda (dest)
+ (let ((msgs (mh-seq-to-msgs dest)))
+ (mh-when msgs
+ (apply 'mh-exec-cmd "refile"
+ "-src" folder (symbol-name dest) msgs)
+ (mh-delete-scan-msgs msgs)))))
+ mh-refile-list)
+
+ ;; Now delete messages
+ (mh-when mh-delete-list
+ (apply 'mh-exec-cmd "rmm" folder mh-delete-list)
+ (mh-delete-scan-msgs mh-delete-list))
+
+ ;; Don't need to remove sequences since delete and refile do so.
+
+ ;; Mark cur message
+ (if (> (buffer-size) 0)
+ (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last"))))
+
+ (mh-invalidate-show-buffer)
+
+ (setq mh-delete-list nil
+ mh-refile-list nil
+ mh-seq-list (mh-read-folder-sequences mh-current-folder nil)
+ mh-seen-list nil)
+ (mh-unmark-all-headers t)
+ (mh-notate-user-sequences)
+ (message "Processing deletes and refiles for %s...done" folder)))
+
+
+(defun mh-delete-scan-msgs (msgs)
+ ;; Delete the scan listing lines for each of the msgs in the LIST.
+ ;; Optimized for speed (i.e., no regular expressions).
+ (setq msgs (sort msgs (function <))) ;okay to clobber msgs
+ (save-excursion
+ (mh-first-msg)
+ (while (and msgs (< (point) (point-max)))
+ (cond ((= (mh-get-msg-num nil) (car msgs))
+ (delete-region (point) (save-excursion (forward-line) (point)))
+ (setq msgs (cdr msgs)))
+ (t
+ (forward-line))))))
+
+
+(defun mh-set-folder-modified-p (flag)
+ "Mark current folder as modified or unmodified according to FLAG."
+ (set-buffer-modified-p flag))
+
+
+(defun mh-outstanding-commands-p ()
+ ;; Returns non-nil if there are outstanding deletes or refiles.
+ (or mh-delete-list mh-refile-list))
+
+\f
+
+;;; Mode for composing and sending a draft message.
+
+(defvar mh-sent-from-folder nil
+ "Folder of msg associated with this letter.")
+
+(defvar mh-sent-from-msg nil
+ "Number of msg associated with this letter.")
+
+(defvar mh-send-args nil
+ "Extra arguments to pass to \"send\" command.")
+
+(defvar mh-annotate-char nil
+ "Character to use to annotate mh-sent-from-msg.")
+
+(defvar mh-annotate-field nil
+ "Field name for message annotation.")
+
+(defun mh-letter-mode ()
+ "Mode for composing letters in mh-e.
+When you have finished composing, type \\[mh-send-letter] to send the letter.
+
+Variables controlling this mode (defaults in parentheses):
+
+ mh-delete-yanked-msg-window (nil)
+ If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying
+ the yanked message.
+
+ mh-yank-from-start-of-msg (t)
+ If non-nil, \\[mh-yank-cur-msg] will include the entire message.
+ If `body', just yank the body (no header).
+ If nil, only the portion of the message following the point will be yanked.
+ If there is a region, this variable is ignored.
+
+Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are
+invoked with no args, if those values are non-nil.
+
+\\{mh-letter-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-start))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate
+ (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-separate))
+ (make-local-variable 'mh-send-args)
+ (make-local-variable 'mh-annotate-char)
+ (make-local-variable 'mh-annotate-field)
+ (make-local-variable 'mh-previous-window-config)
+ (make-local-variable 'mh-sent-from-folder)
+ (make-local-variable 'mh-sent-from-msg)
+ (use-local-map mh-letter-mode-map)
+ (setq major-mode 'mh-letter-mode)
+ (mh-set-mode-name "mh-e letter")
+ (set-syntax-table mh-letter-mode-syntax-table)
+ (run-hooks 'text-mode-hook 'mh-letter-mode-hook)
+ (mh-when auto-fill-hook
+ (make-local-variable 'auto-fill-hook)
+ (setq auto-fill-hook 'mh-auto-fill-for-letter)))
+
+
+(defun mh-auto-fill-for-letter ()
+ ;; Auto-fill in letters treats the header specially by inserting a tab
+ ;; before continuation line.
+ (do-auto-fill)
+ (if (mh-in-header-p)
+ (save-excursion
+ (beginning-of-line nil)
+ (insert-char ?\t 1))))
+
+
+(defun mh-in-header-p ()
+ ;; Return non-nil if the point is in the header of a draft message.
+ (save-excursion
+ (let ((cur-point (point)))
+ (goto-char (dot-min))
+ (re-search-forward "^--------" nil t)
+ (< cur-point (point)))))
+
+
+(defun mh-to-field ()
+ "Move point to the end of a specified header field.
+The field is indicated by the previous keystroke. Create the field if
+it does not exist. Set the mark to point before moving."
+ (interactive "")
+ (expand-abbrev)
+ (let ((target (cdr (assoc (logior last-input-char ?`) mh-to-field-choices)))
+ (case-fold-search t))
+ (cond ((mh-position-on-field target t)
+ (let ((eol (point)))
+ (skip-chars-backward " \t")
+ (delete-region (point) eol))
+ (if (save-excursion
+ (backward-char 1)
+ (not (looking-at "[:,]")))
+ (insert ", ")
+ (insert " ")))
+ (t
+ (goto-char (dot-min))
+ (re-search-forward "^To:")
+ (forward-line 1)
+ (while (looking-at "^[ \t]") (forward-line 1))
+ (insert (format "%s \n" target))
+ (backward-char 1)))))
+
+
+(defun mh-to-fcc ()
+ "Insert an Fcc: field in the current message.
+Prompt for the field name with a completion list of the current folders."
+ (interactive)
+ (let ((last-input-char ?\C-f)
+ (folder (mh-prompt-for-folder "Fcc" "" t)))
+ (expand-abbrev)
+ (save-excursion
+ (mh-to-field)
+ (insert (substring folder 1 nil)))))
+
+
+(defun mh-insert-signature ()
+ "Insert the file ~/.signature at the current point."
+ (interactive "")
+ (insert-file-contents "~/.signature")
+ (set-buffer-modified-p (buffer-modified-p))) ; force mode line update
+
+
+(defun mh-check-whom ()
+ "Verify recipients of the current letter."
+ (interactive)
+ (let ((file-name (buffer-file-name)))
+ (set-buffer-modified-p t) ; Force writing of contents
+ (save-buffer)
+ (message "Checking recipients...")
+ (switch-to-buffer-other-window "*Mail Recipients*")
+ (bury-buffer (current-buffer))
+ (erase-buffer)
+ (mh-exec-cmd-output "whom" t file-name)
+ (other-window -1)
+ (message "Checking recipients...done")))
+
+\f
+
+;;; Routines to make a search pattern and search for a message.
+
+(defvar mh-searching-folder nil "Folder this pick is searching.")
+
+
+(defun mh-make-pick-template ()
+ ;; Initialize the current buffer with a template for a pick pattern.
+ (erase-buffer)
+ (kill-all-local-variables)
+ (make-local-variable 'mh-searching-folder)
+ (insert "From: \n"
+ "To: \n"
+ "Cc: \n"
+ "Date: \n"
+ "Subject: \n"
+ "---------\n")
+ (mh-letter-mode)
+ (use-local-map mh-pick-mode-map)
+ (goto-char (point-min))
+ (end-of-line))
+
+
+(defun mh-do-pick-search ()
+ "Find messages that match the qualifications in the current pattern buffer.
+Messages are searched for in the folder named in mh-searching-folder.
+Put messages found in a sequence named `search'."
+ (interactive)
+ (let ((pattern-buffer (buffer-name))
+ (searching-buffer mh-searching-folder)
+ (range)
+ (pattern nil)
+ (new-buffer nil))
+ (save-excursion
+ (cond ((get-buffer searching-buffer)
+ (set-buffer searching-buffer)
+ (setq range (format "%d-%d" mh-first-msg-num mh-last-msg-num)))
+ (t
+ (mh-make-folder searching-buffer)
+ (setq range "all")
+ (setq new-buffer t))))
+ (message "Searching...")
+ (goto-char (point-min))
+ (while (setq pattern (mh-next-pick-field pattern-buffer))
+ (setq msgs (mh-seq-from-command searching-buffer
+ 'search
+ (nconc (cons "pick" pattern)
+ (list searching-buffer
+ range
+ "-sequence" "search"
+ "-list"))))
+ (setq range "search"))
+ (message "Searching...done")
+ (if new-buffer
+ (mh-scan-folder searching-buffer msgs)
+ (switch-to-buffer searching-buffer))
+ (delete-other-windows)
+ (mh-notate-seq 'search ?% (1+ mh-cmd-note))))
+
+
+(defun mh-next-pick-field (buffer)
+ ;; Return the next piece of a pick argument that can be extracted from the
+ ;; BUFFER. Returns nil if no pieces remain.
+ (set-buffer buffer)
+ (let ((case-fold-search t))
+ (cond ((eobp)
+ nil)
+ ((re-search-forward "^\\([a-z].*\\):[ \t]*\\([a-z0-9].*\\)$" nil t)
+ (let* ((component
+ (format "--%s"
+ (downcase (buffer-substring (match-beginning 1)
+ (match-end 1)))))
+ (pat (buffer-substring (match-beginning 2) (match-end 2))))
+ (forward-line 1)
+ (list component pat)))
+ ((re-search-forward "^-*$" nil t)
+ (forward-char 1)
+ (let ((body (buffer-substring (point) (point-max))))
+ (if (and (> (length body) 0) (not (equal body "\n")))
+ (list "-search" body)
+ nil)))
+ (t
+ nil))))
+
+\f
+
+;;; Routines to compose and send a letter.
+
+(defun mh-compose-and-send-mail (draft send-args
+ sent-from-folder sent-from-msg
+ to subject cc
+ annotate-char annotate-field
+ config)
+ ;; Edit and compose a draft message in buffer DRAFT and send or save it.
+ ;; SENT-FROM-FOLDER is buffer containing scan listing of current folder, or
+ ;; nil if none exists.
+ ;; SENT-FROM-MSG is the message number or sequence name or nil.
+ ;; SEND-ARGS is an optional argument passed to the send command.
+ ;; The TO, SUBJECT, and CC fields are passed to the
+ ;; mh-compose-letter-function.
+ ;; If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the
+ ;; message. In that case, the ANNOTATE-FIELD is used to build a string
+ ;; for mh-annotate-msg.
+ ;; CONFIG is the window configuration to restore after sending the letter.
+ (pop-to-buffer draft)
+ (mh-letter-mode)
+ (setq mh-sent-from-folder sent-from-folder)
+ (setq mh-sent-from-msg sent-from-msg)
+ (setq mh-send-args send-args)
+ (setq mh-annotate-char annotate-char)
+ (setq mh-annotate-field annotate-field)
+ (setq mh-previous-window-config config)
+ (setq mode-line-buffer-identification (list "{%b}"))
+ (if (and (boundp 'mh-compose-letter-function)
+ (symbol-value 'mh-compose-letter-function))
+ ;; run-hooks will not pass arguments.
+ (let ((value (symbol-value 'mh-compose-letter-function)))
+ (if (and (listp value) (not (eq (car value) 'lambda)))
+ (while value
+ (funcall (car value) to subject cc)
+ (setq value (cdr value)))
+ (funcall mh-compose-letter-function to subject cc)))))
+
+
+(defun mh-send-letter (&optional arg)
+ "Send the draft letter in the current buffer.
+If (optional) prefix argument is provided, monitor delivery.
+Run mh-before-send-letter-hook before doing anything."
+ (interactive "P")
+ (run-hooks 'mh-before-send-letter-hook)
+ (set-buffer-modified-p t) ; Make sure buffer is written
+ (save-buffer)
+ (message "Sending...")
+ (let ((draft-buffer (current-buffer))
+ (file-name (buffer-file-name))
+ (config mh-previous-window-config))
+ (cond (arg
+ (pop-to-buffer "MH mail delivery")
+ (erase-buffer)
+ (if mh-send-args
+ (mh-exec-cmd-output "send" t "-watch" "-nopush"
+ "-nodraftfolder" mh-send-args file-name)
+ (mh-exec-cmd-output "send" t "-watch" "-nopush"
+ "-nodraftfolder" file-name))
+ (goto-char (point-max))
+ (recenter -1)
+ (set-buffer draft-buffer)) ; for annotation below
+ (mh-send-args
+ (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose"
+ mh-send-args file-name))
+ (t
+ (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose"
+ file-name)))
+
+ (if mh-annotate-char
+ (mh-annotate-msg mh-sent-from-msg
+ mh-sent-from-folder
+ mh-annotate-char
+ "-component" mh-annotate-field
+ "-text" (format "\"%s %s\""
+ (mh-get-field "To:")
+ (mh-get-field "Cc:"))))
+
+ (mh-when (or (not arg)
+ (y-or-n-p "Kill draft buffer? "))
+ (kill-buffer draft-buffer)
+ (if config
+ (set-window-configuration config)))
+ (message "Sending...done")))
+
+
+(defun mh-insert-letter (prefix-provided folder msg)
+ "Insert a message from any folder into the current letter.
+Removes the message's headers using mh-invisible-headers.
+Prefixes each non-blank line with mh-ins-buf-prefix (default \">> \").
+If (optional) prefix argument provided, do not indent and do not delete
+headers.
+Leaves the mark before the letter and point after it."
+ (interactive
+ (list current-prefix-arg
+ (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
+ (read-input (format "Message number%s: "
+ (if mh-sent-from-msg
+ (format " [%d]" mh-sent-from-msg)
+ "")))))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (let ((start (point-min)))
+ (if (equal msg "") (setq msg (int-to-string mh-sent-from-msg)))
+ (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+ (expand-file-name msg
+ (mh-expand-file-name folder)))
+ (mh-when (not prefix-provided)
+ (mh-clean-msg-header start mh-invisible-headers mh-visible-headers)
+ (set-mark start) ; since mh-clean-msg-header moves it
+ (mh-insert-prefix-string mh-ins-buf-prefix)))))
+
+
+(defun mh-yank-cur-msg ()
+ "Insert the current message into the draft buffer.
+Prefix each non-blank line in the message with the string in
+mh-ins-buf-prefix. If a region is set in the message's buffer, then
+only the region will be inserted. Otherwise, the entire message will
+be inserted if mh-yank-from-start-of-msg is non-nil. If this variable
+is nil, the portion of the message following the point will be yanked.
+If mh-delete-yanked-msg-window is non-nil, any window displaying the
+yanked message will be deleted."
+ (interactive)
+ (if (and mh-sent-from-folder mh-sent-from-msg)
+ (let ((to-point (point))
+ (to-buffer (current-buffer)))
+ (set-buffer mh-sent-from-folder)
+ (if mh-delete-yanked-msg-window
+ (delete-windows-on mh-show-buffer))
+ (set-buffer mh-show-buffer) ; Find displayed message
+ (let ((mh-ins-str (cond ((mark)
+ (buffer-substring (point) (mark)))
+ ((eq 'body mh-yank-from-start-of-msg)
+ (buffer-substring
+ (save-excursion
+ (goto-char (point-min))
+ (mh-goto-header-end 1)
+ (point))
+ (point-max)))
+ (mh-yank-from-start-of-msg
+ (buffer-substring (point-min) (point-max)))
+ (t
+ (buffer-substring (point) (point-max))))))
+ (set-buffer to-buffer)
+ (narrow-to-region to-point to-point)
+ (push-mark)
+ (insert mh-ins-str)
+ (mh-insert-prefix-string mh-ins-buf-prefix)
+ (insert "\n")
+ (widen)))
+ (error "There is no current message")))
+
+
+(defun mh-insert-prefix-string (mh-ins-string)
+ ;; Run MH-YANK-HOOK to insert a prefix string before each line in the buffer.
+ ;; Generality for supercite users.
+ (save-excursion
+ (set-mark (point-max))
+ (goto-char (point-min))
+ (run-hooks 'mh-yank-hooks)))
+
+
+(defun mh-fully-kill-draft ()
+ "Kill the draft message file and the draft message buffer.
+Use \\[kill-buffer] if you don't want to delete the draft message file."
+ (interactive "")
+ (if (y-or-n-p "Kill draft message? ")
+ (let ((config mh-previous-window-config))
+ (if (file-exists-p (buffer-file-name))
+ (delete-file (buffer-file-name)))
+ (set-buffer-modified-p nil)
+ (kill-buffer (buffer-name))
+ (message "")
+ (if config
+ (set-window-configuration config)))
+ (error "Message not killed")))
+
+
+(defun mh-recenter (arg)
+ ;; Like recenter but with two improvements: nil arg means recenter,
+ ;; and only does anything if the current buffer is in the selected
+ ;; window. (Commands like save-some-buffers can make this false.)
+ (if (eql (get-buffer-window (current-buffer))
+ (selected-window))
+ (recenter (if arg arg '(t)))))
+
+\f
+
+;;; Commands to manipulate sequences. Sequences are stored in an alist
+;;; of the form:
+;;; ((seq-name msgs ...) (seq-name msgs ...) ...)
+
+(defun mh-make-seq (name msgs) (cons name msgs))
+
+(defmacro mh-seq-name (pair) (list 'car pair))
+
+(defmacro mh-seq-msgs (pair) (list 'cdr pair))
+
+(defun mh-find-seq (name) (assoc name mh-seq-list))
+
+
+(defun mh-seq-to-msgs (seq)
+ "Return a list of the messages in SEQUENCE."
+ (mh-seq-msgs (mh-find-seq seq)))
+
+
+(defun mh-seq-containing-msg (msg)
+ ;; Return a list of the sequences containing MESSAGE.
+ (let ((l mh-seq-list)
+ (seqs ()))
+ (while l
+ (if (memq msg (mh-seq-msgs (car l)))
+ (mh-push (mh-seq-name (car l)) seqs))
+ (setq l (cdr l)))
+ seqs))
+
+
+(defun mh-msg-to-seq (msg)
+ ;; Given a MESSAGE number, return the first sequence in which it occurs.
+ (car (mh-seq-containing-msg msg)))
+
+
+(defun mh-read-seq-default (prompt not-empty)
+ ;; Read and return sequence name with default narrowed or previous sequence.
+ (mh-read-seq prompt not-empty (or mh-narrowed-to-seq mh-previous-seq)))
+
+
+(defun mh-read-seq (prompt not-empty &optional default)
+ ;; Read and return a sequence name. Prompt with PROMPT, raise an error
+ ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply
+ ;; an optional DEFAULT sequence.
+ ;; A reply of '%' defaults to the first sequence containing the current
+ ;; message.
+ (let* ((input (completing-read (format "%s %s %s" prompt "sequence:"
+ (if default
+ (format "[%s] " default)
+ ""))
+ (mh-seq-names mh-seq-list)))
+ (seq (cond ((equal input "%") (mh-msg-to-seq (mh-get-msg-num t)))
+ ((equal input "") default)
+ (t (intern input))))
+ (msgs (mh-seq-to-msgs seq)))
+ (if (and (null msgs) not-empty)
+ (error (format "No messages in sequence `%s'" seq)))
+ seq))
+
+
+(defun mh-read-folder-sequences (folder define-sequences)
+ ;; Read and return the predefined sequences for a FOLDER. If
+ ;; DEFINE-SEQUENCES is non-nil, then define mh-e's sequences before
+ ;; reading MH's sequences.
+ (let ((seqs ()))
+ (mh-when define-sequences
+ (mh-define-sequences mh-seq-list)
+ (mh-mapc (function (lambda (seq) ; Save the internal sequences
+ (if (mh-folder-name-p (mh-seq-name seq))
+ (mh-push seq seqs))))
+ mh-seq-list))
+ (save-excursion
+ (mh-exec-cmd-quiet " *mh-temp*" "mark" folder "-list")
+ (goto-char (point-min))
+ (while (re-search-forward "^[^:]+" nil t)
+ (mh-push (mh-make-seq (intern (buffer-substring (match-beginning 0)
+ (match-end 0)))
+ (mh-read-msg-list))
+ seqs))
+ (delete-region (point-min) (point))) ; avoid race with mh-process-daemon
+ seqs))
+
+
+(defun mh-seq-names (seq-list)
+ ;; Return an alist containing the names of the SEQUENCES.
+ (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry)))))
+ seq-list))
+
+
+(defun mh-seq-from-command (folder seq seq-command)
+ ;; In FOLDER, make a sequence named SEQ by executing COMMAND.
+ ;; COMMAND is a list. The first element is a program name
+ ;; and the subsequent elements are its arguments, all strings.
+ (let ((msg)
+ (msgs ())
+ (case-fold-search t))
+ (save-excursion
+ (save-window-excursion
+ (apply 'mh-exec-cmd-quiet " *mh-temp*" seq-command)
+ (goto-char (point-min))
+ (while (setq msg (car (mh-read-msg-list)))
+ (mh-push msg msgs)
+ (forward-line 1)))
+ (set-buffer folder)
+ (setq msgs (nreverse msgs)) ; Put in ascending order
+ (mh-push (mh-make-seq seq msgs) mh-seq-list)
+ msgs)))
+
+
+(defun mh-read-msg-list ()
+ ;; Return a list of message numbers from the current point to the end of
+ ;; the line.
+ (let ((msgs ())
+ (end-of-line (save-excursion (end-of-line) (point)))
+ num)
+ (while (re-search-forward "[0-9]+" end-of-line t)
+ (setq num (string-to-int (buffer-substring (match-beginning 0)
+ (match-end 0))))
+ (cond ((looking-at "-") ; Message range
+ (forward-char 1)
+ (re-search-forward "[0-9]+" end-of-line t)
+ (let ((num2 (string-to-int (buffer-substring (match-beginning 0)
+ (match-end 0)))))
+ (if (< num2 num)
+ (error "Bad message range: %d-%d" num num2))
+ (while (<= num num2)
+ (mh-push num msgs)
+ (setq num (1+ num)))))
+ ((not (zerop num)) (mh-push num msgs))))
+ msgs))
+
+
+(defun mh-remove-seq (seq)
+ ;; Delete the SEQUENCE.
+ (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq seq ? (1+ mh-cmd-note) seq)
+ (mh-undefine-sequence seq (list "all"))
+ (mh-delete-seq-locally seq))
+
+
+(defun mh-delete-seq-locally (seq)
+ ;; Remove mh-e's record of SEQUENCE.
+ (let ((entry (mh-find-seq seq)))
+ (setq mh-seq-list (delq entry mh-seq-list))))
+
+
+(defun mh-remove-msg-from-seq (msg seq &optional internal-flag)
+ ;; Remove MESSAGE from the SEQUENCE. If optional FLAG is non-nil, do not
+ ;; inform MH of the change.
+ (let ((entry (mh-find-seq seq)))
+ (mh-when entry
+ (mh-notate-if-in-one-seq msg ? (1+ mh-cmd-note) (mh-seq-name entry))
+ (if (not internal-flag)
+ (mh-undefine-sequence seq (list msg)))
+ (setcdr entry (delq msg (mh-seq-msgs entry))))))
+
+
+(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag)
+ ;; Add MESSAGE(s) to the SEQUENCE. If optional FLAG is non-nil, do not mark
+ ;; the message in the scan listing or inform MH of the addition.
+ (let ((entry (mh-find-seq seq)))
+ (if (and msgs (atom msgs)) (setq msgs (list msgs)))
+ (if (null entry)
+ (mh-push (mh-make-seq seq msgs) mh-seq-list)
+ (if msgs (setcdr entry (append msgs (cdr entry)))))
+ (mh-when (not internal-flag)
+ (mh-add-to-sequence seq msgs)
+ (mh-notate-seq seq ?% (1+ mh-cmd-note)))))
+
+
+(defun mh-rename-seq (seq new-name)
+ "Rename a SEQUENCE to have a new NAME."
+ (interactive "SOld sequence name: \nSNew name: ")
+ (let ((old-seq (mh-find-seq seq)))
+ (if old-seq
+ (rplaca old-seq new-name)
+ (error "Sequence %s does not exists" seq))
+ (mh-undefine-sequence seq (mh-seq-msgs old-seq))
+ (mh-define-sequence new-name (mh-seq-msgs old-seq))))
+
+
+(defun mh-notate-user-sequences ()
+ ;; Mark the scan listing of all messages in user-defined sequences.
+ (let ((seqs mh-seq-list)
+ name)
+ (while seqs
+ (setq name (mh-seq-name (car seqs)))
+ (if (not (mh-internal-seq name))
+ (mh-notate-seq name ?% (1+ mh-cmd-note)))
+ (setq seqs (cdr seqs)))))
+
+
+(defun mh-internal-seq (name)
+ ;; Return non-NIL if NAME is the name of an internal mh-e sequence.
+ (or (memq name '(answered cur deleted forwarded printed))
+ (eq name mh-unseen-seq)
+ (mh-folder-name-p name)))
+
+
+(defun mh-folder-name-p (name)
+ ;; Return non-NIL if NAME is possibly the name of a folder.
+ ;; A name can be a folder name if it begins with "+".
+ (if (symbolp name)
+ (eql (aref (symbol-name name) 0) ?+)
+ (eql (aref name 0) ?+)))
+
+
+(defun mh-notate-seq (seq notation offset)
+ ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER
+ ;; at the given OFFSET from the beginning of the listing line.
+ (mh-map-to-seq-msgs 'mh-notate seq notation offset))
+
+
+(defun mh-notate-if-in-one-seq (msg notation offset seq)
+ ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the
+ ;; message with the CHARACTER at the given OFFSET from the beginning of the
+ ;; listing line.
+ (let ((in-seqs (mh-seq-containing-msg msg)))
+ (if (and (eq seq (car in-seqs)) (null (cdr in-seqs)))
+ (mh-notate msg notation offset))))
+
+
+(defun mh-map-to-seq-msgs (func seq &rest args)
+ ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the
+ ;; remaining ARGS as arguments.
+ (save-excursion
+ (let ((msgs (mh-seq-to-msgs seq)))
+ (while msgs
+ (if (mh-goto-msg (car msgs) t t)
+ (apply func (car msgs) args))
+ (setq msgs (cdr msgs))))))
+
+
+(defun mh-map-over-seqs (func seq-list)
+ ;; Apply the FUNCTION to each element in the list of SEQUENCES,
+ ;; passing the sequence name and the list of messages as arguments.
+ (while seq-list
+ (funcall func (mh-seq-name (car seq-list)) (mh-seq-msgs (car seq-list)))
+ (setq seq-list (cdr seq-list))))
+
+
+(defun mh-define-sequences (seq-list)
+ ;; Define the sequences in SEQ-LIST.
+ (mh-map-over-seqs 'mh-define-sequence seq-list))
+
+
+(defun mh-add-to-sequence (seq msgs)
+ ;; Add to a SEQUENCE each message the list of MSGS.
+ (if (not (mh-folder-name-p seq))
+ (if msgs
+ (apply 'mh-exec-cmd "mark" mh-current-folder
+ "-sequence" (symbol-name seq)
+ "-add" msgs))))
+
+
+(defun mh-define-sequence (seq msgs)
+ ;; Define the SEQUENCE to contain the list of MSGS. Do not mark
+ ;; pseudo-sequences or empty sequences.
+ (if (and msgs
+ (not (mh-folder-name-p seq)))
+ (save-excursion
+ (apply 'mh-exec-cmd "mark" mh-current-folder
+ "-sequence" (symbol-name seq)
+ "-add" "-zero" (mh-list-to-string msgs)))))
+
+
+(defun mh-undefine-sequence (seq msgs)
+ ;; Remove from the SEQUENCE the list of MSGS.
+ (apply 'mh-exec-cmd "mark" mh-current-folder
+ "-sequence" (symbol-name seq)
+ "-delete" msgs))
+
+
+(defun mh-copy-seq-to-point (seq location)
+ ;; Copy the scan listing of the messages in SEQUENCE to after the point
+ ;; LOCATION in the current buffer.
+ (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location))
+
+
+(defun mh-copy-line-to-point (msg location)
+ ;; Copy the current line to the LOCATION in the current buffer.
+ (beginning-of-line)
+ (let ((beginning-of-line (point)))
+ (forward-line 1)
+ (copy-region-as-kill beginning-of-line (point))
+ (goto-char location)
+ (yank)
+ (goto-char beginning-of-line)))
+
+\f
+
+;;; Issue commands to MH.
+
+(defun mh-exec-cmd (command &rest args)
+ ;; Execute MH command COMMAND with ARGS.
+ ;; Any output is assumed to be an error and is shown to the user.
+ (save-excursion
+ (set-buffer " *mh-temp*")
+ (erase-buffer)
+ (apply 'call-process
+ (expand-file-name command mh-progs) nil t nil
+ (mh-list-to-string args))
+ (if (> (buffer-size) 0)
+ (save-window-excursion
+ (switch-to-buffer-other-window " *mh-temp*")
+ (sit-for 5)))))
+
+
+(defun mh-exec-cmd-quiet (buffer command &rest args)
+ ;; In BUFFER, execute MH command COMMAND with ARGS.
+ ;; ARGS is a list of strings. Return in BUFFER, if one exists.
+ (mh-when (stringp buffer)
+ (set-buffer buffer)
+ (erase-buffer))
+ (apply 'call-process
+ (expand-file-name command mh-progs) nil buffer nil
+ args))
+
+
+(defun mh-exec-cmd-output (command display &rest args)
+ ;; Execute MH command COMMAND with DISPLAY flag and ARGS putting the output
+ ;; into buffer after point. Set mark after inserted text.
+ (push-mark (point) t)
+ (apply 'call-process
+ (expand-file-name command mh-progs) nil t display
+ (mh-list-to-string args))
+ (exchange-point-and-mark))
+
+
+(defun mh-exec-cmd-daemon (command &rest args)
+ ;; Execute MH command COMMAND with ARGS. Any output from command is
+ ;; displayed in an asynchronous pop-up window.
+ (save-excursion
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer))
+ (let ((process (apply 'start-process
+ command nil
+ (expand-file-name command mh-progs)
+ (mh-list-to-string args))))
+ (set-process-filter process 'mh-process-daemon)))
+
+
+(defun mh-process-daemon (process output)
+ ;; Process daemon that puts output into a temporary buffer.
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (insert-before-markers output)
+ (display-buffer " *mh-temp*"))
+
+
+(defun mh-exec-lib-cmd-output (command &rest args)
+ ;; Execute MH library command COMMAND with ARGS.
+ ;; Put the output into buffer after point. Set mark after inserted text.
+ (push-mark (point) t)
+ (apply 'call-process
+ (expand-file-name command mh-lib) nil t nil
+ (mh-list-to-string args))
+ (exchange-point-and-mark))
+
+
+(defun mh-list-to-string (l)
+ ;; Flattens the list L and makes every element of the new list into a string.
+ (let ((new-list nil))
+ (while l
+ (cond ((null (car l)))
+ ((symbolp (car l)) (mh-push (symbol-name (car l)) new-list))
+ ((numberp (car l)) (mh-push (int-to-string (car l)) new-list))
+ ((equal (car l) ""))
+ ((stringp (car l)) (mh-push (car l) new-list))
+ ((listp (car l))
+ (setq new-list (nconc (nreverse (mh-list-to-string (car l)))
+ new-list)))
+ (t (error "Bad element in mh-list-to-string: %s" (car l))))
+ (setq l (cdr l)))
+ (nreverse new-list)))
+
+\f
+
+;;; Commands to annotate a message.
+
+(defun mh-annotate-msg (msg buffer note &rest args)
+ ;; Mark the MESSAGE in BUFFER listing with the character NOTE and annotate
+ ;; the saved message with ARGS.
+ (apply 'mh-exec-cmd "anno" buffer msg args)
+ (save-excursion
+ (cond ((get-buffer buffer) ; Buffer may be deleted
+ (set-buffer buffer)
+ (if (symbolp msg)
+ (mh-notate-seq msg note (1+ mh-cmd-note))
+ (mh-notate msg note (1+ mh-cmd-note)))))))
+
+
+(defun mh-notate (msg notation offset)
+ ;; Marks MESSAGE with the character NOTATION at position OFFSET.
+ ;; Null MESSAGE means the message that the cursor points to.
+ (save-excursion
+ (if (or (null msg)
+ (mh-goto-msg msg t t))
+ (with-mh-folder-updating (t)
+ (beginning-of-line)
+ (forward-char offset)
+ (delete-char 1)
+ (insert notation)))))
+
+\f
+
+;;; User prompting commands.
+
+(defun mh-prompt-for-folder (prompt default can-create)
+ ;; Prompt for a folder name with PROMPT. Returns the folder's name.
+ ;; DEFAULT is used if the folder exists and the user types return.
+ ;; If the CAN-CREATE flag is t, then a non-existant folder is made.
+ (let* ((prompt (format "%s folder%s" prompt
+ (if (equal "" default)
+ "? "
+ (format " [%s]? " default))))
+ name)
+ (if (null mh-folder-list)
+ (setq mh-folder-list (mh-make-folder-list)))
+ (while (and (setq name (completing-read prompt mh-folder-list
+ nil nil "+"))
+ (equal name "")
+ (equal default "")))
+ (cond ((or (equal name "") (equal name "+"))
+ (setq name default))
+ ((not (mh-folder-name-p name))
+ (setq name (format "+%s" name))))
+ (let ((new-file-p (not (file-exists-p (mh-expand-file-name name)))))
+ (cond ((and new-file-p
+ (y-or-n-p
+ (format "Folder %s does not exist. Create it? " name)))
+ (message "Creating %s" name)
+ (call-process "mkdir" nil nil nil (mh-expand-file-name name))
+ (message "Creating %s...done" name)
+ (mh-push (list name) mh-folder-list)
+ (mh-push (list (substring name 1 nil)) mh-folder-list))
+ (new-file-p
+ (error "Folder %s is not created" name))
+ (t
+ (mh-when (null (assoc name mh-folder-list))
+ (mh-push (list name) mh-folder-list)
+ (mh-push (list (substring name 1 nil)) mh-folder-list)))))
+ name))
+
+
+(defun mh-make-folder-list ()
+ "Return a list of the user's folders.
+Result is in a form suitable for completing read."
+ (interactive)
+ (message "Collecting folder names...")
+ (save-window-excursion
+ (mh-exec-cmd-quiet " *mh-temp*" "folders" "-fast"
+ (if mh-recursive-folders
+ "-recurse"
+ "-norecurse"))
+ (goto-char (point-min))
+ (let ((list nil)
+ start)
+ (while (not (eobp))
+ (setq start (point))
+ (forward-line 1)
+ (mh-push (list (format "+%s" (buffer-substring start (1- (point)))))
+ list))
+ (message "Collecting folder names...done")
+ list)))
+
+
+(defun mh-remove-folder-from-folder-list (folder)
+ ;; Remove FOLDER from the list of folders.
+ (setq mh-folder-list
+ (delq (assoc folder mh-folder-list) mh-folder-list)))
+
+
+(defun mh-read-msg-range (prompt)
+ ;; Read a list of blank-separated items.
+ (let* ((buf (read-string prompt))
+ (buf-size (length buf))
+ (start 0)
+ (input ()))
+ (while (< start buf-size)
+ (let ((next (read-from-string buf start buf-size)))
+ (mh-push (car next) input)
+ (setq start (cdr next))))
+ (nreverse input)))
+
+\f
+
+;;; Misc. functions.
+
+(defun mh-get-msg-num (error-if-no-message)
+ ;; Return the message number of the displayed message. If the argument
+ ;; ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not
+ ;; pointing to a message.
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at mh-msg-number-regexp)
+ (string-to-int (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (error-if-no-message
+ (error "Cursor not pointing to message"))
+ (t nil))))
+
+
+(defun mh-msg-search-pat (n)
+ ;; Return a search pattern for message N in the scan listing.
+ (format mh-msg-search-regexp n))
+
+
+(defun mh-msg-filename (msg &optional folder)
+ ;; Return the file name of MESSAGE in FOLDER (default current folder).
+ (expand-file-name (int-to-string msg)
+ (if folder
+ (mh-expand-file-name folder)
+ mh-folder-filename)))
+
+
+(defun mh-msg-filenames (msgs &optional folder)
+ ;; Return a list of file names for MSGS in FOLDER (default current folder).
+ (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " "))
+
+
+(defun mh-expand-file-name (filename &optional default)
+ "Just like expand-file-name, but also handles MH folder names.
+Assumes that any filename that starts with '+' is a folder name."
+ (if (mh-folder-name-p filename)
+ (expand-file-name (substring filename 1) mh-user-path)
+ (expand-file-name filename default)))
+
+
+(defun mh-find-path ()
+ ;; Set mh-user-path, mh-draft-folder, and mh-unseen-seq from profile file.
+ (save-excursion
+ ;; Be sure profile is fully expanded before switching buffers
+ (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile"))))
+ (if (not (file-exists-p profile))
+ (error "Cannot find MH profile %s" profile))
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer)
+ (insert-file-contents profile)
+ (setq mh-draft-folder (mh-get-field "Draft-Folder:"))
+ (cond ((equal mh-draft-folder "")
+ (setq mh-draft-folder nil))
+ ((not (mh-folder-name-p mh-draft-folder))
+ (setq mh-draft-folder (format "+%s" mh-draft-folder))))
+ (setq mh-user-path (mh-get-field "Path:"))
+ (if (equal mh-user-path "")
+ (setq mh-user-path "Mail"))
+ (setq mh-user-path
+ (file-name-as-directory
+ (expand-file-name mh-user-path (expand-file-name "~"))))
+ (if (and mh-draft-folder
+ (not (file-exists-p (mh-expand-file-name mh-draft-folder))))
+ (error "Draft folder %s does not exist. Create it and try again."
+ mh-draft-folder))
+ (setq mh-unseen-seq (mh-get-field "Unseen-Sequence:"))
+ (if (equal mh-unseen-seq "")
+ (setq mh-unseen-seq 'unseen)
+ (setq mh-unseen-seq (intern mh-unseen-seq))))))
+
+
+(defun mh-get-field (field)
+ ;; Find and return the value of field FIELD in the current buffer.
+ ;; Returns the empty string if the field is not in the message.
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (cond ((not (search-forward field nil t)) "")
+ ((looking-at "[\t ]*$") "")
+ (t
+ (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t)
+ (let ((field (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ (end-of-match (point)))
+ (forward-line)
+ (while (looking-at "[ \t]") (forward-line 1))
+ (backward-char 1)
+ (if (<= (point) end-of-match)
+ field
+ (format "%s%s"
+ field
+ (buffer-substring end-of-match (point)))))))))
+
+
+(defun mh-insert-fields (&rest name-values)
+ ;; Insert the NAME-VALUE pairs in the current buffer.
+ ;; Do not insert any pairs whose value is the empty string.
+ (let ((case-fold-search t))
+ (while name-values
+ (let ((field-name (car name-values))
+ (value (car (cdr name-values))))
+ (mh-when (not (equal value ""))
+ (goto-char (point-min))
+ (cond ((not (re-search-forward (format "^%s" field-name) nil t))
+ (mh-goto-header-end 0)
+ (insert field-name " " value "\n"))
+ (t
+ (end-of-line)
+ (insert " " value))))
+ (setq name-values (cdr (cdr name-values)))))))
+
+
+(defun mh-position-on-field (field set-mark)
+ ;; Set point to the end of the line beginning with FIELD.
+ ;; Set the mark to the old value of point, if SET-MARK is non-nil.
+ (let ((case-fold-search t))
+ (if set-mark (push-mark))
+ (goto-char (point-min))
+ (mh-goto-header-end 0)
+ (if (re-search-backward (format "^%s" field) nil t)
+ (progn (end-of-line) t)
+ nil)))
+
+
+(defun mh-goto-header-end (arg)
+ ;; Find the end of the message header in the current buffer and position
+ ;; the cursor at the ARG'th newline after the header.
+ (if (re-search-forward "^$\\|^-+$" nil nil)
+ (forward-line arg)))
+
+\f
+
+;;; Build the folder-mode keymap:
+
+(suppress-keymap mh-folder-mode-map)
+(define-key mh-folder-mode-map "q" 'mh-quit)
+(define-key mh-folder-mode-map "b" 'mh-quit)
+(define-key mh-folder-mode-map "?" 'mh-msg-is-in-seq)
+(define-key mh-folder-mode-map "%" 'mh-put-msg-in-seq)
+(define-key mh-folder-mode-map "|" 'mh-pipe-msg)
+(define-key mh-folder-mode-map "\ea" 'mh-edit-again)
+(define-key mh-folder-mode-map "\e%" 'mh-delete-msg-from-seq)
+(define-key mh-folder-mode-map "\C-xn" 'mh-narrow-to-seq)
+(define-key mh-folder-mode-map "\C-xw" 'mh-widen)
+(define-key mh-folder-mode-map "\eb" 'mh-burst-digest)
+(define-key mh-folder-mode-map "\eu" 'mh-undo-folder)
+(define-key mh-folder-mode-map "\e " 'mh-page-digest)
+(define-key mh-folder-mode-map "\e\177" 'mh-page-digest-backwards)
+(define-key mh-folder-mode-map "\ee" 'mh-extract-rejected-mail)
+(define-key mh-folder-mode-map "\ef" 'mh-visit-folder)
+(define-key mh-folder-mode-map "\ek" 'mh-kill-folder)
+(define-key mh-folder-mode-map "\el" 'mh-list-folders)
+(define-key mh-folder-mode-map "\eo" 'mh-write-msg-to-file)
+(define-key mh-folder-mode-map "\ep" 'mh-pack-folder)
+(define-key mh-folder-mode-map "\es" 'mh-search-folder)
+(define-key mh-folder-mode-map "\er" 'mh-rescan-folder)
+(define-key mh-folder-mode-map "l" 'mh-print-msg)
+(define-key mh-folder-mode-map "t" 'mh-toggle-showing)
+(define-key mh-folder-mode-map "c" 'mh-copy-msg)
+(define-key mh-folder-mode-map ">" 'mh-write-msg-to-file)
+(define-key mh-folder-mode-map "i" 'mh-inc-folder)
+(define-key mh-folder-mode-map "x" 'mh-execute-commands)
+(define-key mh-folder-mode-map "e" 'mh-execute-commands)
+(define-key mh-folder-mode-map "r" 'mh-redistribute)
+(define-key mh-folder-mode-map "f" 'mh-forward)
+(define-key mh-folder-mode-map "s" 'mh-send)
+(define-key mh-folder-mode-map "m" 'mh-send)
+(define-key mh-folder-mode-map "a" 'mh-reply)
+(define-key mh-folder-mode-map "j" 'mh-goto-msg)
+(define-key mh-folder-mode-map "g" 'mh-goto-msg)
+(define-key mh-folder-mode-map "\177" 'mh-previous-page)
+(define-key mh-folder-mode-map " " 'mh-page-msg)
+(define-key mh-folder-mode-map "." 'mh-show)
+(define-key mh-folder-mode-map "u" 'mh-undo)
+(define-key mh-folder-mode-map "!" 'mh-refile-or-write-again)
+(define-key mh-folder-mode-map "^" 'mh-refile-msg)
+(define-key mh-folder-mode-map "d" 'mh-delete-msg)
+(define-key mh-folder-mode-map "\C-d" 'mh-delete-msg-no-motion)
+(define-key mh-folder-mode-map "p" 'mh-previous-undeleted-msg)
+(define-key mh-folder-mode-map "n" 'mh-next-undeleted-msg)
+(define-key mh-folder-mode-map "o" 'mh-refile-msg)
+
+
+;;; Build the letter-mode keymap:
+
+(define-key mh-letter-mode-map "\C-c\C-f\C-b" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-f\C-c" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-f\C-f" 'mh-to-fcc)
+(define-key mh-letter-mode-map "\C-c\C-f\C-s" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-f\C-t" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-fb" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-fc" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-ff" 'mh-to-fcc)
+(define-key mh-letter-mode-map "\C-c\C-fs" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-ft" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-q" 'mh-fully-kill-draft)
+(define-key mh-letter-mode-map "\C-c\C-w" 'mh-check-whom)
+(define-key mh-letter-mode-map "\C-c\C-i" 'mh-insert-letter)
+(define-key mh-letter-mode-map "\C-c\C-y" 'mh-yank-cur-msg)
+(define-key mh-letter-mode-map "\C-c\C-s" 'mh-insert-signature)
+(define-key mh-letter-mode-map "\C-c\C-c" 'mh-send-letter)
+
+
+;;; Build the pick-mode keymap:
+
+(define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search)
+(define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-w" 'mh-check-whom)
+
+\f
+
+;;; For Gnu Emacs.
+;;; Local Variables: ***
+;;; eval: (put 'mh-when 'lisp-indent-hook 1) ***
+;;; eval: (put 'with-mh-folder-updating 'lisp-indent-hook 1) ***
+;;; End: ***
+
--- /dev/null
+;; Mim (MDL in MDL) mode.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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.
+
+
+(provide 'mim-mode)
+
+(autoload 'fast-syntax-check-mim "mim-syntax"
+ "Checks Mim syntax quickly.
+Answers correct or incorrect, cannot point out the error context."
+ t)
+
+(autoload 'slow-syntax-check-mim "mim-syntax"
+ "Check Mim syntax slowly.
+Points out the context of the error, if the syntax is incorrect."
+ t)
+
+(defvar mim-mode-hysterical-bindings t
+ "*Non-nil means bind list manipulation commands to Meta keys as well as
+Control-Meta keys for historical reasons. Otherwise, only the latter keys
+are bound.")
+
+(defvar mim-mode-map nil)
+
+(defvar mim-mode-syntax-table nil)
+
+(if mim-mode-syntax-table
+ ()
+ (let ((i -1))
+ (setq mim-mode-syntax-table (make-syntax-table))
+ (while (< i ?\ )
+ (modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table))
+ (while (< i 127)
+ (modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table))
+ (setq i (1- ?a))
+ (while (< i ?z)
+ (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
+ (setq i (1- ?A))
+ (while (< i ?Z)
+ (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
+ (setq i (1- ?0))
+ (while (< i ?9)
+ (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
+ (modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter
+ (modify-syntax-entry ?, "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?. "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?' "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?` "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?~ "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects
+ (modify-syntax-entry ?# "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?% "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?! "' " mim-mode-syntax-table)
+ (modify-syntax-entry ?\" "\" " mim-mode-syntax-table)
+ (modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table)
+ (modify-syntax-entry ?\( "\() " mim-mode-syntax-table)
+ (modify-syntax-entry ?\< "\(> " mim-mode-syntax-table)
+ (modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table)
+ (modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table)
+ (modify-syntax-entry ?\) "\)( " mim-mode-syntax-table)
+ (modify-syntax-entry ?\> "\)< " mim-mode-syntax-table)
+ (modify-syntax-entry ?\} "\){ " mim-mode-syntax-table)
+ (modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table)))
+
+(defconst mim-whitespace "\000- ")
+
+(defvar mim-mode-hook nil
+ "*User function run after mim mode initialization. Usage:
+\(setq mim-mode-hook '(lambda () ... your init forms ...)).")
+
+(define-abbrev-table 'mim-mode-abbrev-table nil)
+
+(defconst indent-mim-hook 'indent-mim-hook
+ "Controls (via properties) indenting of special forms.
+\(put 'FOO 'indent-mim-hook n\), integer n, means lines inside
+<FOO ...> will be indented n spaces from start of form.
+\(put 'FOO 'indent-mim-hook 'DEFINE\) is like above but means use
+value of mim-body-indent as offset from start of form.
+\(put 'FOO 'indent-mim-hook <cons>\) where <cons> is a list or pointted list
+of integers, means indent each form in <FOO ...> by the amount specified
+in <cons>. When <cons> is exhausted, indent remaining forms by
+mim-body-indent unless <cons> is a pointted list, in which case the last
+cdr is used. Confused? Here is an example:
+\(put 'FROBIT 'indent-mim-hook '\(4 2 . 1\)\)
+<FROBIT
+ <CHOMP-IT>
+ <CHOMP-SOME-MORE>
+ <DIGEST>
+ <BELCH>
+ ...>
+Finally, the property can be a function name (read the code).")
+
+(defvar indent-mim-comment t
+ "*Non-nil means indent string comments.")
+
+(defvar mim-body-indent 2
+ "*Amount to indent in special forms which have DEFINE property on
+indent-mim-hook.")
+
+(defvar indent-mim-arglist t
+ "*nil means indent arglists like ordinary lists.
+t means strings stack under start of arglist and variables stack to
+right of them. Otherwise, strings stack under last string (or start
+of arglist if none) and variables stack to right of them.
+Examples (for values 'stack, t, nil):
+
+\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR
+ BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE
+ \"AUX\" \"AUX\" \"AUX\"
+ BLETCH ... BLETCH ... BLETCH ...")
+
+(put 'DEFINE 'indent-mim-hook 'DEFINE)
+(put 'DEFMAC 'indent-mim-hook 'DEFINE)
+(put 'BIND 'indent-mim-hook 'DEFINE)
+(put 'PROG 'indent-mim-hook 'DEFINE)
+(put 'REPEAT 'indent-mim-hook 'DEFINE)
+(put 'CASE 'indent-mim-hook 'DEFINE)
+(put 'FUNCTION 'indent-mim-hook 'DEFINE)
+(put 'MAPF 'indent-mim-hook 'DEFINE)
+(put 'MAPR 'indent-mim-hook 'DEFINE)
+(put 'UNWIND 'indent-mim-hook (cons (* 2 mim-body-indent) mim-body-indent))
+
+(defvar mim-down-parens-only t
+ "*nil means treat ADECLs and ATOM trailers like structures when
+moving down a level of structure.")
+
+(defvar mim-stop-for-slop t
+ "*Non-nil means {next previous}-mim-object consider any
+non-whitespace character in column 0 to be a toplevel object, otherwise
+only open paren syntax characters will be considered.")
+
+(fset 'mdl-mode 'mim-mode)
+
+(defun mim-mode ()
+ "Major mode for editing Mim (MDL in MDL) code.
+Commands:
+ If value of mim-mode-hysterical-bindings is non-nil, then following
+commands are assigned to escape keys as well (e.g. M-f = M-C-f).
+The default action is bind the escape keys.
+ Tab Indents the current line as MDL code.
+ Delete Converts tabs to spaces as it moves back.
+ M-C-f Move forward over next mim object.
+ M-C-b Move backward over previous mim object.
+ M-C-p Move to beginning of previous toplevel mim object.
+ M-C-n Move to the beginning of the next toplevel mim object.
+ M-C-a Move to the top of surrounding toplevel mim form.
+ M-C-e Move to the end of surrounding toplevel mim form.
+ M-C-u Move up a level of mim structure backwards.
+ M-C-d Move down a level of mim structure forwards.
+ M-C-t Transpose mim objects on either side of point.
+ M-C-k Kill next mim object.
+ M-C-h Place mark at end of next mim object.
+ M-C-o Insert a newline before current line and indent.
+ M-Delete Kill previous mim object.
+ M-^ Join current line to previous line.
+ M-\\ Delete whitespace around point.
+ M-; Move to existing comment or insert empty comment if none.
+ M-Tab Indent following mim object and all contained lines.
+Other Commands:
+ Use \\[describe-function] to obtain documentation.
+ replace-in-mim-object find-mim-definition fast-syntax-check-mim
+ slow-syntax-check-mim backward-down-mim-object forward-up-mim-object
+Variables:
+ Use \\[describe-variable] to obtain documentation.
+ mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-hook
+ mim-body-indent mim-down-parens-only mim-stop-for-slop
+ mim-mode-hysterical-bindings
+Entry to this mode calls the value of mim-mode-hook if non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (if (not mim-mode-map)
+ (progn
+ (setq mim-mode-map (make-sparse-keymap))
+ (define-key mim-mode-map "\e\^o" 'open-mim-line)
+ (define-key mim-mode-map "\e\^q" 'indent-mim-object)
+ (define-key mim-mode-map "\e\^p" 'previous-mim-object)
+ (define-key mim-mode-map "\e\^n" 'next-mim-object)
+ (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE)
+ (define-key mim-mode-map "\e\^e" 'end-of-DEFINE)
+ (define-key mim-mode-map "\e\^t" 'transpose-mim-objects)
+ (define-key mim-mode-map "\e\^u" 'backward-up-mim-object)
+ (define-key mim-mode-map "\e\^d" 'forward-down-mim-object)
+ (define-key mim-mode-map "\e\^h" 'mark-mim-object)
+ (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object)
+ (define-key mim-mode-map "\e\^f" 'forward-mim-object)
+ (define-key mim-mode-map "\e\^b" 'backward-mim-object)
+ (define-key mim-mode-map "\e^" 'raise-mim-line)
+ (define-key mim-mode-map "\e\\" 'fixup-whitespace)
+ (define-key mim-mode-map "\177" 'backward-delete-char-untabify)
+ (define-key mim-mode-map "\e\177" 'backward-kill-mim-object)
+ (define-key mim-mode-map "\^j" 'newline-and-mim-indent)
+ (define-key mim-mode-map "\e;" 'begin-mim-comment)
+ (define-key mim-mode-map "\t" 'indent-mim-line)
+ (define-key mim-mode-map "\e\t" 'indent-mim-object)
+ (if (not mim-mode-hysterical-bindings)
+ nil
+ ;; i really hate this but too many people are accustomed to these.
+ (define-key mim-mode-map "\e!" 'line-to-top-of-window)
+ (define-key mim-mode-map "\eo" 'open-mim-line)
+ (define-key mim-mode-map "\ep" 'previous-mim-object)
+ (define-key mim-mode-map "\en" 'next-mim-object)
+ (define-key mim-mode-map "\ea" 'beginning-of-DEFINE)
+ (define-key mim-mode-map "\ee" 'end-of-DEFINE)
+ (define-key mim-mode-map "\et" 'transpose-mim-objects)
+ (define-key mim-mode-map "\eu" 'backward-up-mim-object)
+ (define-key mim-mode-map "\ed" 'forward-down-mim-object)
+ (define-key mim-mode-map "\ek" 'forward-kill-mim-object)
+ (define-key mim-mode-map "\ef" 'forward-mim-object)
+ (define-key mim-mode-map "\eb" 'backward-mim-object))))
+ (use-local-map mim-mode-map)
+ (set-syntax-table mim-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ ;; Most people use string comments.
+ (make-local-variable 'comment-start)
+ (setq comment-start ";\"")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip ";\"")
+ (make-local-variable 'comment-end)
+ (setq comment-end "\"")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'indent-mim-comment)
+ ;; tell generic indenter how to indent.
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'indent-mim-line)
+ ;; look for that paren
+ (make-local-variable 'blink-matching-paren-distance)
+ (setq blink-matching-paren-distance nil)
+ ;; so people who dont like tabs can turn them off locally in indenter.
+ (make-local-variable 'indent-tabs-mode)
+ (setq indent-tabs-mode t)
+ (setq local-abbrev-table mim-mode-abbrev-table)
+ (setq major-mode 'mim-mode)
+ (setq mode-name "Mim")
+ (run-hooks 'mim-mode-hook))
+
+(defun line-to-top-of-window ()
+ "Move current line to top of window."
+ (interactive) ; for lazy people
+ (recenter 0))
+
+(defun forward-mim-object (arg)
+ "Move forward across Mim object.
+With ARG, move forward that many objects."
+ (interactive "p")
+ ;; this function is wierd because it emulates the behavior of the old
+ ;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL,
+ ;; more than one character into the ATOM part and not sitting on the
+ ;; colon, then we move to the DECL part (just past colon) instead of
+ ;; the end of the object (the entire ADECL). otherwise, ADECL's are
+ ;; atomic objects. likewise for ATOM trailers.
+ (if (= (abs arg) 1)
+ (if (inside-atom-p)
+ ;; Move to end of ATOM or to trailer (!) or to ADECL (:).
+ (forward-sexp arg)
+ ;; Either scan an sexp or move over one bracket.
+ (forward-mim-objects arg t))
+ ;; in the multi-object case, don't perform any magic.
+ ;; treats ATOM trailers and ADECLs atomically, stops at unmatched
+ ;; brackets with error.
+ (forward-mim-objects arg)))
+
+(defun inside-atom-p ()
+ ;; Returns t iff inside an atom (takes account of trailers)
+ (let ((c1 (preceding-char))
+ (c2 (following-char)))
+ (and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!))
+ (or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!)))))
+
+(defun forward-mim-objects (arg &optional skip-bracket-p)
+ ;; Move over arg objects ignoring ADECLs and trailers. If
+ ;; skip-bracket-p is non-nil, then move over one bracket on error.
+ (let ((direction (sign arg)))
+ (condition-case conditions
+ (while (/= arg 0)
+ (forward-sexp direction)
+ (if (not (inside-adecl-or-trailer-p direction))
+ (setq arg (- arg direction))))
+ (error (if (not skip-bracket-p)
+ (signal 'error (cdr conditions))
+ (skip-mim-whitespace direction)
+ (goto-char (+ (point) direction)))))
+ ;; If we moved too far move back to first interesting character.
+ (if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction)))))
+
+(defun backward-mim-object (&optional arg)
+ "Move backward across Mim object.
+With ARG, move backward that many objects."
+ (interactive "p")
+ (forward-mim-object (if arg (- arg) -1)))
+
+(defun mark-mim-object (&optional arg)
+ "Mark following Mim object.
+With ARG, mark that many following (preceding, ARG < 0) objects."
+ (interactive "p")
+ (push-mark (save-excursion (forward-mim-object (or arg 1)) (point))))
+
+(defun forward-kill-mim-object (&optional arg)
+ "Kill following Mim object.
+With ARG, kill that many objects."
+ (interactive "*p")
+ (kill-region (point) (progn (forward-mim-object (or arg 1)) (point))))
+
+(defun backward-kill-mim-object (&optional arg)
+ "Kill preceding Mim object.
+With ARG, kill that many objects."
+ (interactive "*p")
+ (forward-kill-mim-object (- (or arg 1))))
+
+(defun raise-mim-line (&optional arg)
+ "Raise following line, fixing up whitespace at join.
+With ARG raise that many following lines.
+A negative ARG will raise current line and previous lines."
+ (interactive "*p")
+ (let* ((increment (sign (or arg (setq arg 1))))
+ (direction (if (> arg 0) 1 0)))
+ (save-excursion
+ (while (/= arg 0)
+ ;; move over eol and kill it
+ (forward-line direction)
+ (delete-region (point) (1- (point)))
+ (fixup-whitespace)
+ (setq arg (- arg increment))))))
+
+(defun forward-down-mim-object (&optional arg)
+ "Move down a level of Mim structure forwards.
+With ARG, move down that many levels forwards (backwards, ARG < 0)."
+ (interactive "p")
+ ;; another wierdo - going down `inside' an ADECL or ATOM trailer
+ ;; depends on the value of mim-down-parens-only. if nil, treat
+ ;; ADECLs and trailers as structured objects.
+ (let ((direction (sign (or arg (setq arg 1)))))
+ (if (and (= (abs arg) 1) (not mim-down-parens-only))
+ (goto-char
+ (save-excursion
+ (skip-mim-whitespace direction)
+ (if (> direction 0) (re-search-forward "\\s'*"))
+ (or (and (let ((c (next-char direction)))
+ (or (= (char-syntax c) ?_)
+ (= (char-syntax c) ?w)))
+ (progn (forward-sexp direction)
+ (if (inside-adecl-or-trailer-p direction)
+ (point))))
+ (scan-lists (point) direction -1)
+ (buffer-end direction))))
+ (while (/= arg 0)
+ (goto-char (or (scan-lists (point) direction -1) (buffer-end direction)))
+ (setq arg (- arg direction))))))
+
+(defun backward-down-mim-object (&optional arg)
+ "Move down a level of Mim structure backwards.
+With ARG, move down that many levels backwards (forwards, ARG < 0)."
+ (interactive "p")
+ (forward-down-mim-object (if arg (- arg) -1)))
+
+(defun forward-up-mim-object (&optional arg)
+ "Move up a level of Mim structure forwards
+With ARG, move up that many levels forwards (backwards, ARG < 0)."
+ (interactive "p")
+ (let ((direction (sign (or arg (setq arg 1)))))
+ (while (/= arg 0)
+ (goto-char (or (scan-lists (point) direction 1) (buffer-end arg)))
+ (setq arg (- arg direction)))
+ (if (< direction 0) (backward-prefix-chars))))
+
+(defun backward-up-mim-object (&optional arg)
+ "Move up a level of Mim structure backwards
+With ARG, move up that many levels backwards (forwards, ARG > 0)."
+ (interactive "p")
+ (forward-up-mim-object (if arg (- arg) -1)))
+
+(defun replace-in-mim-object (old new)
+ "Replace string in following Mim object."
+ (interactive "*sReplace in object: \nsReplace %s with: ")
+ (save-restriction
+ (narrow-to-region (point) (save-excursion (forward-mim-object 1) (point)))
+ (replace-string old new)))
+
+(defun transpose-mim-objects (&optional arg)
+ "Transpose Mim objects around point.
+With ARG, transpose preceding object that many times with following objects.
+A negative ARG will transpose backwards."
+ (interactive "*p")
+ (transpose-subr 'forward-mim-object (or arg 1)))
+
+(defun beginning-of-DEFINE (&optional arg move)
+ "Move backward to beginning of surrounding or previous toplevel Mim form.
+With ARG, do it that many times. Stops at last toplevel form seen if buffer
+end is reached."
+ (interactive "p")
+ (let ((direction (sign (or arg (setq arg 1)))))
+ (if (not move) (setq move t))
+ (if (< direction 0) (goto-char (1+ (point))))
+ (while (and (/= arg 0) (re-search-backward "^<" nil move direction))
+ (setq arg (- arg direction)))
+ (if (< direction 0)
+ (goto-char (1- (point))))))
+
+(defun end-of-DEFINE (&optional arg)
+ "Move forward to end of surrounding or next toplevel mim form.
+With ARG, do it that many times. Stops at end of last toplevel form seen
+if buffer end is reached."
+ (interactive "p")
+ (if (not arg) (setq arg 1))
+ (if (< arg 0)
+ (beginning-of-DEFINE (- (1- arg)))
+ (if (not (looking-at "^<")) (setq arg (1+ arg)))
+ (beginning-of-DEFINE (- arg) 'move)
+ (beginning-of-DEFINE 1))
+ (forward-mim-object 1)
+ (forward-line 1))
+
+(defun next-mim-object (&optional arg)
+ "Move to beginning of next toplevel Mim object.
+With ARG, do it that many times. Stops at last object seen if buffer end
+is reached."
+ (interactive "p")
+ (let ((search-string (if mim-stop-for-slop "^\\S " "^\\s("))
+ (direction (sign (or arg (setq arg 1)))))
+ (if (> direction 0)
+ (goto-char (1+ (point)))) ; no error if end of buffer
+ (while (and (/= arg 0)
+ (re-search-forward search-string nil t direction))
+ (setq arg (- arg direction)))
+ (if (> direction 0)
+ (goto-char (1- (point)))) ; no error if beginning of buffer
+ ;; scroll to top of window if moving forward and end not visible.
+ (if (not (or (< direction 0)
+ (save-excursion (forward-mim-object 1)
+ (pos-visible-in-window-p (point)))))
+ (recenter 0))))
+
+(defun previous-mim-object (&optional arg)
+ "Move to beginning of previous toplevel Mim object.
+With ARG do it that many times. Stops at last object seen if buffer end
+is reached."
+ (interactive "p")
+ (next-mim-object (- (or arg 1))))
+
+(defun calculate-mim-indent (&optional parse-start)
+ "Calculate indentation for Mim line. Returns column."
+ (save-excursion ; some excursion, huh, toto?
+ (beginning-of-line)
+ (let ((indent-point (point)) retry state containing-sexp last-sexp
+ desired-indent start peek where paren-depth)
+ (if parse-start
+ (goto-char parse-start) ; should be containing environment
+ (catch 'from-the-top
+ ;; find a place to start parsing. going backwards is fastest.
+ ;; forward-sexp signals error on encountering unmatched open.
+ (setq retry t)
+ (while retry
+ (condition-case nil (forward-sexp -1) (error (setq retry nil)))
+ (if (looking-at ".?[ \t]*\"")
+ ;; cant parse backward in presence of strings, go forward.
+ (progn
+ (goto-char indent-point)
+ (re-search-backward "^\\s(" nil 'move 1) ; to top of object
+ (throw 'from-the-top nil)))
+ (setq retry (and retry (/= (current-column) 0))))
+ (skip-chars-backward mim-whitespace)
+ (if (not (bobp)) (forward-char -1)) ; onto unclosed open
+ (backward-prefix-chars)))
+ ;; find outermost containing sexp if we started inside an sexp.
+ (while (< (point) indent-point)
+ (setq state (parse-partial-sexp (point) indent-point 0)))
+ ;; find usual column to indent under (not in string or toplevel).
+ ;; on termination, state will correspond to containing environment
+ ;; (if retry is nil), where will be position of character to indent
+ ;; under normally, and desired-indent will be the column to indent to
+ ;; except if inside form, string, or at toplevel. point will be in
+ ;; in column to indent to unless inside string.
+ (setq retry t)
+ (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
+ ;; find innermost containing sexp.
+ (setq retry nil)
+ (setq last-sexp (car (nthcdr 2 state)))
+ (setq containing-sexp (car (cdr state)))
+ (goto-char (1+ containing-sexp)) ; to last unclosed open
+ (if (and last-sexp (> last-sexp (point)))
+ ;; is the last sexp a containing sexp?
+ (progn (setq peek (parse-partial-sexp last-sexp indent-point 0))
+ (if (setq retry (car (cdr peek))) (setq state peek))))
+ (if retry
+ nil
+ (setq where (1+ containing-sexp)) ; innermost containing sexp
+ (goto-char where)
+ (cond
+ ((not last-sexp) ; indent-point after bracket
+ (setq desired-indent (current-column)))
+ ((= (preceding-char) ?\<) ; it's a form
+ (cond ((> (progn (forward-sexp 1) (point)) last-sexp)
+ (goto-char where)) ; only one frob
+ ((> (save-excursion (forward-line 1) (point)) last-sexp)
+ (skip-chars-forward " \t") ; last-sexp is on same line
+ (setq where (point))) ; as containing-sexp
+ ((progn
+ (goto-char last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (or (= (point) last-sexp)
+ (save-excursion
+ (= (car (parse-partial-sexp (point) last-sexp 0))
+ 0))))
+ (backward-prefix-chars) ; last-sexp 1st on line or 1st
+ (setq where (point))) ; frob on that line level 0
+ (t (goto-char where)))) ; punt, should never occur
+ ((and indent-mim-arglist ; maybe hack arglist
+ (= (preceding-char) ?\() ; its a list
+ (save-excursion ; look for magic atoms
+ (setq peek 0) ; using peek as counter
+ (forward-char -1) ; back over containing paren
+ (while (and (< (setq peek (1+ peek)) 6)
+ (condition-case nil
+ (progn (forward-sexp -1) t)
+ (error nil))))
+ (and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION"))))
+ ;; frobs stack under strings they belong to or under first
+ ;; frob to right of strings they belong to unless luser has
+ ;; frob (non-string) on preceding line with different
+ ;; indentation. strings stack under start of arglist unless
+ ;; mim-indent-arglist is not t, in which case they stack
+ ;; under the last string, if any, else the start of the arglist.
+ (let ((eol 0) last-string)
+ (while (< (point) last-sexp) ; find out where the strings are
+ (skip-chars-forward mim-whitespace last-sexp)
+ (if (> (setq start (point)) eol)
+ (progn ; simultaneously keeping track
+ (setq where (min where start))
+ (end-of-line) ; of indentation of first frob
+ (setq eol (point)) ; on each line
+ (goto-char start)))
+ (if (= (following-char) ?\")
+ (progn (setq last-string (point))
+ (forward-sexp 1)
+ (if (= last-string last-sexp)
+ (setq where last-sexp)
+ (skip-chars-forward mim-whitespace last-sexp)
+ (setq where (point))))
+ (forward-sexp 1)))
+ (goto-char indent-point) ; if string is first on
+ (skip-chars-forward " \t" (point-max)) ; line we are indenting, it
+ (if (= (following-char) ?\") ; goes under arglist start
+ (if (and last-string (not (equal indent-mim-arglist t)))
+ (setq where last-string) ; or under last string.
+ (setq where (1+ containing-sexp)))))
+ (goto-char where)
+ (setq desired-indent (current-column)))
+ (t ; plain vanilla structure
+ (cond ((> (save-excursion (forward-line 1) (point)) last-sexp)
+ (skip-chars-forward " \t") ; last-sexp is on same line
+ (setq where (point))) ; as containing-sexp
+ ((progn
+ (goto-char last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (or (= (point) last-sexp)
+ (save-excursion
+ (= (car (parse-partial-sexp (point) last-sexp 0))
+ 0))))
+ (backward-prefix-chars) ; last-sexp 1st on line or 1st
+ (setq where (point))) ; frob on that line level 0
+ (t (goto-char where))) ; punt, should never occur
+ (setq desired-indent (current-column))))))
+ ;; state is innermost containing environment unless toplevel or string.
+ (if (car (nthcdr 3 state)) ; inside string
+ (progn
+ (if last-sexp ; string must be next
+ (progn (goto-char last-sexp)
+ (forward-sexp 1)
+ (search-forward "\"")
+ (forward-char -1))
+ (goto-char indent-point) ; toplevel string, look for it
+ (re-search-backward "[^\\]\"")
+ (forward-char 1))
+ (setq start (point)) ; opening double quote
+ (skip-chars-backward " \t")
+ (backward-prefix-chars)
+ ;; see if the string is really a comment.
+ (if (and (looking-at ";[ \t]*\"") indent-mim-comment)
+ ;; it's a comment, line up under the start unless disabled.
+ (goto-char (1+ start))
+ ;; it's a string, dont mung the indentation.
+ (goto-char indent-point)
+ (skip-chars-forward " \t"))
+ (setq desired-indent (current-column))))
+ ;; point is sitting in usual column to indent to and if retry is nil
+ ;; then state corresponds to containing environment. if desired
+ ;; indentation not determined, we are inside a form, so call hook.
+ (or desired-indent
+ (and indent-mim-hook
+ (not retry)
+ (setq desired-indent
+ (funcall indent-mim-hook state indent-point)))
+ (setq desired-indent (current-column)))
+ (goto-char indent-point) ; back to where we started
+ desired-indent))) ; return column to indent to
+
+(defun indent-mim-hook (state indent-point)
+ "Compute indentation for Mim special forms. Returns column or nil."
+ (let ((containing-sexp (car (cdr state))) (current-indent (point)))
+ (save-excursion
+ (goto-char (1+ containing-sexp))
+ (backward-prefix-chars)
+ ;; make sure we are looking at a symbol. if so, see if it is a special
+ ;; symbol. if so, add the special indentation to the indentation of
+ ;; the start of the special symbol, unless the property is not
+ ;; an integer and not nil (in this case, call the property, it must
+ ;; be a function which returns the appropriate indentation or nil and
+ ;; does not change the buffer).
+ (if (looking-at "\\sw\\|\\s_")
+ (let* ((start (current-column))
+ (function
+ (intern-soft (buffer-substring (point)
+ (progn (forward-sexp 1)
+ (point)))))
+ (method (get function 'indent-mim-hook)))
+ (if (or (if (equal method 'DEFINE) (setq method mim-body-indent))
+ (integerp method))
+ ;; only use method if its first line after containing-sexp.
+ ;; we could have done this in calculate-mim-indent, but someday
+ ;; someone might want to format frobs in a special form based
+ ;; on position instead of indenting uniformly (like lisp if),
+ ;; so preserve right for posterity. if not first line,
+ ;; calculate-mim-indent already knows right indentation -
+ ;; give luser chance to change indentation manually by changing
+ ;; 1st line after containing-sexp.
+ (if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state)))
+ (+ method start))
+ (goto-char current-indent)
+ (if (consp method)
+ ;; list or pointted list of explicit indentations
+ (indent-mim-offset state indent-point)
+ (if (and (symbolp method) (fboundp method))
+ ;; luser function - s/he better know what's going on.
+ ;; should take state and indent-point as arguments - for
+ ;; description of state, see parse-partial-sexp
+ ;; documentation the function is guaranteed the following:
+ ;; (1) state describes the closest surrounding form,
+ ;; (2) indent-point is the beginning of the line being
+ ;; indented, (3) point points to char in column that would
+ ;; normally be used for indentation, (4) function is bound
+ ;; to the special ATOM. See indent-mim-offset for example
+ ;; of a special function.
+ (funcall method state indent-point)))))))))
+
+(defun indent-mim-offset (state indent-point)
+ ;; offset forms explicitly according to list of indentations.
+ (let ((mim-body-indent mim-body-indent)
+ (indentations (get function 'indent-mim-hook))
+ (containing-sexp (car (cdr state)))
+ (last-sexp (car (nthcdr 2 state)))
+ indentation)
+ (goto-char (1+ containing-sexp))
+ ;; determine wheich of the indentations to use.
+ (while (and (< (point) indent-point)
+ (condition-case nil
+ (progn (forward-sexp 1)
+ (parse-partial-sexp (point) indent-point 1 t))
+ (error nil)))
+ (skip-chars-backward " \t")
+ (backward-prefix-chars)
+ (if (= (following-char) ?\;)
+ nil ; ignore comments
+ (setq indentation (car indentations))
+ (if (integerp (setq indentations (cdr indentations)))
+ ;; if last cdr is integer, that is indentation to use for all
+ ;; all the rest of the forms.
+ (progn (setq mim-body-indent indentations)
+ (setq indentations nil)))))
+ (goto-char (1+ containing-sexp))
+ (+ (current-column) (or indentation mim-body-indent))))
+
+(defun indent-mim-comment (&optional start)
+ "Indent a one line (string) Mim comment following object, if any."
+ (let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp)
+ ;; this function assumes that comment indenting is enabled. it is caller's
+ ;; responsibility to check the indent-mim-comment flag before calling.
+ (beginning-of-line)
+ (catch 'no-comment
+ (setq state (parse-partial-sexp (point) eol))
+ ;; determine if there is an existing regular comment. a `regular'
+ ;; comment is defined as a commented string which is the last thing
+ ;; on the line and does not extend beyond the end of the line.
+ (if (or (not (setq last-sexp (car (nthcdr 2 state))))
+ (car (nthcdr 3 state)))
+ ;; empty line or inside string (multiple line).
+ (throw 'no-comment nil))
+ ;; could be a comment, but make sure its not the only object.
+ (beginning-of-line)
+ (parse-partial-sexp (point) eol 0 t)
+ (if (= (point) last-sexp)
+ ;; only one object on line
+ (throw 'no-comment t))
+ (goto-char last-sexp)
+ (skip-chars-backward " \t")
+ (backward-prefix-chars)
+ (if (not (looking-at ";[ \t]*\""))
+ ;; aint no comment
+ (throw 'no-comment nil))
+ ;; there is an existing regular comment
+ (delete-horizontal-space)
+ ;; move it to comment-column if possible else to tab-stop
+ (if (< (current-column) comment-column)
+ (indent-to comment-column)
+ (tab-to-tab-stop)))
+ (goto-char old-point)))
+
+(defun indent-mim-line ()
+ "Indent line of Mim code."
+ (interactive "*")
+ (let* ((position (- (point-max) (point)))
+ (bol (progn (beginning-of-line) (point)))
+ (indent (calculate-mim-indent)))
+ (skip-chars-forward " \t")
+ (if (/= (current-column) indent)
+ (progn (delete-region bol (point)) (indent-to indent)))
+ (if (> (- (point-max) position) (point)) (goto-char (- (point-max) position)))))
+
+(defun newline-and-mim-indent ()
+ "Insert newline at point and indent."
+ (interactive "*")
+ ;; commented code would correct indentation of line in arglist which
+ ;; starts with string, but it would indent every line twice. luser can
+ ;; just say tab after typing string to get same effect.
+ ;(if indent-mim-arglist (indent-mim-line))
+ (newline)
+ (indent-mim-line))
+
+(defun open-mim-line (&optional lines)
+ "Insert newline before point and indent.
+With ARG insert that many newlines."
+ (interactive "*p")
+ (beginning-of-line)
+ (let ((indent (calculate-mim-indent)))
+ (while (> lines 0)
+ (newline)
+ (forward-line -1)
+ (indent-to indent)
+ (setq lines (1- lines)))))
+
+(defun indent-mim-object (&optional dont-indent-first-line)
+ "Indent object following point and all lines contained inside it.
+With ARG, idents only contained lines (skips first line)."
+ (interactive "*P")
+ (let (end bol indent start)
+ (save-excursion (parse-partial-sexp (point) (point-max) 0 t)
+ (setq start (point))
+ (forward-sexp 1)
+ (setq end (- (point-max) (point))))
+ (save-excursion
+ (if (not dont-indent-first-line) (indent-mim-line))
+ (while (progn (forward-line 1) (> (- (point-max) (point)) end))
+ (setq indent (calculate-mim-indent start))
+ (setq bol (point))
+ (skip-chars-forward " \t")
+ (if (/= indent (current-column))
+ (progn (delete-region bol (point)) (indent-to indent)))
+ (if indent-mim-comment (indent-mim-comment))))))
+
+(defun find-mim-definition (name)
+ "Search for definition of function, macro, or gfcn.
+You need type only enough of the name to be unambiguous."
+ (interactive "sName: ")
+ (let (where)
+ (save-excursion
+ (goto-char (point-min))
+ (condition-case nil
+ (progn
+ (re-search-forward
+ (concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)"
+ name))
+ (setq where (point)))
+ (error (error "Can't find %s" name))))
+ (if where
+ (progn (push-mark)
+ (goto-char where)
+ (beginning-of-line)
+ (recenter 0)))))
+
+(defun begin-mim-comment ()
+ "Move to existing comment or insert empty comment."
+ (interactive "*")
+ (let* ((eol (progn (end-of-line) (point)))
+ (bol (progn (beginning-of-line) (point))))
+ ;; check for existing comment first.
+ (if (re-search-forward ";[ \t]*\"" eol t)
+ ;; found it. indent if desired and go there.
+ (if indent-mim-comment
+ (let ((where (- (point-max) (point))))
+ (indent-mim-comment)
+ (goto-char (- (point-max) where))))
+ ;; nothing there, make a comment.
+ (let (state last-sexp)
+ ;; skip past all the sexps on the line
+ (goto-char bol)
+ (while (and (equal (car (setq state (parse-partial-sexp (point) eol 0)))
+ 0)
+ (car (nthcdr 2 state)))
+ (setq last-sexp (car (nthcdr 2 state))))
+ (if (car (nthcdr 3 state))
+ nil ; inside a string, punt
+ (delete-region (point) eol) ; flush trailing whitespace
+ (if (and (not last-sexp) (equal (car state) 0))
+ (indent-to (calculate-mim-indent)) ; empty, indent like code
+ (if (> (current-column) comment-column) ; indent to comment column
+ (tab-to-tab-stop) ; unless past it, else to
+ (indent-to comment-column))) ; tab-stop
+ ;; if luser changes comment-{start end} to something besides semi
+ ;; followed by zero or more whitespace characters followed by string
+ ;; delimiters, the code above fails to find existing comments, but as
+ ;; taa says, `let the losers lose'.
+ (insert comment-start)
+ (save-excursion (insert comment-end)))))))
+
+(defun skip-mim-whitespace (direction)
+ (if (>= direction 0)
+ (skip-chars-forward mim-whitespace (point-max))
+ (skip-chars-backward mim-whitespace (point-min))))
+
+(defun inside-adecl-or-trailer-p (direction)
+ (if (>= direction 0)
+ (looking-at ":\\|!-")
+ (or (= (preceding-char) ?:)
+ (looking-at "!-"))))
+
+(defun sign (n)
+ "Returns -1 if N < 0, else 1."
+ (if (>= n 0) 1 -1))
+
+(defun abs (n)
+ "Returns the absolute value of N."
+ (if (>= n 0) n (- n)))
+
+(defun next-char (direction)
+ "Returns preceding-char if DIRECTION < 0, otherwise following-char."
+ (if (>= direction 0) (following-char) (preceding-char)))
--- /dev/null
+;; Syntax checker for Mim (MDL).
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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.
+
+
+(require 'mim-mode)
+
+(defun slow-syntax-check-mim ()
+ "Check Mim syntax slowly.
+Points out the context of the error, if the syntax is incorrect."
+ (interactive)
+ (message "checking syntax...")
+ (let ((stop (point-max)) point-stack current last-bracket whoops last-point)
+ (save-excursion
+ (goto-char (point-min))
+ (while (and (not whoops)
+ (re-search-forward "\\s(\\|\\s)\\|\"\\|[\\]" stop t))
+ (setq current (preceding-char))
+ (cond ((= current ?\")
+ (condition-case nil
+ (progn (re-search-forward "[^\\]\"")
+ (setq current nil))
+ (error (setq whoops (point)))))
+ ((= current ?\\)
+ (condition-case nil (forward-char 1) (error nil)))
+ ((= (char-syntax current) ?\))
+ (if (or (not last-bracket)
+ (not (= (logand (lsh (aref (syntax-table) last-bracket) -8)
+ ?\177)
+ current)))
+ (setq whoops (point))
+ (setq last-point (car point-stack))
+ (setq last-bracket (if last-point (char-after (1- last-point))))
+ (setq point-stack (cdr point-stack))))
+ (t
+ (if last-point (setq point-stack (cons last-point point-stack)))
+ (setq last-point (point))
+ (setq last-bracket current)))))
+ (cond ((not (or whoops last-point))
+ (message "Syntax correct"))
+ (whoops
+ (goto-char whoops)
+ (cond ((equal current ?\")
+ (error "Unterminated string"))
+ ((not last-point)
+ (error "Extraneous %s" (char-to-string current)))
+ (t
+ (error "Mismatched %s with %s"
+ (save-excursion
+ (setq whoops (1- (point)))
+ (goto-char (1- last-point))
+ (buffer-substring (point)
+ (min (progn (end-of-line) (point))
+ whoops)))
+ (char-to-string current)))))
+ (t
+ (goto-char last-point)
+ (error "Unmatched %s" (char-to-string last-bracket))))))
+
+(defun fast-syntax-check-mim ()
+ "Checks Mim syntax quickly.
+Answers correct or incorrect, cannot point out the error context."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let (state)
+ (while (and (not (eobp))
+ (equal (car (setq state (parse-partial-sexp (point) (point-max) 0)))
+ 0)))
+ (if (equal (car state) 0)
+ (message "Syntax correct")
+ (error "Syntax incorrect")))))
+
+
+
--- /dev/null
+;; Convert buffer of Mocklisp code to real lisp.
+;; Copyright (C) 1985 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.
+
+(defun convert-mocklisp-buffer ()
+ "Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run."
+ (interactive)
+ (emacs-lisp-mode)
+ (set-syntax-table (copy-sequence (syntax-table)))
+ (modify-syntax-entry ?\| "w")
+ (message "Converting mocklisp (ugh!)...")
+ (goto-char (point-min))
+ (fix-mlisp-syntax)
+
+ ;; Emulation of mocklisp is accurate only within a mocklisp-function
+ ;; so turn any non-function into a defun and then call it.
+ (goto-char (point-min))
+ (condition-case ignore
+ (while t
+ (let ((opt (point))
+ (form (read (current-buffer))))
+ (and (listp form)
+ (not (eq (car form) 'defun))
+ (progn (insert "))\n\n(ml-foo)\n\n")
+ (save-excursion
+ (goto-char opt)
+ (skip-chars-forward "\n")
+ (insert "(defun (ml-foo \n "))))))
+ (end-of-file nil))
+
+ (goto-char (point-min))
+ (insert ";;; GNU Emacs code converted from Mocklisp\n")
+ (insert "(require 'mlsupport)\n\n")
+ (fix-mlisp-symbols)
+
+ (goto-char (point-min))
+ (message "Converting mocklisp...done"))
+
+(defun fix-mlisp-syntax ()
+ (while (re-search-forward "['\"]" nil t)
+ (if (= (preceding-char) ?\")
+ (progn (forward-char -1)
+ (forward-sexp 1))
+ (delete-char -1)
+ (insert "?")
+ (if (or (= (following-char) ?\\) (= (following-char) ?^))
+ (forward-char 1)
+ (if (looking-at "[^a-zA-Z]")
+ (insert ?\\)))
+ (forward-char 1)
+ (delete-char 1))))
+
+(defun fix-mlisp-symbols ()
+ (while (progn
+ (skip-chars-forward " \t\n()")
+ (not (eobp)))
+ (cond ((or (= (following-char) ?\?)
+ (= (following-char) ?\"))
+ (forward-sexp 1))
+ ((= (following-char) ?\;)
+ (forward-line 1))
+ (t
+ (let ((start (point)) prop)
+ (forward-sexp 1)
+ (setq prop (get (intern-soft (buffer-substring start (point)))
+ 'mocklisp))
+ (cond ((null prop))
+ ((stringp prop)
+ (delete-region start (point))
+ (insert prop))
+ (t
+ (save-excursion
+ (goto-char start)
+ (funcall prop)))))))))
+
+(defun ml-expansion (ml-name lisp-string)
+ (put ml-name 'mocklisp lisp-string))
+
+(ml-expansion 'defun "ml-defun")
+(ml-expansion 'if "ml-if")
+(ml-expansion 'setq '(lambda ()
+ (if (looking-at "setq[ \t\n]+buffer-modified-p")
+ (replace-match "set-buffer-modified-p"))))
+
+(ml-expansion 'while '(lambda ()
+ (let ((end (progn (forward-sexp 2) (point-marker)))
+ (start (progn (forward-sexp -1) (point))))
+ (let ((cond (buffer-substring start end)))
+ (cond ((equal cond "1")
+ (delete-region (point) end)
+ (insert "t"))
+ (t
+ (insert "(not (zerop ")
+ (goto-char end)
+ (insert "))")))
+ (set-marker end nil)
+ (goto-char start)))))
+
+(ml-expansion 'arg "ml-arg")
+(ml-expansion 'nargs "ml-nargs")
+(ml-expansion 'interactive "ml-interactive")
+(ml-expansion 'message "ml-message")
+(ml-expansion 'print "ml-print")
+(ml-expansion 'set "ml-set")
+(ml-expansion 'set-default "ml-set-default")
+(ml-expansion 'provide-prefix-argument "ml-provide-prefix-argument")
+(ml-expansion 'prefix-argument-loop "ml-prefix-argument-loop")
+(ml-expansion 'prefix-argument "ml-prefix-arg")
+(ml-expansion 'use-local-map "ml-use-local-map")
+(ml-expansion 'use-global-map "ml-use-global-map")
+(ml-expansion 'modify-syntax-entry "ml-modify-syntax-entry")
+(ml-expansion 'error-message "error")
+
+(ml-expansion 'dot "point-marker")
+(ml-expansion 'mark "mark-marker")
+(ml-expansion 'beginning-of-file "beginning-of-buffer")
+(ml-expansion 'end-of-file "end-of-buffer")
+(ml-expansion 'exchange-dot-and-mark "exchange-point-and-mark")
+(ml-expansion 'set-mark "set-mark-command")
+(ml-expansion 'argument-prefix "universal-arg")
+
+(ml-expansion 'previous-page "ml-previous-page")
+(ml-expansion 'next-page "ml-next-page")
+(ml-expansion 'next-window "ml-next-window")
+(ml-expansion 'previous-window "ml-previous-window")
+
+(ml-expansion 'newline "ml-newline")
+(ml-expansion 'next-line "ml-next-line")
+(ml-expansion 'previous-line "ml-previous-line")
+(ml-expansion 'self-insert "self-insert-command")
+(ml-expansion 'meta-digit "digit-argument")
+(ml-expansion 'meta-minus "negative-argument")
+
+(ml-expansion 'newline-and-indent "ml-newline-and-indent")
+(ml-expansion 'yank-from-killbuffer "yank")
+(ml-expansion 'yank-buffer "insert-buffer")
+(ml-expansion 'copy-region "copy-region-as-kill")
+(ml-expansion 'delete-white-space "delete-horizontal-space")
+(ml-expansion 'widen-region "widen")
+
+(ml-expansion 'forward-word '(lambda ()
+ (if (looking-at "forward-word[ \t\n]*)")
+ (replace-match "forward-word 1)"))))
+(ml-expansion 'backward-word '(lambda ()
+ (if (looking-at "backward-word[ \t\n]*)")
+ (replace-match "backward-word 1)"))))
+
+(ml-expansion 'forward-paren "forward-list")
+(ml-expansion 'backward-paren "backward-list")
+(ml-expansion 'search-reverse "ml-search-backward")
+(ml-expansion 're-search-reverse "ml-re-search-backward")
+(ml-expansion 'search-forward "ml-search-forward")
+(ml-expansion 're-search-forward "ml-re-search-forward")
+(ml-expansion 'quote "regexp-quote")
+(ml-expansion 're-query-replace "query-replace-regexp")
+(ml-expansion 're-replace-string "replace-regexp")
+
+; forward-paren-bl, backward-paren-bl
+
+(ml-expansion 'get-tty-character "read-char")
+(ml-expansion 'get-tty-input "read-input")
+(ml-expansion 'get-tty-string "read-string")
+(ml-expansion 'get-tty-buffer "read-buffer")
+(ml-expansion 'get-tty-command "read-command")
+(ml-expansion 'get-tty-variable "read-variable")
+(ml-expansion 'get-tty-no-blanks-input "read-no-blanks-input")
+(ml-expansion 'get-tty-key "read-key")
+
+(ml-expansion 'c= "char-equal")
+(ml-expansion 'goto-character "goto-char")
+(ml-expansion 'substr "ml-substr")
+(ml-expansion 'variable-apropos "apropos")
+(ml-expansion 'execute-mlisp-buffer "eval-current-buffer")
+(ml-expansion 'execute-mlisp-file "load")
+(ml-expansion 'visit-file "find-file")
+(ml-expansion 'read-file "find-file")
+(ml-expansion 'write-modified-files "save-some-buffers")
+(ml-expansion 'backup-before-writing "make-backup-files")
+(ml-expansion 'write-file-exit "save-buffers-kill-emacs")
+(ml-expansion 'write-named-file "write-file")
+(ml-expansion 'change-file-name "set-visited-file-name")
+(ml-expansion 'change-buffer-name "rename-buffer")
+(ml-expansion 'buffer-exists "get-buffer")
+(ml-expansion 'delete-buffer "kill-buffer")
+(ml-expansion 'unlink-file "delete-file")
+(ml-expansion 'unlink-checkpoint-files "delete-auto-save-files")
+(ml-expansion 'file-exists "file-exists-p")
+(ml-expansion 'write-current-file "save-buffer")
+(ml-expansion 'change-directory "cd")
+(ml-expansion 'temp-use-buffer "set-buffer")
+(ml-expansion 'fast-filter-region "filter-region")
+
+(ml-expansion 'pending-input "input-pending-p")
+(ml-expansion 'execute-keyboard-macro "call-last-kbd-macro")
+(ml-expansion 'start-remembering "start-kbd-macro")
+(ml-expansion 'end-remembering "end-kbd-macro")
+(ml-expansion 'define-keyboard-macro "name-last-kbd-macro")
+(ml-expansion 'define-string-macro "ml-define-string-macro")
+
+(ml-expansion 'current-column "ml-current-column")
+(ml-expansion 'current-indent "ml-current-indent")
+(ml-expansion 'insert-character "insert")
+
+(ml-expansion 'users-login-name "user-login-name")
+(ml-expansion 'users-full-name "user-full-name")
+(ml-expansion 'current-time "current-time-string")
+(ml-expansion 'current-numeric-time "current-numeric-time-you-lose")
+(ml-expansion 'current-buffer-name "buffer-name")
+(ml-expansion 'current-file-name "buffer-file-name")
+
+(ml-expansion 'local-binding-of "local-key-binding")
+(ml-expansion 'global-binding-of "global-key-binding")
+
+;defproc (ProcedureType, "procedure-type");
+
+(ml-expansion 'remove-key-binding "global-unset-key")
+(ml-expansion 'remove-binding "global-unset-key")
+(ml-expansion 'remove-local-binding "local-unset-key")
+(ml-expansion 'remove-all-local-bindings "use-local-map nil")
+(ml-expansion 'autoload "ml-autoload")
+
+(ml-expansion 'checkpoint-frequency "auto-save-interval")
+
+(ml-expansion 'mode-string "mode-name")
+(ml-expansion 'right-margin "fill-column")
+(ml-expansion 'tab-size "tab-width")
+(ml-expansion 'default-right-margin "default-fill-column")
+(ml-expansion 'default-tab-size "default-tab-width")
+(ml-expansion 'buffer-is-modified "(buffer-modified-p)")
+
+(ml-expansion 'file-modified-time "you-lose-on-file-modified-time")
+(ml-expansion 'needs-checkpointing "you-lose-on-needs-checkpointing")
+
+(ml-expansion 'lines-on-screen "set-screen-height")
+(ml-expansion 'columns-on-screen "set-screen-width")
+
+(ml-expansion 'dumped-emacs "t")
+
+(ml-expansion 'buffer-size "ml-buffer-size")
+(ml-expansion 'dot-is-visible "pos-visible-in-window-p")
+
+(ml-expansion 'track-eol-on-^N-^P "track-eol")
+(ml-expansion 'ctlchar-with-^ "ctl-arrow")
+(ml-expansion 'help-on-command-completion-error "completion-auto-help")
+(ml-expansion 'dump-stack-trace "backtrace")
+(ml-expansion 'pause-emacs "suspend-emacs")
+(ml-expansion 'compile-it "compile")
+
+(ml-expansion '!= "/=")
+(ml-expansion '& "logand")
+(ml-expansion '| "logior")
+(ml-expansion '^ "logxor")
+(ml-expansion '! "ml-not")
+(ml-expansion '<< "lsh")
+
+;Variable pause-writes-files
+
--- /dev/null
+;; Run-time support for mocklisp code.
+;; Copyright (C) 1985 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.
+
+
+(provide 'mlsupport)
+
+(defmacro ml-defun (&rest defs)
+ (list 'ml-defun-1 (list 'quote defs)))
+
+(defun ml-defun-1 (args)
+ (while args
+ (fset (car (car args)) (cons 'mocklisp (cdr (car args))))
+ (setq args (cdr args))))
+
+(defmacro declare-buffer-specific (&rest vars)
+ (cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars)))
+
+(defmacro setq-default (var val)
+ (list 'set-default (list 'quote var) val))
+
+(defun ml-set-default (varname value)
+ (set-default (intern varname) value))
+
+; Lossage: must make various things default missing args to the prefix arg
+; Alternatively, must make provide-prefix-argument do something hairy.
+
+(defun >> (val count) (lsh val (- count)))
+(defun novalue () nil)
+
+(defun ml-not (arg) (if (zerop arg) 1 0))
+
+(defun provide-prefix-arg (arg form)
+ (funcall (car form) arg))
+
+(defun define-keymap (name)
+ (fset (intern name) (make-keymap)))
+
+(defun ml-use-local-map (name)
+ (use-local-map (intern (concat name "-map"))))
+
+(defun ml-use-global-map (name)
+ (use-global-map (intern (concat name "-map"))))
+
+(defun local-bind-to-key (name key)
+ (or (current-local-map)
+ (use-local-map (make-keymap)))
+ (define-key (current-local-map)
+ (if (integerp key)
+ (if (>= key 128)
+ (concat (char-to-string meta-prefix-char)
+ (char-to-string (- key 128)))
+ (char-to-string key))
+ key)
+ (intern name)))
+
+(defun bind-to-key (name key)
+ (define-key global-map (if (integerp key) (char-to-string key) key)
+ (intern name)))
+
+(defun ml-autoload (name file)
+ (autoload (intern name) file))
+
+(defun ml-define-string-macro (name defn)
+ (fset (intern name) defn))
+
+(defun push-back-character (char)
+ (setq unread-command-char char))
+
+(defun to-col (column)
+ (indent-to column 0))
+
+(defmacro is-bound (&rest syms)
+ (cons 'and (mapcar (function (lambda (sym) (list 'boundp (list 'quote sym)))) syms)))
+
+(defmacro declare-global (&rest syms)
+ (cons 'progn (mapcar (function (lambda (sym) (list 'defvar sym nil))) syms)))
+
+(defmacro error-occurred (&rest body)
+ (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
+
+(defun return-prefix-argument (value)
+ (setq prefix-arg value))
+
+(defun ml-prefix-argument ()
+ (if (null current-prefix-arg) 1
+ (if (listp current-prefix-arg) (car current-prefix-arg)
+ (if (eq current-prefix-arg '-) -1
+ current-prefix-arg))))
+
+(defun ml-print (varname)
+ (interactive "vPrint variable: ")
+ (if (boundp varname)
+ (message "%s => %s" (symbol-name varname) (symbol-value varname))
+ (message "%s has no value" (symbol-name varname))))
+
+(defun ml-set (str val) (set (intern str) val))
+
+(defun ml-message (&rest args) (message "%s" (apply 'concat args)))
+
+(defun kill-to-end-of-line ()
+ (ml-prefix-argument-loop
+ (if (eolp)
+ (kill-region (point) (1+ (point)))
+ (kill-region (point) (if (search-forward ?\n nil t)
+ (1- (point)) (point-max))))))
+
+(defun set-auto-fill-hook (arg)
+ (setq auto-fill-hook (intern arg)))
+
+(defun auto-execute (function pattern)
+ (if (/= (aref pattern 0) ?*)
+ (error "Only patterns starting with * supported in auto-execute"))
+ (setq auto-mode-alist (cons (cons (concat "\\." (substring pattern 1)
+ "$")
+ function)
+ auto-mode-alist)))
+
+(defun move-to-comment-column ()
+ (indent-to comment-column))
+
+(defun erase-region ()
+ (delete-region (point) (mark)))
+
+(defun delete-region-to-buffer (bufname)
+ (copy-to-buffer bufname (point) (mark))
+ (delete-region (point) (mark)))
+
+(defun copy-region-to-buffer (bufname)
+ (copy-to-buffer bufname (point) (mark)))
+
+(defun append-region-to-buffer (bufname)
+ (append-to-buffer bufname (point) (mark)))
+
+(defun prepend-region-to-buffer (bufname)
+ (prepend-to-buffer bufname (point) (mark)))
+
+(defun delete-next-character ()
+ (delete-char (ml-prefix-argument)))
+
+(defun delete-next-word ()
+ (delete-region (point) (progn (forward-word (ml-prefix-argument)) (point))))
+
+(defun delete-previous-word ()
+ (delete-region (point) (progn (backward-word (ml-prefix-argument)) (point))))
+
+(defun delete-previous-character ()
+ (delete-backward-char (ml-prefix-argument)))
+
+(defun forward-character ()
+ (forward-char (ml-prefix-argument)))
+
+(defun backward-character ()
+ (backward-char (ml-prefix-argument)))
+
+(defun ml-newline ()
+ (newline (ml-prefix-argument)))
+
+(defun ml-next-line ()
+ (next-line (ml-prefix-argument)))
+
+(defun ml-previous-line ()
+ (previous-line (ml-prefix-argument)))
+
+(defun delete-to-kill-buffer ()
+ (kill-region (point) (mark)))
+
+(defun narrow-region ()
+ (narrow-to-region (point) (mark)))
+
+(defun ml-newline-and-indent ()
+ (let ((column (current-indentation)))
+ (newline (ml-prefix-argument))
+ (indent-to column)))
+
+(defun newline-and-backup ()
+ (open-line (ml-prefix-argument)))
+
+(defun quote-char ()
+ (quoted-insert (ml-prefix-argument)))
+
+(defun ml-current-column ()
+ (1+ (current-column)))
+
+(defun ml-current-indent ()
+ (1+ (current-indentation)))
+
+(defun region-around-match (&optional n)
+ (set-mark (match-beginning n))
+ (goto-char (match-end n)))
+
+(defun region-to-string ()
+ (buffer-substring (min (point) (mark)) (max (point) (mark))))
+
+(defun use-abbrev-table (name)
+ (let ((symbol (intern (concat name "-abbrev-table"))))
+ (or (boundp symbol)
+ (define-abbrev-table symbol nil))
+ (symbol-value symbol)))
+
+(defun define-hooked-local-abbrev (name exp hook)
+ (define-local-abbrev name exp (intern hook)))
+
+(defun define-hooked-global-abbrev (name exp hook)
+ (define-global-abbrev name exp (intern hook)))
+
+(defun case-word-lower ()
+ (ml-casify-word 'downcase-region))
+
+(defun case-word-upper ()
+ (ml-casify-word 'upcase-region))
+
+(defun case-word-capitalize ()
+ (ml-casify-word 'capitalize-region))
+
+(defun ml-casify-word (fun)
+ (save-excursion
+ (forward-char 1)
+ (forward-word -1)
+ (funcall fun (point)
+ (progn (forward-word (ml-prefix-argument))
+ (point)))))
+
+(defun case-region-lower ()
+ (downcase-region (point) (mark)))
+
+(defun case-region-upper ()
+ (upcase-region (point) (mark)))
+
+(defun case-region-capitalize ()
+ (capitalize-region (point) (mark)))
+\f
+(defvar saved-command-line-args nil)
+
+(defun argc ()
+ (or saved-command-line-args
+ (setq saved-command-line-args command-line-args
+ command-line-args ()))
+ (length command-line-args))
+
+(defun argv (i)
+ (or saved-command-line-args
+ (setq saved-command-line-args command-line-args
+ command-line-args ()))
+ (nth i saved-command-line-args))
+
+(defun invisible-argc ()
+ (length (or saved-command-line-args
+ command-line-args)))
+
+(defun invisible-argv (i)
+ (nth i (or saved-command-line-args
+ command-line-args)))
+
+(defun exit-emacs ()
+ (interactive)
+ (condition-case ()
+ (exit-recursive-edit)
+ (error (kill-emacs))))
+\f
+;; Lisp function buffer-size returns total including invisible;
+;; mocklisp wants just visible.
+(defun ml-buffer-size ()
+ (- (point-max) (point-min)))
+
+(defun previous-command ()
+ last-command)
+
+(defun beginning-of-window ()
+ (goto-char (window-start)))
+
+(defun end-of-window ()
+ (goto-char (window-start))
+ (vertical-motion (- (window-height) 2)))
+\f
+(defun ml-search-forward (string)
+ (search-forward string nil nil (ml-prefix-argument)))
+
+(defun ml-re-search-forward (string)
+ (re-search-forward string nil nil (ml-prefix-argument)))
+
+(defun ml-search-backward (string)
+ (search-backward string nil nil (ml-prefix-argument)))
+
+(defun ml-re-search-backward (string)
+ (re-search-backward string nil nil (ml-prefix-argument)))
+
+(defvar use-users-shell 1
+ "Mocklisp compatibility variable; 1 means use shell from SHELL env var.
+0 means use /bin/sh.")
+
+(defvar use-csh-option-f 1
+ "Mocklisp compatibility variable; 1 means pass -f when calling csh.")
+
+(defun filter-region (command)
+ (let ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
+ (csh (equal (file-name-nondirectory shell) "csh")))
+ (call-process-region (point) (mark) shell t t nil
+ (if (and csh use-csh-option-f) "-cf" "-c")
+ (concat "exec " command))))
+
+(defun execute-monitor-command (command)
+ (let ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
+ (csh (equal (file-name-nondirectory shell) "csh")))
+ (call-process shell nil t t
+ (if (and csh use-csh-option-f) "-cf" "-c")
+ (concat "exec " command))))
+\f
+(defun use-syntax-table (name)
+ (set-syntax-table (symbol-value (intern (concat name "-syntax-table")))))
+
+(defun line-to-top-of-window ()
+ (recenter (1- (ml-prefix-argument))))
+
+(defun ml-previous-page (&optional arg)
+ (let ((count (or arg (ml-prefix-argument))))
+ (while (> count 0)
+ (scroll-down nil)
+ (setq count (1- count)))
+ (while (< count 0)
+ (scroll-up nil)
+ (setq count (1+ count)))))
+
+(defun ml-next-page ()
+ (previous-page (- (ml-prefix-argument))))
+
+(defun page-next-window (&optional arg)
+ (let ((count (or arg (ml-prefix-argument))))
+ (while (> count 0)
+ (scroll-other-window nil)
+ (setq count (1- count)))
+ (while (< count 0)
+ (scroll-other-window '-)
+ (setq count (1+ count)))))
+
+(defun ml-next-window ()
+ (select-window (next-window)))
+
+(defun ml-previous-window ()
+ (select-window (previous-window)))
+
+(defun scroll-one-line-up ()
+ (scroll-up (ml-prefix-argument)))
+
+(defun scroll-one-line-down ()
+ (scroll-down (ml-prefix-argument)))
+
+(defun split-current-window ()
+ (split-window (selected-window)))
+
+(defun last-key-struck () last-command-char)
+
+(defun execute-mlisp-line (string)
+ (eval (read string)))
+
+(defun move-dot-to-x-y (x y)
+ (goto-char (window-start (selected-window)))
+ (vertical-motion (1- y))
+ (move-to-column (1- x)))
+
+(defun ml-modify-syntax-entry (string)
+ (let ((i 5)
+ (len (length string))
+ (datastring (substring string 0 2)))
+ (if (= (aref string 0) ?\-)
+ (aset datastring 0 ?\ ))
+ (if (= (aref string 2) ?\{)
+ (if (= (aref string 4) ?\ )
+ (aset datastring 0 ?\<)
+ (error "Two-char comment delimiter: use modify-syntax-entry directly")))
+ (if (= (aref string 3) ?\})
+ (if (= (aref string 4) ?\ )
+ (aset datastring 0 ?\>)
+ (error "Two-char comment delimiter: use modify-syntax-entry directly")))
+ (while (< i len)
+ (modify-syntax-entry (aref string i) datastring)
+ (setq i (1+ i))
+ (if (and (< i len)
+ (= (aref string i) ?\-))
+ (let ((c (aref string (1- i)))
+ (lim (aref string (1+ i))))
+ (while (<= c lim)
+ (modify-syntax-entry c datastring)
+ (setq c (1+ c)))
+ (setq i (+ 2 i)))))))
+\f
+
+
+(defun ml-substr (string from to)
+ (let ((length (length string)))
+ (if (< from 0) (setq from (+ from length)))
+ (if (< to 0) (setq to (+ to length)))
+ (substring string from (+ from to))))
--- /dev/null
+;; Handling of disabled commands ("novice mode") for Emacs.
+;; Copyright (C) 1985, 1986, 1987 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.
+
+
+;; This function is called (by autoloading)
+;; to handle any disabled command.
+;; The command is found in this-command
+;; and the keys are returned by (this-command-keys).
+
+(defun disabled-command-hook (&rest ignore)
+ (let (char)
+ (save-window-excursion
+ (with-output-to-temp-buffer "*Help*"
+ (if (= (aref (this-command-keys) 0) ?\M-x)
+ (princ "You have invoked the disabled command ")
+ (princ "You have typed ")
+ (princ (key-description (this-command-keys)))
+ (princ ", invoking disabled command "))
+ (princ this-command)
+ (princ ":\n")
+ ;; Print any special message saying why the command is disabled.
+ (if (stringp (get this-command 'disabled))
+ (princ (get this-command 'disabled)))
+ (princ (or (condition-case ()
+ (documentation this-command)
+ (error nil))
+ "<< not documented >>"))
+ ;; Keep only the first paragraph of the documentation.
+ (save-excursion
+ (set-buffer "*Help*")
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (delete-region (1- (point)) (point-max))
+ (goto-char (point-max))))
+ (princ "\n\n")
+ (princ "You can now type
+Space to try the command just this once,
+ but leave it disabled,
+Y to try it and enable it (no questions if you use it again),
+N to do nothing (command remains disabled)."))
+ (message "Type y, n or Space: ")
+ (let ((cursor-in-echo-area t))
+ (while (not (memq (setq char (downcase (read-char)))
+ '(? ?y ?n)))
+ (ding)
+ (message "Please type y, n or Space: "))))
+ (if (= char ?y)
+ (if (y-or-n-p "Enable command for future editing sessions also? ")
+ (enable-command this-command)
+ (put this-command 'disabled nil)))
+ (if (/= char ?n)
+ (call-interactively this-command))))
+
+(defun enable-command (command)
+ "Allow COMMAND to be executed without special confirmation from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions."
+ (interactive "CEnable command: ")
+ (put command 'disabled nil)
+ (save-excursion
+ (set-buffer (find-file-noselect (substitute-in-file-name "~/.emacs")))
+ (goto-char (point-min))
+ (if (search-forward (concat "(put '" (symbol-name command) " ") nil t)
+ (delete-region
+ (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point)))
+ ;; Must have been disabled by default.
+ (goto-char (point-max))
+ (insert "\n(put '" (symbol-name command) " 'disabled nil)\n"))
+ (setq foo (buffer-modified-p))
+ (save-buffer)))
+
+(defun disable-command (command)
+ "Require special confirmation to execute COMMAND from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions."
+ (interactive "CDisable command: ")
+ (put command 'disabled t)
+ (save-excursion
+ (set-buffer (find-file-noselect (substitute-in-file-name "~/.emacs")))
+ (goto-char (point-min))
+ (if (search-forward (concat "(put '" (symbol-name command) " ") nil t)
+ (delete-region
+ (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (goto-char (point-max))
+ (insert "(put '" (symbol-name command) " 'disabled t)\n")
+ (save-buffer)))
+
--- /dev/null
+;; GNU Emacs major mode for editing nroff source
+;; 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.
+
+
+
+(defvar nroff-mode-abbrev-table nil
+ "Abbrev table used while in nroff mode.")
+
+(defvar nroff-mode-map nil
+ "Major mode keymap for nroff-mode buffers")
+(if (not nroff-mode-map)
+ (progn
+ (setq nroff-mode-map (make-sparse-keymap))
+ (define-key nroff-mode-map "\t" 'tab-to-tab-stop)
+ (define-key nroff-mode-map "\es" 'center-line)
+ (define-key nroff-mode-map "\e?" 'count-text-lines)
+ (define-key nroff-mode-map "\n" 'electric-nroff-newline)
+ (define-key nroff-mode-map "\en" 'forward-text-line)
+ (define-key nroff-mode-map "\ep" 'backward-text-line)))
+
+(defun nroff-mode ()
+ "Major mode for editing text intended for nroff to format.
+\\{nroff-mode-map}
+Turning on Nroff mode runs text-mode-hook, then nroff-mode-hook.
+Also, try nroff-electric-mode, for automatically inserting
+closing requests for requests that are used in matched pairs."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map nroff-mode-map)
+ (setq mode-name "Nroff")
+ (setq major-mode 'nroff-mode)
+ (set-syntax-table text-mode-syntax-table)
+ (setq local-abbrev-table nroff-mode-abbrev-table)
+ (make-local-variable 'nroff-electric-mode)
+ ;; now define a bunch of variables for use by commands in this mode
+ (make-local-variable 'page-delimiter)
+ (setq page-delimiter "^\\.\\(bp\\|SK\\|OP\\)")
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^[.']\\|" paragraph-start))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate (concat "^[.']\\|" paragraph-separate))
+ ;; comment syntax added by mit-erl!gildea 18 Apr 86
+ (make-local-variable 'comment-start)
+ (setq comment-start "\\\" ")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "\\\\\"[ \t]*")
+ (make-local-variable 'comment-column)
+ (setq comment-column 24)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'nroff-comment-indent)
+ (run-hooks 'text-mode-hook 'nroff-mode-hook))
+
+;;; Compute how much to indent a comment in nroff/troff source.
+;;; By mit-erl!gildea April 86
+(defun nroff-comment-indent ()
+ "Compute indent for an nroff/troff comment.
+Puts a full-stop before comments on a line by themselves."
+ (let ((pt (point)))
+ (unwind-protect
+ (progn
+ (skip-chars-backward " \t")
+ (if (bolp)
+ (progn
+ (setq pt (1+ pt))
+ (insert ?.)
+ 1)
+ (if (save-excursion
+ (backward-char 1)
+ (looking-at "^[.']"))
+ 1
+ (max comment-column
+ (* 8 (/ (+ (current-column)
+ 9) 8)))))) ; add 9 to ensure at least two blanks
+ (goto-char pt))))
+
+(defun count-text-lines (start end &optional print)
+ "Count lines in region, except for nroff request lines.
+All lines not starting with a period are counted up.
+Interactively, print result in echo area.
+Noninteractively, return number of non-request lines from START to END."
+ (interactive "r\np")
+ (if print
+ (message "Region has %d text lines" (count-text-lines start end))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (- (buffer-size) (forward-text-line (buffer-size)))))))
+
+(defun forward-text-line (&optional cnt)
+ "Go forward one nroff text line, skipping lines of nroff requests.
+An argument is a repeat count; if negative, move backward."
+ (interactive "p")
+ (if (not cnt) (setq cnt 1))
+ (while (and (> cnt 0) (not (eobp)))
+ (forward-line 1)
+ (while (and (not (eobp)) (looking-at "[.']."))
+ (forward-line 1))
+ (setq cnt (- cnt 1)))
+ (while (and (< cnt 0) (not (bobp)))
+ (forward-line -1)
+ (while (and (not (bobp))
+ (looking-at "[.']."))
+ (forward-line -1))
+ (setq cnt (+ cnt 1)))
+ cnt)
+
+(defun backward-text-line (&optional cnt)
+ "Go backward one nroff text line, skipping lines of nroff requests.
+An argument is a repeat count; negative means move forward."
+ (interactive "p")
+ (forward-text-line (- cnt)))
+
+(defconst nroff-brace-table
+ '((".(b" . ".)b")
+ (".(l" . ".)l")
+ (".(q" . ".)q")
+ (".(c" . ".)c")
+ (".(x" . ".)x")
+ (".(z" . ".)z")
+ (".(d" . ".)d")
+ (".(f" . ".)f")
+ (".LG" . ".NL")
+ (".SM" . ".NL")
+ (".LD" . ".DE")
+ (".CD" . ".DE")
+ (".BD" . ".DE")
+ (".DS" . ".DE")
+ (".DF" . ".DE")
+ (".FS" . ".FE")
+ (".KS" . ".KE")
+ (".KF" . ".KE")
+ (".LB" . ".LE")
+ (".AL" . ".LE")
+ (".BL" . ".LE")
+ (".DL" . ".LE")
+ (".ML" . ".LE")
+ (".RL" . ".LE")
+ (".VL" . ".LE")
+ (".RS" . ".RE")
+ (".TS" . ".TE")
+ (".EQ" . ".EN")
+ (".PS" . ".PE")
+ (".BS" . ".BE")
+ (".G1" . ".G2") ; grap
+ (".na" . ".ad b")
+ (".nf" . ".fi")
+ (".de" . "..")))
+
+(defun electric-nroff-newline (arg)
+ "Insert newline for nroff mode; special if electric-nroff mode.
+In electric-nroff-mode, if ending a line containing an nroff opening request,
+automatically inserts the matching closing request after point."
+ (interactive "P")
+ (let ((completion (save-excursion
+ (beginning-of-line)
+ (and (null arg)
+ nroff-electric-mode
+ (<= (point) (- (point-max) 3))
+ (cdr (assoc (buffer-substring (point)
+ (+ 3 (point)))
+ nroff-brace-table)))))
+ (needs-nl (not (looking-at "[ \t]*$"))))
+ (if (null completion)
+ (newline (prefix-numeric-value arg))
+ (save-excursion
+ (insert "\n\n" completion)
+ (if needs-nl (insert "\n")))
+ (forward-char 1))))
+
+(defun electric-nroff-mode (&optional arg)
+ "Toggle nroff-electric-newline minor mode
+Nroff-electric-newline forces emacs to check for an nroff
+request at the beginning of the line, and insert the
+matching closing request if necessary.
+This command toggles that mode (off->on, on->off),
+with an argument, turns it on iff arg is positive, otherwise off."
+ (interactive "P")
+ (or (eq major-mode 'nroff-mode) (error "Must be in nroff mode"))
+ (or (assq 'nroff-electric-mode minor-mode-alist)
+ (setq minor-mode-alist (append minor-mode-alist
+ (list '(nroff-electric-mode
+ " Electric")))))
+ (setq nroff-electric-mode
+ (cond ((null arg) (null nroff-electric-mode))
+ (t (> (prefix-numeric-value arg) 0)))))
+
--- /dev/null
+;; Edit Options command for Emacs.
+;; Copyright (C) 1985 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.
+
+
+(defun list-options ()
+ "Display a list of Emacs user options, with values and documentation."
+ (interactive)
+ (save-excursion
+ (set-buffer (get-buffer-create "*List Options*"))
+ (Edit-options-mode))
+ (with-output-to-temp-buffer "*List Options*"
+ (let (vars)
+ (mapatoms (function (lambda (sym)
+ (if (user-variable-p sym)
+ (setq vars (cons sym vars))))))
+ (setq vars (sort vars 'string-lessp))
+ (while vars
+ (let ((sym (car vars)))
+ (princ ";; ")
+ (prin1 sym)
+ (princ ":\n\t")
+ (prin1 (symbol-value sym))
+ (terpri)
+ (princ (substitute-command-keys
+ (documentation-property sym 'variable-documentation)))
+ (princ "\n;;\n"))
+ (setq vars (cdr vars))))))
+
+(defun edit-options ()
+ "Edit a list of Emacs user option values.
+Selects a buffer containing such a list,
+in which there are commands to set the option values.
+Type \\[describe-mode] in that buffer for a list of commands."
+ (interactive)
+ (list-options)
+ (pop-to-buffer "*List Options*"))
+
+(defvar Edit-options-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "s" 'Edit-options-set)
+ (define-key map "x" 'Edit-options-toggle)
+ (define-key map "1" 'Edit-options-t)
+ (define-key map "0" 'Edit-options-nil)
+ (define-key map "p" 'backward-paragraph)
+ (define-key map " " 'forward-paragraph)
+ (define-key map "n" 'forward-paragraph)
+ map)
+ "")
+
+;; Edit Options mode is suitable only for specially formatted data.
+(put 'Edit-options-mode 'mode-class 'special)
+
+(defun Edit-options-mode ()
+ "Major mode for editing Emacs user option settings.
+Special commands are:
+s -- set variable point points at. New value read using minibuffer.
+x -- toggle variable, t -> nil, nil -> t.
+1 -- set variable to t.
+0 -- set variable to nil.
+Each variable description is a paragraph.
+For convenience, the characters p and n move back and forward by paragraphs."
+ (kill-all-local-variables)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (use-local-map Edit-options-mode-map)
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate "[^\^@-\^?]")
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start "^\t")
+ (setq truncate-lines t)
+ (setq major-mode 'Edit-options-mode)
+ (setq mode-name "Options"))
+
+(defun Edit-options-set () (interactive)
+ (Edit-options-modify
+ '(lambda (var) (eval-minibuffer (concat "New " (symbol-name var) ": ")))))
+
+(defun Edit-options-toggle () (interactive)
+ (Edit-options-modify '(lambda (var) (not (symbol-value var)))))
+
+(defun Edit-options-t () (interactive)
+ (Edit-options-modify '(lambda (var) t)))
+
+(defun Edit-options-nil () (interactive)
+ (Edit-options-modify '(lambda (var) nil)))
+
+(defun Edit-options-modify (modfun)
+ (save-excursion
+ (let (var pos)
+ (re-search-backward "^;; ")
+ (forward-char 3)
+ (setq pos (point))
+ (save-restriction
+ (narrow-to-region pos (progn (end-of-line) (1- (point))))
+ (goto-char pos)
+ (setq var (read (current-buffer))))
+ (goto-char pos)
+ (forward-line 1)
+ (forward-char 1)
+ (save-excursion
+ (set var (funcall modfun var)))
+ (kill-sexp 1)
+ (prin1 (symbol-value var) (current-buffer)))))
+
--- /dev/null
+;; Outline mode commands for Emacs
+;; Copyright (C) 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.
+
+;; Jan '86, Some new features added by Peter Desnoyers and rewritten by RMS.
+
+(defvar outline-regexp "[*\^l]+"
+ "*Regular expression to match the beginning of a heading line.
+Any line whose beginning matches this regexp is considered a heading.
+The recommended way to set this is with a Local Variables: list
+in the file it applies to.")
+
+(defvar outline-mode-map nil "")
+
+(if outline-mode-map
+ nil
+ (setq outline-mode-map (copy-keymap text-mode-map))
+ (define-key outline-mode-map "\C-c\C-n" 'outline-next-visible-heading)
+ (define-key outline-mode-map "\C-c\C-p" 'outline-previous-visible-heading)
+ (define-key outline-mode-map "\C-c\C-i" 'show-children)
+ (define-key outline-mode-map "\C-c\C-s" 'show-subtree)
+ (define-key outline-mode-map "\C-c\C-h" 'hide-subtree)
+ (define-key outline-mode-map "\C-c\C-u" 'outline-up-heading)
+ (define-key outline-mode-map "\C-c\C-f" 'outline-forward-same-level)
+ (define-key outline-mode-map "\C-c\C-b" 'outline-backward-same-level))
+
+(defun outline-mode ()
+ "Set major mode for editing outlines with selective display.
+Headings are lines which start with asterisks: one for major headings,
+two for subheadings, etc. Lines not starting with asterisks are body lines.
+
+Body text or subheadings under a heading can be made temporarily
+invisible, or visible again. Invisible lines are attached to the end
+of the heading, so they move with it, if the line is killed and yanked
+back. A heading with text hidden under it is marked with an ellipsis (...).
+
+Commands:
+C-c C-n outline-next-visible-heading move by visible headings
+C-c C-p outline-previous-visible-heading
+C-c C-f outline-forward-same-level similar but skip subheadings
+C-c C-b outline-backward-same-level
+C-c C-u outline-up-heading move from subheading to heading
+
+Meta-x hide-body make all text invisible (not headings).
+Meta-x show-all make everything in buffer visible.
+
+The remaining commands are used when point is on a heading line.
+They apply to some of the body or subheadings of that heading.
+C-c C-h hide-subtree make body and subheadings invisible.
+C-c C-s show-subtree make body and subheadings visible.
+C-c C-i show-children make direct subheadings visible.
+ No effect on body, or subheadings 2 or more levels down.
+ With arg N, affects subheadings N levels down.
+M-x hide-entry make immediately following body invisible.
+M-x show-entry make it visible.
+M-x hide-leaves make body under heading and under its subheadings invisible.
+ The subheadings remain visible.
+M-x show-branches make all subheadings at all levels visible.
+
+The variable outline-regexp can be changed to control what is a heading.
+A line is a heading if outline-regexp matches something at the
+beginning of the line. The longer the match, the deeper the level.
+
+Turning on outline mode calls the value of text-mode-hook and then of
+outline-mode-hook, if they are non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (setq selective-display t)
+ (use-local-map outline-mode-map)
+ (setq mode-name "Outline")
+ (setq major-mode 'outline-mode)
+ (define-abbrev-table 'text-mode-abbrev-table ())
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (set-syntax-table text-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat paragraph-start "\\|^\\("
+ outline-regexp "\\)"))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate (concat paragraph-separate "\\|^\\("
+ outline-regexp "\\)"))
+ (run-hooks 'text-mode-hook 'outline-mode-hook))
+\f
+(defun outline-level ()
+ "Return the depth to which a statement is nested in the outline.
+Point must be at the beginning of a header line.
+This is actually the length of whatever outline-regexp matches."
+ (save-excursion
+ (looking-at outline-regexp)
+ (- (match-end 0) (match-beginning 0))))
+
+(defun outline-next-preface ()
+ "Skip forward to just before the next heading line."
+ (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
+ nil 'move)
+ (goto-char (match-beginning 0)))
+ (if (memq (preceding-char) '(?\n ?\^M))
+ (forward-char -1)))
+
+(defun outline-next-heading ()
+ "Move to the next (possibly invisible) heading line."
+ (interactive)
+ (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
+ nil 'move)
+ (goto-char (1+ (match-beginning 0)))))
+
+(defun outline-back-to-heading ()
+ "Move to previous (possibly invisible) heading line,
+or to beginning of this line if it is a heading line."
+ (beginning-of-line)
+ (or (outline-on-heading-p)
+ (re-search-backward (concat "^\\(" outline-regexp "\\)") nil 'move)))
+
+(defun outline-on-heading-p ()
+ "Return T if point is on a header line."
+ (save-excursion
+ (beginning-of-line)
+ (and (eq (preceding-char) ?\n)
+ (looking-at outline-regexp))))
+
+(defun outline-next-visible-heading (arg)
+ "Move to the next visible heading line.
+With argument, repeats or can move backward if negative.
+A heading line is one that starts with a `*' (or that outline-regexp matches)."
+ (interactive "p")
+ (if (< arg 0)
+ (beginning-of-line)
+ (end-of-line))
+ (re-search-forward (concat "^\\(" outline-regexp "\\)") nil nil arg)
+ (beginning-of-line))
+
+(defun outline-previous-visible-heading (arg)
+ "Move to the previous heading line.
+With argument, repeats or can move forward if negative.
+A heading line is one that starts with a `*' (or that outline-regexp matches)."
+ (interactive "p")
+ (outline-next-visible-heading (- arg)))
+
+(defun outline-flag-region (from to flag)
+ "Hides or shows lines from FROM to TO, according to FLAG.
+If FLAG is `\\n' (newline character) then text is shown,
+while if FLAG is `\\^M' (control-M) the text is hidden."
+ (let ((modp (buffer-modified-p)))
+ (unwind-protect
+ (subst-char-in-region from to
+ (if (= flag ?\n) ?\^M ?\n)
+ flag t)
+ (set-buffer-modified-p modp))))
+\f
+(defun hide-entry ()
+ "Hide the body directly following this heading."
+ (interactive)
+ (outline-back-to-heading)
+ (save-excursion
+ (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\^M)))
+
+(defun show-entry ()
+ "Show the body directly following this heading."
+ (interactive)
+ (save-excursion
+ (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\n)))
+
+(defun hide-body ()
+ "Hide all of buffer except headings."
+ (interactive)
+ (hide-region-body (point-min) (point-max)))
+
+(defun hide-region-body (start end)
+ "Hide all body lines in the region, but not headings."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\^M)
+ (if (not (eobp))
+ (forward-char
+ (if (looking-at "[\n\^M][\n\^M]")
+ 2 1)))))))
+
+(defun show-all ()
+ "Show all of the text in the buffer."
+ (interactive)
+ (outline-flag-region (point-min) (point-max) ?\n))
+
+(defun hide-subtree ()
+ "Hide everything after this heading at deeper levels."
+ (interactive)
+ (outline-flag-subtree ?\^M))
+
+(defun hide-leaves ()
+ "Hide all body after this heading at deeper levels."
+ (interactive)
+ (outline-back-to-heading)
+ (hide-region-body (point) (progn (outline-end-of-subtree) (point))))
+
+(defun show-subtree ()
+ "Show everything after this heading at deeper levels."
+ (interactive)
+ (outline-flag-subtree ?\n))
+
+(defun outline-flag-subtree (flag)
+ (save-excursion
+ (outline-back-to-heading)
+ (outline-flag-region (point)
+ (progn (outline-end-of-subtree) (point))
+ flag)))
+
+(defun outline-end-of-subtree ()
+ (beginning-of-line)
+ (let ((opoint (point))
+ (first t)
+ (level (outline-level)))
+ (while (and (not (eobp))
+ (or first (> (outline-level) level)))
+ (setq first nil)
+ (outline-next-heading))
+ (forward-char -1)
+ (if (memq (preceding-char) '(?\n ?\^M))
+ (forward-char -1))))
+\f
+(defun show-branches ()
+ "Show all subheadings of this heading, but not their bodies."
+ (interactive)
+ (show-children 1000))
+
+(defun show-children (&optional level)
+ "Show all direct subheadings of this heading. Optional LEVEL specifies
+how many levels below the current level should be shown."
+ (interactive "p")
+ (or level (setq level 1))
+ (save-excursion
+ (save-restriction
+ (beginning-of-line)
+ (setq level (+ level (outline-level)))
+ (narrow-to-region (point)
+ (progn (outline-end-of-subtree) (1+ (point))))
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (progn
+ (outline-next-heading)
+ (not (eobp))))
+ (if (<= (outline-level) level)
+ (save-excursion
+ (let ((end (1+ (point))))
+ (forward-char -1)
+ (if (memq (preceding-char) '(?\n ?\^M))
+ (forward-char -1))
+ (outline-flag-region (point) end ?\n))))))))
+\f
+(defun outline-up-heading (arg)
+ "Move to the heading line of which the present line is a subheading.
+With argument, move up ARG levels."
+ (interactive "p")
+ (outline-back-to-heading)
+ (if (eq (outline-level) 1)
+ (error ""))
+ (while (and (> (outline-level) 1)
+ (> arg 0)
+ (not (bobp)))
+ (let ((present-level (outline-level)))
+ (while (not (< (outline-level) present-level))
+ (outline-previous-visible-heading 1))
+ (setq arg (- arg 1)))))
+
+(defun outline-forward-same-level (arg)
+ "Move forward to the ARG'th subheading from here of the same level as the
+present one. It stops at the first and last subheadings of a superior heading."
+ (interactive "p")
+ (outline-back-to-heading)
+ (while (> arg 0)
+ (let ((point-to-move-to (save-excursion
+ (outline-get-next-sibling))))
+ (if point-to-move-to
+ (progn
+ (goto-char point-to-move-to)
+ (setq arg (1- arg)))
+ (progn
+ (setq arg 0)
+ (error ""))))))
+
+(defun outline-get-next-sibling ()
+ "Position the point at the next heading of the same level,
+and return that position or nil if it cannot be found."
+ (let ((level (outline-level)))
+ (outline-next-visible-heading 1)
+ (while (and (> (outline-level) level)
+ (not (eobp)))
+ (outline-next-visible-heading 1))
+ (if (< (outline-level) level)
+ nil
+ (point))))
+
+(defun outline-backward-same-level (arg)
+ "Move backward to the ARG'th subheading from here of the same level as the
+present one. It stops at the first and last subheadings of a superior heading."
+ (interactive "p")
+ (outline-back-to-heading)
+ (while (> arg 0)
+ (let ((point-to-move-to (save-excursion
+ (outline-get-last-sibling))))
+ (if point-to-move-to
+ (progn
+ (goto-char point-to-move-to)
+ (setq arg (1- arg)))
+ (progn
+ (setq arg 0)
+ (error ""))))))
+
+(defun outline-get-last-sibling ()
+ "Position the point at the previous heading of the same level,
+and return that position or nil if it cannot be found."
+ (let ((level (outline-level)))
+ (outline-previous-visible-heading 1)
+ (while (and (> (outline-level) level)
+ (not (bobp)))
+ (outline-previous-visible-heading 1))
+ (if (< (outline-level) level)
+ nil
+ (point))))
+
--- /dev/null
+;; Page motion commands for emacs.
+;; Copyright (C) 1985 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.
+
+
+(defun forward-page (&optional count)
+ "Move forward to page boundary. With arg, repeat, or go back if negative.
+A page boundary is any line whose beginning matches the regexp page-delimiter."
+ (interactive "p")
+ (or count (setq count 1))
+ (while (and (> count 0) (not (eobp)))
+ (if (re-search-forward page-delimiter nil t)
+ nil
+ (goto-char (point-max)))
+ (setq count (1- count)))
+ (while (and (< count 0) (not (bobp)))
+ (forward-char -1)
+ (if (re-search-backward page-delimiter nil t)
+ (goto-char (match-end 0))
+ (goto-char (point-min)))
+ (setq count (1+ count))))
+
+(defun backward-page (&optional count)
+ "Move backward to page boundary. With arg, repeat, or go fwd if negative.
+A page boundary is any line whose beginning matches the regexp page-delimiter."
+ (interactive "p")
+ (or count (setq count 1))
+ (forward-page (- count)))
+
+(defun mark-page (&optional arg)
+ "Put mark at end of page, point at beginning.
+A numeric arg specifies to move forward or backward by that many pages,
+thus marking a page other than the one point was originally in."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 0))
+ (if (> arg 0)
+ (forward-page arg)
+ (if (< arg 0)
+ (forward-page (1- arg))))
+ (forward-page)
+ (push-mark nil t)
+ (forward-page -1))
+
+(defun narrow-to-page (&optional arg)
+ "Make text outside current page invisible.
+A numeric arg specifies to move forward or backward by that many pages,
+thus showing a page other than the one point was originally in."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 0))
+ (save-excursion
+ (widen)
+ (if (> arg 0)
+ (forward-page arg)
+ (if (< arg 0)
+ (forward-page (1- arg))))
+ ;; Find the end of the page.
+ (forward-page)
+ ;; If we stopped due to end of buffer, stay there.
+ ;; If we stopped after a page delimiter, put end of restriction
+ ;; at the beginning of that line.
+ (if (save-excursion (beginning-of-line)
+ (looking-at page-delimiter))
+ (beginning-of-line))
+ (narrow-to-region (point)
+ (progn
+ ;; Find the top of the page.
+ (forward-page -1)
+ ;; If we found beginning of buffer, stay there.
+ ;; If extra text follows page delimiter on same line,
+ ;; include it.
+ ;; Otherwise, show text starting with following line.
+ (if (and (eolp) (not (bobp)))
+ (forward-line 1))
+ (point)))))
+
+(defun count-lines-page ()
+ "Report number of lines on current page, and how many are before or after point."
+ (interactive)
+ (save-excursion
+ (let ((opoint (point)) beg end
+ total before after)
+ (forward-page)
+ (beginning-of-line)
+ (or (looking-at page-delimiter)
+ (end-of-line))
+ (setq end (point))
+ (backward-page)
+ (setq beg (point))
+ (setq total (count-lines beg end)
+ before (count-lines beg opoint)
+ after (count-lines opoint end))
+ (message "Page has %d lines (%d + %d)" total before after))))
+
+(defun what-page ()
+ "Print page and line number of point."
+ (interactive)
+ (save-restriction
+ (widen)
+ (save-excursion
+ (beginning-of-line)
+ (let ((count 1)
+ (opoint (point)))
+ (goto-char 1)
+ (while (re-search-forward page-delimiter opoint t)
+ (setq count (1+ count)))
+ (message "Page %d, line %d"
+ count
+ (1+ (count-lines (point) opoint)))))))
--- /dev/null
+;; Paragraph and sentence parsing.
+;; Copyright (C) 1985 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.
+
+
+(defvar paragraph-ignore-fill-prefix nil
+ "Non-nil means the paragraph commands are not affected by fill-prefix.
+This is desirable in modes where blank lines are the paragraph delimiters.")
+
+(defun forward-paragraph (&optional arg)
+ "Move forward to end of paragraph. With arg, do it arg times.
+A line which paragraph-start matches either separates paragraphs
+\(if paragraph-separate matches it also) or is the first line of a paragraph.
+A paragraph end is the beginning of a line which is not part of the paragraph
+to which the end of the previous line belongs, or the end of the buffer."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let* ((fill-prefix-regexp
+ (and fill-prefix (not (equal fill-prefix ""))
+ (not paragraph-ignore-fill-prefix)
+ (regexp-quote fill-prefix)))
+ (paragraph-separate
+ (if fill-prefix-regexp
+ (concat paragraph-separate "\\|^"
+ fill-prefix-regexp "[ \t]*$")
+ paragraph-separate)))
+ (while (< arg 0)
+ (if (and (not (looking-at paragraph-separate))
+ (re-search-backward "^\n" (max (1- (point)) (point-min)) t))
+ nil
+ (forward-char -1) (beginning-of-line)
+ (while (and (not (bobp)) (looking-at paragraph-separate))
+ (forward-line -1))
+ (end-of-line)
+ ;; Search back for line that starts or separates paragraphs.
+ (if (if fill-prefix-regexp
+ ;; There is a fill prefix; it overrides paragraph-start.
+ (progn
+ (while (progn (beginning-of-line)
+ (and (not (bobp))
+ (not (looking-at paragraph-separate))
+ (looking-at fill-prefix-regexp)))
+ (forward-line -1))
+ (not (bobp)))
+ (re-search-backward paragraph-start nil t))
+ ;; Found one.
+ (progn
+ (while (and (not (eobp)) (looking-at paragraph-separate))
+ (forward-line 1))
+ (if (eq (char-after (- (point) 2)) ?\n)
+ (forward-line -1)))
+ ;; No starter or separator line => use buffer beg.
+ (goto-char (point-min))))
+ (setq arg (1+ arg)))
+ (while (> arg 0)
+ (beginning-of-line)
+ (while (prog1 (and (not (eobp))
+ (looking-at paragraph-separate))
+ (forward-line 1)))
+ (if fill-prefix-regexp
+ ;; There is a fill prefix; it overrides paragraph-start.
+ (while (and (not (eobp))
+ (not (looking-at paragraph-separate))
+ (looking-at fill-prefix-regexp))
+ (forward-line 1))
+ (if (re-search-forward paragraph-start nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max))))
+ (setq arg (1- arg)))))
+
+(defun backward-paragraph (&optional arg)
+ "Move backward to start of paragraph. With arg, do it arg times.
+A paragraph start is the beginning of a line which is a first-line-of-paragraph
+or which is ordinary text and follows a paragraph-separating line; except:
+if the first real line of a paragraph is preceded by a blank line,
+the paragraph starts at that blank line.
+See forward-paragraph for more information."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (forward-paragraph (- arg)))
+
+(defun mark-paragraph ()
+ "Put point at beginning of this paragraph, mark at end."
+ (interactive)
+ (forward-paragraph 1)
+ (push-mark nil t)
+ (backward-paragraph 1))
+
+(defun kill-paragraph (arg)
+ "Kill to end of paragraph."
+ (interactive "*p")
+ (kill-region (point) (progn (forward-paragraph arg) (point))))
+
+(defun backward-kill-paragraph (arg)
+ "Kill back to start of paragraph."
+ (interactive "*p")
+ (kill-region (point) (progn (backward-paragraph arg) (point))))
+
+(defun transpose-paragraphs (arg)
+ "Interchange this (or next) paragraph with previous one."
+ (interactive "*p")
+ (transpose-subr 'forward-paragraph arg))
+
+(defun start-of-paragraph-text ()
+ (let ((opoint (point)) npoint)
+ (forward-paragraph -1)
+ (setq npoint (point))
+ (skip-chars-forward " \t\n")
+ ;; If the range of blank lines found spans the original start point,
+ ;; try again from the beginning of it.
+ ;; Must be careful to avoid infinite loop
+ ;; when following a single return at start of buffer.
+ (if (and (>= (point) opoint) (< npoint opoint))
+ (progn
+ (goto-char npoint)
+ (if (> npoint (point-min))
+ (start-of-paragraph-text))))))
+
+(defun end-of-paragraph-text ()
+ (let ((opoint (point)))
+ (forward-paragraph 1)
+ (if (eq (preceding-char) ?\n) (forward-char -1))
+ (if (<= (point) opoint)
+ (progn
+ (forward-char 1)
+ (if (< (point) (point-max))
+ (end-of-paragraph-text))))))
+
+(defun forward-sentence (&optional arg)
+ "Move forward to next sentence-end. With argument, repeat.
+With negative argument, move backward repeatedly to sentence-beginning.
+Sentence ends are identified by the value of sentence-end
+treated as a regular expression. Also, every paragraph boundary
+terminates sentences as well."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (while (< arg 0)
+ (let ((par-beg (save-excursion (start-of-paragraph-text) (point))))
+ (if (re-search-backward (concat sentence-end "[^ \t\n]") par-beg t)
+ (goto-char (1- (match-end 0)))
+ (goto-char par-beg)))
+ (setq arg (1+ arg)))
+ (while (> arg 0)
+ (let ((par-end (save-excursion (end-of-paragraph-text) (point))))
+ (if (re-search-forward sentence-end par-end t)
+ (skip-chars-backward " \t\n")
+ (goto-char par-end)))
+ (setq arg (1- arg))))
+
+(defun backward-sentence (&optional arg)
+ "Move backward to start of sentence. With arg, do it arg times.
+See forward-sentence for more information."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (forward-sentence (- arg)))
+
+(defun kill-sentence (&optional arg)
+ "Kill from point to end of sentence.
+With arg, repeat, or backward if negative arg."
+ (interactive "*p")
+ (let ((beg (point)))
+ (forward-sentence arg)
+ (kill-region beg (point))))
+
+(defun backward-kill-sentence (&optional arg)
+ "Kill back from point to start of sentence.
+With arg, repeat, or forward if negative arg."
+ (interactive "*p")
+ (let ((beg (point)))
+ (backward-sentence arg)
+ (kill-region beg (point))))
+
+(defun mark-end-of-sentence (arg)
+ "Put mark at end of sentence. Arg works as in forward-sentence."
+ (interactive "p")
+ (push-mark
+ (save-excursion
+ (forward-sentence arg)
+ (point))))
+
+(defun transpose-sentences (arg)
+ "Interchange this (next) and previous sentence."
+ (interactive "*p")
+ (transpose-subr 'forward-sentence arg))
--- /dev/null
+;; Define pathnames for use by various Emacs commands.
+;; Copyright (C) 1986, 1988 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.
+
+
+;; These are default settings for names of certain files and directories
+;; that Emacs needs to refer to from time to time.
+
+;; If these settings are not right, override them with `setq'
+;; in site-init.el. Do not change this file.
+
+(defvar Info-directory (expand-file-name "../info/" exec-directory))
+
+(defvar news-path "/usr/spool/news/"
+ "The root directory below which all news files are stored.")
+(defvar news-inews-program
+ (cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews")
+ ((file-exists-p "/usr/local/inews") "/usr/local/inews")
+ ((file-exists-p "/usr/local/bin/inews") "/usr/local/bin/inews")
+ ((file-exists-p "/usr/lib/news/inews") "/usr/lib/news/inews")
+ (t "inews"))
+ "Program to post news.")
+
+(defvar mh-progs
+ (cond ((file-exists-p "/usr/new/mh") "/usr/new/mh/")
+ ((file-exists-p "/usr/local/bin/mh") "/usr/local/bin/mh/")
+ (t "/usr/local/mh/"))
+ "Directory containing MH commands")
+
+(defvar mh-lib
+ (cond ((file-exists-p "/usr/new/lib/mh") "/usr/new/lib/mh/")
+ ((file-exists-p "/usr/local/lib/mh") "/usr/local/lib/mh/")
+ (t "/usr/local/bin/mh/"))
+ "Directory of MH library")
+
+(defconst rmail-file-name "~/RMAIL"
+ "Name of user's primary mail file.")
+
+(defconst rmail-spool-directory
+ (if (memq system-type '(hpux usg-unix-v unisoft-unix rtu
+ silicon-graphics-unix))
+ "/usr/mail/"
+ "/usr/spool/mail/")
+ "Name of directory used by system mailer for delivering new mail.
+Its name should end with a slash.")
+
+(defconst sendmail-program
+ (if (file-exists-p "/usr/lib/sendmail")
+ "/usr/lib/sendmail"
+ "fakemail") ;In ../etc, to interface to /bin/mail.
+ "Program used to send messages.")
+
+(defconst term-file-prefix (if (eq system-type 'vax-vms) "[.term]" "term/")
+ "If non-nil, Emacs startup does (load (concat term-file-prefix (getenv \"TERM\")))
+You may set this variable to nil in your `.emacs' file if you do not wish
+the terminal-initialization file to be loaded.")
+
+(defconst manual-program (if (eq system-type 'berkeley-unix)
+ "/usr/ucb/man" "/usr/bin/man")
+ "Program to run to print man pages.")
+
+;; Note that /usr/man/cat is not really right for this on sysV; nothing is,
+;; judging by the list of directories below. You can't get the dir
+;; for a section by appending the section number to any one prefix.
+;; But it turns out that a string that's wrong does no harm here.
+(defconst manual-formatted-dir-prefix
+ (if (file-exists-p "/usr/man/cat.C") ;; Check for Xenix.
+ "/usr/man/cat." "/usr/man/cat")
+ "Prefix for directories containing formatted manual pages.
+Append a section-number or section-name to get a directory name.")
+
+(defconst manual-formatted-dirlist
+ (cond ((eq system-type 'hpux)
+ '("/usr/man/cat1" "/usr/man/cat2" "/usr/man/cat3"
+ "/usr/man/cat4" "/usr/man/cat5" "/usr/man/cat6"
+ "/usr/man/cat7" "/usr/man/cat1m" "/usr/man/cat8"
+ "/usr/local/man/cat1" "/usr/local/man/cat2" "/usr/local/man/cat3"
+ "/usr/local/man/cat4" "/usr/local/man/cat5" "/usr/local/man/cat6"
+ "/usr/local/man/cat7" "/usr/local/man/cat1m" "/usr/local/man/cat8"
+ "/usr/contrib/man/cat1" "/usr/contrib/man/cat2"
+ "/usr/contrib/man/cat3" "/usr/contrib/man/cat4"
+ "/usr/contrib/man/cat5" "/usr/contrib/man/cat6"
+ "/usr/contrib/man/cat7" "/usr/contrib/man/cat1m"
+ "/usr/contrib/man/cat8"))
+ ((file-exists-p "/usr/man/cat.C") ; Xenix
+ '("/usr/man/cat.C" "/usr/man/cat.CP" "/usr/man/cat.CT"
+ "/usr/man/cat.DOS/" "/usr/man/cat.F" "/usr/man/cat.HW"
+ "/usr/man/cat.M/" "/usr/man/cat.S" "/usr/man/cat.LOCAL"))
+ ((file-exists-p "/usr/man/cat1")
+ '("/usr/man/cat1" "/usr/man/cat2" "/usr/man/cat3"
+ "/usr/man/cat4" "/usr/man/cat5" "/usr/man/cat6"
+ "/usr/man/cat7" "/usr/man/cat8" "/usr/man/catl" "/usr/man/catn"))
+ (t
+ '("/usr/catman/u_man/man1" "/usr/catman/u_man/man6"
+ "/usr/catman/p_man/man2" "/usr/catman/p_man/man3"
+ "/usr/catman/p_man/man4" "/usr/catman/p_man/man5"
+ "/usr/catman/a_man/man1" "/usr/catman/a_man/man7"
+ "/usr/catman/a_man/man8" "/usr/catman/local")))
+ "List of directories containing formatted manual pages.")
+
+(defconst abbrev-file-name
+ (if (eq system-type 'vax-vms)
+ "~/abbrev.def"
+ "~/.abbrev_defs")
+ "*Default name of file to read abbrevs from.")
--- /dev/null
+;; "Picture mode" -- editing using quarter-plane screen model.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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.
+
+
+(provide 'picture)
+
+(defun move-to-column-force (column)
+ "Move to column COLUMN in current line.
+Differs from move-to-column in that it creates or modifies whitespace
+if necessary to attain exactly the specified column."
+ (move-to-column column)
+ (let ((col (current-column)))
+ (if (< col column)
+ (indent-to column)
+ (if (and (/= col column)
+ (= (preceding-char) ?\t))
+ (let (indent-tabs-mode)
+ (delete-char -1)
+ (indent-to col)
+ (move-to-column column))))))
+
+\f
+;; Picture Movement Commands
+
+(defun picture-end-of-line (&optional arg)
+ "Position point after last non-blank character on current line.
+With ARG not nil, move forward ARG - 1 lines first.
+If scan reaches end of buffer, stop there without error."
+ (interactive "P")
+ (if arg (forward-line (1- (prefix-numeric-value arg))))
+ (beginning-of-line)
+ (skip-chars-backward " \t" (prog1 (point) (end-of-line))))
+
+(defun picture-forward-column (arg)
+ "Move cursor right, making whitespace if necessary.
+With argument, move that many columns."
+ (interactive "p")
+ (move-to-column-force (+ (current-column) arg)))
+
+(defun picture-backward-column (arg)
+ "Move cursor left, making whitespace if necessary.
+With argument, move that many columns."
+ (interactive "p")
+ (move-to-column-force (- (current-column) arg)))
+
+(defun picture-move-down (arg)
+ "Move vertically down, making whitespace if necessary.
+With argument, move that many lines."
+ (interactive "p")
+ (let ((col (current-column)))
+ (picture-newline arg)
+ (move-to-column-force col)))
+
+(defconst picture-vertical-step 0
+ "Amount to move vertically after text character in Picture mode.")
+
+(defconst picture-horizontal-step 1
+ "Amount to move horizontally after text character in Picture mode.")
+
+(defun picture-move-up (arg)
+ "Move vertically up, making whitespace if necessary.
+With argument, move that many lines."
+ (interactive "p")
+ (picture-move-down (- arg)))
+
+(defun picture-movement-right ()
+ "Move right after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion 0 1))
+
+(defun picture-movement-left ()
+ "Move left after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion 0 -1))
+
+(defun picture-movement-up ()
+ "Move up after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion -1 0))
+
+(defun picture-movement-down ()
+ "Move down after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion 1 0))
+
+(defun picture-movement-nw ()
+ "Move up and left after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion -1 -1))
+
+(defun picture-movement-ne ()
+ "Move up and right after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion -1 1))
+
+(defun picture-movement-sw ()
+ "Move down and left after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion 1 -1))
+
+(defun picture-movement-se ()
+ "Move down and right after self-inserting character in Picture mode."
+ (interactive)
+ (picture-set-motion 1 1))
+
+(defun picture-set-motion (vert horiz)
+ "Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
+The mode line is updated to reflect the current direction."
+ (setq picture-vertical-step vert
+ picture-horizontal-step horiz)
+ (setq mode-name
+ (format "Picture:%s"
+ (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
+ '(nw up ne left none right sw down se)))))
+ ;; Kludge - force the mode line to be updated. Is there a better
+ ;; way to this?
+ (set-buffer-modified-p (buffer-modified-p))
+ (message ""))
+
+(defun picture-move ()
+ "Move in direction of picture-vertical-step and picture-horizontal-step."
+ (picture-move-down picture-vertical-step)
+ (picture-forward-column picture-horizontal-step))
+
+(defun picture-motion (arg)
+ "Move point in direction of current picture motion in Picture mode.
+With ARG do it that many times. Useful for delineating rectangles in
+conjunction with diagonal picture motion.
+Do \\[command-apropos] picture-movement to see commands which control motion."
+ (interactive "p")
+ (picture-move-down (* arg picture-vertical-step))
+ (picture-forward-column (* arg picture-horizontal-step)))
+
+(defun picture-motion-reverse (arg)
+ "Move point in direction opposite of current picture motion in Picture mode.
+With ARG do it that many times. Useful for delineating rectangles in
+conjunction with diagonal picture motion.
+Do \\[command-apropos] picture-movement to see commands which control motion."
+ (interactive "p")
+ (picture-motion (- arg)))
+
+\f
+;; Picture insertion and deletion.
+
+(defun picture-self-insert (arg)
+ "Insert this character in place of character previously at the cursor.
+The cursor then moves in the direction you previously specified
+with the commands picture-movement-right, picture-movement-up, etc.
+Do \\[command-apropos] picture-movement to see those commands."
+ (interactive "p")
+ (while (> arg 0)
+ (setq arg (1- arg))
+ (move-to-column-force (1+ (current-column)))
+ (delete-char -1)
+ (insert last-input-char)
+ (forward-char -1)
+ (picture-move)))
+
+(defun picture-clear-column (arg)
+ "Clear out ARG columns after point without moving."
+ (interactive "p")
+ (let* ((opoint (point))
+ (original-col (current-column))
+ (target-col (+ original-col arg)))
+ (move-to-column-force target-col)
+ (delete-region opoint (point))
+ (save-excursion
+ (indent-to (max target-col original-col)))))
+
+(defun picture-backward-clear-column (arg)
+ "Clear out ARG columns before point, moving back over them."
+ (interactive "p")
+ (picture-clear-column (- arg)))
+
+(defun picture-clear-line (arg)
+ "Clear out rest of line; if at end of line, advance to next line.
+Cleared-out line text goes into the kill ring, as do
+newlines that are advanced over.
+With argument, clear out (and save in kill ring) that many lines."
+ (interactive "P")
+ (if arg
+ (progn
+ (setq arg (prefix-numeric-value arg))
+ (kill-line arg)
+ (newline (if (> arg 0) arg (- arg))))
+ (if (looking-at "[ \t]*$")
+ (kill-ring-save (point) (progn (forward-line 1) (point)))
+ (kill-region (point) (progn (end-of-line) (point))))))
+
+(defun picture-newline (arg)
+ "Move to the beginning of the following line.
+With argument, moves that many lines (up, if negative argument);
+always moves to the beginning of a line."
+ (interactive "p")
+ (if (< arg 0)
+ (forward-line arg)
+ (while (> arg 0)
+ (end-of-line)
+ (if (eobp) (newline) (forward-char 1))
+ (setq arg (1- arg)))))
+
+(defun picture-open-line (arg)
+ "Insert an empty line after the current line.
+With positive argument insert that many lines."
+ (interactive "p")
+ (save-excursion
+ (end-of-line)
+ (open-line arg)))
+
+(defun picture-duplicate-line ()
+ "Insert a duplicate of the current line, below it."
+ (interactive)
+ (save-excursion
+ (let ((contents
+ (buffer-substring
+ (progn (beginning-of-line) (point))
+ (progn (picture-newline 1) (point)))))
+ (forward-line -1)
+ (insert contents))))
+
+\f
+;; Picture Tabs
+
+(defvar picture-tab-chars "!-~"
+ "*A character set which controls behavior of commands
+\\[picture-set-tab-stops] and \\[picture-tab-search]. It is NOT a
+regular expression, any regexp special characters will be quoted.
+It defines a set of \"interesting characters\" to look for when setting
+\(or searching for) tab stops, initially \"!-~\" (all printing characters).
+For example, suppose that you are editing a table which is formatted thus:
+| foo | bar + baz | 23 *
+| bubbles | and + etc | 97 *
+and that picture-tab-chars is \"|+*\". Then invoking
+\\[picture-set-tab-stops] on either of the previous lines would result
+in the following tab stops
+ : : : :
+Another example - \"A-Za-z0-9\" would produce the tab stops
+ : : : :
+
+Note that if you want the character `-' to be in the set, it must be
+included in a range or else appear in a context where it cannot be
+taken for indicating a range (e.g. \"-A-Z\" declares the set to be the
+letters `A' through `Z' and the character `-'). If you want the
+character `\\' in the set it must be preceded by itself: \"\\\\\".
+
+The command \\[picture-tab-search] is defined to move beneath (or to) a
+character belonging to this set independent of the tab stops list.")
+
+(defun picture-set-tab-stops (&optional arg)
+ "Set value of tab-stop-list according to context of this line.
+This controls the behavior of \\[picture-tab]. A tab stop
+is set at every column occupied by an \"interesting character\" that is
+preceded by whitespace. Interesting characters are defined by the
+variable picture-tab-chars, see its documentation for an example
+of usage. With ARG, just (re)set tab-stop-list to its default value.
+The tab stops computed are displayed in the minibuffer with `:' at
+each stop."
+ (interactive "P")
+ (save-excursion
+ (let (tabs)
+ (if arg
+ (setq tabs (default-value 'tab-stop-list))
+ (let ((regexp (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")))
+ (beginning-of-line)
+ (let ((bol (point)))
+ (end-of-line)
+ (while (re-search-backward regexp bol t)
+ (skip-chars-forward " \t")
+ (setq tabs (cons (current-column) tabs)))
+ (if (null tabs)
+ (error "No characters in set %s on this line."
+ (regexp-quote picture-tab-chars))))))
+ (setq tab-stop-list tabs)
+ (let ((blurb (make-string (1+ (nth (1- (length tabs)) tabs)) ?\ )))
+ (while tabs
+ (aset blurb (car tabs) ?:)
+ (setq tabs (cdr tabs)))
+ (message blurb)))))
+
+(defun picture-tab-search (&optional arg)
+ "Move to column beneath next interesting char in previous line.
+With ARG move to column occupied by next interesting character in this
+line. The character must be preceded by whitespace.
+\"interesting characters\" are defined by variable picture-tab-chars.
+If no such character is found, move to beginning of line."
+ (interactive "P")
+ (let ((target (current-column)))
+ (save-excursion
+ (if (and (not arg)
+ (progn
+ (beginning-of-line)
+ (skip-chars-backward
+ (concat "^" (regexp-quote picture-tab-chars))
+ (point-min))
+ (not (bobp))))
+ (move-to-column target))
+ (if (re-search-forward
+ (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")
+ (save-excursion (end-of-line) (point))
+ 'move)
+ (setq target (1- (current-column)))
+ (setq target nil)))
+ (if target
+ (move-to-column-force target)
+ (beginning-of-line))))
+
+(defun picture-tab (&optional arg)
+ "Tab transparently (move) to next tab stop.
+With ARG overwrite the traversed text with spaces. The tab stop
+list can be changed by \\[picture-set-tab-stops] and \\[edit-tab-stops].
+See also documentation for variable picture-tab-chars."
+ (interactive "P")
+ (let* ((opoint (point))
+ (target (prog2 (tab-to-tab-stop)
+ (current-column)
+ (delete-region opoint (point)))))
+ (move-to-column-force target)
+ (if arg
+ (let (indent-tabs-mode)
+ (delete-region opoint (point))
+ (indent-to target)))))
+\f
+;; Picture Rectangles
+
+(defconst picture-killed-rectangle nil
+ "Rectangle killed or copied by \\[picture-clear-rectangle] in Picture mode.
+The contents can be retrieved by \\[picture-yank-rectangle]")
+
+(defun picture-clear-rectangle (start end &optional killp)
+ "Clear and save rectangle delineated by point and mark.
+The rectangle is saved for yanking by \\[picture-yank-rectangle] and replaced
+with whitespace. The previously saved rectangle, if any, is lost.
+With prefix argument, the rectangle is actually killed, shifting remaining
+text."
+ (interactive "r\nP")
+ (setq picture-killed-rectangle (picture-snarf-rectangle start end killp)))
+
+(defun picture-clear-rectangle-to-register (start end register &optional killp)
+ "Clear rectangle delineated by point and mark into REGISTER.
+The rectangle is saved in REGISTER and replaced with whitespace.
+With prefix argument, the rectangle is actually killed, shifting remaining
+text."
+ (interactive "r\ncRectangle to register: \nP")
+ (set-register register (picture-snarf-rectangle start end killp)))
+
+(defun picture-snarf-rectangle (start end &optional killp)
+ (let ((column (current-column))
+ (indent-tabs-mode nil))
+ (prog1 (save-excursion
+ (if killp
+ (delete-extract-rectangle start end)
+ (prog1 (extract-rectangle start end)
+ (clear-rectangle start end))))
+ (move-to-column-force column))))
+
+(defun picture-yank-rectangle (&optional insertp)
+ "Overlay rectangle saved by \\[picture-clear-rectangle]
+The rectangle is positioned with upper left corner at point, overwriting
+existing text. With prefix argument, the rectangle is inserted instead,
+shifting existing text. Leaves mark at one corner of rectangle and
+point at the other (diagonally opposed) corner."
+ (interactive "P")
+ (if (not (consp picture-killed-rectangle))
+ (error "No rectangle saved.")
+ (picture-insert-rectangle picture-killed-rectangle insertp)))
+
+(defun picture-yank-rectangle-from-register (register &optional insertp)
+ "Overlay rectangle saved in REGISTER.
+The rectangle is positioned with upper left corner at point, overwriting
+existing text. With prefix argument, the rectangle is
+inserted instead, shifting existing text. Leaves mark at one corner
+of rectangle and point at the other (diagonally opposed) corner."
+ (interactive "cRectangle from register: \nP")
+ (let ((rectangle (get-register register)))
+ (if (not (consp rectangle))
+ (error "Register %c does not contain a rectangle." register)
+ (picture-insert-rectangle rectangle insertp))))
+
+(defun picture-insert-rectangle (rectangle &optional insertp)
+ "Overlay RECTANGLE with upper left corner at point.
+Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted.
+Leaves the region surrounding the rectangle."
+ (let ((indent-tabs-mode nil))
+ (if (not insertp)
+ (save-excursion
+ (delete-rectangle (point)
+ (progn
+ (picture-forward-column (length (car rectangle)))
+ (picture-move-down (1- (length rectangle)))
+ (point)))))
+ (push-mark)
+ (insert-rectangle rectangle)))
+
+\f
+;; Picture Keymap, entry and exit points.
+
+(defconst picture-mode-map nil)
+
+(if (not picture-mode-map)
+ (let ((i ?\ ))
+ (setq picture-mode-map (make-keymap))
+ (while (< i ?\177)
+ (aset picture-mode-map i 'picture-self-insert)
+ (setq i (1+ i)))
+ (define-key picture-mode-map "\C-f" 'picture-forward-column)
+ (define-key picture-mode-map "\C-b" 'picture-backward-column)
+ (define-key picture-mode-map "\C-d" 'picture-clear-column)
+ (define-key picture-mode-map "\C-c\C-d" 'delete-char)
+ (define-key picture-mode-map "\177" 'picture-backward-clear-column)
+ (define-key picture-mode-map "\C-k" 'picture-clear-line)
+ (define-key picture-mode-map "\C-o" 'picture-open-line)
+ (define-key picture-mode-map "\C-m" 'picture-newline)
+ (define-key picture-mode-map "\C-j" 'picture-duplicate-line)
+ (define-key picture-mode-map "\C-n" 'picture-move-down)
+ (define-key picture-mode-map "\C-p" 'picture-move-up)
+ (define-key picture-mode-map "\C-e" 'picture-end-of-line)
+ (define-key picture-mode-map "\e\t" 'picture-toggle-tab-state)
+ (define-key picture-mode-map "\t" 'picture-tab)
+ (define-key picture-mode-map "\e\t" 'picture-tab-search)
+ (define-key picture-mode-map "\C-c\t" 'picture-set-tab-stops)
+ (define-key picture-mode-map "\C-c\C-k" 'picture-clear-rectangle)
+ (define-key picture-mode-map "\C-c\C-w" 'picture-clear-rectangle-to-register)
+ (define-key picture-mode-map "\C-c\C-y" 'picture-yank-rectangle)
+ (define-key picture-mode-map "\C-c\C-x" 'picture-yank-rectangle-from-register)
+ (define-key picture-mode-map "\C-c\C-c" 'picture-mode-exit)
+ (define-key picture-mode-map "\C-c\C-f" 'picture-motion)
+ (define-key picture-mode-map "\C-c\C-b" 'picture-motion-reverse)
+ (define-key picture-mode-map "\C-c<" 'picture-movement-left)
+ (define-key picture-mode-map "\C-c>" 'picture-movement-right)
+ (define-key picture-mode-map "\C-c^" 'picture-movement-up)
+ (define-key picture-mode-map "\C-c." 'picture-movement-down)
+ (define-key picture-mode-map "\C-c`" 'picture-movement-nw)
+ (define-key picture-mode-map "\C-c'" 'picture-movement-ne)
+ (define-key picture-mode-map "\C-c/" 'picture-movement-sw)
+ (define-key picture-mode-map "\C-c\\" 'picture-movement-se)))
+
+(defvar edit-picture-hook nil
+ "If non-nil, it's value is called on entry to Picture mode.
+Picture mode is invoked by the command \\[edit-picture].")
+
+(defun edit-picture ()
+ "Switch to Picture mode, in which a quarter-plane screen model is used.
+Printing characters replace instead of inserting themselves with motion
+afterwards settable by these commands:
+ C-c < Move left after insertion.
+ C-c > Move right after insertion.
+ C-c ^ Move up after insertion.
+ C-c . Move down after insertion.
+ C-c ` Move northwest (nw) after insertion.
+ C-c ' Move northeast (ne) after insertion.
+ C-c / Move southwest (sw) after insertion.
+ C-c \\ Move southeast (se) after insertion.
+The current direction is displayed in the mode line. The initial
+direction is right. Whitespace is inserted and tabs are changed to
+spaces when required by movement. You can move around in the buffer
+with these commands:
+ C-p Move vertically to SAME column in previous line.
+ C-n Move vertically to SAME column in next line.
+ C-e Move to column following last non-whitespace character.
+ C-f Move right inserting spaces if required.
+ C-b Move left changing tabs to spaces if required.
+ C-c C-f Move in direction of current picture motion.
+ C-c C-b Move in opposite direction of current picture motion.
+ Return Move to beginning of next line.
+You can edit tabular text with these commands:
+ M-Tab Move to column beneath (or at) next interesting character.
+ `Indents' relative to a previous line.
+ Tab Move to next stop in tab stop list.
+ C-c Tab Set tab stops according to context of this line.
+ With ARG resets tab stops to default (global) value.
+ See also documentation of variable picture-tab-chars
+ which defines \"interesting character\". You can manually
+ change the tab stop list with command \\[edit-tab-stops].
+You can manipulate text with these commands:
+ C-d Clear (replace) ARG columns after point without moving.
+ C-c C-d Delete char at point - the command normally assigned to C-d.
+ Delete Clear (replace) ARG columns before point, moving back over them.
+ C-k Clear ARG lines, advancing over them. The cleared
+ text is saved in the kill ring.
+ C-o Open blank line(s) beneath current line.
+You can manipulate rectangles with these commands:
+ C-c C-k Clear (or kill) a rectangle and save it.
+ C-c C-w Like C-c C-k except rectangle is saved in named register.
+ C-c C-y Overlay (or insert) currently saved rectangle at point.
+ C-c C-x Like C-c C-y except rectangle is taken from named register.
+ \\[copy-rectangle-to-register] Copies a rectangle to a register.
+ \\[advertised-undo] Can undo effects of rectangle overlay commands
+ commands if invoked soon enough.
+You can return to the previous mode with:
+ C-c C-c Which also strips trailing whitespace from every line.
+ Stripping is suppressed by supplying an argument.
+
+Entry to this mode calls the value of edit-picture-hook if non-nil.
+
+Note that Picture mode commands will work outside of Picture mode, but
+they are not defaultly assigned to keys."
+ (interactive)
+ (if (eq major-mode 'edit-picture)
+ (error "You are already editing a Picture.")
+ (make-local-variable 'picture-mode-old-local-map)
+ (setq picture-mode-old-local-map (current-local-map))
+ (use-local-map picture-mode-map)
+ (make-local-variable 'picture-mode-old-mode-name)
+ (setq picture-mode-old-mode-name mode-name)
+ (make-local-variable 'picture-mode-old-major-mode)
+ (setq picture-mode-old-major-mode major-mode)
+ (setq major-mode 'edit-picture)
+ (make-local-variable 'picture-killed-rectangle)
+ (setq picture-killed-rectangle nil)
+ (make-local-variable 'tab-stop-list)
+ (setq tab-stop-list (default-value 'tab-stop-list))
+ (make-local-variable 'picture-tab-chars)
+ (setq picture-tab-chars (default-value 'picture-tab-chars))
+ (make-local-variable 'picture-vertical-step)
+ (make-local-variable 'picture-horizontal-step)
+ (picture-set-motion 0 1)
+ (run-hooks 'edit-picture-hook)
+ (message
+ (substitute-command-keys
+ "Type \\[picture-mode-exit] in this buffer to return it to %s mode.")
+ picture-mode-old-mode-name)))
+
+(fset 'picture-mode 'edit-picture) ; for the confused
+
+(defun picture-mode-exit (&optional nostrip)
+ "Undo edit-picture and return to previous major mode.
+With no argument strips whitespace from end of every line in Picture buffer
+ otherwise just return to previous mode."
+ (interactive "P")
+ (if (not (eq major-mode 'edit-picture))
+ (error "You aren't editing a Picture.")
+ (if (not nostrip) (picture-clean))
+ (setq mode-name picture-mode-old-mode-name)
+ (use-local-map picture-mode-old-local-map)
+ (setq major-mode picture-mode-old-major-mode)
+ (kill-local-variable 'tab-stop-list)
+ ;; Kludge - force the mode line to be updated. Is there a better
+ ;; way to do this?
+ (set-buffer-modified-p (buffer-modified-p))))
+
+(defun picture-clean ()
+ "Eliminate whitespace at ends of lines."
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t][ \t]*$" nil t)
+ (delete-region (match-beginning 0) (point)))))
--- /dev/null
+;; Major mode for editing Prolog, and for running Prolog under Emacs
+;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
+;; Author Masanobu UMEDA (umerin@flab.flab.fujitsu.junet)
+
+;; 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.
+
+(defvar prolog-mode-syntax-table nil)
+(defvar prolog-mode-abbrev-table nil)
+(defvar prolog-mode-map nil)
+
+(defvar prolog-consult-string "reconsult(user).\n"
+ "*(Re)Consult mode (for C-Prolog and Quintus Prolog). ")
+
+(defvar prolog-compile-string "compile(user).\n"
+ "*Compile mode (for Quintus Prolog).")
+
+(defvar prolog-eof-string "end_of_file.\n"
+ "*String that represents end of file for prolog.
+nil means send actual operaing system end of file.")
+
+(defvar prolog-indent-width 4)
+
+(if prolog-mode-syntax-table
+ ()
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?_ "w" table)
+ (modify-syntax-entry ?\\ "\\" table)
+ (modify-syntax-entry ?/ "." table)
+ (modify-syntax-entry ?* "." table)
+ (modify-syntax-entry ?+ "." table)
+ (modify-syntax-entry ?- "." table)
+ (modify-syntax-entry ?= "." table)
+ (modify-syntax-entry ?% "<" table)
+ (modify-syntax-entry ?< "." table)
+ (modify-syntax-entry ?> "." table)
+ (modify-syntax-entry ?\' "\"" table)
+ (setq prolog-mode-syntax-table table)))
+
+(define-abbrev-table 'prolog-mode-abbrev-table ())
+
+(defun prolog-mode-variables ()
+ (set-syntax-table prolog-mode-syntax-table)
+ (setq local-abbrev-table prolog-mode-abbrev-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^%%\\|^$\\|" page-delimiter)) ;'%%..'
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'prolog-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start "%")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "%+ *")
+ (make-local-variable 'comment-column)
+ (setq comment-column 48)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'prolog-comment-indent))
+
+(defun prolog-mode-commands (map)
+ (define-key map "\t" 'prolog-indent-line)
+ (define-key map "\e\C-x" 'prolog-consult-region))
+
+(if prolog-mode-map
+ nil
+ (setq prolog-mode-map (make-sparse-keymap))
+ (prolog-mode-commands prolog-mode-map))
+
+(defun prolog-mode ()
+ "Major mode for editing Prolog code for Prologs.
+Blank lines and `%%...' separate paragraphs. `%'s start comments.
+Commands:
+\\{prolog-mode-map}
+Entry to this mode calls the value of prolog-mode-hook
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map prolog-mode-map)
+ (setq major-mode 'prolog-mode)
+ (setq mode-name "Prolog")
+ (prolog-mode-variables)
+ (run-hooks 'prolog-mode-hook))
+
+(defun prolog-indent-line (&optional whole-exp)
+ "Indent current line as Prolog code.
+With argument, indent any additional lines of the same clause
+rigidly along with this one (not yet)."
+ (interactive "p")
+ (let ((indent (prolog-indent-level))
+ (pos (- (point-max) (point))) beg)
+ (beginning-of-line)
+ (setq beg (point))
+ (skip-chars-forward " \t")
+ (if (zerop (- indent (current-column)))
+ nil
+ (delete-region beg (point))
+ (indent-to indent))
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ ))
+
+(defun prolog-indent-level ()
+ "Compute prolog indentation level."
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (cond
+ ((looking-at "%%%") 0) ;Large comment starts
+ ((looking-at "%[^%]") comment-column) ;Small comment starts
+ ((bobp) 0) ;Beginning of buffer
+ (t
+ (let ((empty t) ind more less)
+ (if (looking-at ")")
+ (setq less t) ;Find close
+ (setq less nil))
+ ;; See previous indentation
+ (while empty
+ (forward-line -1)
+ (beginning-of-line)
+ (if (bobp)
+ (setq empty nil)
+ (skip-chars-forward " \t")
+ (if (not (or (looking-at "%[^%]") (looking-at "\n")))
+ (setq empty nil))))
+ (if (bobp)
+ (setq ind 0) ;Beginning of buffer
+ (setq ind (current-column))) ;Beginning of clause
+ ;; See its beginning
+ (if (looking-at "%%[^%]")
+ ind
+ ;; Real prolog code
+ (if (looking-at "(")
+ (setq more t) ;Find open
+ (setq more nil))
+ ;; See its tail
+ (end-of-prolog-clause)
+ (or (bobp) (forward-char -1))
+ (cond ((looking-at "[,(;>]")
+ (if (and more (looking-at "[^,]"))
+ (+ ind prolog-indent-width) ;More indentation
+ (max tab-width ind))) ;Same indentation
+ ((looking-at "-") tab-width) ;TAB
+ ((or less (looking-at "[^.]"))
+ (max (- ind prolog-indent-width) 0)) ;Less indentation
+ (t 0)) ;No indentation
+ )))
+ )))
+
+(defun end-of-prolog-clause ()
+ "Go to end of clause in this line."
+ (beginning-of-line 1)
+ (let* ((eolpos (save-excursion (end-of-line) (point))))
+ (if (re-search-forward comment-start-skip eolpos 'move)
+ (goto-char (match-beginning 0)))
+ (skip-chars-backward " \t")))
+
+(defun prolog-comment-indent ()
+ "Compute prolog comment indentation."
+ (cond ((looking-at "%%%") 0)
+ ((looking-at "%%") (prolog-indent-level))
+ (t
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (1+ (current-column)) ;Insert one space at least
+ comment-column)))
+ ))
+
+\f
+;;;
+;;; Inferior prolog mode
+;;;
+(defvar inferior-prolog-mode-map nil)
+
+;; Moved into inferior-prolog-mode
+;;(if inferior-prolog-mode-map
+;; nil
+;; (setq inferior-prolog-mode-map (copy-alist shell-mode-map))
+;; (prolog-mode-commands inferior-prolog-mode-map))
+
+(defun inferior-prolog-mode ()
+ "Major mode for interacting with an inferior Prolog process.
+
+The following commands are available:
+\\{inferior-prolog-mode-map}
+
+Entry to this mode calls the value of prolog-mode-hook with no arguments,
+if that value is non-nil. Likewise with the value of shell-mode-hook.
+prolog-mode-hook is called after shell-mode-hook.
+
+You can send text to the inferior Prolog from other buffers
+using the commands send-region, send-string and \\[prolog-consult-region].
+
+Commands:
+Tab indents for Prolog; with argument, shifts rest
+ of expression rigidly with the current line.
+Paragraphs are separated only by blank lines and '%%'. '%'s start comments.
+
+Return at end of buffer sends line as input.
+Return not at end copies rest of line to end and sends it.
+\\[shell-send-eof] sends end-of-file as input.
+\\[kill-shell-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing.
+\\[interrupt-shell-subjob] interrupts the shell or its current subjob if any.
+\\[stop-shell-subjob] stops, likewise. \\[quit-shell-subjob] sends quit signal, likewise."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'inferior-prolog-mode)
+ (setq mode-name "Inferior Prolog")
+ (setq mode-line-process '(": %s"))
+ (prolog-mode-variables)
+ (require 'shell)
+ (if inferior-prolog-mode-map
+ nil
+ (setq inferior-prolog-mode-map (copy-alist shell-mode-map))
+ (prolog-mode-commands inferior-prolog-mode-map))
+ (use-local-map inferior-prolog-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-variable-buffer-local 'shell-prompt-pattern)
+ (setq shell-prompt-pattern "^| [ ?][- ] *") ;Set prolog prompt pattern
+ (run-hooks 'shell-mode-hook 'prolog-mode-hook))
+
+(defun run-prolog ()
+ "Run an inferior Prolog process, input and output via buffer *prolog*."
+ (interactive)
+ (require 'shell)
+ (switch-to-buffer (make-shell "prolog" "prolog"))
+ (inferior-prolog-mode))
+
+(defun prolog-consult-region (compile beg end)
+ "Send the region to the Prolog process made by M-x run-prolog.
+ If COMPILE (prefix arg) is not nil,
+ use compile mode rather than consult mode."
+ (interactive "P\nr")
+ (save-excursion
+ (if compile
+ (send-string "prolog" prolog-compile-string)
+ (send-string "prolog" prolog-consult-string))
+ (send-region "prolog" beg end)
+ (send-string "prolog" "\n") ;May be unnecessary
+ (if prolog-eof-string
+ (send-string "prolog" prolog-eof-string)
+ (process-send-eof "prolog")))) ;Send eof to prolog process.
+
+(defun prolog-consult-region-and-go (compile beg end)
+ "Send the region to the inferior Prolog, and switch to *prolog* buffer.
+ If COMPILE (prefix arg) is not nil,
+ use compile mode rather than consult mode."
+ (interactive "P\nr")
+ (prolog-consult-region compile beg end)
+ (switch-to-buffer "*prolog*"))
--- /dev/null
+;; Rectangle functions for GNU Emacs.
+;; Copyright (C) 1985 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.
+
+
+(defun operate-on-rectangle (function start end coerce-tabs)
+ "Call FUNCTION for each line of rectangle with corners at START, END.
+If COERCE-TABS is non-nil, convert multi-column characters
+that span the starting or ending columns on any line
+to multiple spaces before calling FUNCTION.
+FUNCTION is called with three arguments:
+ position of start of segment of this line within the rectangle,
+ number of columns that belong to rectangle but are before that position,
+ number of columns that belong to rectangle but are after point.
+Point is at the end of the segment of this line within the rectangle."
+ (let (startcol startlinepos endcol endlinepos)
+ (save-excursion
+ (goto-char start)
+ (setq startcol (current-column))
+ (beginning-of-line)
+ (setq startlinepos (point)))
+ (save-excursion
+ (goto-char end)
+ (setq endcol (current-column))
+ (forward-line 1)
+ (setq endlinepos (point-marker)))
+ (if (< endcol startcol)
+ (let ((tem startcol))
+ (setq startcol endcol endcol tem)))
+ (if (/= endcol startcol)
+ (save-excursion
+ (goto-char startlinepos)
+ (while (< (point) endlinepos)
+ (let (startpos begextra endextra)
+ (move-to-column startcol)
+ (and coerce-tabs
+ (> (current-column) startcol)
+ (rectangle-coerce-tab startcol))
+ (setq begextra (- (current-column) startcol))
+ (setq startpos (point))
+ (move-to-column endcol)
+ (if (> (current-column) endcol)
+ (if coerce-tabs
+ (rectangle-coerce-tab endcol)
+ (forward-char -1)))
+ (setq endextra (- endcol (current-column)))
+ (if (< begextra 0)
+ (setq endextra (+ endextra begextra)
+ begextra 0))
+ (funcall function startpos begextra endextra))
+ (forward-line 1))))
+ (- endcol startcol)))
+
+(defun delete-rectangle-line (startdelpos ignore ignore)
+ (delete-region startdelpos (point)))
+
+(defun delete-extract-rectangle-line (startdelpos begextra endextra)
+ (save-excursion
+ (extract-rectangle-line startdelpos begextra endextra))
+ (delete-region startdelpos (point)))
+
+(defun extract-rectangle-line (startdelpos begextra endextra)
+ (let ((line (buffer-substring startdelpos (point)))
+ (end (point)))
+ (goto-char startdelpos)
+ (while (search-forward "\t" end t)
+ (let ((width (- (current-column)
+ (save-excursion (forward-char -1)
+ (current-column)))))
+ (setq line (concat (substring line 0 (- (point) end 1))
+ (spaces-string width)
+ (substring line (+ (length line) (- (point) end)))))))
+ (if (or (> begextra 0) (> endextra 0))
+ (setq line (concat (spaces-string begextra)
+ line
+ (spaces-string endextra))))
+ (setq lines (cons line lines))))
+
+(defconst spaces-strings
+ '["" " " " " " " " " " " " " " " " "])
+
+(defun spaces-string (n)
+ (if (<= n 8) (aref spaces-strings n)
+ (let ((val ""))
+ (while (> n 8)
+ (setq val (concat " " val)
+ n (- n 8)))
+ (concat val (aref spaces-strings n)))))
+
+(defun delete-rectangle (start end)
+ "Delete (don't save) text in rectangle with point and mark as corners.
+The same range of columns is deleted in each line
+starting with the line where the region begins
+and ending with the line where the region ends."
+ (interactive "r")
+ (operate-on-rectangle 'delete-rectangle-line start end t))
+
+(defun delete-extract-rectangle (start end)
+ "Return and delete contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle."
+ (let (lines)
+ (operate-on-rectangle 'delete-extract-rectangle-line
+ start end t)
+ (nreverse lines)))
+
+(defun extract-rectangle (start end)
+ "Return contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle."
+ (let (lines)
+ (operate-on-rectangle 'extract-rectangle-line start end nil)
+ (nreverse lines)))
+
+(defvar killed-rectangle nil
+ "Rectangle for yank-rectangle to insert.")
+
+(defun kill-rectangle (start end)
+ "Delete rectangle with corners at point and mark; save as last killed one.
+Calling from program, supply two args START and END, buffer positions.
+But in programs you might prefer to use delete-extract-rectangle."
+ (interactive "r")
+ (setq killed-rectangle (delete-extract-rectangle start end)))
+
+(defun yank-rectangle ()
+ "Yank the last killed rectangle with upper left corner at point."
+ (interactive)
+ (insert-rectangle killed-rectangle))
+
+(defun insert-rectangle (rectangle)
+ "Insert text of RECTANGLE with upper left corner at point.
+RECTANGLE's first line is inserted at point,
+its second line is inserted at a point vertically under point, etc.
+RECTANGLE should be a list of strings."
+ (let ((lines rectangle)
+ (insertcolumn (current-column))
+ (first t))
+ (while lines
+ (or first
+ (progn
+ (forward-line 1)
+ (or (bolp) (insert ?\n))
+ (move-to-column insertcolumn)
+ (if (> (current-column) insertcolumn)
+ (rectangle-coerce-tab insertcolumn))
+ (if (< (current-column) insertcolumn)
+ (indent-to insertcolumn))))
+ (setq first nil)
+ (insert (car lines))
+ (setq lines (cdr lines)))))
+
+(defun open-rectangle (start end)
+ "Blank out rectangle with corners at point and mark, shifting text right.
+The text previously in the region is not overwritten by the blanks,
+but insted winds up to the right of the rectangle."
+ (interactive "r")
+ (operate-on-rectangle 'open-rectangle-line start end nil))
+
+(defun open-rectangle-line (startpos begextra endextra)
+ (let ((column (+ (current-column) begextra endextra)))
+ (goto-char startpos)
+ (let ((ocol (current-column)))
+ (skip-chars-forward " \t")
+ (setq column (+ column (- (current-column) ocol))))
+ (delete-region (point)
+ (progn (skip-chars-backward " \t")
+ (point)))
+ (indent-to column)))
+
+(defun clear-rectangle (start end)
+ "Blank out rectangle with corners at point and mark.
+The text previously in the region is overwritten by the blanks."
+ (interactive "r")
+ (operate-on-rectangle 'clear-rectangle-line start end t))
+
+(defun clear-rectangle-line (startpos begextra endextra)
+ (skip-chars-forward " \t")
+ (let ((column (+ (current-column) endextra)))
+ (delete-region (point)
+ (progn (goto-char startpos)
+ (skip-chars-backward " \t")
+ (point)))
+ (indent-to column)))
+
+(defun rectangle-coerce-tab (column)
+ (let ((aftercol (current-column))
+ (indent-tabs-mode nil))
+ (delete-char -1)
+ (indent-to aftercol)
+ (backward-char (- aftercol column))))
--- /dev/null
+;; Register commands for Emacs.
+;; Copyright (C) 1985 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.
+
+
+(defvar register-alist nil
+ "Alist of elements (NAME . CONTENTS), one for each Emacs register.
+NAME is a character (a number). CONTENTS is a string, number,
+mark or list. A list represents a rectangle; its elements are strings.")
+
+(defun get-register (char)
+ "Return contents of Emacs register named CHAR, or nil if none."
+ (cdr (assq char register-alist)))
+
+(defun set-register (char value)
+ "Set contents of Emacs register named CHAR to VALUE."
+ (let ((aelt (assq char register-alist)))
+ (if aelt
+ (setcdr aelt value)
+ (setq aelt (cons char value))
+ (setq register-alist (cons aelt register-alist)))))
+
+(defun point-to-register (char)
+ "Store current location of point in a register.
+Argument is a character, naming the register."
+ (interactive "cPoint to register: ")
+ (set-register char (point-marker)))
+
+(defun register-to-point (char)
+ "Move point to location stored in a register.
+Argument is a character, naming the register."
+ (interactive "cRegister to point: ")
+ (let ((val (get-register char)))
+ (if (markerp val)
+ (progn
+ (switch-to-buffer (marker-buffer val))
+ (goto-char val))
+ (error "Register doesn't contain a buffer position"))))
+
+;(defun number-to-register (arg char)
+; "Store a number in a register.
+;Two args, NUMBER and REGISTER (a character, naming the register).
+;If NUMBER is nil, digits in the buffer following point are read
+;to get the number to store.
+;Interactively, NUMBER is the prefix arg (none means nil)."
+; (interactive "P\ncNumber to register: ")
+; (set-register char
+; (if arg
+; (prefix-numeric-value arg)
+; (if (looking-at "[0-9][0-9]*")
+; (save-excursion
+; (save-restriction
+; (narrow-to-region (point)
+; (progn (skip-chars-forward "0-9")
+; (point)))
+; (goto-char (point-min))
+; (read (current-buffer))))
+; 0))))
+
+;(defun increment-register (arg char)
+; "Add NUMBER to the contents of register REGISTER.
+;Interactively, NUMBER is the prefix arg (none means nil)."
+; (interactive "p\ncNumber to register: ")
+; (or (integerp (get-register char))
+; (error "Register does not contain a number"))
+; (set-register char (+ arg (get-register char))))
+
+(defun view-register (char)
+ "Display what is contained in register named REGISTER.
+REGISTER is a character."
+ (interactive "cView register: ")
+ (let ((val (get-register char)))
+ (if (null val)
+ (message "Register %s is empty" (single-key-description char))
+ (with-output-to-temp-buffer "*Output*"
+ (princ "Register ")
+ (princ (single-key-description char))
+ (princ " contains ")
+ (if (integerp val)
+ (princ val)
+ (if (markerp val)
+ (progn
+ (princ "a buffer position:\nbuffer ")
+ (princ (buffer-name (marker-buffer val)))
+ (princ ", position ")
+ (princ (+ 0 val)))
+ (if (consp val)
+ (progn
+ (princ "the rectangle:\n")
+ (while val
+ (princ (car val))
+ (terpri)
+ (setq val (cdr val))))
+ (princ "the string:\n")
+ (princ val))))))))
+
+(defun insert-register (char &optional arg)
+ "Insert contents of register REG. REG is a character.
+Normally puts point before and mark after the inserted text.
+If optional second arg is non-nil, puts mark before and point after.
+Interactively, second arg is non-nil if prefix arg is supplied."
+ (interactive "cInsert register: \nP")
+ (push-mark)
+ (let ((val (get-register char)))
+ (if (consp val)
+ (insert-rectangle val)
+ (if (stringp val)
+ (insert val)
+ (if (or (integerp val) (markerp val))
+ (princ (+ 0 val) (current-buffer))
+ (error "Register does not contain text")))))
+ (or arg (exchange-point-and-mark)))
+
+(defun copy-to-register (char start end &optional delete-flag)
+ "Copy region into register REG.
+With prefix arg, delete as well.
+Called from program, takes four args:
+REG, START, END and DELETE-FLAG.
+START and END are buffer positions indicating what to copy."
+ (interactive "cCopy to register: \nr\nP")
+ (set-register char (buffer-substring start end))
+ (if delete-flag (delete-region start end)))
+
+(defun append-to-register (char start end &optional delete-flag)
+ "Append region to text in register REG.
+With prefix arg, delete as well.
+Called from program, takes four args:
+REG, START, END and DELETE-FLAG.
+START and END are buffer positions indicating what to append."
+ (interactive "cAppend to register: \nr\nP")
+ (or (stringp (get-register char))
+ (error "Register does not contain text"))
+ (set-register char (concat (get-register char)
+ (buffer-substring start end)))
+ (if delete-flag (delete-region start end)))
+
+(defun prepend-to-register (char start end &optional delete-flag)
+ "Prepend region to text in register REG.
+With prefix arg, delete as well.
+Called from program, takes four args:
+REG, START, END and DELETE-FLAG.
+START and END are buffer positions indicating what to prepend."
+ (interactive "cPrepend to register: \nr\nP")
+ (or (stringp (get-register char))
+ (error "Register does not contain text"))
+ (set-register char (concat (buffer-substring start end)
+ (get-register char)))
+ (if delete-flag (delete-region start end)))
+
+(defun copy-rectangle-to-register (char start end &optional delete-flag)
+ "Copy rectangular region into register REG.
+With prefix arg, delete as well.
+Called from program, takes four args:
+REG, START, END and DELETE-FLAG.
+START and END are buffer positions giving two corners of rectangle."
+ (interactive "cCopy rectangle to register: \nr\nP")
+ (set-register char
+ (if delete-flag
+ (delete-extract-rectangle start end)
+ (extract-rectangle start end))))
--- /dev/null
+;; Replace commands for Emacs.
+;; 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.
+
+
+(fset 'delete-non-matching-lines 'keep-lines)
+(defun keep-lines (regexp)
+ "Delete all lines except those containing matches for REGEXP.
+A match split across lines preserves all the lines it lies in.
+Applies to all lines after point."
+ (interactive "sKeep lines (containing match for regexp): ")
+ (save-excursion
+ (or (bolp) (forward-line 1))
+ (let ((start (point)))
+ (while (not (eobp))
+ ;; Start is first char not preserved by previous match.
+ (if (not (re-search-forward regexp nil 'move))
+ (delete-region start (point-max))
+ (let ((end (save-excursion (goto-char (match-beginning 0))
+ (beginning-of-line)
+ (point))))
+ ;; Now end is first char preserved by the new match.
+ (if (< start end)
+ (delete-region start end))))
+ (setq start (save-excursion (forward-line 1)
+ (point)))))))
+
+(fset 'delete-matching-lines 'flush-lines)
+(defun flush-lines (regexp)
+ "Delete lines containing matches for REGEXP.
+If a match is split across lines, all the lines it lies in are deleted.
+Applies to lines after point."
+ (interactive "sFlush lines (containing match for regexp): ")
+ (save-excursion
+ (while (and (not (eobp))
+ (re-search-forward regexp nil t))
+ (delete-region (save-excursion (goto-char (match-beginning 0))
+ (beginning-of-line)
+ (point))
+ (progn (forward-line 1) (point))))))
+
+(fset 'count-matches 'how-many)
+(defun how-many (regexp)
+ "Print number of matches for REGEXP following point."
+ (interactive "sHow many matches for (regexp): ")
+ (let ((count 0) opoint)
+ (save-excursion
+ (while (and (not (eobp))
+ (progn (setq opoint (point))
+ (re-search-forward regexp nil t)))
+ (if (= opoint (point))
+ (forward-char 1)
+ (setq count (1+ count))))
+ (message "%d occurrences" count))))
+
+(defvar occur-mode-map ())
+(if occur-mode-map
+ ()
+ (setq occur-mode-map (make-sparse-keymap))
+ (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence))
+
+(defvar occur-buffer nil)
+(defvar occur-nlines nil)
+(defvar occur-pos-list nil)
+
+(defun occur-mode ()
+ "Major mode for output from \\[occur].
+Move point to one of the occurrences in this buffer,
+then use \\[occur-mode-goto-occurrence] to go to the same occurrence
+in the buffer that the occurrences were found in.
+\\{occur-mode-map}"
+ (kill-all-local-variables)
+ (use-local-map occur-mode-map)
+ (setq major-mode 'occur-mode)
+ (setq mode-name "Occur")
+ (make-local-variable 'occur-buffer)
+ (make-local-variable 'occur-nlines)
+ (make-local-variable 'occur-pos-list))
+
+(defun occur-mode-goto-occurrence ()
+ "Go to the line this occurrence was found in, in the buffer it was found in."
+ (interactive)
+ (if (or (null occur-buffer)
+ (null (buffer-name occur-buffer)))
+ (progn
+ (setq occur-buffer nil
+ occur-pos-list nil)
+ (error "Buffer in which occurences were found is deleted.")))
+ (let* ((occur-number (save-excursion
+ (beginning-of-line)
+ (/ (1- (count-lines (point-min) (point)))
+ (cond ((< occur-nlines 0)
+ (- 2 occur-nlines))
+ ((> occur-nlines 0)
+ (+ 2 (* 2 occur-nlines)))
+ (t 1)))))
+ (pos (nth occur-number occur-pos-list)))
+ (pop-to-buffer occur-buffer)
+ (goto-char (marker-position pos))))
+
+(defvar list-matching-lines-default-context-lines 0
+ "*Default number of context lines to include around a list-matching-lines
+match. A negative number means to include that many lines before the match.
+A positive number means to include that many lines both before and after.")
+
+(fset 'list-matching-lines 'occur)
+(defun occur (regexp &optional nlines)
+ "Show all lines following point containing a match for REGEXP.
+Display each line with NLINES lines before and after,
+ or -NLINES before if NLINES is negative.
+NLINES defaults to list-matching-lines-default-context-lines.
+Interactively it is the prefix arg.
+
+The lines are shown in a buffer named *Occur*.
+It serves as a menu to find any of the occurrences in this buffer.
+\\[describe-mode] in that buffer will explain how."
+ (interactive "sList lines matching regexp: \nP")
+ (setq nlines (if nlines (prefix-numeric-value nlines)
+ list-matching-lines-default-context-lines))
+ (let ((first t)
+ (buffer (current-buffer))
+ linenum prevpos)
+ (save-excursion
+ (beginning-of-line)
+ (setq linenum (1+ (count-lines (point-min) (point))))
+ (setq prevpos (point)))
+ (with-output-to-temp-buffer "*Occur*"
+ (save-excursion
+ (set-buffer standard-output)
+ (insert "Lines matching ")
+ (prin1 regexp)
+ (insert " in buffer " (buffer-name buffer) ?. ?\n)
+ (occur-mode)
+ (setq occur-buffer buffer)
+ (setq occur-nlines nlines)
+ (setq occur-pos-list ()))
+ (if (eq buffer standard-output)
+ (goto-char (point-max)))
+ (save-excursion
+ ;; Find next match, but give up if prev match was at end of buffer.
+ (while (and (not (= prevpos (point-max)))
+ (re-search-forward regexp nil t))
+ (beginning-of-line 1)
+ (save-excursion
+ (setq linenum (+ linenum (count-lines prevpos (point))))
+ (setq prevpos (point)))
+ (let* ((start (save-excursion
+ (forward-line (if (< nlines 0) nlines (- nlines)))
+ (point)))
+ (end (save-excursion
+ (if (> nlines 0)
+ (forward-line (1+ nlines))
+ (forward-line 1))
+ (point)))
+ (tag (format "%3d" linenum))
+ (empty (make-string (length tag) ?\ ))
+ tem)
+ (save-excursion
+ (setq tem (make-marker))
+ (set-marker tem (point))
+ (set-buffer standard-output)
+ (setq occur-pos-list (cons tem occur-pos-list))
+ (or first (zerop nlines)
+ (insert "--------\n"))
+ (setq first nil)
+ (insert-buffer-substring buffer start end)
+ (backward-char (- end start))
+ (setq tem (if (< nlines 0) (- nlines) nlines))
+ (while (> tem 0)
+ (insert empty ?:)
+ (forward-line 1)
+ (setq tem (1- tem)))
+ (insert tag ?:)
+ (forward-line 1)
+ (while (< tem nlines)
+ (insert empty ?:)
+ (forward-line 1)
+ (setq tem (1+ tem))))
+ (forward-line 1)))
+ (set-buffer standard-output)
+ ;; Put positions in increasing order to go with buffer.
+ (setq occur-pos-list (nreverse occur-pos-list))
+ (if (interactive-p)
+ (message "%d matching lines." (length occur-pos-list)))))))
+\f
+(defconst query-replace-help
+ "Type Space or `y' to replace one match, Delete or `n' to skip to next,
+ESC or `q' to exit, Period to replace one match and exit,
+Comma to replace but not move point immediately,
+C-r to enter recursive edit (\\[exit-recursive-edit] to get out again),
+C-w to delete match and recursive edit,
+C-l to clear the screen, redisplay, and offer same replacement again,
+! to replace all remaining matches with no more questions,
+^ to move point back to previous match."
+ "Help message while in query-replace")
+
+(defun perform-replace (from-string to-string
+ query-flag regexp-flag delimited-flag)
+ (let ((nocasify (not (and case-fold-search case-replace
+ (string-equal from-string
+ (downcase from-string)))))
+ (literal (not regexp-flag))
+ (search-function (if regexp-flag 're-search-forward 'search-forward))
+ (search-string from-string)
+ (keep-going t)
+ (lastrepl nil)) ;Position after last match considered.
+ (if delimited-flag
+ (setq search-function 're-search-forward
+ search-string (concat "\\b"
+ (if regexp-flag from-string
+ (regexp-quote from-string))
+ "\\b")))
+ (push-mark)
+ (push-mark)
+ (while (and keep-going
+ (not (eobp))
+ (progn
+ (set-mark (point))
+ (funcall search-function search-string nil t)))
+ ;; Don't replace the null string
+ ;; right after end of previous replacement.
+ (if (eq lastrepl (point))
+ (forward-char 1)
+ (undo-boundary)
+ (if (not query-flag)
+ (replace-match to-string nocasify literal)
+ (let (done replaced)
+ (while (not done)
+ ;; Preserve the match data. Process filters and sentinels
+ ;; could run inside read-char..
+ (let ((data (match-data))
+ (help-form
+ '(concat "Query replacing "
+ (if regexp-flag "regexp " "")
+ from-string " with " to-string ".\n\n"
+ (substitute-command-keys query-replace-help))))
+ (setq char help-char)
+ (while (= char help-char)
+ (message "Query replacing %s with %s: " from-string to-string)
+ (setq char (read-char))
+ (if (= char ??)
+ (setq unread-command-char help-char char help-char)))
+ (store-match-data data))
+ (cond ((or (= char ?\e)
+ (= char ?q))
+ (setq keep-going nil)
+ (setq done t))
+ ((= char ?^)
+ (goto-char (mark))
+ (setq replaced t))
+ ((or (= char ?\ )
+ (= char ?y))
+ (or replaced
+ (replace-match to-string nocasify literal))
+ (setq done t))
+ ((= char ?\.)
+ (or replaced
+ (replace-match to-string nocasify literal))
+ (setq keep-going nil)
+ (setq done t))
+ ((= char ?\,)
+ (if (not replaced)
+ (progn
+ (replace-match to-string nocasify literal)
+ (setq replaced t))))
+ ((= char ?!)
+ (or replaced
+ (replace-match to-string nocasify literal))
+ (setq done t query-flag nil))
+ ((or (= char ?\177)
+ (= char ?n))
+ (setq done t))
+ ((= char ?\C-l)
+ (recenter nil))
+ ((= char ?\C-r)
+ (store-match-data
+ (prog1 (match-data)
+ (save-excursion (recursive-edit)))))
+ ((= char ?\C-w)
+ (delete-region (match-beginning 0) (match-end 0))
+ (store-match-data
+ (prog1 (match-data)
+ (save-excursion (recursive-edit))))
+ (setq replaced t))
+ (t
+ (setq keep-going nil)
+ (setq unread-command-char char)
+ (setq done t))))))
+ (setq lastrepl (point))))
+ (pop-mark)
+ keep-going))
+
--- /dev/null
+;; Hairy rfc822 parser for mail and news and suchlike
+;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
+;; Author Richard Mlynarik.
+
+;; 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.
+
+(provide 'rfc822)
+
+;; uses address-start free, throws to address
+(defun rfc822-bad-address (reason)
+ (save-restriction
+ (insert "_^_")
+ (narrow-to-region address-start
+ (if (re-search-forward "[,;]" nil t)
+ (max (point-min) (1- (point)))
+ (point-max)))
+ ;; make the error string be suitable for inclusion in (...)
+ (let ((losers '("\\" "(" ")" "\n")))
+ (while losers
+ (goto-char (point-min))
+ (while (search-forward (car losers) nil t)
+ (backward-char 1)
+ (insert ?\\)
+ (forward-char 1))
+ (setq losers (cdr losers))))
+ (goto-char (point-min)) (insert "(Unparsable address -- "
+ reason
+ ":\n\t \"")
+ (goto-char (point-max)) (insert "\")"))
+ (rfc822-nuke-whitespace)
+ (throw 'address (buffer-substring address-start (point))))
+
+(defun rfc822-nuke-whitespace (&optional leave-space)
+ (let (ch)
+ (while (cond ((eobp)
+ nil)
+ ((= (setq ch (following-char)) ?\()
+ (forward-char 1)
+ (while (if (eobp)
+ (rfc822-bad-address "Unbalanced comment (...)")
+ (/= (setq ch (following-char)) ?\)))
+ (cond ((looking-at "[^()\\]+")
+ (replace-match ""))
+ ((= ch ?\()
+ (rfc822-nuke-whitespace))
+ ((< (point) (1- (point-max)))
+ (delete-char 2))
+ (t
+ (rfc822-bad-address "orphaned backslash"))))
+ ;; delete remaining "()"
+ (forward-char -1)
+ (delete-char 2)
+ t)
+ ((memq ch '(?\ ?\t ?\n))
+ (delete-region (point)
+ (progn (skip-chars-forward " \t\n") (point)))
+ t)
+ (t
+ nil)))
+ (or (not leave-space)
+ (eobp)
+ (bobp)
+ (= (preceding-char) ?\ )
+ (insert ?\ ))))
+
+(defun rfc822-looking-at (regex &optional leave-space)
+ (if (cond ((stringp regex)
+ (if (looking-at regex)
+ (progn (goto-char (match-end 0))
+ t)))
+ (t
+ (if (and (not (eobp))
+ (= (following-char) regex))
+ (progn (forward-char 1)
+ t))))
+ (let ((tem (match-data)))
+ (rfc822-nuke-whitespace leave-space)
+ (store-match-data tem)
+ t)))
+
+(defun rfc822-snarf-word ()
+ ;; word is atom | quoted-string
+ (cond ((= (following-char) ?\")
+ ;; quoted-string
+ (or (rfc822-looking-at "\"\\([^\"\\\n]\\|\\\\.\\|\\\\\n\\)*\"")
+ (rfc822-bad-address "Unterminated quoted string")))
+ ((rfc822-looking-at "[^][\000-\037\177-\377 ()<>@,;:\\\".]+")
+ ;; atom
+ )
+ (t
+ (rfc822-bad-address "Rubbish in address"))))
+
+(defun rfc822-snarf-words ()
+ (rfc822-snarf-word)
+ (while (rfc822-looking-at ?.)
+ (rfc822-snarf-word)))
+
+(defun rfc822-snarf-subdomain ()
+ ;; sub-domain is domain-ref | domain-literal
+ (cond ((= (following-char) ?\[)
+ ;; domain-ref
+ (or (rfc822-looking-at "\\[\\([^][\\\n]\\|\\\\.\\|\\\\\n\\)*\\]")
+ (rfc822-bad-address "Unterminated domain literal [...]")))
+ ((rfc822-looking-at "[^][\000-\037\177-\377 ()<>@,;:\\\".]+")
+ ;; domain-literal = atom
+ )
+ (t
+ (rfc822-bad-address "Rubbish in host/domain specification"))))
+
+(defun rfc822-snarf-domain ()
+ (rfc822-snarf-subdomain)
+ (while (rfc822-looking-at ?.)
+ (rfc822-snarf-subdomain)))
+
+(defun rfc822-snarf-frob-list (name separator terminator snarfer
+ &optional return)
+ (let ((first t)
+ (list ())
+ tem)
+ (while (cond ((eobp)
+ (rfc822-bad-address
+ (format "End of addresses in middle of %s" name)))
+ ((rfc822-looking-at terminator)
+ nil)
+ ((rfc822-looking-at separator)
+ ;; multiple separators are allowed and do nothing.
+ (while (rfc822-looking-at separator))
+ t)
+ (first
+ t)
+ (t
+ (rfc822-bad-address
+ (format "Gubbish in middle of %s" name))))
+ (setq tem (funcall snarfer)
+ first nil)
+ (and return tem
+ (setq list (if (listp tem)
+ (nconc (reverse tem) list)
+ (cons tem list)))))
+ (nreverse list)))
+
+;; return either an address (a string) or a list of addresses
+(defun rfc822-addresses-1 (&optional allow-groups)
+ ;; Looking for an rfc822 `address'
+ ;; Either a group (1*word ":" [#mailbox] ";")
+ ;; or a mailbox (addr-spec | 1*word route-addr)
+ ;; addr-spec is (local-part "@" domain)
+ ;; route-addr is ("<" [1#("@" domain) ":"] addr-spec ">")
+ ;; local-part is (word *("." word))
+ ;; word is (atom | quoted-string)
+ ;; quoted-string is ("\([^\"\\n]\|\\.\|\\\n\)")
+ ;; atom is [^\000-\037\177 ()<>@,;:\".[]]+
+ ;; domain is sub-domain *("." sub-domain)
+ ;; sub-domain is domain-ref | domain-literal
+ ;; domain-literal is "[" *(dtext | quoted-pair) "]"
+ ;; dtext is "[^][\\n"
+ ;; domain-ref is atom
+ (let ((address-start (point))
+ (n 0))
+ (catch 'address
+ ;; optimize common cases:
+ ;; foo
+ ;; foo.bar@bar.zap
+ ;; followed by "\\'\\|,\\|([^()\\]*)\\'"
+ ;; other common cases are:
+ ;; foo bar <foo.bar@baz.zap>
+ ;; "foo bar" <foo.bar@baz.zap>
+ ;; those aren't hacked yet.
+ (if (and (rfc822-looking-at "[^][\000-\037\177-\377 ()<>@,;:\\\"]+\\(\\|@[^][\000-\037\177-\377 ()<>@,;:\\\"]+\\)" t)
+ (progn (or (eobp)
+ (rfc822-looking-at ?,))))
+ (progn
+ ;; rfc822-looking-at may have inserted a space
+ (or (bobp) (/= (preceding-char) ?\ ) (delete-char -1))
+ ;; relying on the fact that rfc822-looking-at <char>
+ ;; doesn't mung match-data
+ (throw 'address (buffer-substring address-start (match-end 0)))))
+ (goto-char address-start)
+ (while t
+ (cond ((and (= n 1) (rfc822-looking-at ?@))
+ ;; local-part@domain
+ (rfc822-snarf-domain)
+ (throw 'address
+ (buffer-substring address-start (point))))
+ ((rfc822-looking-at ?:)
+ (cond ((not allow-groups)
+ (rfc822-bad-address "A group name may not appear here"))
+ ((= n 0)
+ (rfc822-bad-address "No name for :...; group")))
+ ;; group
+ (throw 'address
+ ;; return a list of addresses
+ (rfc822-snarf-frob-list ":...; group" ?\, ?\;
+ 'rfc822-addresses-1 t)))
+ ((rfc822-looking-at ?<)
+ (let ((start (point))
+ (strip t))
+ (cond ((rfc822-looking-at ?>)
+ ;; empty path
+ ())
+ ((and (not (eobp)) (= (following-char) ?\@))
+ ;; <@foo.bar,@baz:quux@abcd.efg>
+ (rfc822-snarf-frob-list "<...> address" ?\, ?\:
+ (function (lambda ()
+ (if (rfc822-looking-at ?\@)
+ (rfc822-snarf-domain)
+ (rfc822-bad-address
+ "Gubbish in route-addr")))))
+ (rfc822-snarf-words)
+ (or (rfc822-looking-at ?@)
+ (rfc822-bad-address "Malformed <..@..> address"))
+ (rfc822-snarf-domain)
+ (setq strip nil))
+ ((progn (rfc822-snarf-words) (rfc822-looking-at ?@))
+ ; allow <foo> (losing unix seems to do this)
+ (rfc822-snarf-domain)))
+ (let ((end (point)))
+ (if (rfc822-looking-at ?\>)
+ (throw 'address
+ (buffer-substring (if strip start (1- start))
+ (if strip end (1+ end))))
+ (rfc822-bad-address "Unterminated <...> address")))))
+ ((looking-at "[^][\000-\037\177-\377 ()<>@,;:\\.]")
+ ;; this allows "." to be part of the words preceding
+ ;; an addr-spec, since many broken mailers output
+ ;; "Hern K. Herklemeyer III
+ ;; <yank@megadeath.dod.gods-own-country>"
+ (let ((again t))
+ (while again
+ (or (= n 0) (bobp) (= (preceding-char) ?\ )
+ (insert ?\ ))
+ (rfc822-snarf-words)
+ (setq n (1+ n))
+ (setq again (or (rfc822-looking-at ?.)
+ (looking-at "[^][\000-\037\177-\377 ()<>@,;:\\.]"))))))
+ ((= n 0)
+ (throw 'address nil))
+ ((= n 1) ; allow "foo" (losing unix seems to do this)
+ (throw 'address
+ (buffer-substring address-start (point))))
+ ((> n 1)
+ (rfc822-bad-address "Missing comma between addresses or badly-formatted address"))
+ ((or (eobp) (= (following-char) ?,))
+ (rfc822-bad-address "Missing comma or route-spec"))
+ (t
+ (rfc822-bad-address "Strange character or missing comma")))))))
+
+
+(defun rfc822-addresses (header-text)
+ (if (string-match "\\`[ \t]*\\([^][\000-\037\177-\377 ()<>@,;:\\\".]+\\)[ \t]*\\'"
+ header-text)
+ ;; Make very simple case moderately fast.
+ (list (substring header-text (match-beginning 1) (match-end 1)))
+ (let ((buf (generate-new-buffer " rfc822")))
+ (unwind-protect
+ (save-excursion
+ (set-buffer buf)
+ (make-local-variable 'case-fold-search)
+ (setq case-fold-search nil) ;For speed(?)
+ (insert header-text)
+ ;; unfold continuation lines
+ (goto-char (point-min))
+
+ (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
+ (replace-match "\\1 " t))
+
+ (goto-char (point-min))
+ (rfc822-nuke-whitespace)
+ (let ((list ())
+ tem
+ address-start); this is for rfc822-bad-address
+ (while (not (eobp))
+ (setq address-start (point))
+ (setq tem
+ (catch 'address ; this is for rfc822-bad-address
+ (cond ((rfc822-looking-at ?\,)
+ nil)
+ ((looking-at "[][\000-\037\177-\377@;:\\.>)]")
+ (forward-char)
+ (rfc822-bad-address
+ (format "Strange character \\%c found"
+ (preceding-char))))
+ (t
+ (rfc822-addresses-1 t)))))
+ (cond ((null tem))
+ ((stringp tem)
+ (setq list (cons tem list)))
+ (t
+ (setq list (nconc (nreverse tem) list)))))
+ (nreverse list)))
+ (and buf (kill-buffer buf))))))
--- /dev/null
+;; "RMAIL" mail reader for Emacs.
+;; Copyright (C) 1985, 1986, 1987, 1988, 1990 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.
+
+
+;; Souped up by shane@mit-ajax based on ideas of rlk@athena.mit.edu
+;; New features include attribute and keyword support, message
+;; selection by dispatch table, summary by attributes and keywords,
+;; expunging by dispatch table, sticky options for file commands.
+
+(require 'mail-utils)
+(provide 'rmail)
+
+; these variables now declared in loaddefs or paths.el
+;(defvar rmail-spool-directory "/usr/spool/mail/"
+; "This is the name of the directory used by the system mailer for\n\
+;delivering new mail. It's name should end with a slash.")
+;(defvar rmail-dont-reply-to-names
+; nil
+; "*A regexp specifying names to prune of reply to messages.
+;nil means dont reply to yourself.")
+;(defvar rmail-ignored-headers
+; "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^message-id:\\|^summary-line:"
+; "*Gubbish headers one would rather not see.")
+;(defvar rmail-file-name
+; (expand-file-name "~/RMAIL")
+; "")
+;
+;(defvar rmail-delete-after-output nil
+; "*Non-nil means automatically delete a message that is copied to a file.")
+;
+;(defvar rmail-primary-inbox-list
+; '("/usr/spool/mail/$USER" "~/mbox")
+; "")
+
+;; these may be altered by site-init.el to match the format of mmdf files
+;; delimitation used on a given host (delim1 and delim2 from the config
+;; files)
+
+(defvar mmdf-delim1 "^\001\001\001\001\n"
+ "Regexp marking the start of an mmdf message")
+(defvar mmdf-delim2 "^\001\001\001\001\n"
+ "Regexp marking the end of an mmdf message")
+
+(defvar rmail-message-filter nil
+ "If non nil, is a filter function for new headers in RMAIL.
+Called with region narrowed to unformatted header.")
+
+(defvar rmail-mode-map nil)
+
+;; Message counters and markers. Deleted flags.
+
+(defvar rmail-current-message nil)
+(defvar rmail-total-messages nil)
+(defvar rmail-message-vector nil)
+(defvar rmail-deleted-vector nil)
+
+;; These are used by autoloaded rmail-summary.
+
+(defvar rmail-summary-buffer nil)
+(defvar rmail-summary-vector nil)
+
+;; `Sticky' default variables.
+
+;; Last individual label specified to a or k.
+(defvar rmail-last-label nil)
+;; Last set of labels specified to C-M-n or C-M-p or C-M-l.
+(defvar rmail-last-multi-labels nil)
+(defvar rmail-last-file nil)
+(defvar rmail-last-rmail-file nil)
+\f
+;;;; *** Rmail Mode ***
+
+(defun rmail (&optional file-name-arg)
+ "Read and edit incoming mail.
+Moves messages into file named by rmail-file-name (a babyl format file)
+ and edits that file in RMAIL Mode.
+Type \\[describe-mode] once editing that file, for a list of RMAIL commands.
+
+May be called with filename as argument;
+then performs rmail editing on that file,
+but does not copy any new mail into the file."
+ (interactive (if current-prefix-arg
+ (list (read-file-name "Run rmail on RMAIL file: "
+ nil nil t))))
+ (or rmail-last-file
+ (setq rmail-last-file (expand-file-name "~/xmail")))
+ (or rmail-last-rmail-file
+ (setq rmail-last-rmail-file (expand-file-name "~/XMAIL")))
+ (let* ((file-name (expand-file-name (or file-name-arg rmail-file-name)))
+ (existed (get-file-buffer file-name))
+ ;; Don't be confused by apparent local-variables spec
+ ;; in the last message in the RMAIL file.
+ (inhibit-local-variables t))
+ ;; Like find-file, but in the case where a buffer existed
+ ;; and the file was reverted, recompute the message-data.
+ (if (and existed (not (verify-visited-file-modtime existed)))
+ (progn
+ (find-file file-name)
+ (if (and (verify-visited-file-modtime existed)
+ (eq major-mode 'rmail-mode))
+ (progn (rmail-forget-messages)
+ (rmail-set-message-counters))))
+ (find-file file-name))
+ (if (eq major-mode 'rmail-edit-mode)
+ (error "exit rmail-edit-mode before getting new mail"))
+ (if (and existed (eq major-mode 'rmail-mode))
+ nil
+ (rmail-mode)
+ ;; Provide default set of inboxes for primary mail file ~/RMAIL.
+ (and (null rmail-inbox-list)
+ (null file-name-arg)
+ (setq rmail-inbox-list
+ (or rmail-primary-inbox-list
+ (list "~/mbox"
+ (concat rmail-spool-directory
+ (or (getenv "LOGNAME")
+ (getenv "USER")
+ (user-login-name)))))))
+ ;; Convert all or part to Babyl file if possible.
+ (rmail-convert-file)
+ (goto-char (point-max))
+ (if (null rmail-inbox-list)
+ (progn
+ (rmail-set-message-counters)
+ (rmail-show-message))))
+ (rmail-get-new-mail)))
+
+(defun rmail-convert-file ()
+ (let (convert)
+ (widen)
+ (goto-char (point-min))
+ ;; If file doesn't start like a Babyl file,
+ ;; convert it to one, by adding a header and converting each message.
+ (cond ((looking-at "BABYL OPTIONS:"))
+ ((looking-at "Version: 5\n")
+ ;; Losing babyl file made by old version of Rmail.
+ ;; Just fix the babyl file header; don't make a new one,
+ ;; so we don't lose the Labels: file attribute, etc.
+ (let ((buffer-read-only nil))
+ (insert "BABYL OPTIONS:\n")))
+ (t
+ (setq convert t)
+ (rmail-insert-rmail-file-header)))
+ ;; If file was not a Babyl file or if there are
+ ;; Unix format messages added at the end,
+ ;; convert file as necessary.
+ (if (or convert
+ (progn (goto-char (point-max))
+ (search-backward "\^_")
+ (forward-char 1)
+ (looking-at "\n*From ")))
+ (let ((buffer-read-only nil))
+ (message "Converting to Babyl format...")
+ (narrow-to-region (point) (point-max))
+ (rmail-convert-to-babyl-format)
+ (message "Converting to Babyl format...done")))))
+
+(defun rmail-insert-rmail-file-header ()
+ (let ((buffer-read-only nil))
+ (insert "BABYL OPTIONS:
+Version: 5
+Labels:
+Note: This is the header of an rmail file.
+Note: If you are seeing it in rmail,
+Note: it means the file has no messages in it.\n\^_")))
+
+(if rmail-mode-map
+ nil
+ (setq rmail-mode-map (make-keymap))
+ (suppress-keymap rmail-mode-map)
+ (define-key rmail-mode-map "." 'rmail-beginning-of-message)
+ (define-key rmail-mode-map " " 'scroll-up)
+ (define-key rmail-mode-map "\177" 'scroll-down)
+ (define-key rmail-mode-map "n" 'rmail-next-undeleted-message)
+ (define-key rmail-mode-map "p" 'rmail-previous-undeleted-message)
+ (define-key rmail-mode-map "\en" 'rmail-next-message)
+ (define-key rmail-mode-map "\ep" 'rmail-previous-message)
+ (define-key rmail-mode-map "\e\C-n" 'rmail-next-labeled-message)
+ (define-key rmail-mode-map "\e\C-p" 'rmail-previous-labeled-message)
+ (define-key rmail-mode-map "a" 'rmail-add-label)
+ (define-key rmail-mode-map "k" 'rmail-kill-label)
+ (define-key rmail-mode-map "d" 'rmail-delete-forward)
+ (define-key rmail-mode-map "u" 'rmail-undelete-previous-message)
+ (define-key rmail-mode-map "e" 'rmail-expunge)
+ (define-key rmail-mode-map "x" 'rmail-expunge)
+ (define-key rmail-mode-map "s" 'rmail-expunge-and-save)
+ (define-key rmail-mode-map "g" 'rmail-get-new-mail)
+ (define-key rmail-mode-map "h" 'rmail-summary)
+ (define-key rmail-mode-map "\e\C-h" 'rmail-summary)
+ (define-key rmail-mode-map "l" 'rmail-summary-by-labels)
+ (define-key rmail-mode-map "\e\C-l" 'rmail-summary-by-labels)
+ (define-key rmail-mode-map "\e\C-r" 'rmail-summary-by-recipients)
+ (define-key rmail-mode-map "t" 'rmail-toggle-header)
+ (define-key rmail-mode-map "m" 'rmail-mail)
+ (define-key rmail-mode-map "r" 'rmail-reply)
+ (define-key rmail-mode-map "c" 'rmail-continue)
+ (define-key rmail-mode-map "f" 'rmail-forward)
+ (define-key rmail-mode-map "\es" 'rmail-search)
+ (define-key rmail-mode-map "j" 'rmail-show-message)
+ (define-key rmail-mode-map "o" 'rmail-output-to-rmail-file)
+ (define-key rmail-mode-map "\C-o" 'rmail-output)
+ (define-key rmail-mode-map "i" 'rmail-input)
+ (define-key rmail-mode-map "q" 'rmail-quit)
+ (define-key rmail-mode-map ">" 'rmail-last-message)
+ (define-key rmail-mode-map "?" 'describe-mode)
+ (define-key rmail-mode-map "w" 'rmail-edit-current-message)
+ (define-key rmail-mode-map "\C-d" 'rmail-delete-backward))
+
+;; Rmail mode is suitable only for specially formatted data.
+(put 'rmail-mode 'mode-class 'special)
+
+(defun rmail-mode ()
+ "Rmail Mode is used by \\[rmail] for editing Rmail files.
+All normal editing commands are turned off.
+Instead, these commands are available:
+
+. Move point to front of this message (same as \\[beginning-of-buffer]).
+SPC Scroll to next screen of this message.
+DEL Scroll to previous screen of this message.
+n Move to Next non-deleted message.
+p Move to Previous non-deleted message.
+M-n Move to Next message whether deleted or not.
+M-p Move to Previous message whether deleted or not.
+> Move to the last message in Rmail file.
+j Jump to message specified by numeric position in file.
+M-s Search for string and show message it is found in.
+d Delete this message, move to next nondeleted.
+C-d Delete this message, move to previous nondeleted.
+u Undelete message. Tries current message, then earlier messages
+ till a deleted message is found.
+e Expunge deleted messages.
+s Expunge and save the file.
+q Quit Rmail: expunge, save, then switch to another buffer.
+C-x C-s Save without expunging.
+g Move new mail from system spool directory or mbox into this file.
+m Mail a message (same as \\[mail-other-window]).
+c Continue composing outgoing message started before.
+r Reply to this message. Like m but initializes some fields.
+f Forward this message to another user.
+o Output this message to an Rmail file (append it).
+C-o Output this message to a Unix-format mail file (append it).
+i Input Rmail file. Run Rmail on that file.
+a Add label to message. It will be displayed in the mode line.
+k Kill label. Remove a label from current message.
+C-M-n Move to Next message with specified label
+ (label defaults to last one specified).
+ Standard labels: filed, unseen, answered, forwarded, deleted.
+ Any other label is present only if you add it with `a'.
+C-M-p Move to Previous message with specified label
+C-M-h Show headers buffer, with a one line summary of each message.
+C-M-l Like h only just messages with particular label(s) are summarized.
+C-M-r Like h only just messages with particular recipient(s) are summarized.
+t Toggle header, show Rmail header if unformatted or vice versa.
+w Edit the current message. C-c C-c to return to Rmail."
+ (interactive)
+ (kill-all-local-variables)
+ (rmail-mode-1)
+ (rmail-variables)
+ (run-hooks 'rmail-mode-hook))
+
+(defun rmail-mode-1 ()
+ (setq major-mode 'rmail-mode)
+ (setq mode-name "RMAIL")
+ (setq buffer-read-only t)
+ ;; No need to auto save RMAIL files.
+ (setq buffer-auto-save-file-name nil)
+ (if (boundp 'mode-line-modified)
+ (setq mode-line-modified "--- ")
+ (setq mode-line-format
+ (cons "--- " (cdr (default-value 'mode-line-format)))))
+ (use-local-map rmail-mode-map)
+ (set-syntax-table text-mode-syntax-table)
+ (setq local-abbrev-table text-mode-abbrev-table))
+
+(defun rmail-variables ()
+ (make-local-variable 'revert-buffer-function)
+ (setq revert-buffer-function 'rmail-revert)
+ (make-local-variable 'rmail-last-label)
+ (make-local-variable 'rmail-deleted-vector)
+ (make-local-variable 'rmail-keywords)
+ (make-local-variable 'rmail-summary-buffer)
+ (make-local-variable 'rmail-summary-vector)
+ (make-local-variable 'rmail-current-message)
+ (make-local-variable 'rmail-total-messages)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline nil)
+ (make-local-variable 'version-control)
+ (setq version-control 'never)
+ (make-local-variable 'file-precious-flag)
+ (setq file-precious-flag t)
+ (make-local-variable 'rmail-message-vector)
+ (make-local-variable 'rmail-last-file)
+ (make-local-variable 'rmail-inbox-list)
+ (setq rmail-inbox-list (rmail-parse-file-inboxes))
+ (make-local-variable 'rmail-keywords)
+ ;; this gets generated as needed
+ (setq rmail-keywords nil))
+
+;; Handle M-x revert-buffer done in an rmail-mode buffer.
+(defun rmail-revert (arg noconfirm)
+ (let (revert-buffer-function)
+ ;; Call our caller again, but this time it does the default thing.
+ (if (revert-buffer arg noconfirm)
+ ;; If the user said "yes", and we changed something,
+ ;; reparse the messages.
+ (progn
+ (rmail-convert-file)
+ (goto-char (point-max))
+ (rmail-set-message-counters)
+ (rmail-show-message)))))
+
+;; Return a list of files from this buffer's Mail: option.
+;; Does not assume that messages have been parsed.
+;; Just returns nil if buffer does not look like Babyl format.
+(defun rmail-parse-file-inboxes ()
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char 1)
+ (cond ((looking-at "BABYL OPTIONS:")
+ (search-forward "\^_" nil 'move)
+ (narrow-to-region 1 (point))
+ (goto-char 1)
+ (if (search-forward "\nMail:" nil t)
+ (progn
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ (goto-char (point-min))
+ (mail-parse-comma-list))))))))
+
+(defun rmail-expunge-and-save ()
+ "Expunge and save RMAIL file."
+ (interactive)
+ (rmail-expunge)
+ (save-buffer))
+
+(defun rmail-quit ()
+ "Quit out of RMAIL."
+ (interactive)
+ (rmail-expunge-and-save)
+ ;; Don't switch to the summary buffer even if it was recently visible.
+ (if rmail-summary-buffer
+ (bury-buffer rmail-summary-buffer))
+ (let ((obuf (current-buffer)))
+ (switch-to-buffer (other-buffer))
+ (bury-buffer obuf)))
+
+(defun rmail-input (filename)
+ "Run RMAIL on file FILENAME."
+ (interactive "FRun rmail on RMAIL file: ")
+ (rmail filename))
+
+\f
+;;;; *** Rmail input ***
+
+;; RLK feature not added in this version:
+;; argument specifies inbox file or files in various ways.
+
+(defun rmail-get-new-mail (&optional file-name)
+ "Move any new mail from this RMAIL file's inbox files.
+The inbox files can be specified with the file's Mail: option.
+The variable rmail-primary-inbox-list specifies the inboxes for
+your primary RMAIL file if it has no Mail: option.
+These are normally your ~/mbox and your /usr/spool/mail/$USER.
+
+You can also specify the file to get new mail from. In this
+case, the file of new mail is not changed or deleted.
+Noninteractively, you can pass the inbox file name as an argument.
+Interactively, a prefix argument causes us to read a file name
+and use that file as the inbox."
+ (interactive
+ (list (if current-prefix-arg
+ (read-file-name "Get new mail from file: "))))
+ (or (verify-visited-file-modtime (current-buffer))
+ (progn
+ (find-file (buffer-file-name))
+ (if (verify-visited-file-modtime (current-buffer))
+ (rmail-forget-messages))))
+ (rmail-maybe-set-message-counters)
+ (widen)
+ ;; Get rid of all undo records for this buffer.
+ (or (eq buffer-undo-list t)
+ (setq buffer-undo-list nil))
+ (unwind-protect
+ (let ((opoint (point))
+ (new-messages 0)
+ (delete-files ())
+ ;; If buffer has not changed yet, and has not been saved yet,
+ ;; don't replace the old backup file now.
+ (make-backup-files (and make-backup-files (buffer-modified-p)))
+ (buffer-read-only nil)
+ ;; Don't make undo records for what we do in getting mail.
+ (buffer-undo-list t))
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n") ; just in case of brain damage
+ (delete-region (point) (point-max)) ; caused by require-final-newline
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;; Read in the contents of the inbox files,
+ ;; renaming them as necessary,
+ ;; and adding to the list of files to delete eventually.
+ (if file-name
+ (rmail-insert-inbox-text (list file-name) nil)
+ (setq delete-files (rmail-insert-inbox-text rmail-inbox-list t)))
+ ;; Scan the new text and convert each message to babyl format.
+ (goto-char (point-min))
+ (save-excursion
+ (setq new-messages (rmail-convert-to-babyl-format)))
+ (or (zerop new-messages)
+ (let (success)
+ (widen)
+ (search-backward "\^_")
+ (narrow-to-region (point) (point-max))
+ (goto-char (1+ (point-min)))
+ (rmail-count-new-messages)
+ (save-buffer)))
+ ;; Delete the old files, now that babyl file is saved.
+ (while delete-files
+ (condition-case ()
+ (delete-file (car delete-files))
+ (file-error nil))
+ (setq delete-files (cdr delete-files)))))
+ (if (= new-messages 0)
+ (progn (goto-char opoint)
+ (if (or file-name rmail-inbox-list)
+ (message "(No new mail has arrived)")))
+ (message "%d new message%s read"
+ new-messages (if (= 1 new-messages) "" "s"))))
+ ;; Don't leave the buffer screwed up if we get a disk-full error.
+ (rmail-show-message)))
+
+(defun rmail-insert-inbox-text (files renamep)
+ (let (file tofile delete-files movemail popmail)
+ (while files
+ (setq file (expand-file-name (substitute-in-file-name (car files)))
+ ;;>> un*x specific <<
+ tofile (concat file "~"))
+ ;; If getting from mail spool directory,
+ ;; use movemail to move rather than renaming.
+ (setq movemail (equal (file-name-directory file) rmail-spool-directory))
+ (setq popmail (string-match "^po:" (file-name-nondirectory file)))
+ (if popmail (setq file (file-name-nondirectory file)
+ renamep t))
+ (if movemail
+ (progn
+ (setq tofile (expand-file-name
+ ".newmail"
+ ;; Use the directory of this rmail file
+ ;; because it's a nuisance to use the homedir
+ ;; if that is on a full disk and this rmail
+ ;; file isn't.
+ (file-name-directory
+ (expand-file-name buffer-file-name))))
+ ;; On some systems, /usr/spool/mail/foo is a directory
+ ;; and the actual inbox is /usr/spool/mail/foo/foo.
+ (if (file-directory-p file)
+ (setq file (expand-file-name (or (getenv "LOGNAME")
+ (getenv "USER")
+ (user-login-name))
+ file)))))
+ (if popmail
+ (message "Getting mail from post office ...")
+ (if (or (file-exists-p tofile) (file-exists-p file))
+ (message "Getting mail from %s..." file)))
+ ;; Set TOFILE if have not already done so, and
+ ;; rename or copy the file FILE to TOFILE if and as appropriate.
+ (cond ((not renamep)
+ (setq tofile file))
+ ((or (file-exists-p tofile) (and (not popmail)
+ (not (file-exists-p file))))
+ nil)
+ ((and (not movemail) (not popmail))
+ (rename-file file tofile nil))
+ (t
+ (let ((errors nil))
+ (unwind-protect
+ (save-excursion
+ (setq errors (generate-new-buffer " *rmail loss*"))
+ (buffer-flush-undo errors)
+ (call-process
+ (expand-file-name "movemail" exec-directory)
+ nil errors nil file tofile)
+ (if (not (buffer-modified-p errors))
+ ;; No output => movemail won
+ nil
+ (set-buffer errors)
+ (subst-char-in-region (point-min) (point-max)
+ ?\n ?\ )
+ (goto-char (point-max))
+ (skip-chars-backward " \t")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (if (looking-at "movemail: ")
+ (delete-region (point-min) (match-end 0)))
+ (beep t)
+ (message (concat "movemail: "
+ (buffer-substring (point-min)
+ (point-max))))
+ (sit-for 3)
+ nil))
+ (if errors (kill-buffer errors))))))
+ ;; At this point, TOFILE contains the name to read:
+ ;; Either the alternate name (if we renamed)
+ ;; or the actual inbox (if not renaming).
+ (if (file-exists-p tofile)
+ (progn (goto-char (point-max))
+ (insert-file-contents tofile)
+ (goto-char (point-max))
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (setq delete-files (cons tofile delete-files))))
+ (message "")
+ (setq files (cdr files)))
+ delete-files))
+
+;; the rmail-break-forwarded-messages feature is not implemented
+(defun rmail-convert-to-babyl-format ()
+ (let ((count 0) start
+ (case-fold-search nil))
+ (goto-char (point-min))
+ (save-restriction
+ (while (not (eobp))
+ (cond ((looking-at "BABYL OPTIONS:");Babyl header
+ (search-forward "\n\^_")
+ (delete-region (point-min) (point)))
+ ;; Babyl format message
+ ((looking-at "\^L")
+ (or (search-forward "\n\^_" nil t)
+ (progn
+ (message "Invalid Babyl format in inbox!")
+ (sit-for 1)
+ (goto-char (point-max))))
+ (setq count (1+ count))
+ ;; Make sure there is no extra white space after the ^_
+ ;; at the end of the message.
+ ;; Narrowing will make sure that whatever follows the junk
+ ;; will be treated properly.
+ (delete-region (point)
+ (save-excursion
+ (skip-chars-forward " \t\n")
+ (point)))
+ (narrow-to-region (point) (point-max)))
+ ;;*** MMDF format
+ ((let ((case-fold-search t))
+ (looking-at mmdf-delim1))
+ (let ((case-fold-search t))
+ (replace-match "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (setq start (point))
+ (re-search-forward mmdf-delim2 nil t)
+ (replace-match "\^_"))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start (1- (point)))
+ (goto-char (point-min))
+ (while (search-forward "\n\^_" nil t) ; single char "\^_"
+ (replace-match "\n^_")))) ; 2 chars: "^" and "_"
+ (narrow-to-region (point) (point-max))
+ (setq count (1+ count)))
+ ;;*** Mail format
+ ((looking-at "^From ")
+ (setq start (point))
+ (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (rmail-nuke-pinhead-header)
+ (if (re-search-forward
+ (concat "^[\^_]?\\("
+ "From [^ \n]*\\(\\|\".*\"[^ \n]*\\) ?[^ \n]* [^ \n]* *"
+ "[0-9]* [0-9:]*\\( ?[A-Z]?[A-Z][A-Z]T\\| ?[-+]?[0-9][0-9][0-9][0-9]\\|\\) " ; EDT, -0500
+ "19[0-9]* *\\(remote from .*\\)?$\\|"
+ mmdf-delim1 "\\|"
+ "^BABYL OPTIONS:\\|"
+ "\^L\n[01],\\)") nil t)
+ (goto-char (match-beginning 1))
+ (goto-char (point-max)))
+ (setq count (1+ count))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char (point-min))
+ (while (search-forward "\n\^_" nil t); single char
+ (replace-match "\n^_")))); 2 chars: "^" and "_"
+ (insert ?\^_)
+ (narrow-to-region (point) (point-max)))
+ ;;
+ ;;This is a kludge, in case we're wrong about mmdf not
+ ;;allowing anything in between. If it loses, we'll have
+ ;;to look for something else
+ (t (delete-char 1)))))
+ count))
+
+(defun rmail-nuke-pinhead-header ()
+ (save-excursion
+ (save-restriction
+ (let ((start (point))
+ (end (progn
+ (condition-case ()
+ (search-forward "\n\n")
+ (error
+ (goto-char (point-max))
+ (insert "\n\n")))
+ (point)))
+ has-from has-date)
+ (narrow-to-region start end)
+ (let ((case-fold-search t))
+ (goto-char start)
+ (setq has-from (search-forward "\nFrom:" nil t))
+ (goto-char start)
+ (setq has-date (and (search-forward "\nDate:" nil t) (point)))
+ (goto-char start))
+ (let ((case-fold-search nil))
+ (if (re-search-forward
+ "^From \\([^ ]*\\(\\|\".*\"[^ ]*\\)\\) ?\\([^ ]*\\) \\([^ ]*\\) *\\([0-9]*\\) \\([0-9:]*\\)\\( ?[A-Z]?[A-Z][A-Z]T\\| ?[-+]?[0-9][0-9][0-9][0-9]\\|\\) 19\\([0-9]*\\) *\\(remote from [^\n]*\\)?\n" nil t)
+ (replace-match
+ (concat
+ ;; Keep and reformat the date if we don't
+ ;; have a Date: field.
+ (if has-date
+ ""
+ ;; If no time zone specified, assume est.
+ (if (= (match-beginning 7) (match-end 7))
+ "Date: \\3, \\5 \\4 \\8 \\6 EST\n"
+ "Date: \\3, \\5 \\4 \\8 \\6\\7\n"))
+ ;; Keep and reformat the sender if we don't
+ ;; have a From: field.
+ (if has-from
+ ""
+ "From: \\1\n")))))))))
+\f
+;;;; *** Rmail Message Formatting and Header Manipulation ***
+
+(defun rmail-reformat-message (beg end)
+ (goto-char beg)
+ (forward-line 1)
+ (if (/= (following-char) ?0)
+ (error "Bad format in RMAIL file."))
+ (let ((buffer-read-only nil)
+ (delta (- (buffer-size) end)))
+ (delete-char 1)
+ (insert ?1)
+ (forward-line 1)
+ (if (looking-at "Summary-line: ")
+ (forward-line 1))
+ (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*\n")
+ (delete-region (point)
+ (progn (forward-line 1) (point))))
+ (let ((str (buffer-substring (point)
+ (save-excursion (search-forward "\n\n" end 'move)
+ (point)))))
+ (insert str "*** EOOH ***\n")
+ (narrow-to-region (point) (- (buffer-size) delta)))
+ (goto-char (point-min))
+ (if rmail-ignored-headers (rmail-clear-headers))
+ (if rmail-message-filter (funcall rmail-message-filter))))
+
+(defun rmail-clear-headers ()
+ (if (search-forward "\n\n" nil t)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let ((buffer-read-only nil))
+ (while (let ((case-fold-search t))
+ (goto-char (point-min))
+ (re-search-forward rmail-ignored-headers nil t))
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (re-search-forward "\n[^ \t]")
+ (forward-char -1)
+ (point))))))))
+
+(defun rmail-toggle-header ()
+ "Show original message header if pruned header currently shown, or vice versa."
+ (interactive)
+ (rmail-maybe-set-message-counters)
+ (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max))
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (forward-line 1)
+ (if (= (following-char) ?1)
+ (progn (delete-char 1)
+ (insert ?0)
+ (forward-line 1)
+ (if (looking-at "Summary-Line:")
+ (forward-line 1))
+ (insert "*** EOOH ***\n")
+ (forward-char -1)
+ (search-forward "\n*** EOOH ***\n")
+ (forward-line -1)
+ (let ((temp (point)))
+ (and (search-forward "\n\n" nil t)
+ (delete-region temp (point))))
+ (goto-char (point-min))
+ (search-forward "\n*** EOOH ***\n")
+ (narrow-to-region (point) (point-max)))
+ (rmail-reformat-message (point-min) (point-max)))))
+\f
+;;;; *** Rmail Attributes and Keywords ***
+
+;; Make a string describing current message's attributes and keywords
+;; and set it up as the name of a minor mode
+;; so it will appear in the mode line.
+(defun rmail-display-labels ()
+ (let ((blurb "") (beg (point-min-marker)) (end (point-max-marker)))
+ (save-excursion
+ (unwind-protect
+ (progn
+ (widen)
+ (goto-char (rmail-msgbeg rmail-current-message))
+ (forward-line 1)
+ (if (looking-at "[01],")
+ (progn
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ ;; Truly valid BABYL format requires a space before each
+ ;; attribute or keyword name. Put them in if missing.
+ (let (buffer-read-only)
+ (goto-char (point-min))
+ (while (search-forward "," nil t)
+ (or (looking-at "[ ,]") (eobp)
+ (insert " "))))
+ (goto-char (point-max))
+ (if (search-backward ",," nil 'move)
+ (progn
+ (if (> (point) (1+ (point-min)))
+ (setq blurb (buffer-substring (+ 1 (point-min)) (point))))
+ (if (> (- (point-max) (point)) 2)
+ (setq blurb
+ (concat blurb
+ ";"
+ (buffer-substring (+ (point) 3)
+ (1- (point-max)))))))))))
+ (narrow-to-region beg end)
+ (set-marker beg nil)
+ (set-marker end nil)))
+ (while (string-match " +," blurb)
+ (setq blurb (concat (substring blurb 0 (match-beginning 0)) ","
+ (substring blurb (match-end 0)))))
+ (while (string-match ", +" blurb)
+ (setq blurb (concat (substring blurb 0 (match-beginning 0)) ","
+ (substring blurb (match-end 0)))))
+ (setq mode-line-process
+ (concat " " rmail-current-message "/" rmail-total-messages
+ blurb))))
+
+;; Turn an attribute of the current message on or off according to STATE.
+;; ATTR is the name of the attribute, as a string.
+(defun rmail-set-attribute (attr state)
+ (let ((omax (- (buffer-size) (point-max)))
+ (omin (- (buffer-size) (point-min)))
+ (buffer-read-only nil))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char (+ 3 (rmail-msgbeg rmail-current-message)))
+ (let ((curstate (search-backward (concat ", " attr ",")
+ (prog1 (point) (end-of-line)) t)))
+ (or (eq curstate (not (not state)))
+ (if curstate
+ (delete-region (point) (1- (match-end 0)))
+ (beginning-of-line)
+ (forward-char 2)
+ (insert " " attr ","))))
+ (if (string= attr "deleted")
+ (rmail-set-message-deleted-p rmail-current-message state)))
+ (narrow-to-region (max 1 (- (buffer-size) omin))
+ (- (buffer-size) omax))
+ (rmail-display-labels))))
+
+;; Return t if the attributes/keywords line of msg number MSG
+;; contains a match for the regexp LABELS.
+(defun rmail-message-labels-p (msg labels)
+ (goto-char (rmail-msgbeg msg))
+ (forward-char 3)
+ (re-search-backward labels (prog1 (point) (end-of-line)) t))
+\f
+;;;; *** Rmail Message Selection And Support ***
+
+(defun rmail-msgend (n)
+ (marker-position (aref rmail-message-vector (1+ n))))
+
+(defun rmail-msgbeg (n)
+ (marker-position (aref rmail-message-vector n)))
+
+(defun rmail-widen-to-current-msgbeg (function)
+ "Call FUNCTION with point at start of internal data of current message.
+Assumes that bounds were previously narrowed to display the message in Rmail.
+The bounds are widened enough to move point where desired,
+then narrowed again afterward.
+Assumes that the visible text of the message is not changed by FUNCTION."
+ (save-excursion
+ (let ((obeg (- (point-max) (point-min)))
+ (unwind-protect
+ (progn
+ (narrow-to-region (rmail-msgbeg rmail-current-message)
+ (point-max))
+ (goto-char (point-min))
+ (funcall function))
+ (narrow-to-region (- (point-max) obeg) (point-max)))))))
+
+(defun rmail-forget-messages ()
+ (unwind-protect
+ (if (vectorp rmail-message-vector)
+ (let* ((i 0)
+ (v rmail-message-vector)
+ (n (length v)))
+ (while (< i n)
+ (move-marker (aref v i) nil)
+ (setq i (1+ i)))))
+ (setq rmail-message-vector nil)
+ (setq rmail-deleted-vector nil)))
+
+(defun rmail-maybe-set-message-counters ()
+ (if (not (and rmail-deleted-vector
+ rmail-message-vector
+ rmail-current-message
+ rmail-total-messages))
+ (rmail-set-message-counters)))
+
+(defun rmail-count-new-messages (&optional nomsg)
+ (let* ((case-fold-search nil)
+ (total-messages 0)
+ (messages-head nil)
+ (deleted-head nil))
+ (or nomsg (message "Counting new messages..."))
+ (goto-char (point-max))
+ ;; Put at the end of messages-head
+ ;; the entry for message N+1, which marks
+ ;; the end of message N. (N = number of messages).
+ (search-backward "\^_")
+ (setq messages-head (list (point-marker)))
+ (rmail-set-message-counters-counter (point-min))
+ (setq rmail-current-message (1+ rmail-total-messages))
+ (setq rmail-total-messages
+ (+ rmail-total-messages total-messages))
+ (setq rmail-message-vector
+ (vconcat rmail-message-vector (cdr messages-head)))
+ (aset rmail-message-vector
+ rmail-current-message (car messages-head))
+ (setq rmail-deleted-vector
+ (concat rmail-deleted-vector deleted-head))
+ (setq rmail-summary-vector
+ (vconcat rmail-summary-vector (make-vector total-messages nil)))
+ (goto-char (point-min))
+ (or nomsg (message "Counting new messages...done (%d)" total-messages))))
+
+(defun rmail-set-message-counters ()
+ (rmail-forget-messages)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let* ((point-save (point))
+ (total-messages 0)
+ (messages-after-point)
+ (case-fold-search nil)
+ (messages-head nil)
+ (deleted-head nil))
+ (message "Counting messages...")
+ (goto-char (point-max))
+ ;; Put at the end of messages-head
+ ;; the entry for message N+1, which marks
+ ;; the end of message N. (N = number of messages).
+ (search-backward "\^_")
+ (setq messages-head (list (point-marker)))
+ (rmail-set-message-counters-counter (min (point) point-save))
+ (setq messages-after-point total-messages)
+ (rmail-set-message-counters-counter)
+ (setq rmail-total-messages total-messages)
+ (setq rmail-current-message
+ (min total-messages
+ (max 1 (- total-messages messages-after-point))))
+ (setq rmail-message-vector
+ (apply 'vector (cons (point-min-marker) messages-head))
+ rmail-deleted-vector (concat "D" deleted-head)
+ rmail-summary-vector (make-vector rmail-total-messages nil))
+ (message "Counting messages...done")))))
+
+(defun rmail-set-message-counters-counter (&optional stop)
+ (while (search-backward "\^_\^L\n" stop t)
+ (setq messages-head (cons (point-marker) messages-head))
+ (save-excursion
+ (setq deleted-head
+ (cons (if (search-backward ", deleted,"
+ (prog1 (point)
+ (forward-line 2))
+ t)
+ ?D ?\ )
+ deleted-head)))
+ (if (zerop (% (setq total-messages (1+ total-messages)) 20))
+ (message "Counting messages...%d" total-messages))))
+
+(defun rmail-beginning-of-message ()
+ "Show current message starting from the beginning."
+ (interactive)
+ (rmail-show-message rmail-current-message))
+
+(defun rmail-show-message (&optional n)
+ "Show message number N (prefix argument), counting from start of file."
+ (interactive "p")
+ (rmail-maybe-set-message-counters)
+ (widen)
+ (if (zerop rmail-total-messages)
+ (progn (narrow-to-region (point-min) (1- (point-max)))
+ (goto-char (point-min))
+ (setq mode-line-process nil))
+ (let (blurb)
+ (if (not n)
+ (setq n rmail-current-message)
+ (cond ((<= n 0)
+ (setq n 1
+ rmail-current-message 1
+ blurb "No previous message"))
+ ((> n rmail-total-messages)
+ (setq n rmail-total-messages
+ rmail-current-message rmail-total-messages
+ blurb "No following message"))
+ (t
+ (setq rmail-current-message n))))
+ (let ((beg (rmail-msgbeg n))
+ (end (rmail-msgend n)))
+ (goto-char beg)
+ (forward-line 1)
+ (if (= (following-char) ?0)
+ (progn
+ (rmail-reformat-message beg end)
+ (rmail-set-attribute "unseen" nil))
+ (search-forward "\n*** EOOH ***\n" end t)
+ (narrow-to-region (point) end))
+ (goto-char (point-min))
+ (rmail-display-labels)
+ (run-hooks 'rmail-show-message-hook)
+ (if blurb
+ (message blurb))))))
+
+(defun rmail-next-message (n)
+ "Show following message whether deleted or not.
+With prefix argument N, moves forward N messages,
+or backward if N is negative."
+ (interactive "p")
+ (rmail-maybe-set-message-counters)
+ (rmail-show-message (+ rmail-current-message n)))
+
+(defun rmail-previous-message (n)
+ "Show previous message whether deleted or not.
+With prefix argument N, moves backward N messages,
+or forward if N is negative."
+ (interactive "p")
+ (rmail-next-message (- n)))
+
+(defun rmail-next-undeleted-message (n)
+ "Show following non-deleted message.
+With prefix argument N, moves forward N non-deleted messages,
+or backward if N is negative."
+ (interactive "p")
+ (rmail-maybe-set-message-counters)
+ (let ((lastwin rmail-current-message)
+ (current rmail-current-message))
+ (while (and (> n 0) (< current rmail-total-messages))
+ (setq current (1+ current))
+ (if (not (rmail-message-deleted-p current))
+ (setq lastwin current n (1- n))))
+ (while (and (< n 0) (> current 1))
+ (setq current (1- current))
+ (if (not (rmail-message-deleted-p current))
+ (setq lastwin current n (1+ n))))
+ (if (/= lastwin rmail-current-message)
+ (rmail-show-message lastwin))
+ (if (< n 0)
+ (message "No previous nondeleted message"))
+ (if (> n 0)
+ (message "No following nondeleted message"))))
+
+(defun rmail-previous-undeleted-message (n)
+ "Show previous non-deleted message.
+With prefix argument N, moves backward N non-deleted messages,
+or forward if N is negative."
+ (interactive "p")
+ (rmail-next-undeleted-message (- n)))
+
+(defun rmail-last-message ()
+ "Show last message in file."
+ (interactive)
+ (rmail-maybe-set-message-counters)
+ (rmail-show-message rmail-total-messages))
+
+(defun rmail-what-message ()
+ (let ((where (point))
+ (low 1)
+ (high rmail-total-messages)
+ (mid (/ rmail-total-messages 2)))
+ (while (> (- high low) 1)
+ (if (>= where (rmail-msgbeg mid))
+ (setq low mid)
+ (setq high mid))
+ (setq mid (+ low (/ (- high low) 2))))
+ (if (>= where (rmail-msgbeg high)) high low)))
+
+(defvar rmail-search-last-regexp nil)
+(defun rmail-search (regexp &optional reversep)
+ "Show message containing next match for REGEXP.
+Search in reverse (earlier messages) with non-nil 2nd arg REVERSEP.
+Interactively, empty argument means use same regexp used last time,
+and reverse search is specified by a negative numeric arg."
+ (interactive
+ (let* ((reversep (< (prefix-numeric-value current-prefix-arg) 0))
+ (prompt (concat (if reversep "Reverse " "") "Rmail search (regexp): "))
+ regexp)
+ (if rmail-search-last-regexp
+ (setq prompt (concat prompt
+ "(default "
+ rmail-search-last-regexp
+ ") ")))
+ (setq regexp (read-string prompt))
+ (cond ((not (equal regexp ""))
+ (setq rmail-search-last-regexp regexp))
+ ((not rmail-search-last-regexp)
+ (error "No previous Rmail search string")))
+ (list rmail-search-last-regexp reversep)))
+ (message "%sRmail search for %s..."
+ (if reversep "Reverse " "")
+ regexp)
+ (rmail-maybe-set-message-counters)
+ (let ((omin (point-min))
+ (omax (point-max))
+ (opoint (point))
+ win
+ (msg rmail-current-message))
+ (unwind-protect
+ (progn
+ (widen)
+ ;; Check messages one by one, advancing message number up or down
+ ;; but searching forward through each message.
+ (if reversep
+ (while (and (null win) (> msg 1))
+ (goto-char (rmail-msgbeg (setq msg (1- msg))))
+ (setq win (re-search-forward
+ regexp (rmail-msgend msg) t)))
+ (while (and (null win) (< msg rmail-total-messages))
+ (goto-char (rmail-msgbeg (setq msg (1+ msg))))
+ (setq win (re-search-forward regexp (rmail-msgend msg) t)))))
+ (if win
+ (progn
+ ;; If this is a reverse search and we found a message,
+ ;; search backward thru this message to position point.
+ (if reversep
+ (progn
+ (goto-char (rmail-msgend msg))
+ (re-search-backward
+ regexp (rmail-msgbeg msg) t)))
+ (setq win (point))
+ (rmail-show-message msg)
+ (message "%sRmail search for %s...done"
+ (if reversep "Reverse " "")
+ regexp)
+ (goto-char win))
+ (goto-char opoint)
+ (narrow-to-region omin omax)
+ (ding)
+ (message "Searched failed: %s" regexp)))))
+\f
+;;;; *** Rmail Message Deletion Commands ***
+
+(defun rmail-message-deleted-p (n)
+ (= (aref rmail-deleted-vector n) ?D))
+
+(defun rmail-set-message-deleted-p (n state)
+ (aset rmail-deleted-vector n (if state ?D ?\ )))
+
+(defun rmail-delete-message ()
+ "Delete this message and stay on it."
+ (interactive)
+ (rmail-set-attribute "deleted" t))
+
+(defun rmail-undelete-previous-message ()
+ "Back up to deleted message, select it, and undelete it."
+ (interactive)
+ (let ((msg rmail-current-message))
+ (while (and (> msg 0)
+ (not (rmail-message-deleted-p msg)))
+ (setq msg (1- msg)))
+ (if (= msg 0)
+ (error "No previous deleted message")
+ (if (/= msg rmail-current-message)
+ (rmail-show-message msg))
+ (rmail-set-attribute "deleted" nil))))
+
+(defun rmail-delete-forward (&optional backward)
+ "Delete this message and move to next nondeleted one.
+Deleted messages stay in the file until the \\[rmail-expunge] command is given.
+With prefix argument, delete and move backward."
+ (interactive "P")
+ (rmail-set-attribute "deleted" t)
+ (rmail-next-undeleted-message (if backward -1 1)))
+
+(defun rmail-delete-backward ()
+ "Delete this message and move to previous nondeleted one.
+Deleted messages stay in the file until the \\[rmail-expunge] command is given."
+ (interactive)
+ (rmail-delete-forward t))
+
+(defun rmail-expunge ()
+ "Actually erase all deleted messages in the file."
+ (interactive)
+ (message "Expunging deleted messages...")
+ ;; Discard any prior undo information.
+ (or (eq buffer-undo-list t)
+ (setq buffer-undo-list nil))
+ (rmail-maybe-set-message-counters)
+ (let* ((omax (- (buffer-size) (point-max)))
+ (omin (- (buffer-size) (point-min)))
+ (opoint (if (and (> rmail-current-message 0)
+ (= ?D (aref rmail-deleted-vector rmail-current-message)))
+ 0 (- (point) (point-min))))
+ (messages-head (cons (aref rmail-message-vector 0) nil))
+ (messages-tail messages-head)
+ ;; Don't make any undo records for the expunging itself.
+ (buffer-undo-list t)
+ (win))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char (point-min))
+ (let ((counter 0)
+ (number 1)
+ (total rmail-total-messages)
+ (new-message-number rmail-current-message)
+ (new-summary nil)
+ (buffer-read-only nil)
+ (messages rmail-message-vector)
+ (deleted rmail-deleted-vector)
+ (summary rmail-summary-vector))
+ (setq rmail-total-messages nil
+ rmail-current-message nil
+ rmail-message-vector nil
+ rmail-deleted-vector nil
+ rmail-summary-vector nil)
+ (while (<= number total)
+ (if (= (aref deleted number) ?D)
+ (progn
+ (delete-region
+ (marker-position (aref messages number))
+ (marker-position (aref messages (1+ number))))
+ (move-marker (aref messages number) nil)
+ (if (> new-message-number counter)
+ (setq new-message-number (1- new-message-number))))
+ (setq counter (1+ counter))
+ (setq messages-tail
+ (setcdr messages-tail
+ (cons (aref messages number) nil)))
+ (setq new-summary
+ (cons (if (= counter number) (aref summary (1- number)))
+ new-summary)))
+ (if (zerop (% (setq number (1+ number)) 20))
+ (message "Expunging deleted messages...%d" number)))
+ (setq messages-tail
+ (setcdr messages-tail
+ (cons (aref messages number) nil)))
+ (setq rmail-current-message new-message-number
+ rmail-total-messages counter
+ rmail-message-vector (apply 'vector messages-head)
+ rmail-deleted-vector (make-string (1+ counter) ?\ )
+ rmail-summary-vector (vconcat (nreverse new-summary))
+ win t)))
+ (message "Expunging deleted messages...done")
+ (if (not win)
+ (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)))
+ (rmail-show-message
+ (if (zerop rmail-current-message) 1 nil))
+ (forward-char opoint))))
+\f
+;;;; *** Rmail Mailing Commands ***
+
+(defun rmail-mail ()
+ "Send mail in another window.
+While composing the message, use \\[mail-yank-original] to yank the
+original message into it."
+ (interactive)
+ (mail-other-window nil nil nil nil nil (current-buffer)))
+
+(defun rmail-continue ()
+ "Continue composing outgoing message previously being composed."
+ (interactive)
+ (mail-other-window t))
+
+(defun rmail-reply (just-sender)
+ "Reply to the current message.
+Normally include CC: to all other recipients of original message;
+prefix argument means ignore them.
+While composing the reply, use \\[mail-yank-original] to yank the
+original message into it."
+ (interactive "P")
+ ;;>> this gets set even if we abort. Can't do anything about it, though.
+ (rmail-set-attribute "answered" t)
+ (rmail-display-labels)
+ (let (from reply-to cc subject date to message-id resent-reply-to)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (rmail-msgbeg rmail-current-message))
+ (forward-line 1)
+ (if (= (following-char) ?0)
+ (narrow-to-region
+ (progn (forward-line 2)
+ (point))
+ (progn (search-forward "\n\n" (rmail-msgend rmail-current-message)
+ 'move)
+ (point)))
+ (narrow-to-region (point)
+ (progn (search-forward "\n*** EOOH ***\n")
+ (beginning-of-line) (point))))
+ (setq resent-reply-to (mail-fetch-field "resent-reply-to" t)
+ from (mail-fetch-field "from")
+ reply-to (or resent-reply-to
+ (mail-fetch-field "reply-to" nil t)
+ from)
+ cc (cond (just-sender nil)
+ (resent-reply-to (mail-fetch-field "resent-cc" t))
+ (t (mail-fetch-field "cc" nil t)))
+ subject (or (and resent-reply-to
+ (mail-fetch-field "resent-subject" t))
+ (mail-fetch-field "subject"))
+ date (cond (resent-reply-to
+ (mail-fetch-field "resent-date" t))
+ ((mail-fetch-field "date")))
+ to (cond (resent-reply-to
+ (mail-fetch-field "resent-to" t))
+ ((mail-fetch-field "to" nil t))
+ ;((mail-fetch-field "apparently-to")) ack gag barf
+ (t ""))
+ message-id (cond (resent-reply-to
+ (mail-fetch-field "resent-message-id" t))
+ ((mail-fetch-field "message-id"))))))
+ (and subject
+ (string-match "\\`Re: " subject)
+ (setq subject (substring subject 4)))
+ (mail-other-window nil
+ (mail-strip-quoted-names reply-to)
+ subject
+ (rmail-make-in-reply-to-field from date message-id)
+ (if just-sender
+ nil
+ (let* ((cc-list (rmail-dont-reply-to
+ (mail-strip-quoted-names
+ (if (null cc) to (concat to ", " cc))))))
+ (if (string= cc-list "") nil cc-list)))
+ (current-buffer))))
+
+(defun rmail-make-in-reply-to-field (from date message-id)
+ (if mail-use-rfc822 (require 'rfc822))
+ (let (field)
+ (if (and mail-use-rfc822 from)
+ (let ((tem (car (rfc822-addresses from))))
+ (and message-id
+ (setq field (if (string-match
+ (regexp-quote
+ (if (string-match "@[^@]*\\'" tem)
+ (substring tem
+ 0 (match-beginning 0))
+ tem))
+ message-id)
+ message-id
+ (concat message-id " \"" tem "\""))
+ message-id nil date nil))
+ (or field
+ (setq field (prin1-to-string tem))))
+; (if message-id
+; (setq field message-id message-id nil date nil)
+; (setq field (car (rfc882-addresses from))))
+ )
+ (or field
+ (not from)
+ ;; Compute the sender for the in-reply-to; prefer full name.
+ (let* ((stop-pos (string-match " *at \\| *@ \\| *<" from))
+ (start-pos (if stop-pos 0
+ ;;>> this loses on nested ()'s
+ (let ((pos (string-match " *(" from)))
+ (if (not pos) nil
+ (setq stop-pos (string-match ")" from pos))
+ (if (zerop pos) 0 (+ 2 pos)))))))
+ (setq field (if stop-pos
+ (substring from start-pos stop-pos)
+ from))))
+ (if date (setq field (concat field "'s message of " date)))
+ (if message-id (setq field (concat field " " message-id)))
+ field))
+
+(defun rmail-forward ()
+ "Forward the current message to another user."
+ (interactive)
+ ;;>> this gets set even if we abort. Can't do anything about it, though.
+ (rmail-set-attribute "forwarded" t)
+ (let ((forward-buffer (current-buffer))
+ (subject (concat "["
+ (mail-strip-quoted-names (mail-fetch-field "From"))
+ ": " (or (mail-fetch-field "Subject") "") "]")))
+ ;; If only one window, use it for the mail buffer.
+ ;; Otherwise, use another window for the mail buffer
+ ;; so that the Rmail buffer remains visible
+ ;; and sending the mail will get back to it.
+ (if (if (one-window-p t)
+ (mail nil nil subject)
+ (mail-other-window nil nil subject))
+ (save-excursion
+ (goto-char (point-max))
+ (forward-line 1)
+ (insert-buffer forward-buffer)))))
+\f
+;;;; *** Rmail Specify Inbox Files ***
+
+(autoload 'set-rmail-inbox-list "rmailmsc"
+ "Set the inbox list of the current RMAIL file to FILE-NAME.
+This may be a list of file names separated by commas.
+If FILE-NAME is empty, remove any inbox list."
+ t)
+
+;;;; *** Rmail Commands for Labels ***
+
+(autoload 'rmail-add-label "rmailkwd"
+ "Add LABEL to labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ t)
+
+(autoload 'rmail-kill-label "rmailkwd"
+ "Remove LABEL from labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ t)
+
+(autoload 'rmail-next-labeled-message "rmailkwd"
+ "Show next message with LABEL. Defaults to last label used.
+With prefix argument N moves forward N messages with this label."
+ t)
+
+(autoload 'rmail-previous-labeled-message "rmailkwd"
+ "Show previous message with LABEL. Defaults to last label used.
+With prefix argument N moves backward N messages with this label."
+ t)
+
+;;;; *** Rmail Edit Mode ***
+
+(autoload 'rmail-edit-current-message "rmailedit"
+ "Edit the contents of the current message"
+ t)
+\f
+;;;; *** Rmail Summary Mode ***
+
+(autoload 'rmail-summary "rmailsum"
+ "Display a summary of all messages, one line per message."
+ t)
+
+(autoload 'rmail-summary-by-labels "rmailsum"
+ "Display a summary of all messages with one or more LABELS.
+LABELS should be a string containing the desired labels, separated by commas."
+ t)
+
+(autoload 'rmail-summary-by-recipients "rmailsum"
+ "Display a summary of all messages with the given RECIPIENTS.
+Normally checks the To, From and Cc fields of headers;
+but if PRIMARY-ONLY is non-nil (prefix arg given),
+ only look in the To and From fields.
+RECIPIENTS is a string of names separated by commas."
+ t)
+\f
+;;;; *** Rmail output messages to files ***
+
+(autoload 'rmail-output-to-rmail-file "rmailout"
+ "Append the current message to an Rmail file named FILE-NAME.
+If the file does not exist, ask if it should be created.
+If file is being visited, the message is appended to the Emacs
+buffer visiting that file."
+ t)
+
+(autoload 'rmail-output "rmailout"
+ "Append this message to Unix mail file named FILE-NAME."
+ t)
+
+;;;; *** Rmail undigestification ***
+
+(autoload 'undigestify-rmail-message "undigest"
+ "Break up a digest message into its constituent messages.
+Leaves original message, deleted, before the undigestified messages."
+ t)
--- /dev/null
+;; "RMAIL edit mode" Edit the current message.
+;; Copyright (C) 1985 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.
+
+
+(require 'rmail)
+
+(defvar rmail-edit-map nil)
+(if rmail-edit-map
+ nil
+ (setq rmail-edit-map (copy-keymap text-mode-map))
+ (define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
+ (define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
+
+;; Rmail Edit mode is suitable only for specially formatted data.
+(put 'rmail-edit-mode 'mode-class 'special)
+
+(defun rmail-edit-mode ()
+ "Major mode for editing the contents of an RMAIL message.
+The editing commands are the same as in Text mode, together with two commands
+to return to regular RMAIL:
+ * rmail-abort-edit cancels the changes
+ you have made and returns to RMAIL
+ * rmail-cease-edit makes them permanent.
+\\{rmail-edit-map}"
+ (use-local-map rmail-edit-map)
+ (setq major-mode 'rmail-edit-mode)
+ (setq mode-name "RMAIL Edit")
+ (if (boundp 'mode-line-modified)
+ (setq mode-line-modified (default-value 'mode-line-modified))
+ (setq mode-line-format (default-value 'mode-line-format)))
+ (run-hooks 'text-mode-hook 'rmail-edit-mode-hook))
+
+(defun rmail-edit-current-message ()
+ "Edit the contents of this message."
+ (interactive)
+ (rmail-edit-mode)
+ (make-local-variable 'rmail-old-text)
+ (setq rmail-old-text (buffer-substring (point-min) (point-max)))
+ (setq buffer-read-only nil)
+ (set-buffer-modified-p (buffer-modified-p))
+ ;; Make mode line update.
+ (if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
+ (eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
+ (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
+ (message (substitute-command-keys
+ "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
+
+(defun rmail-cease-edit ()
+ "Finish editing message; switch back to Rmail proper."
+ (interactive)
+ ;; Make sure buffer ends with a newline.
+ (save-excursion
+ (goto-char (point-max))
+ (if (/= (preceding-char) ?\n)
+ (insert "\n"))
+ ;; Adjust the marker that points to the end of this message.
+ (set-marker (aref rmail-message-vector (1+ rmail-current-message))
+ (point)))
+ (let ((old rmail-old-text))
+ ;; Update the mode line.
+ (set-buffer-modified-p (buffer-modified-p))
+ (rmail-mode-1)
+ (if (and (= (length old) (- (point-max) (point-min)))
+ (string= old (buffer-substring (point-min) (point-max))))
+ ()
+ (setq old nil)
+ (rmail-set-attribute "edited" t)
+ (if (boundp 'rmail-summary-vector)
+ (progn
+ (aset rmail-summary-vector (1- rmail-current-message) nil)
+ (save-excursion
+ (rmail-widen-to-current-msgbeg
+ (function (lambda ()
+ (forward-line 2)
+ (if (looking-at "Summary-line: ")
+ (let ((buffer-read-only nil))
+ (delete-region (point)
+ (progn (forward-line 1)
+ (point))))))))
+ (rmail-show-message))))))
+ (setq buffer-read-only t))
+
+(defun rmail-abort-edit ()
+ "Abort edit of current message; restore original contents."
+ (interactive)
+ (delete-region (point-min) (point-max))
+ (insert rmail-old-text)
+ (rmail-cease-edit))
+
--- /dev/null
+;; "RMAIL" mail reader for Emacs.
+;; Copyright (C) 1985, 1988 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.
+
+
+;; Global to all RMAIL buffers. It exists primarily for the sake of
+;; completion. It is better to use strings with the label functions
+;; and let them worry about making the label.
+
+(defvar rmail-label-obarray (make-vector 47 0))
+
+;; Named list of symbols representing valid message attributes in RMAIL.
+
+(defconst rmail-attributes
+ (cons 'rmail-keywords
+ (mapcar '(lambda (s) (intern s rmail-label-obarray))
+ '("deleted" "answered" "filed" "forwarded" "unseen" "edited"))))
+
+(defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
+
+;; Named list of symbols representing valid message keywords in RMAIL.
+
+(defvar rmail-keywords nil)
+\f
+(defun rmail-add-label (string)
+ "Add LABEL to labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ (interactive (list (rmail-read-label "Add label")))
+ (rmail-set-label string t))
+
+(defun rmail-kill-label (string)
+ "Remove LABEL from labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ (interactive (list (rmail-read-label "Remove label")))
+ (rmail-set-label string nil))
+
+(defun rmail-read-label (prompt)
+ (if (not rmail-keywords) (rmail-parse-file-keywords))
+ (let ((result
+ (completing-read (concat prompt
+ (if rmail-last-label
+ (concat " (default "
+ (symbol-name rmail-last-label)
+ "): ")
+ ": "))
+ rmail-label-obarray
+ nil
+ nil)))
+ (if (string= result "")
+ rmail-last-label
+ (setq rmail-last-label (rmail-make-label result t)))))
+
+(defun rmail-set-label (l state &optional n)
+ (rmail-maybe-set-message-counters)
+ (if (not n) (setq n rmail-current-message))
+ (aset rmail-summary-vector (1- n) nil)
+ (let* ((attribute (rmail-attribute-p l))
+ (keyword (and (not attribute)
+ (or (rmail-keyword-p l)
+ (rmail-install-keyword l))))
+ (label (or attribute keyword)))
+ (if label
+ (let ((omax (- (buffer-size) (point-max)))
+ (omin (- (buffer-size) (point-min)))
+ (buffer-read-only nil)
+ (case-fold-search t))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char (rmail-msgbeg n))
+ (forward-line 1)
+ (if (not (looking-at "[01],"))
+ nil
+ (let ((start (1+ (point)))
+ (bound))
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ (setq bound (point-max))
+ (search-backward ",," nil t)
+ (if attribute
+ (setq bound (1+ (point)))
+ (setq start (1+ (point))))
+ (goto-char start)
+; (while (re-search-forward "[ \t]*,[ \t]*" nil t)
+; (replace-match ","))
+; (goto-char start)
+ (if (re-search-forward
+ (concat ", " (rmail-quote-label-name label) ",")
+ bound
+ 'move)
+ (if (not state) (replace-match ","))
+ (if state (insert " " (symbol-name label) ",")))
+ (if (eq label rmail-deleted-label)
+ (rmail-set-message-deleted-p n state)))))
+ (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
+ (if (= n rmail-current-message) (rmail-display-labels)))))))
+\f
+;; Commented functions aren't used by RMAIL but might be nice for user
+;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
+;; is in rmailsum now.
+
+;(defun rmail-message-attribute-p (attribute &optional n)
+; "Returns t if ATTRIBUTE on NTH or current message."
+; (rmail-message-labels-p (rmail-make-label attribute t) n))
+
+;(defun rmail-message-keyword-p (keyword &optional n)
+; "Returns t if KEYWORD on NTH or current message."
+; (rmail-message-labels-p (rmail-make-label keyword t) n t))
+
+;(defun rmail-message-label-p (label &optional n)
+; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
+; (rmail-message-labels-p (rmail-make-label label t) n 'all))
+
+;; Not used by RMAIL but might be nice for user package.
+
+;(defun rmail-parse-message-labels (&optional n)
+; "Returns labels associated with NTH or current RMAIL message.
+;Results is a list of two lists. The first is the message attributes
+;and the second is the message keywords. Labels are represented as symbols."
+; (let ((omin (- (buffer-size) (point-min)))
+; (omax (- (buffer-size) (point-max)))
+; (result))
+; (unwind-protect
+; (save-excursion
+; (let ((beg (rmail-msgbeg (or n rmail-current-message))))
+; (widen)
+; (goto-char beg)
+; (forward-line 1)
+; (if (looking-at "[01],")
+; (save-restriction
+; (narrow-to-region (point) (save-excursion (end-of-line) (point)))
+; (rmail-nuke-whitespace)
+; (goto-char (1+ (point-min)))
+; (list (mail-parse-comma-list) (mail-parse-comma-list))))))
+; (narrow-to-region (- (buffer-size) omin)
+; (- (buffer-size) omax))
+; nil)))
+
+(defun rmail-attribute-p (s)
+ (let ((symbol (rmail-make-label s)))
+ (if (memq symbol (cdr rmail-attributes)) symbol)))
+
+(defun rmail-keyword-p (s)
+ (let ((symbol (rmail-make-label s)))
+ (if (memq symbol (cdr (rmail-keywords))) symbol)))
+
+(defun rmail-make-label (s &optional forcep)
+ (cond ((symbolp s) s)
+ (forcep (intern (downcase s) rmail-label-obarray))
+ (t (intern-soft (downcase s) rmail-label-obarray))))
+
+(defun rmail-force-make-label (s)
+ (intern (downcase s) rmail-label-obarray))
+
+(defun rmail-quote-label-name (label)
+ (regexp-quote (symbol-name (rmail-make-label label t))))
+\f
+;; Motion on messages with keywords.
+
+(defun rmail-previous-labeled-message (n label)
+ "Show previous message with LABEL. Defaults to last labels used.
+With prefix argument N moves backward N messages with these labels."
+ (interactive "p\nsMove to previous msg with labels: ")
+ (rmail-next-labeled-message (- n) label))
+
+(defun rmail-next-labeled-message (n labels)
+ "Show next message with LABEL. Defaults to last labels used.
+With prefix argument N moves forward N messages with these labels."
+ (interactive "p\nsMove to next msg with labels: ")
+ (if (string= labels "")
+ (setq labels rmail-last-multi-labels))
+ (or labels
+ (error "No labels to find have been specified previously"))
+ (setq rmail-last-multi-labels labels)
+ (rmail-maybe-set-message-counters)
+ (let ((lastwin rmail-current-message)
+ (current rmail-current-message)
+ (regexp (concat ", ?\\("
+ (mail-comma-list-regexp labels)
+ "\\),")))
+ (save-restriction
+ (widen)
+ (while (and (> n 0) (< current rmail-total-messages))
+ (setq current (1+ current))
+ (if (rmail-message-labels-p current regexp)
+ (setq lastwin current n (1- n))))
+ (while (and (< n 0) (> current 1))
+ (setq current (1- current))
+ (if (rmail-message-labels-p current regexp)
+ (setq lastwin current n (1+ n)))))
+ (rmail-show-message lastwin)
+ (if (< n 0)
+ (message "No previous message with labels %s" labels))
+ (if (> n 0)
+ (message "No following message with labels %s" labels))))
+\f
+;;; Manipulate the file's Labels option.
+
+;; Return a list of symbols for all
+;; the keywords (labels) recorded in this file's Labels option.
+(defun rmail-keywords ()
+ (or rmail-keywords (rmail-parse-file-keywords)))
+
+;; Set rmail-keywords to a list of symbols for all
+;; the keywords (labels) recorded in this file's Labels option.
+(defun rmail-parse-file-keywords ()
+ (save-restriction
+ (save-excursion
+ (widen)
+ (goto-char 1)
+ (setq rmail-keywords
+ (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
+ (progn
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ (goto-char (point-min))
+ (cons 'rmail-keywords
+ (mapcar 'rmail-force-make-label
+ (mail-parse-comma-list)))))))))
+
+;; Add WORD to the list in the file's Labels option.
+;; Any keyword used for the first time needs this done.
+(defun rmail-install-keyword (word)
+ (let ((keyword (rmail-make-label word t))
+ (keywords (rmail-keywords)))
+ (if (not (or (rmail-attribute-p keyword)
+ (rmail-keyword-p keyword)))
+ (let ((omin (- (buffer-size) (point-min)))
+ (omax (- (buffer-size) (point-max))))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char 1)
+ (let ((case-fold-search t)
+ (buffer-read-only nil))
+ (or (search-forward "\nLabels:" nil t)
+ (progn
+ (end-of-line)
+ (insert "\nLabels:")))
+ (delete-region (point) (progn (end-of-line) (point)))
+ (setcdr keywords (cons keyword (cdr keywords)))
+ (while (setq keywords (cdr keywords))
+ (insert (symbol-name (car keywords)) ","))
+ (delete-char -1)))
+ (narrow-to-region (- (buffer-size) omin)
+ (- (buffer-size) omax)))))
+ keyword))
--- /dev/null
+;; Copyright (C) 1985 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.
+
+
+(defun set-rmail-inbox-list (file-name)
+ "Set the inbox list of the current RMAIL file to FILE-NAME. This may be
+a list of file names separated by commas. If FILE-NAME is empty, remove
+any inbox list."
+ (interactive "sSet mailbox list to (comma-separated list of filenames): ")
+ (save-excursion
+ (let ((names (rmail-parse-file-inboxes))
+ (standard-output nil))
+ (if (or (not names)
+ (y-or-n-p (concat "Replace "
+ (mapconcat 'identity names ", ")
+ "? ")))
+ (let ((buffer-read-only nil))
+ (widen)
+ (goto-char (point-min))
+ (search-forward "\n\^_")
+ (re-search-backward "^Mail" nil t)
+ (forward-line 0)
+ (if (looking-at "Mail:")
+ (delete-region (point)
+ (progn (forward-line 1)
+ (point))))
+ (if (not (string= file-name ""))
+ (insert "Mail: " file-name "\n"))))))
+ (setq rmail-inbox-list (rmail-parse-file-inboxes))
+ (rmail-show-message rmail-current-message))
--- /dev/null
+;; "RMAIL" mail reader for Emacs: output message to a file.
+;; Copyright (C) 1985, 1987 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.
+
+
+;; Temporary until Emacs always has this variable.
+(defvar rmail-delete-after-output nil
+ "*Non-nil means automatically delete a message that is copied to a file.")
+
+(defun rmail-output-to-rmail-file (file-name)
+ "Append the current message to an Rmail file named FILE-NAME.
+If the file does not exist, ask if it should be created.
+If file is being visited, the message is appended to the Emacs
+buffer visiting that file."
+ (interactive (list (read-file-name
+ (concat "Output message to Rmail file: (default "
+ (file-name-nondirectory rmail-last-rmail-file)
+ ") ")
+ (file-name-directory rmail-last-rmail-file)
+ rmail-last-rmail-file)))
+ (setq file-name (expand-file-name file-name))
+ (setq rmail-last-rmail-file file-name)
+ (rmail-maybe-set-message-counters)
+ (or (get-file-buffer file-name)
+ (file-exists-p file-name)
+ (if (yes-or-no-p
+ (concat "\"" file-name "\" does not exist, create it? "))
+ (let ((file-buffer (create-file-buffer file-name)))
+ (save-excursion
+ (set-buffer file-buffer)
+ (rmail-insert-rmail-file-header)
+ (let ((require-final-newline nil))
+ (write-region (point-min) (point-max) file-name t 1)))
+ (kill-buffer file-buffer))
+ (error "Output file does not exist")))
+ (save-restriction
+ (widen)
+ ;; Decide whether to append to a file or to an Emacs buffer.
+ (save-excursion
+ (let ((buf (get-file-buffer file-name))
+ (cur (current-buffer))
+ (beg (1+ (rmail-msgbeg rmail-current-message)))
+ (end (1+ (rmail-msgend rmail-current-message))))
+ (if (not buf)
+ (append-to-file beg end file-name)
+ (if (eq buf (current-buffer))
+ (error "Can't output message to same file it's already in"))
+ ;; File has been visited, in buffer BUF.
+ (set-buffer buf)
+ (let ((buffer-read-only nil)
+ (msg (and (boundp 'rmail-current-message)
+ rmail-current-message)))
+ ;; If MSG is non-nil, buffer is in RMAIL mode.
+ (if msg
+ (progn (rmail-maybe-set-message-counters)
+ (widen)
+ (narrow-to-region (point-max) (point-max))))
+ (insert-buffer-substring cur beg end)
+ (if msg
+ (progn
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\^_")
+ (narrow-to-region (point) (point-max))
+ (goto-char (1+ (point-min)))
+ (rmail-count-new-messages t)
+ (rmail-show-message msg))))))))
+ (rmail-set-attribute "filed" t)
+ (and rmail-delete-after-output (rmail-delete-forward)))
+
+(defun rmail-output (file-name)
+ "Append this message to Unix mail file named FILE-NAME."
+ (interactive
+ (list
+ (read-file-name
+ (concat "Output message to Unix mail file"
+ (if rmail-last-file
+ (concat " (default "
+ (file-name-nondirectory rmail-last-file)
+ "): " )
+ ": "))
+ (and rmail-last-file (file-name-directory rmail-last-file))
+ rmail-last-file)))
+ (setq file-name (expand-file-name file-name))
+ (setq rmail-last-file file-name)
+ (let ((rmailbuf (current-buffer))
+ (tembuf (get-buffer-create " rmail-output"))
+ (case-fold-search t))
+ (save-excursion
+ (set-buffer tembuf)
+ (erase-buffer)
+ (insert-buffer-substring rmailbuf)
+ (insert "\n")
+ (goto-char (point-min))
+ (insert "From "
+ (or (mail-strip-quoted-names (mail-fetch-field "from"))
+ "unknown")
+ " " (current-time-string) "\n")
+ ;; ``Quote'' "\nFrom " as "\n>From "
+ ;; (note that this isn't really quoting, as there is no requirement
+ ;; that "\n[>]+From " be quoted in the same transparent way.)
+ (while (search-forward "\nFrom " nil t)
+ (forward-char -5)
+ (insert ?>))
+ (append-to-file (point-min) (point-max) file-name))
+ (kill-buffer tembuf))
+ (if (equal major-mode 'rmail-mode)
+ (progn
+ (rmail-set-attribute "filed" t)
+ (and rmail-delete-after-output (rmail-delete-forward)))))
--- /dev/null
+;; "RMAIL" mail reader for Emacs.
+;; Copyright (C) 1985 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.
+
+
+;; summary things
+
+(defun rmail-summary ()
+ "Display a summary of all messages, one line per message."
+ (interactive)
+ (rmail-new-summary "All" nil))
+
+(defun rmail-summary-by-labels (labels)
+ "Display a summary of all messages with one or more LABELS.
+LABELS should be a string containing the desired labels, separated by commas."
+ (interactive "sLabels to summarize by: ")
+ (if (string= labels "")
+ (setq labels (or rmail-last-multi-labels
+ (error "No label specified"))))
+ (setq rmail-last-multi-labels labels)
+ (rmail-new-summary (concat "labels " labels)
+ 'rmail-message-labels-p
+ (concat ", \\(" (mail-comma-list-regexp labels) "\\),")))
+
+(defun rmail-summary-by-recipients (recipients &optional primary-only)
+ "Display a summary of all messages with the given RECIPIENTS.
+Normally checks the To, From and Cc fields of headers;
+but if PRIMARY-ONLY is non-nil (prefix arg given),
+ only look in the To and From fields.
+RECIPIENTS is a string of names separated by commas."
+ (interactive "sRecipients to summarize by: \nP")
+ (rmail-new-summary
+ (concat "recipients " recipients)
+ 'rmail-message-recipients-p
+ (mail-comma-list-regexp recipients) primary-only))
+
+(defun rmail-message-recipients-p (msg recipients &optional primary-only)
+ (save-restriction
+ (goto-char (rmail-msgbeg msg))
+ (search-forward "\n*** EOOH ***\n")
+ (narrow-to-region (point) (progn (search-forward "\n\n") (point)))
+ (or (string-match recipients (or (mail-fetch-field "To") ""))
+ (string-match recipients (or (mail-fetch-field "From") ""))
+ (if (not primary-only)
+ (string-match recipients (or (mail-fetch-field "Cc") ""))))))
+
+(defun rmail-new-summary (description function &rest args)
+ "Create a summary of selected messages.
+DESCRIPTION makes part of the mode line of the summary buffer.
+For each message, FUNCTION is applied to the message number and ARGS...
+and if the result is non-nil, that message is included.
+nil for FUNCTION means all messages."
+ (message "Computing summary lines...")
+ (or (and rmail-summary-buffer
+ (buffer-name rmail-summary-buffer))
+ (setq rmail-summary-buffer
+ (generate-new-buffer (concat (buffer-name) "-summary"))))
+ (let ((summary-msgs ())
+ (new-summary-line-count 0))
+ (let ((msgnum 1)
+ (buffer-read-only nil))
+ (save-restriction
+ (save-excursion
+ (widen)
+ (goto-char (point-min))
+ (while (>= rmail-total-messages msgnum)
+ (if (or (null function)
+ (apply function (cons msgnum args)))
+ (setq summary-msgs
+ (cons (rmail-make-summary-line msgnum)
+ summary-msgs)))
+ (setq msgnum (1+ msgnum))))))
+ (let ((sbuf rmail-summary-buffer)
+ (rbuf (current-buffer))
+ (total rmail-total-messages)
+ (mesg rmail-current-message))
+ (pop-to-buffer sbuf)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (cond (summary-msgs
+ (princ (nreverse summary-msgs) sbuf)
+ (delete-char -1)
+ (subst-char-in-region 1 2 ?\( ?\ ))))
+ (setq buffer-read-only t)
+ (goto-char (point-min))
+ (rmail-summary-mode)
+ (make-local-variable 'minor-mode-alist)
+ (setq minor-mode-alist (list ": " description))
+ (setq rmail-buffer rbuf
+ rmail-total-messages total)
+ (rmail-summary-goto-msg mesg t)))
+ (message "Computing summary lines...done"))
+
+(defun rmail-make-summary-line (msg)
+ (let ((line (or (aref rmail-summary-vector (1- msg))
+ (progn
+ (setq new-summary-line-count
+ (1+ new-summary-line-count))
+ (if (zerop (% new-summary-line-count 10))
+ (message "Computing summary lines...%d"
+ new-summary-line-count))
+ (rmail-make-summary-line-1 msg)))))
+ ;; Fix up the part of the summary that says "deleted" or "unseen".
+ (aset line 4
+ (if (rmail-message-deleted-p msg) ?\D
+ (if (= ?0 (char-after (+ 3 (rmail-msgbeg msg))))
+ ?\- ?\ )))
+ line))
+
+(defun rmail-make-summary-line-1 (msg)
+ (goto-char (rmail-msgbeg msg))
+ (let* ((lim (save-excursion (forward-line 2) (point)))
+ pos
+ (labels
+ (progn
+ (forward-char 3)
+ (concat
+; (if (save-excursion (re-search-forward ",answered," lim t))
+; "*" "")
+; (if (save-excursion (re-search-forward ",filed," lim t))
+; "!" "")
+ (if (progn (search-forward ",,") (eolp))
+ ""
+ (concat "{"
+ (buffer-substring (point)
+ (progn (end-of-line) (point)))
+ "} ")))))
+ (line
+ (progn
+ (forward-line 1)
+ (if (looking-at "Summary-line: ")
+ (progn
+ (goto-char (match-end 0))
+ (setq line
+ (buffer-substring (point)
+ (progn (forward-line 1) (point)))))))))
+ ;; Obsolete status lines lacking a # should be flushed.
+ (and line
+ (not (string-match "#" line))
+ (progn
+ (delete-region (point)
+ (progn (forward-line -1) (point)))
+ (setq line nil)))
+ ;; If we didn't get a valid status line from the message,
+ ;; make a new one and put it in the message.
+ (or line
+ (let* ((case-fold-search t)
+ (next (rmail-msgend msg))
+ (beg (if (progn (goto-char (rmail-msgbeg msg))
+ (search-forward "\n*** EOOH ***\n" next t))
+ (point)
+ (forward-line 1)
+ (point)))
+ (end (progn (search-forward "\n\n" nil t) (point))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char beg)
+ (setq line (rmail-make-basic-summary-line)))
+ (goto-char (rmail-msgbeg msg))
+ (forward-line 2)
+ (insert "Summary-line: " line)))
+ (setq pos (string-match "#" line))
+ (aset rmail-summary-vector (1- msg)
+ (concat (format "%4d " msg)
+ (substring line 0 pos)
+ labels
+ (substring line (1+ pos))))))
+
+(defun rmail-make-basic-summary-line ()
+ (goto-char (point-min))
+ (concat (save-excursion
+ (if (not (re-search-forward "^Date:" nil t))
+ " "
+ (cond ((re-search-forward "\\([^0-9:]\\)\\([0-3]?[0-9]\\)\\([- \t_]+\\)\\([adfjmnos][aceopu][bcglnprtvy]\\)"
+ (save-excursion (end-of-line) (point)) t)
+ (format "%2d-%3s"
+ (string-to-int (buffer-substring
+ (match-beginning 2)
+ (match-end 2)))
+ (buffer-substring
+ (match-beginning 4) (match-end 4))))
+ ((re-search-forward "\\([^a-z]\\)\\([adfjmnos][acepou][bcglnprtvy]\\)\\([-a-z \t_]*\\)\\([0-9][0-9]?\\)"
+ (save-excursion (end-of-line) (point)) t)
+ (format "%2d-%3s"
+ (string-to-int (buffer-substring
+ (match-beginning 4)
+ (match-end 4)))
+ (buffer-substring
+ (match-beginning 2) (match-end 2))))
+ (t "??????"))))
+ " "
+ (save-excursion
+ (if (not (re-search-forward "^From:[ \t]*" nil t))
+ " "
+ (let* ((from (mail-strip-quoted-names
+ (buffer-substring
+ (1- (point))
+ (progn (end-of-line)
+ (skip-chars-backward " \t")
+ (point)))))
+ len mch lo)
+ (if (string-match (concat "^"
+ (regexp-quote (user-login-name))
+ "\\($\\|@\\)")
+ from)
+ (save-excursion
+ (goto-char (point-min))
+ (if (not (re-search-forward "^To:[ \t]*" nil t))
+ nil
+ (setq from
+ (concat "to: "
+ (mail-strip-quoted-names
+ (buffer-substring
+ (point)
+ (progn (end-of-line)
+ (skip-chars-backward " \t")
+ (point)))))))))
+ (setq len (length from))
+ (setq mch (string-match "[@%]" from))
+ (format "%25s"
+ (if (or (not mch) (<= len 25))
+ (substring from (max 0 (- len 25)))
+ (substring from
+ (setq lo (cond ((< (- mch 9) 0) 0)
+ ((< len (+ mch 16))
+ (- len 25))
+ (t (- mch 9))))
+ (min len (+ lo 25))))))))
+ " #"
+ (if (re-search-forward "^Subject:" nil t)
+ (progn (skip-chars-forward " \t")
+ (buffer-substring (point)
+ (progn (end-of-line)
+ (point))))
+ (re-search-forward "[\n][\n]+" nil t)
+ (buffer-substring (point) (progn (end-of-line) (point))))
+ "\n"))
+
+(defun rmail-summary-next-all (&optional number)
+ (interactive "p")
+ (forward-line (if number number 1))
+ (rmail-summary-goto-msg))
+
+(defun rmail-summary-previous-all (&optional number)
+ (interactive "p")
+ (forward-line (- (if number number 1)))
+ (rmail-summary-goto-msg))
+
+(defun rmail-summary-next-msg (&optional number)
+ (interactive "p")
+ (forward-line 0)
+ (and (> number 0) (forward-line 1))
+ (let ((count (if (< number 0) (- number) number))
+ (search (if (> number 0) 're-search-forward 're-search-backward))
+ end)
+ (while (and (> count 0) (funcall search "^.....[^D]" nil t))
+ (setq count (1- count)))
+ (rmail-summary-goto-msg)))
+
+(defun rmail-summary-previous-msg (&optional number)
+ (interactive "p")
+ (rmail-summary-next-msg (- (if number number 1))))
+
+(defun rmail-summary-delete-forward ()
+ (interactive)
+ (let (end)
+ (rmail-summary-goto-msg)
+ (pop-to-buffer rmail-buffer)
+ (rmail-delete-message)
+ (pop-to-buffer rmail-summary-buffer)
+ (let ((buffer-read-only nil))
+ (skip-chars-forward " ")
+ (skip-chars-forward "[0-9]")
+ (delete-char 1)
+ (insert "D"))
+ (rmail-summary-next-msg 1)))
+
+(defun rmail-summary-undelete ()
+ (interactive)
+ (let ((buffer-read-only nil))
+ (end-of-line)
+ (cond ((re-search-backward "\\(^ *[0-9]*\\)\\(D\\)" nil t)
+ (replace-match "\\1 ")
+ (rmail-summary-goto-msg)
+ (pop-to-buffer rmail-buffer)
+ (and (rmail-message-deleted-p rmail-current-message)
+ (rmail-undelete-previous-message))
+ (pop-to-buffer rmail-summary-buffer))
+ (t
+ (rmail-summary-goto-msg)))))
+
+;; Rmail Summary mode is suitable only for specially formatted data.
+(put 'rmail-summary-mode 'mode-class 'special)
+
+(defun rmail-summary-mode ()
+ "Major mode in effect in Rmail summary buffer.
+A subset of the Rmail mode commands are supported in this mode.
+As commands are issued in the summary buffer the corresponding
+mail message is displayed in the rmail buffer.
+
+n Move to next undeleted message, or arg messages.
+p Move to previous undeleted message, or arg messages.
+C-n Move to next, or forward arg messages.
+C-p Move to previous, or previous arg messages.
+j Jump to the message at the cursor location.
+d Delete the message at the cursor location and move to next message.
+u Undelete this or previous deleted message.
+q Quit Rmail.
+x Exit and kill the summary window.
+space Scroll message in other window forward.
+delete Scroll message backward.
+
+Entering this mode calls value of hook variable rmail-summary-mode-hook."
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'rmail-buffer)
+ (make-local-variable 'rmail-total-messages)
+ (setq major-mode 'rmail-summary-mode)
+ (setq mode-name "RMAIL Summary")
+ (use-local-map rmail-summary-mode-map)
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (set-syntax-table text-mode-syntax-table)
+ (run-hooks 'rmail-summary-mode-hook))
+
+(defun rmail-summary-goto-msg (&optional n nowarn)
+ (interactive "P")
+ (if (consp n) (setq n (prefix-numeric-value n)))
+ (if (eobp) (forward-line -1))
+ (beginning-of-line)
+ (let ((buf rmail-buffer)
+ (cur (point))
+ (curmsg (string-to-int
+ (buffer-substring (point)
+ (min (point-max) (+ 5 (point)))))))
+ (if (not n)
+ (setq n curmsg)
+ (if (< n 1)
+ (progn (message "No preceding message")
+ (setq n 1)))
+ (if (> n rmail-total-messages)
+ (progn (message "No following message")
+ (goto-char (point-max))
+ (rmail-summary-goto-msg)))
+ (goto-char (point-min))
+ (if (not (re-search-forward (concat "^ *" (int-to-string n)) nil t))
+ (progn (or nowarn (message "Message %d not found" n))
+ (setq n curmsg)
+ (goto-char cur))))
+ (beginning-of-line)
+ (skip-chars-forward " ")
+ (skip-chars-forward "0-9")
+ (save-excursion (if (= (following-char) ?-)
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert " "))))
+ (beginning-of-line)
+ (pop-to-buffer buf)
+ (rmail-show-message n)
+ (pop-to-buffer rmail-summary-buffer)))
+
+(defvar rmail-summary-mode-map nil)
+
+(if rmail-summary-mode-map
+ nil
+ (setq rmail-summary-mode-map (make-keymap))
+ (suppress-keymap rmail-summary-mode-map)
+ (define-key rmail-summary-mode-map "j" 'rmail-summary-goto-msg)
+ (define-key rmail-summary-mode-map "n" 'rmail-summary-next-msg)
+ (define-key rmail-summary-mode-map "p" 'rmail-summary-previous-msg)
+ (define-key rmail-summary-mode-map "\C-n" 'rmail-summary-next-all)
+ (define-key rmail-summary-mode-map "\C-p" 'rmail-summary-previous-all)
+ (define-key rmail-summary-mode-map " " 'rmail-summary-scroll-msg-up)
+ (define-key rmail-summary-mode-map "q" 'rmail-summary-quit)
+ (define-key rmail-summary-mode-map "u" 'rmail-summary-undelete)
+ (define-key rmail-summary-mode-map "x" 'rmail-summary-exit)
+ (define-key rmail-summary-mode-map "\177" 'rmail-summary-scroll-msg-down)
+ (define-key rmail-summary-mode-map "d" 'rmail-summary-delete-forward))
+
+(defun rmail-summary-scroll-msg-up (&optional dist)
+ "Scroll other window forward."
+ (interactive "P")
+ (let ((window (selected-window))
+ (new-window (display-buffer rmail-buffer)))
+ (unwind-protect
+ (progn
+ (select-window new-window)
+ (scroll-up dist))
+ (select-window window))))
+
+(defun rmail-summary-scroll-msg-down (&optional dist)
+ "Scroll other window backward."
+ (interactive "P")
+ (let ((window (selected-window))
+ (new-window (display-buffer rmail-buffer)))
+ (unwind-protect
+ (progn
+ (select-window new-window)
+ (scroll-down dist))
+ (select-window window))))
+
+(defun rmail-summary-quit ()
+ "Quit out of rmail and rmail summary."
+ (interactive)
+ (rmail-summary-exit)
+ (rmail-quit))
+
+(defun rmail-summary-exit ()
+ "Exit rmail summary, remaining within rmail."
+ (interactive)
+ (bury-buffer (current-buffer))
+ (if (get-buffer-window rmail-buffer)
+ ;; Select the window with rmail in it, then delete this window.
+ (select-window (prog1
+ (get-buffer-window rmail-buffer)
+ (delete-window (selected-window))))
+ ;; Switch to the rmail buffer in this window.
+ (switch-to-buffer rmail-buffer)))
--- /dev/null
+;;; USENET news reader for gnu emacs
+;; Copyright (C) 1985, 1986, 1987 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.
+
+;; Created Sun Mar 10,1985 at 21:35:01 ads and sundar@hernes.ai.mit.edu
+;; Should do the point pdl stuff sometime
+;; finito except pdl.... Sat Mar 16,1985 at 06:43:44
+;; lets keep the summary stuff out until we get it working ..
+;; sundar@hermes.ai.mit.edu Wed Apr 10,1985 at 16:32:06
+;; hack slash maim. mly@prep.ai.mit.edu Thu 18 Apr, 1985 06:11:14
+;; modified to correct reentrance bug, to not bother with groups that
+;; received no new traffic since last read completely, to find out
+;; what traffic a group has available much more quickly when
+;; possible, to do some completing reads for group names - should
+;; be much faster...
+;; KING@KESTREL.arpa, Thu Mar 13 09:03:28 1986
+;; made news-{next,previous}-group skip groups with no new messages; and
+;; added checking for unsubscribed groups to news-add-news-group
+;; tower@prep.ai.mit.edu Jul 18 1986
+;; bound rmail-output to C-o; and changed header-field commands binding to
+;; agree with the new C-c C-f usage in sendmail
+;; tower@prep Sep 3 1986
+;; added news-rotate-buffer-body
+;; tower@prep Oct 17 1986
+;; made messages more user friendly, cleanuped news-inews
+;; move posting and mail code to new file rnewpost.el
+;; tower@prep Oct 29 1986
+;; added caesar-region, rename news-caesar-buffer-body, hacked accordingly
+;; tower@prep Nov 21 1986
+;; added (provide 'rnews) tower@prep 22 Apr 87
+(provide 'rnews)
+(require 'mail-utils)
+
+(autoload 'rmail-output "rmailout"
+ "Append this message to Unix mail file named FILE-NAME."
+ t)
+
+(autoload 'news-reply "rnewspost"
+ "Compose and post a reply to the current article on USENET.
+While composing the reply, use \\[mail-yank-original] to yank the original
+message into it."
+ t)
+
+(autoload 'news-mail-other-window "rnewspost"
+ "Send mail in another window.
+While composing the message, use \\[mail-yank-original] to yank the
+original message into it."
+ t)
+
+(autoload 'news-post-news "rnewspost"
+ "Begin editing a new USENET news article to be posted."
+ t)
+
+(autoload 'news-mail-reply "rnewspost"
+ "Mail a reply to the author of the current article.
+While composing the reply, use \\[mail-yank-original] to yank the original
+message into it."
+ t)
+
+(defvar rmail-last-file (expand-file-name "~/mbox.news"))
+
+;Now in paths.el.
+;(defvar news-path "/usr/spool/news/"
+; "The root directory below which all news files are stored.")
+
+(defvar news-startup-file "$HOME/.newsrc" "Contains ~/.newsrc")
+(defvar news-certification-file "$HOME/.news-dates" "Contains ~/.news-dates")
+
+;; random headers that we decide to ignore.
+(defvar news-ignored-headers
+ "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:"
+ "All random fields within the header of a message.")
+
+(defvar news-mode-map nil)
+(defvar news-read-first-time-p t)
+;; Contains the (dotified) news groups of which you are a member.
+(defvar news-user-group-list nil)
+
+(defvar news-current-news-group nil)
+(defvar news-current-group-begin nil)
+(defvar news-current-group-end nil)
+(defvar news-current-certifications nil
+ "An assoc list of a group name and the time at which it is
+known that the group had no new traffic")
+(defvar news-current-certifiable nil
+ "The time when the directory we are now working on was written")
+
+(defvar news-message-filter nil
+ "User specifiable filter function that will be called during
+formatting of the news file")
+
+;(defvar news-mode-group-string "Starting-Up"
+; "Mode line group name info is held in this variable")
+(defvar news-list-of-files nil
+ "Global variable in which we store the list of files
+associated with the current newsgroup")
+(defvar news-list-of-files-possibly-bogus nil
+ "variable indicating we only are guessing at which files are available.
+Not currently used.")
+
+;; association list in which we store lists of the form
+;; (pointified-group-name (first last old-last))
+(defvar news-group-article-assoc nil)
+
+(defvar news-current-message-number 0 "Displayed Article Number")
+(defvar news-total-current-group 0 "Total no of messages in group")
+
+(defvar news-unsubscribe-groups ())
+(defvar news-point-pdl () "List of visited news messages.")
+(defvar news-no-jumps-p t)
+(defvar news-buffer () "Buffer into which news files are read.")
+
+(defmacro news-push (item ref)
+ (list 'setq ref (list 'cons item ref)))
+
+(defmacro news-cadr (x) (list 'car (list 'cdr x)))
+(defmacro news-cdar (x) (list 'cdr (list 'car x)))
+(defmacro news-caddr (x) (list 'car (list 'cdr (list 'cdr x))))
+(defmacro news-cadar (x) (list 'car (list 'cdr (list 'car x))))
+(defmacro news-caadr (x) (list 'car (list 'car (list 'cdr x))))
+(defmacro news-cdadr (x) (list 'cdr (list 'car (list 'cdr x))))
+
+(defmacro news-wins (pfx index)
+ (` (file-exists-p (concat (, pfx) "/" (int-to-string (, index))))))
+
+(defvar news-max-plausible-gap 2
+ "* In an rnews directory, the maximum possible gap size.
+A gap is a sequence of missing messages between two messages that exist.
+An empty file does not contribute to a gap -- it ends one.")
+
+(defun news-find-first-and-last (prefix base)
+ (and (news-wins prefix base)
+ (cons (news-find-first-or-last prefix base -1)
+ (news-find-first-or-last prefix base 1))))
+
+(defmacro news-/ (a1 a2)
+;; a form of / that guarantees that (/ -1 2) = 0
+ (if (zerop (/ -1 2))
+ (` (/ (, a1) (, a2)))
+ (` (if (< (, a1) 0)
+ (- (/ (- (, a1)) (, a2)))
+ (/ (, a1) (, a2))))))
+
+(defun news-find-first-or-last (pfx base dirn)
+ ;; first use powers of two to find a plausible ceiling
+ (let ((original-dir dirn))
+ (while (news-wins pfx (+ base dirn))
+ (setq dirn (* dirn 2)))
+ (setq dirn (news-/ dirn 2))
+ ;; Then use a binary search to find the high water mark
+ (let ((offset (news-/ dirn 2)))
+ (while (/= offset 0)
+ (if (news-wins pfx (+ base dirn offset))
+ (setq dirn (+ dirn offset)))
+ (setq offset (news-/ offset 2))))
+ ;; If this high-water mark is bogus, recurse.
+ (let ((offset (* news-max-plausible-gap original-dir)))
+ (while (and (/= offset 0) (not (news-wins pfx (+ base dirn offset))))
+ (setq offset (- offset original-dir)))
+ (if (= offset 0)
+ (+ base dirn)
+ (news-find-first-or-last pfx (+ base dirn offset) original-dir)))))
+
+(defun rnews ()
+"Read USENET news for groups for which you are a member and add or
+delete groups.
+You can reply to articles posted and send articles to any group.
+
+Type \\[describe-mode] once reading news to get a list of rnews commands."
+ (interactive)
+ (let ((last-buffer (buffer-name)))
+ (make-local-variable 'rmail-last-file)
+ (switch-to-buffer (setq news-buffer (get-buffer-create "*news*")))
+ (news-mode)
+ (setq news-buffer-save last-buffer)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq buffer-read-only t)
+ (set-buffer-modified-p t)
+ (sit-for 0)
+ (message "Getting new USENET news...")
+ (news-set-mode-line)
+ (news-get-certifications)
+ (news-get-new-news)))
+
+(defun news-group-certification (group)
+ (cdr-safe (assoc group news-current-certifications)))
+
+
+(defun news-set-current-certifiable ()
+ ;; Record the date that corresponds to the directory you are about to check
+ (let ((file (concat news-path
+ (string-subst-char ?/ ?. news-current-news-group))))
+ (setq news-current-certifiable
+ (nth 5 (file-attributes
+ (or (file-symlink-p file) file))))))
+
+(defun news-get-certifications ()
+ ;; Read the certified-read file from last session
+ (save-excursion
+ (save-window-excursion
+ (setq news-current-certifications
+ (car-safe
+ (condition-case var
+ (let*
+ ((file (substitute-in-file-name news-certification-file))
+ (buf (find-file-noselect file)))
+ (and (file-exists-p file)
+ (progn
+ (switch-to-buffer buf 'norecord)
+ (unwind-protect
+ (read-from-string (buffer-string))
+ (kill-buffer buf)))))
+ (error nil)))))))
+
+(defun news-write-certifications ()
+ ;; Write a certification file.
+ ;; This is an assoc list of group names with doubletons that represent
+ ;; mod times of the directory when group is read completely.
+ (save-excursion
+ (save-window-excursion
+ (with-output-to-temp-buffer
+ "*CeRtIfIcAtIoNs*"
+ (print news-current-certifications))
+ (let ((buf (get-buffer "*CeRtIfIcAtIoNs*")))
+ (switch-to-buffer buf)
+ (write-file (substitute-in-file-name news-certification-file))
+ (kill-buffer buf)))))
+
+(defun news-set-current-group-certification ()
+ (let ((cgc (assoc news-current-news-group news-current-certifications)))
+ (if cgc (setcdr cgc news-current-certifiable)
+ (news-push (cons news-current-news-group news-current-certifiable)
+ news-current-certifications))))
+
+(defun news-set-minor-modes ()
+ "Creates a minor mode list that has group name, total articles,
+and attribute for current article."
+ (setq news-minor-modes (list (cons 'foo
+ (concat news-current-message-number
+ "/"
+ news-total-current-group
+ (news-get-attribute-string)))))
+ ;; Detect Emacs versions 18.16 and up, which display
+ ;; directly from news-minor-modes by using a list for mode-name.
+ (or (boundp 'minor-mode-alist)
+ (setq minor-modes news-minor-modes)))
+
+(defun news-set-message-counters ()
+ "Scan through current news-groups filelist to figure out how many messages
+are there. Set counters for use with minor mode display."
+ (if (null news-list-of-files)
+ (setq news-current-message-number 0)))
+
+(if news-mode-map
+ nil
+ (setq news-mode-map (make-keymap))
+ (suppress-keymap news-mode-map)
+ (define-key news-mode-map "." 'beginning-of-buffer)
+ (define-key news-mode-map " " 'scroll-up)
+ (define-key news-mode-map "\177" 'scroll-down)
+ (define-key news-mode-map "n" 'news-next-message)
+ (define-key news-mode-map "c" 'news-make-link-to-message)
+ (define-key news-mode-map "p" 'news-previous-message)
+ (define-key news-mode-map "j" 'news-goto-message)
+ (define-key news-mode-map "q" 'news-exit)
+ (define-key news-mode-map "e" 'news-exit)
+ (define-key news-mode-map "\ej" 'news-goto-news-group)
+ (define-key news-mode-map "\en" 'news-next-group)
+ (define-key news-mode-map "\ep" 'news-previous-group)
+ (define-key news-mode-map "l" 'news-list-news-groups)
+ (define-key news-mode-map "?" 'describe-mode)
+ (define-key news-mode-map "g" 'news-get-new-news)
+ (define-key news-mode-map "f" 'news-reply)
+ (define-key news-mode-map "m" 'news-mail-other-window)
+ (define-key news-mode-map "a" 'news-post-news)
+ (define-key news-mode-map "r" 'news-mail-reply)
+ (define-key news-mode-map "o" 'news-save-item-in-file)
+ (define-key news-mode-map "\C-o" 'rmail-output)
+ (define-key news-mode-map "t" 'news-show-all-headers)
+ (define-key news-mode-map "x" 'news-force-update)
+ (define-key news-mode-map "A" 'news-add-news-group)
+ (define-key news-mode-map "u" 'news-unsubscribe-current-group)
+ (define-key news-mode-map "U" 'news-unsubscribe-group)
+ (define-key news-mode-map "\C-c\C-r" 'news-caesar-buffer-body))
+
+(defun news-mode ()
+ "News Mode is used by M-x rnews for reading USENET Newsgroups articles.
+New readers can find additional help in newsgroup: news.announce.newusers .
+All normal editing commands are turned off.
+Instead, these commands are available:
+
+. move point to front of this news article (same as Meta-<).
+Space scroll to next screen of this news article.
+Delete scroll down previous page of this news article.
+n move to next news article, possibly next group.
+p move to previous news article, possibly previous group.
+j jump to news article specified by numeric position.
+M-j jump to news group.
+M-n goto next news group.
+M-p goto previous news group.
+l list all the news groups with current status.
+? print this help message.
+C-c C-r caesar rotate all letters by 13 places in the article's body (rot13).
+g get new USENET news.
+f post a reply article to USENET.
+a post an original news article.
+A add a newsgroup.
+o save the current article in the named file (append if file exists).
+C-o output this message to a Unix-format mail file (append it).
+c \"copy\" (actually link) current or prefix-arg msg to file.
+ warning: target directory and message file must be on same device
+ (UNIX magic)
+t show all the headers this news article originally had.
+q quit reading news after updating .newsrc file.
+e exit updating .newsrc file.
+m mail a news article. Same as C-x 4 m.
+x update last message seen to be the current message.
+r mail a reply to this news article. Like m but initializes some fields.
+u unsubscribe from current newsgroup.
+U unsubscribe from specified newsgroup."
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'news-read-first-time-p)
+ (setq news-read-first-time-p t)
+ (make-local-variable 'news-current-news-group)
+; (setq news-current-news-group "??")
+ (make-local-variable 'news-current-group-begin)
+ (setq news-current-group-begin 0)
+ (make-local-variable 'news-current-message-number)
+ (setq news-current-message-number 0)
+ (make-local-variable 'news-total-current-group)
+ (make-local-variable 'news-buffer-save)
+ (make-local-variable 'version-control)
+ (setq version-control 'never)
+ (make-local-variable 'news-point-pdl)
+; This breaks it. I don't have time to figure out why. -- RMS
+; (make-local-variable 'news-group-article-assoc)
+ (setq major-mode 'news-mode)
+ (if (boundp 'minor-mode-alist)
+ ;; Emacs versions 18.16 and up.
+ (setq mode-name '("NEWS" news-minor-modes))
+ ;; Earlier versions display minor-modes via a special mechanism.
+ (setq mode-name "NEWS"))
+ (news-set-mode-line)
+ (set-syntax-table text-mode-syntax-table)
+ (use-local-map news-mode-map)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (run-hooks 'news-mode-hook))
+
+(defun string-subst-char (new old string)
+ (let (index)
+ (setq old (regexp-quote (char-to-string old))
+ string (substring string 0))
+ (while (setq index (string-match old string))
+ (aset string index new)))
+ string)
+
+;; update read message number
+(defmacro news-update-message-read (ngroup nno)
+ (list 'setcar
+ (list 'news-cdadr
+ (list 'assoc ngroup 'news-group-article-assoc))
+ nno))
+
+(defun news-parse-range (number-string)
+ "Parse string representing range of numbers of he form <a>-<b>
+to a list (a . b)"
+ (let ((n (string-match "-" number-string)))
+ (if n
+ (cons (string-to-int (substring number-string 0 n))
+ (string-to-int (substring number-string (1+ n))))
+ (setq n (string-to-int number-string))
+ (cons n n))))
+
+;(defun is-in (elt lis)
+; (catch 'foo
+; (while lis
+; (if (equal (car lis) elt)
+; (throw 'foo t)
+; (setq lis (cdr lis))))))
+
+(defun news-get-new-news ()
+ "Get new USENET news, if there is any for the current user."
+ (interactive)
+ (if (not (null news-user-group-list))
+ (news-update-newsrc-file))
+ (setq news-group-article-assoc ())
+ (setq news-user-group-list ())
+ (message "Looking up %s file..." news-startup-file)
+ (let ((file (substitute-in-file-name news-startup-file))
+ (temp-user-groups ()))
+ (save-excursion
+ (let ((newsrcbuf (find-file-noselect file))
+ start end endofline tem)
+ (set-buffer newsrcbuf)
+ (goto-char 0)
+ (while (search-forward ": " nil t)
+ (setq end (point))
+ (beginning-of-line)
+ (setq start (point))
+ (end-of-line)
+ (setq endofline (point))
+ (setq tem (buffer-substring start (- end 2)))
+ (let ((range (news-parse-range
+ (buffer-substring end endofline))))
+ (if (assoc tem news-group-article-assoc)
+ (message "You are subscribed twice to %s; I ignore second"
+ tem)
+ (setq temp-user-groups (cons tem temp-user-groups)
+ news-group-article-assoc
+ (cons (list tem (list (car range)
+ (cdr range)
+ (cdr range)))
+ news-group-article-assoc)))))
+ (kill-buffer newsrcbuf)))
+ (setq temp-user-groups (nreverse temp-user-groups))
+ (message "Prefrobnicating...")
+ (switch-to-buffer news-buffer)
+ (setq news-user-group-list temp-user-groups)
+ (while (and temp-user-groups
+ (not (news-read-files-into-buffer
+ (car temp-user-groups) nil)))
+ (setq temp-user-groups (cdr temp-user-groups)))
+ (if (null temp-user-groups)
+ (message "No news is good news.")
+ (message ""))))
+
+(defun news-list-news-groups ()
+ "Display all the news groups to which you belong."
+ (interactive)
+ (with-output-to-temp-buffer "*Newsgroups*"
+ (save-excursion
+ (set-buffer standard-output)
+ (insert
+ "News Group Msg No. News Group Msg No.\n")
+ (insert
+ "------------------------- -------------------------\n")
+ (let ((temp news-user-group-list)
+ (flag nil))
+ (while temp
+ (let ((item (assoc (car temp) news-group-article-assoc)))
+ (insert (car item))
+ (indent-to (if flag 52 20))
+ (insert (int-to-string (news-cadr (news-cadr item))))
+ (if flag
+ (insert "\n")
+ (indent-to 33))
+ (setq temp (cdr temp) flag (not flag))))))))
+
+;; Mode line hack
+(defun news-set-mode-line ()
+ "Set mode line string to something useful."
+ (setq mode-line-process
+ (concat " "
+ (if (integerp news-current-message-number)
+ (int-to-string news-current-message-number)
+ "??")
+ "/"
+ (if (integerp news-current-group-end)
+ (int-to-string news-current-group-end)
+ news-current-group-end)))
+ (setq mode-line-buffer-identification
+ (concat "NEWS: "
+ news-current-news-group
+ ;; Enough spaces to pad group name to 17 positions.
+ (substring " "
+ 0 (max 0 (- 17 (length news-current-news-group))))))
+ (set-buffer-modified-p t)
+ (sit-for 0))
+
+(defun news-goto-news-group (gp)
+ "Takes a string and goes to that news group."
+ (interactive (list (completing-read "NewsGroup: "
+ news-group-article-assoc)))
+ (message "Jumping to news group %s..." gp)
+ (news-select-news-group gp)
+ (message "Jumping to news group %s... done." gp))
+
+(defun news-select-news-group (gp)
+ (let ((grp (assoc gp news-group-article-assoc)))
+ (if (null grp)
+ (error "Group not subscribed to in file %s." news-startup-file)
+ (progn
+ (news-update-message-read news-current-news-group
+ (news-cdar news-point-pdl))
+ (news-read-files-into-buffer (car grp) nil)
+ (news-set-mode-line)))))
+
+(defun news-goto-message (arg)
+ "Goes to the article ARG in current newsgroup."
+ (interactive "p")
+ (if (null current-prefix-arg)
+ (setq arg (read-no-blanks-input "Go to article: " "")))
+ (news-select-message arg))
+
+(defun news-select-message (arg)
+ (if (stringp arg) (setq arg (string-to-int arg)))
+ (let ((file (concat news-path
+ (string-subst-char ?/ ?. news-current-news-group)
+ "/" arg)))
+ (if (file-exists-p file)
+ (let ((buffer-read-only ()))
+ (if (= arg
+ (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files))
+ 0))
+ (setcdr (car news-point-pdl) arg))
+ (setq news-current-message-number arg)
+ (news-read-in-file file)
+ (news-set-mode-line))
+ (error "Article %d nonexistent" arg))))
+
+(defun news-force-update ()
+ "updates the position of last article read in the current news group"
+ (interactive)
+ (setcdr (car news-point-pdl) news-current-message-number)
+ (message "Updated to %d" news-current-message-number))
+
+(defun news-next-message (arg)
+ "Move ARG messages forward within one newsgroup.
+Negative ARG moves backward.
+If ARG is 1 or -1, moves to next or previous newsgroup if at end."
+ (interactive "p")
+ (let ((no (+ arg news-current-message-number)))
+ (if (or (< no news-current-group-begin)
+ (> no news-current-group-end))
+ (cond ((= arg 1)
+ (news-set-current-group-certification)
+ (news-next-group))
+ ((= arg -1)
+ (news-previous-group))
+ (t (error "Article out of range")))
+ (let ((plist (news-get-motion-lists
+ news-current-message-number
+ news-list-of-files)))
+ (if (< arg 0)
+ (news-select-message (nth (1- (- arg)) (car (cdr plist))))
+ (news-select-message (nth (1- arg) (car plist))))))))
+
+(defun news-previous-message (arg)
+ "Move ARG messages backward in current newsgroup.
+With no arg or arg of 1, move one message
+and move to previous newsgroup if at beginning.
+A negative ARG means move forward."
+ (interactive "p")
+ (news-next-message (- arg)))
+
+(defun news-move-to-group (arg)
+ "Given arg move forward or backward to a new newsgroup."
+ (let ((cg news-current-news-group))
+ (let ((plist (news-get-motion-lists cg news-user-group-list))
+ ngrp)
+ (if (< arg 0)
+ (or (setq ngrp (nth (1- (- arg)) (news-cadr plist)))
+ (error "No previous news groups"))
+ (or (setq ngrp (nth arg (car plist)))
+ (error "No more news groups")))
+ (news-select-news-group ngrp))))
+
+(defun news-next-group ()
+ "Moves to the next user group."
+ (interactive)
+; (message "Moving to next group...")
+ (news-move-to-group 0)
+ (while (null news-list-of-files)
+ (news-move-to-group 0)))
+; (message "Moving to next group... done.")
+
+(defun news-previous-group ()
+ "Moves to the previous user group."
+ (interactive)
+; (message "Moving to previous group...")
+ (news-move-to-group -1)
+ (while (null news-list-of-files)
+ (news-move-to-group -1)))
+; (message "Moving to previous group... done.")
+
+(defun news-get-motion-lists (arg listy)
+ "Given a msgnumber/group this will return a list of two lists;
+one for moving forward and one for moving backward."
+ (let ((temp listy)
+ (result ()))
+ (catch 'out
+ (while temp
+ (if (equal (car temp) arg)
+ (throw 'out (cons (cdr temp) (list result)))
+ (setq result (nconc (list (car temp)) result))
+ (setq temp (cdr temp)))))))
+
+;; miscellaneous io routines
+(defun news-read-in-file (filename)
+ (erase-buffer)
+ (let ((start (point)))
+ (insert-file-contents filename)
+ (news-convert-format)
+ (goto-char start)
+ (forward-line 1)
+ (if (eobp)
+ (message "(Empty file?)")
+ (goto-char start))))
+
+(defun news-convert-format ()
+ (save-excursion
+ (save-restriction
+ (let* ((start (point))
+ (end (condition-case ()
+ (progn (search-forward "\n\n") (point))
+ (error nil)))
+ has-from has-date)
+ (cond (end
+ (narrow-to-region start end)
+ (goto-char start)
+ (setq has-from (search-forward "\nFrom:" nil t))
+ (cond ((and (not has-from) has-date)
+ (goto-char start)
+ (search-forward "\nDate:")
+ (beginning-of-line)
+ (kill-line) (kill-line)))
+ (news-delete-headers start)
+ (goto-char start)))))))
+
+(defun news-show-all-headers ()
+ "Redisplay current news item with all original headers"
+ (interactive)
+ (let (news-ignored-headers
+ (buffer-read-only ()))
+ (erase-buffer)
+ (news-set-mode-line)
+ (news-read-in-file
+ (concat news-path
+ (string-subst-char ?/ ?. news-current-news-group)
+ "/" (int-to-string news-current-message-number)))))
+
+(defun news-delete-headers (pos)
+ (goto-char pos)
+ (and (stringp news-ignored-headers)
+ (while (re-search-forward news-ignored-headers nil t)
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (re-search-forward "\n[^ \t]")
+ (forward-char -1)
+ (point))))))
+
+(defun news-exit ()
+ "Quit news reading session and update the .newsrc file."
+ (interactive)
+ (if (y-or-n-p "Do you really wanna quit reading news ? ")
+ (progn (message "Updating %s..." news-startup-file)
+ (news-update-newsrc-file)
+ (news-write-certifications)
+ (message "Updating %s... done" news-startup-file)
+ (message "Now do some real work")
+ (and (fboundp 'bury-buffer) (bury-buffer (current-buffer)))
+ (switch-to-buffer news-buffer-save)
+ (setq news-user-group-list ()))
+ (message "")))
+
+(defun news-update-newsrc-file ()
+ "Updates the .newsrc file in the users home dir."
+ (let ((newsrcbuf (find-file-noselect
+ (substitute-in-file-name news-startup-file)))
+ (tem news-user-group-list)
+ group)
+ (save-excursion
+ (if (not (null news-current-news-group))
+ (news-update-message-read news-current-news-group
+ (news-cdar news-point-pdl)))
+ (switch-to-buffer newsrcbuf)
+ (while tem
+ (setq group (assoc (car tem)
+ news-group-article-assoc))
+ (if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group)))
+ nil
+ (goto-char 0)
+ (if (search-forward (concat (car group) ": ") nil t)
+ (kill-line nil)
+ (insert (car group) ": \n") (backward-char 1))
+ (insert (int-to-string (car (news-cadr group))) "-"
+ (int-to-string (news-cadr (news-cadr group)))))
+ (setq tem (cdr tem)))
+ (while news-unsubscribe-groups
+ (setq group (assoc (car news-unsubscribe-groups)
+ news-group-article-assoc))
+ (goto-char 0)
+ (if (search-forward (concat (car group) ": ") nil t)
+ (progn
+ (backward-char 2)
+ (kill-line nil)
+ (insert "! " (int-to-string (car (news-cadr group)))
+ "-" (int-to-string (news-cadr (news-cadr group))))))
+ (setq news-unsubscribe-groups (cdr news-unsubscribe-groups)))
+ (save-buffer)
+ (kill-buffer (current-buffer)))))
+
+
+(defun news-unsubscribe-group (group)
+ "Removes you from newgroup GROUP."
+ (interactive (list (completing-read "Unsubscribe from group: "
+ news-group-article-assoc)))
+ (news-unsubscribe-internal group))
+
+(defun news-unsubscribe-current-group ()
+ "Removes you from the newsgroup you are now reading."
+ (interactive)
+ (if (y-or-n-p "Do you really want to unsubscribe from this group ? ")
+ (news-unsubscribe-internal news-current-news-group)))
+
+(defun news-unsubscribe-internal (group)
+ (let ((tem (assoc group news-group-article-assoc)))
+ (if tem
+ (progn
+ (setq news-unsubscribe-groups (cons group news-unsubscribe-groups))
+ (news-update-message-read group (news-cdar news-point-pdl))
+ (if (equal group news-current-news-group)
+ (news-next-group))
+ (message ""))
+ (error "Not subscribed to group: %s" group))))
+
+(defun news-save-item-in-file (file)
+ "Save the current article that is being read by appending to a file."
+ (interactive "FSave item in file: ")
+ (append-to-file (point-min) (point-max) file))
+
+(defun news-get-pruned-list-of-files (gp-list end-file-no)
+ "Given a news group it finds all files in the news group.
+The arg must be in slashified format.
+Using ls was found to be too slow in a previous version."
+ (let
+ ((answer
+ (and
+ (not (and end-file-no
+ (equal (news-set-current-certifiable)
+ (news-group-certification gp-list))
+ (setq news-list-of-files nil
+ news-list-of-files-possibly-bogus t)))
+ (let* ((file-directory (concat news-path
+ (string-subst-char ?/ ?. gp-list)))
+ tem
+ (last-winner
+ (and end-file-no
+ (news-wins file-directory end-file-no)
+ (news-find-first-or-last file-directory end-file-no 1))))
+ (setq news-list-of-files-possibly-bogus t news-list-of-files nil)
+ (if last-winner
+ (progn
+ (setq news-list-of-files-possibly-bogus t
+ news-current-group-end last-winner)
+ (while (> last-winner end-file-no)
+ (news-push last-winner news-list-of-files)
+ (setq last-winner (1- last-winner)))
+ news-list-of-files)
+ (if (or (not (file-directory-p file-directory))
+ (not (file-readable-p file-directory)))
+ nil
+ (setq news-list-of-files
+ (condition-case error
+ (directory-files file-directory)
+ (file-error
+ (if (string= (nth 2 error) "permission denied")
+ (message "Newsgroup %s is read-protected"
+ gp-list)
+ (signal 'file-error (cdr error)))
+ nil)))
+ (setq tem news-list-of-files)
+ (while tem
+ (if (or (not (string-match "^[0-9]*$" (car tem)))
+ ;; dont get confused by directories that look like numbers
+ (file-directory-p
+ (concat file-directory "/" (car tem)))
+ (<= (string-to-int (car tem)) end-file-no))
+ (setq news-list-of-files
+ (delq (car tem) news-list-of-files)))
+ (setq tem (cdr tem)))
+ (if (null news-list-of-files)
+ (progn (setq news-current-group-end 0)
+ nil)
+ (setq news-list-of-files
+ (mapcar 'string-to-int news-list-of-files))
+ (setq news-list-of-files (sort news-list-of-files '<))
+ (setq news-current-group-end
+ (elt news-list-of-files
+ (1- (length news-list-of-files))))
+ news-list-of-files)))))))
+ (or answer (progn (news-set-current-group-certification) nil))))
+
+(defun news-read-files-into-buffer (group reversep)
+ (let* ((files-start-end (news-cadr (assoc group news-group-article-assoc)))
+ (start-file-no (car files-start-end))
+ (end-file-no (news-cadr files-start-end))
+ (buffer-read-only nil))
+ (setq news-current-news-group group)
+ (setq news-current-message-number nil)
+ (setq news-current-group-end nil)
+ (news-set-mode-line)
+ (news-get-pruned-list-of-files group end-file-no)
+ (news-set-mode-line)
+ ;; @@ should be a lot smarter than this if we have to move
+ ;; @@ around correctly.
+ (setq news-point-pdl (list (cons (car files-start-end)
+ (news-cadr files-start-end))))
+ (if (null news-list-of-files)
+ (progn (erase-buffer)
+ (setq news-current-group-end end-file-no)
+ (setq news-current-group-begin end-file-no)
+ (setq news-current-message-number end-file-no)
+ (news-set-mode-line)
+; (message "No new articles in " group " group.")
+ nil)
+ (setq news-current-group-begin (car news-list-of-files))
+ (if reversep
+ (setq news-current-message-number news-current-group-end)
+ (if (> (car news-list-of-files) end-file-no)
+ (setcdr (car news-point-pdl) (car news-list-of-files)))
+ (setq news-current-message-number news-current-group-begin))
+ (news-set-message-counters)
+ (news-set-mode-line)
+ (news-read-in-file (concat news-path
+ (string-subst-char ?/ ?. group)
+ "/"
+ (int-to-string
+ news-current-message-number)))
+ (news-set-message-counters)
+ (news-set-mode-line)
+ t)))
+
+(defun news-add-news-group (gp)
+ "Resubscribe to or add a USENET news group named GROUP (a string)."
+; @@ (completing-read ...)
+; @@ could be based on news library file ../active (slightly facist)
+; @@ or (expensive to compute) all directories under the news spool directory
+ (interactive "sAdd news group: ")
+ (let ((file-dir (concat news-path (string-subst-char ?/ ?. gp))))
+ (save-excursion
+ (if (null (assoc gp news-group-article-assoc))
+ (let ((newsrcbuf (find-file-noselect
+ (substitute-in-file-name news-startup-file))))
+ (if (file-directory-p file-dir)
+ (progn
+ (switch-to-buffer newsrcbuf)
+ (goto-char 0)
+ (if (search-forward (concat gp "! ") nil t)
+ (progn
+ (message "Re-subscribing to group %s." gp)
+ ;;@@ news-unsubscribe-groups isn't being used
+ ;;(setq news-unsubscribe-groups
+ ;; (delq gp news-unsubscribe-groups))
+ (backward-char 2)
+ (delete-char 1)
+ (insert ":"))
+ (progn
+ (message
+ "Added %s to your list of newsgroups." gp)
+ (end-of-buffer)
+ (insert gp ": 1-1\n")))
+ (search-backward gp nil t)
+ (let (start end endofline tem)
+ (search-forward ": " nil t)
+ (setq end (point))
+ (beginning-of-line)
+ (setq start (point))
+ (end-of-line)
+ (setq endofline (point))
+ (setq tem (buffer-substring start (- end 2)))
+ (let ((range (news-parse-range
+ (buffer-substring end endofline))))
+ (setq news-group-article-assoc
+ (cons (list tem (list (car range)
+ (cdr range)
+ (cdr range)))
+ news-group-article-assoc))))
+ (save-buffer)
+ (kill-buffer (current-buffer)))
+ (message "Newsgroup %s doesn't exist." gp)))
+ (message "Already subscribed to group %s." gp)))))
+
+(defun news-make-link-to-message (number newname)
+ "Forges a link to an rnews message numbered number (current if no arg)
+Good for hanging on to a message that might or might not be
+automatically deleted."
+ (interactive "P
+FName to link to message: ")
+ (add-name-to-file
+ (concat news-path
+ (string-subst-char ?/ ?. news-current-news-group)
+ "/" (if number
+ (prefix-numeric-value number)
+ news-current-message-number))
+ newname))
+
+;;; caesar-region written by phr@prep.ai.mit.edu Nov 86
+;;; modified by tower@prep Nov 86
+(defun caesar-region (&optional n)
+ "Caesar rotation of region by N, default 13, for decrypting netnews."
+ (interactive (if current-prefix-arg ; Was there a prefix arg?
+ (list (prefix-numeric-value current-prefix-arg))
+ (list nil)))
+ (cond ((not (numberp n)) (setq n 13))
+ ((< n 0) (setq n (- 26 (% (- n) 26))))
+ (t (setq n (% n 26)))) ;canonicalize N
+ (if (not (zerop n)) ; no action needed for a rot of 0
+ (progn
+ (if (or (not (boundp 'caesar-translate-table))
+ (/= (aref caesar-translate-table ?a) (+ ?a n)))
+ (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
+ (message "Building caesar-translate-table...")
+ (setq caesar-translate-table (make-vector 256 0))
+ (while (< i 256)
+ (aset caesar-translate-table i i)
+ (setq i (1+ i)))
+ (setq lower (concat lower lower) upper (upcase lower) i 0)
+ (while (< i 26)
+ (aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
+ (aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
+ (setq i (1+ i)))
+ (message "Building caesar-translate-table... done")))
+ (let ((from (region-beginning))
+ (to (region-end))
+ (i 0) str len)
+ (setq str (buffer-substring from to))
+ (setq len (length str))
+ (while (< i len)
+ (aset str i (aref caesar-translate-table (aref str i)))
+ (setq i (1+ i)))
+ (goto-char from)
+ (kill-region from to)
+ (insert str)))))
+
+;;; news-caesar-buffer-body written by paul@media-lab.mit.edu Wed Oct 1, 1986
+;;; hacked further by tower@prep.ai.mit.edu
+(defun news-caesar-buffer-body (&optional rotnum)
+ "Caesar rotates all letters in the current buffer by 13 places.
+Used to encode/decode possibly offensive messages (commonly in net.jokes).
+With prefix arg, specifies the number of places to rotate each letter forward.
+Mail and USENET news headers are not rotated."
+ (interactive (if current-prefix-arg ; Was there a prefix arg?
+ (list (prefix-numeric-value current-prefix-arg))
+ (list nil)))
+ (save-excursion
+ (let ((buffer-status buffer-read-only))
+ (setq buffer-read-only nil)
+ ;; setup the region
+ (set-mark (if (progn (goto-char (point-min))
+ (search-forward
+ (concat "\n"
+ (if (equal major-mode 'news-mode)
+ ""
+ mail-header-separator)
+ "\n") nil t))
+ (point)
+ (point-min)))
+ (goto-char (point-max))
+ (caesar-region rotnum)
+ (setq buffer-read-only buffer-status))))
--- /dev/null
+;;; USENET news poster/mailer for GNU Emacs
+;; Copyright (C) 1985, 1986, 1987 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.
+
+;; moved posting and mail code from rnews.el
+;; tower@prep.ai.mit.edu Wed Oct 29 1986
+;; brought posting code almost up to the revision of RFC 850 for News 2.11
+;; - couldn't see handling the special meaning of the Keyword: poster
+;; - not worth the code space to support the old A news Title: (which
+;; Subject: replaced) and Article-I.D.: (which Message-ID: replaced)
+;; tower@prep Nov 86
+;; changed C-c C-r key-binding due to rename of news-caesar-buffer-body
+;; tower@prep 21 Nov 86
+;; added (require 'rnews) tower@prep 22 Apr 87
+;; restricted call of news-show-all-headers in news-post-news & news-reply
+;; tower@prep 28 Apr 87
+;; commented out Posting-Front-End to save USENET bytes tower@prep Jul 31 87
+;; commented out -n and -t args in news-inews tower@prep 15 Oct 87
+(require 'sendmail)
+(require 'rnews)
+
+;Now in paths.el.
+;(defvar news-inews-program "inews"
+; "Function to post news.")
+
+;; Replying and posting news items are done by these functions.
+;; imported from rmail and modified to work with rnews ...
+;; Mon Mar 25,1985 at 03:07:04 ads@mit-hermes.
+;; this is done so that rnews can operate independently from rmail.el and
+;; sendmail and dosen't have to autoload these functions.
+;;
+;;; >> Nuked by Mly to autoload those functions again, as the duplication of
+;;; >> code was making maintenance too difficult.
+
+(defvar news-reply-mode-map () "Mode map used by news-reply.")
+
+(or news-reply-mode-map
+ (progn
+ (setq news-reply-mode-map (make-keymap))
+ (define-key news-reply-mode-map "\C-c?" 'describe-mode)
+ (define-key news-reply-mode-map "\C-c\C-f\C-d" 'news-reply-distribution)
+ (define-key news-reply-mode-map "\C-c\C-f\C-k" 'news-reply-keywords)
+ (define-key news-reply-mode-map "\C-c\C-f\C-n" 'news-reply-newsgroups)
+ (define-key news-reply-mode-map "\C-c\C-f\C-f" 'news-reply-followup-to)
+ (define-key news-reply-mode-map "\C-c\C-f\C-s" 'mail-subject)
+ (define-key news-reply-mode-map "\C-c\C-f\C-a" 'news-reply-summary)
+ (define-key news-reply-mode-map "\C-c\C-r" 'news-caesar-buffer-body)
+ (define-key news-reply-mode-map "\C-c\C-w" 'news-reply-signature)
+ (define-key news-reply-mode-map "\C-c\C-y" 'news-reply-yank-original)
+ (define-key news-reply-mode-map "\C-c\C-q" 'mail-fill-yanked-message)
+ (define-key news-reply-mode-map "\C-c\C-c" 'news-inews)
+ (define-key news-reply-mode-map "\C-c\C-s" 'news-inews)))
+
+(defun news-reply-mode ()
+ "Major mode for editing news to be posted on USENET.
+First-time posters are asked to please read the articles in newsgroup:
+ news.announce.newusers .
+Like Text Mode but with these additional commands:
+
+C-c C-s news-inews (post the message) C-c C-c news-inews
+C-c C-f move to a header field (and create it if there isn't):
+ C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj:
+ C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords:
+ C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary:
+C-c C-y news-reply-yank-original (insert current message, in NEWS).
+C-c C-q mail-fill-yanked-message (fill what was yanked).
+C-c C-r caesar rotate all letters by 13 places in the article's body (rot13)."
+ (interactive)
+ ;; require...
+ (or (fboundp 'mail-setup) (load "sendmail"))
+ (kill-all-local-variables)
+ (make-local-variable 'mail-reply-buffer)
+ (setq mail-reply-buffer nil)
+ (set-syntax-table text-mode-syntax-table)
+ (use-local-map news-reply-mode-map)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (setq major-mode 'news-reply-mode)
+ (setq mode-name "News")
+ (make-local-variable 'paragraph-separate)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^" mail-header-separator "$\\|"
+ paragraph-start))
+ (setq paragraph-separate (concat "^" mail-header-separator "$\\|"
+ paragraph-separate))
+ (run-hooks 'text-mode-hook 'news-reply-mode-hook))
+
+(defvar news-reply-yank-from
+ "Save From: field for news-reply-yank-original."
+ "")
+
+(defvar news-reply-yank-message-id
+ "Save Message-Id: field for news-reply-yank-original."
+ "")
+
+(defun news-reply-yank-original (arg)
+ "Insert the message being replied to, if any (in rmail).
+Puts point before the text and mark after.
+Indents each nonblank line ARG spaces (default 3).
+Just \\[universal-argument] as argument means don't indent
+and don't delete any header fields."
+ (interactive "P")
+ (mail-yank-original arg)
+ (exchange-point-and-mark)
+ (insert "In article " news-reply-yank-message-id
+ " " news-reply-yank-from " writes:\n\n"))
+
+(defun news-reply-newsgroups ()
+ "Move point to end of Newsgroups: field.
+RFC 850 constrains the Newsgroups: field to be a comma separated list of valid
+newsgroups names at your site:
+Newsgroups: news.misc,comp.misc,rec.misc"
+ (interactive)
+ (expand-abbrev)
+ (goto-char (point-min))
+ (mail-position-on-field "Newsgroups"))
+
+(defun news-reply-followup-to ()
+ "Move point to end of Followup-To: field. Create the field if none.
+One usually requests followups to only one newsgroup.
+RFC 850 constrains the Followup-To: field to be a comma separated list of valid
+newsgroups names at your site, that are also in the Newsgroups: field:
+Newsgroups: news.misc,comp.misc,rec.misc,misc.misc,soc.misc
+Followup-To: news.misc,comp.misc,rec.misc"
+ (interactive)
+ (expand-abbrev)
+ (or (mail-position-on-field "Followup-To" t)
+ (progn (mail-position-on-field "newsgroups")
+ (insert "\nFollowup-To: ")))
+ ;; @@ could do a completing read based on the Newsgroups: field to
+ ;; @@ fill in the Followup-To: field
+)
+
+(defun news-reply-distribution ()
+ "Move point to end of Distribution: optional field.
+Create the field if none. Without this field the posting goes to all of
+USENET. The field is used to restrict the posting to parts of USENET."
+ (interactive)
+ (expand-abbrev)
+ (mail-position-on-field "Distribution")
+ ;; @@could do a completing read based on the news library file:
+ ;; @@ ../distributions to fill in the field.
+ )
+
+(defun news-reply-keywords ()
+ "Move point to end of Keywords: optional field. Create the field if none.
+Used as an aid to the news reader, it can contain a few, well selected keywords
+identifying the message."
+ (interactive)
+ (expand-abbrev)
+ (mail-position-on-field "Keywords"))
+
+(defun news-reply-summary ()
+ "Move point to end of Summary: optional field. Create the field if none.
+Used as an aid to the news reader, it can contain a succinct
+summary (abstract) of the message."
+ (interactive)
+ (expand-abbrev)
+ (mail-position-on-field "Summary"))
+
+(defun news-reply-signature ()
+ "The inews program appends ~/.signature automatically."
+ (interactive)
+ (message "~/.signature will be appended automatically."))
+
+(defun news-setup (to subject in-reply-to newsgroups replybuffer)
+ "Setup the news reply or posting buffer with the proper headers and in
+news-reply-mode."
+ (setq mail-reply-buffer replybuffer)
+ (let ((mail-setup-hook nil))
+ (if (null to)
+ ;; this hack is needed so that inews wont be confused by
+ ;; the fcc: and bcc: fields
+ (let ((mail-self-blind nil)
+ (mail-archive-file-name nil))
+ (mail-setup to subject in-reply-to nil replybuffer)
+ (beginning-of-line)
+ (kill-line 1)
+ (goto-char (point-max)))
+ (mail-setup to subject in-reply-to nil replybuffer))
+ ;;;(mail-position-on-field "Posting-Front-End")
+ ;;;(insert (emacs-version))
+ (goto-char (point-max))
+ (if (let ((case-fold-search t))
+ (re-search-backward "^Subject:" (point-min) t))
+ (progn (beginning-of-line)
+ (insert "Newsgroups: " (or newsgroups "") "\n")
+ (if (not newsgroups)
+ (backward-char 1)
+ (goto-char (point-max)))))
+ (run-hooks 'news-setup-hook)))
+
+(defun news-inews ()
+ "Send a news message using inews."
+ (interactive)
+ (let* (newsgroups subject
+ (case-fold-search nil))
+ (save-excursion
+ (save-restriction
+ (goto-char (point-min))
+ (search-forward (concat "\n" mail-header-separator "\n"))
+ (narrow-to-region (point-min) (point))
+ (setq newsgroups (mail-fetch-field "newsgroups")
+ subject (mail-fetch-field "subject")))
+ (widen)
+ (goto-char (point-min))
+ (run-hooks 'news-inews-hook)
+ (goto-char (point-min))
+ (search-forward (concat "\n" mail-header-separator "\n"))
+ (replace-match "\n\n")
+ (goto-char (point-max))
+ ;; require a newline at the end for inews to append .signature to
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (message "Posting to USENET...")
+ (call-process-region (point-min) (point-max)
+ news-inews-program nil 0 nil
+ "-h") ; take all header lines!
+ ;@@ setting of subject and newsgroups still needed?
+ ;"-t" subject
+ ;"-n" newsgroups
+ (message "Posting to USENET... done")
+ (goto-char (point-min)) ;restore internal header separator
+ (search-forward "\n\n")
+ (replace-match (concat "\n" mail-header-separator "\n"))
+ (set-buffer-modified-p nil))
+ (and (fboundp 'bury-buffer) (bury-buffer))))
+
+;@@ shares some code with news-reply and news-post-news
+(defun news-mail-reply ()
+ "Mail a reply to the author of the current article.
+While composing the reply, use \\[news-reply-yank-original] to yank the
+original message into it."
+ (interactive)
+ (let (from cc subject date to reply-to
+ (buffer (current-buffer)))
+ (save-restriction
+ (narrow-to-region (point-min) (progn (goto-line (point-min))
+ (search-forward "\n\n")
+ (- (point) 1)))
+ (setq from (mail-fetch-field "from")
+ subject (mail-fetch-field "subject")
+ reply-to (mail-fetch-field "reply-to")
+ date (mail-fetch-field "date"))
+ (setq to from)
+ (pop-to-buffer "*mail*")
+ (mail nil
+ (if reply-to reply-to to)
+ subject
+ (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (concat (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of "
+ date))
+ nil
+ buffer))))
+
+;@@ the guts of news-reply and news-post-news should be combined. -tower
+(defun news-reply ()
+ "Compose and post a reply (aka a followup) to the current article on USENET.
+While composing the followup, use \\[news-reply-yank-original] to yank the
+original message into it."
+ (interactive)
+ (if (y-or-n-p "Are you sure you want to followup to all of USENET? ")
+ (let (from cc subject date to followup-to newsgroups message-of
+ references distribution message-id
+ (buffer (current-buffer)))
+ (save-restriction
+ (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of
+ ;@@ of article file
+ (equal major-mode 'news-mode) ;@@ if rmail-mode,
+ ;@@ should show full headers
+ (progn
+ (news-show-all-headers) ;@@ should save/restore header state,
+ ;@@ but rnews.el lacks support
+ (narrow-to-region (point-min) (progn (goto-char (point-min))
+ (search-forward "\n\n")
+ (- (point) 1)))))
+ (setq from (mail-fetch-field "from")
+ news-reply-yank-from from
+ ;; @@ not handling old Title: field
+ subject (mail-fetch-field "subject")
+ date (mail-fetch-field "date")
+ followup-to (mail-fetch-field "followup-to")
+ newsgroups (or followup-to
+ (mail-fetch-field "newsgroups"))
+ references (mail-fetch-field "references")
+ ;; @@ not handling old Article-I.D.: field
+ distribution (mail-fetch-field "distribution")
+ message-id (mail-fetch-field "message-id")
+ news-reply-yank-message-id message-id)
+ (pop-to-buffer "*post-news*")
+ (news-reply-mode)
+ (if (and (buffer-modified-p)
+ (not
+ (y-or-n-p "Unsent article being composed; erase it? ")))
+ ()
+ (progn
+ (erase-buffer)
+ (and subject
+ (progn (if (string-match "\\`Re: " subject)
+ (while (string-match "\\`Re: " subject)
+ (setq subject (substring subject 4))))
+ (setq subject (concat "Re: " subject))))
+ (and from
+ (progn
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (setq message-of
+ (concat
+ (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of "
+ date)))))
+ (news-setup
+ nil
+ subject
+ message-of
+ newsgroups
+ buffer)
+ (if followup-to
+ (progn (news-reply-followup-to)
+ (insert followup-to)))
+ (if distribution
+ (progn
+ (mail-position-on-field "Distribution")
+ (insert distribution)))
+ (mail-position-on-field "References")
+ (if references
+ (insert references))
+ (if (and references message-id)
+ (insert " "))
+ (if message-id
+ (insert message-id))
+ (goto-char (point-max))))))
+ (message "")))
+
+;@@ the guts of news-reply and news-post-news should be combined. -tower
+(defun news-post-news ()
+ "Begin editing a new USENET news article to be posted.
+Type \\[describe-mode] once editing the article to get a list of commands."
+ (interactive)
+ (if (y-or-n-p "Are you sure you want to post to all of USENET? ")
+ (let ((buffer (current-buffer)))
+ (save-restriction
+ (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of
+ ;@@ of article file
+ (equal major-mode 'news-mode) ;@@ if rmail-mode,
+ ;@@ should show full headers
+ (progn
+ (news-show-all-headers) ;@@ should save/restore header state,
+ ;@@ but rnews.el lacks support
+ (narrow-to-region (point-min) (progn (goto-char (point-min))
+ (search-forward "\n\n")
+ (- (point) 1)))))
+ (setq news-reply-yank-from (mail-fetch-field "from")
+ ;; @@ not handling old Article-I.D.: field
+ news-reply-yank-message-id (mail-fetch-field "message-id")))
+ (pop-to-buffer "*post-news*")
+ (news-reply-mode)
+ (if (and (buffer-modified-p)
+ (not (y-or-n-p "Unsent article being composed; erase it? ")))
+ () ;@@ not saving point from last time
+ (progn (erase-buffer)
+ (news-setup () () () () buffer))))
+ (message "")))
+
+(defun news-mail-other-window ()
+ "Send mail in another window.
+While composing the message, use \\[news-reply-yank-original] to yank the
+original message into it."
+ (interactive)
+ (mail-other-window nil nil nil nil nil (current-buffer)))
--- /dev/null
+;; Scheme mode, and its idiosyncratic commands.
+;; Copyright (C) 1986, 1987, 1988, 1990 Free Software Foundation, Inc.
+;; Adapted from Lisp mode by Bill Rozas, jinx@prep.
+
+;; 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.
+
+
+;; Initially a query replace of Lisp mode, except for the indentation
+;; of special forms. Probably the code should be merged at some point
+;; so that there is sharing between both libraries.
+
+;;; $Header: scheme.el,v 1.7 88/07/15 20:20:00 GMT cph Exp $
+
+(provide 'scheme)
+\f
+(defvar scheme-mode-syntax-table nil "")
+(if (not scheme-mode-syntax-table)
+ (let ((i 0))
+ (setq scheme-mode-syntax-table (make-syntax-table))
+ (set-syntax-table scheme-mode-syntax-table)
+
+ ;; Default is atom-constituent.
+ (while (< i 256)
+ (modify-syntax-entry i "_ ")
+ (setq i (1+ i)))
+
+ ;; Word components.
+ (setq i ?0)
+ (while (<= i ?9)
+ (modify-syntax-entry i "w ")
+ (setq i (1+ i)))
+ (setq i ?A)
+ (while (<= i ?Z)
+ (modify-syntax-entry i "w ")
+ (setq i (1+ i)))
+ (setq i ?a)
+ (while (<= i ?z)
+ (modify-syntax-entry i "w ")
+ (setq i (1+ i)))
+
+ ;; Whitespace
+ (modify-syntax-entry ?\t " ")
+ (modify-syntax-entry ?\n "> ")
+ (modify-syntax-entry ?\f " ")
+ (modify-syntax-entry ?\r " ")
+ (modify-syntax-entry ? " ")
+
+ ;; These characters are delimiters but otherwise undefined.
+ ;; Brackets and braces balance for editing convenience.
+ (modify-syntax-entry ?[ "(] ")
+ (modify-syntax-entry ?] ")[ ")
+ (modify-syntax-entry ?{ "(} ")
+ (modify-syntax-entry ?} "){ ")
+ (modify-syntax-entry ?\| " ")
+
+ ;; Other atom delimiters
+ (modify-syntax-entry ?\( "() ")
+ (modify-syntax-entry ?\) ")( ")
+ (modify-syntax-entry ?\; "< ")
+ (modify-syntax-entry ?\" "\" ")
+ (modify-syntax-entry ?' "' ")
+ (modify-syntax-entry ?` "' ")
+
+ ;; Special characters
+ (modify-syntax-entry ?, "' ")
+ (modify-syntax-entry ?@ "' ")
+ (modify-syntax-entry ?# "' ")
+ (modify-syntax-entry ?\\ "\\ ")))
+\f
+(defvar scheme-mode-abbrev-table nil "")
+(define-abbrev-table 'scheme-mode-abbrev-table ())
+
+(defun scheme-mode-variables ()
+ (set-syntax-table scheme-mode-syntax-table)
+ (setq local-abbrev-table scheme-mode-abbrev-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'scheme-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start ";")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip ";+[ \t]*")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'scheme-comment-indent)
+ (setq mode-line-process '("" scheme-mode-line-process)))
+
+(defvar scheme-mode-line-process "")
+
+(defun scheme-mode-commands (map)
+ (define-key map "\t" 'scheme-indent-line)
+ (define-key map "\177" 'backward-delete-char-untabify)
+ (define-key map "\e\C-q" 'scheme-indent-sexp))
+
+(defvar scheme-mode-map nil)
+(if (not scheme-mode-map)
+ (progn
+ (setq scheme-mode-map (make-sparse-keymap))
+ (scheme-mode-commands scheme-mode-map)))
+\f
+(defun scheme-mode ()
+ "Major mode for editing Scheme code.
+Editing commands are similar to those of lisp-mode.
+
+In addition, if an inferior Scheme process is running, some additional
+commands will be defined, for evaluating expressions and controlling
+the interpreter, and the state of the process will be displayed in the
+modeline of all Scheme buffers. The names of commands that interact
+with the Scheme process start with \"xscheme-\". For more information
+see the documentation for xscheme-interaction-mode.
+
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs. Semicolons start comments.
+\\{scheme-mode-map}
+Entry to this mode calls the value of scheme-mode-hook
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (scheme-mode-initialize)
+ (scheme-mode-variables)
+ (run-hooks 'scheme-mode-hook))
+
+(defun scheme-mode-initialize ()
+ (use-local-map scheme-mode-map)
+ (setq major-mode 'scheme-mode)
+ (setq mode-name "Scheme"))
+
+(defvar scheme-mit-dialect t
+ "If non-nil, scheme mode is specialized for MIT Scheme.
+Set this to nil if you normally use another dialect.")
+\f
+(defun scheme-comment-indent (&optional pos)
+ (save-excursion
+ (if pos (goto-char pos))
+ (cond ((looking-at ";;;") (current-column))
+ ((looking-at ";;")
+ (let ((tem (calculate-scheme-indent)))
+ (if (listp tem) (car tem) tem)))
+ (t
+ (skip-chars-backward " \t")
+ (max (if (bolp) 0 (1+ (current-column)))
+ comment-column)))))
+
+(defvar scheme-indent-offset nil "")
+(defvar scheme-indent-hook 'scheme-indent-hook "")
+
+(defun scheme-indent-line (&optional whole-exp)
+ "Indent current line as Scheme code.
+With argument, indent any additional lines of the same expression
+rigidly along with this one."
+ (interactive "P")
+ (let ((indent (calculate-scheme-indent)) shift-amt beg end
+ (pos (- (point-max) (point))))
+ (beginning-of-line)
+ (setq beg (point))
+ (skip-chars-forward " \t")
+ (if (looking-at "[ \t]*;;;")
+ ;; Don't alter indentation of a ;;; comment line.
+ nil
+ (if (listp indent) (setq indent (car indent)))
+ (setq shift-amt (- indent (current-column)))
+ (if (zerop shift-amt)
+ nil
+ (delete-region beg (point))
+ (indent-to indent))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ ;; If desired, shift remaining lines of expression the same amount.
+ (and whole-exp (not (zerop shift-amt))
+ (save-excursion
+ (goto-char beg)
+ (forward-sexp 1)
+ (setq end (point))
+ (goto-char beg)
+ (forward-line 1)
+ (setq beg (point))
+ (> end beg))
+ (indent-code-rigidly beg end shift-amt)))))
+\f
+(defun calculate-scheme-indent (&optional parse-start)
+ "Return appropriate indentation for current line as scheme code.
+In usual case returns an integer: the column to indent to.
+Can instead return a list, whose car is the column to indent to.
+This means that following lines at the same level of indentation
+should not necessarily be indented the same way.
+The second element of the list is the buffer position
+of the start of the containing expression."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point)) state paren-depth desired-indent (retry t)
+ last-sexp containing-sexp first-sexp-list-p)
+ (if parse-start
+ (goto-char parse-start)
+ (beginning-of-defun))
+ ;; Find outermost containing sexp
+ (while (< (point) indent-point)
+ (setq state (parse-partial-sexp (point) indent-point 0)))
+ ;; Find innermost containing sexp
+ (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
+ (setq retry nil)
+ (setq last-sexp (nth 2 state))
+ (setq containing-sexp (car (cdr state)))
+ ;; Position following last unclosed open.
+ (goto-char (1+ containing-sexp))
+ ;; Is there a complete sexp since then?
+ (if (and last-sexp (> last-sexp (point)))
+ ;; Yes, but is there a containing sexp after that?
+ (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
+ (if (setq retry (car (cdr peek))) (setq state peek))))
+ (if (not retry)
+ ;; Innermost containing sexp found
+ (progn
+ (goto-char (1+ containing-sexp))
+ (if (not last-sexp)
+ ;; indent-point immediately follows open paren.
+ ;; Don't call hook.
+ (setq desired-indent (current-column))
+ ;; Move to first sexp after containing open paren
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (setq first-sexp-list-p (looking-at "\\s("))
+ (cond
+ ((> (save-excursion (forward-line 1) (point))
+ last-sexp)
+ ;; Last sexp is on same line as containing sexp.
+ ;; It's almost certainly a function call.
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (if (/= (point) last-sexp)
+ ;; Indent beneath first argument or, if only one sexp
+ ;; on line, indent beneath that.
+ (progn (forward-sexp 1)
+ (parse-partial-sexp (point) last-sexp 0 t)))
+ (backward-prefix-chars))
+ (t
+ ;; Indent beneath first sexp on same line as last-sexp.
+ ;; Again, it's almost certainly a function call.
+ (goto-char last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (backward-prefix-chars)))))))
+ ;; If looking at a list, don't call hook.
+ (if first-sexp-list-p
+ (setq desired-indent (current-column)))
+ ;; Point is at the point to indent under unless we are inside a string.
+ ;; Call indentation hook except when overriden by scheme-indent-offset
+ ;; or if the desired indentation has already been computed.
+ (cond ((car (nthcdr 3 state))
+ ;; Inside a string, don't change indentation.
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (setq desired-indent (current-column)))
+ ((and (integerp scheme-indent-offset) containing-sexp)
+ ;; Indent by constant offset
+ (goto-char containing-sexp)
+ (setq desired-indent (+ scheme-indent-offset (current-column))))
+ ((not (or desired-indent
+ (and (boundp 'scheme-indent-hook)
+ scheme-indent-hook
+ (not retry)
+ (setq desired-indent
+ (funcall scheme-indent-hook
+ indent-point state)))))
+ ;; Use default indentation if not computed yet
+ (setq desired-indent (current-column))))
+ desired-indent)))
+\f
+(defun scheme-indent-hook (indent-point state)
+ (let ((normal-indent (current-column)))
+ (save-excursion
+ (goto-char (1+ (car (cdr state))))
+ (re-search-forward "\\sw\\|\\s_")
+ (if (/= (point) (car (cdr state)))
+ (let ((function (buffer-substring (progn (forward-char -1) (point))
+ (progn (forward-sexp 1) (point))))
+ method)
+ ;; Who cares about this, really?
+ ;(if (not (string-match "\\\\\\||" function)))
+ (setq function (downcase function))
+ (setq method (get (intern-soft function) 'scheme-indent-hook))
+ (cond ((integerp method)
+ (scheme-indent-specform method state indent-point))
+ (method
+ (funcall method state indent-point))
+ ((and (> (length function) 3)
+ (string-equal (substring function 0 3) "def"))
+ (scheme-indent-defform state indent-point))))))))
+
+(defvar scheme-body-indent 2 "")
+\f
+(defun scheme-indent-specform (count state indent-point)
+ (let ((containing-form-start (car (cdr state))) (i count)
+ body-indent containing-form-column)
+ ;; Move to the start of containing form, calculate indentation
+ ;; to use for non-distinguished forms (> count), and move past the
+ ;; function symbol. scheme-indent-hook guarantees that there is at
+ ;; least one word or symbol character following open paren of containing
+ ;; form.
+ (goto-char containing-form-start)
+ (setq containing-form-column (current-column))
+ (setq body-indent (+ scheme-body-indent containing-form-column))
+ (forward-char 1)
+ (forward-sexp 1)
+ ;; Now find the start of the last form.
+ (parse-partial-sexp (point) indent-point 1 t)
+ (while (and (< (point) indent-point)
+ (condition-case nil
+ (progn
+ (setq count (1- count))
+ (forward-sexp 1)
+ (parse-partial-sexp (point) indent-point 1 t))
+ (error nil))))
+ ;; Point is sitting on first character of last (or count) sexp.
+ (cond ((> count 0)
+ ;; A distinguished form. Use double scheme-body-indent.
+ (list (+ containing-form-column (* 2 scheme-body-indent))
+ containing-form-start))
+ ;; A non-distinguished form. Use body-indent if there are no
+ ;; distinguished forms and this is the first undistinguished
+ ;; form, or if this is the first undistinguished form and
+ ;; the preceding distinguished form has indentation at least
+ ;; as great as body-indent.
+ ((and (= count 0)
+ (or (= i 0)
+ (<= body-indent normal-indent)))
+ body-indent)
+ (t
+ normal-indent))))
+
+(defun scheme-indent-defform (state indent-point)
+ (goto-char (car (cdr state)))
+ (forward-line 1)
+ (if (> (point) (car (cdr (cdr state))))
+ (progn
+ (goto-char (car (cdr state)))
+ (+ scheme-body-indent (current-column)))))
+\f
+;;; Let is different in Scheme
+
+(defun would-be-symbol (string)
+ (not (string-equal (substring string 0 1) "(")))
+
+(defun next-sexp-as-string ()
+ ;; Assumes that protected by a save-excursion
+ (forward-sexp 1)
+ (let ((the-end (point)))
+ (backward-sexp 1)
+ (buffer-substring (point) the-end)))
+
+;; This is correct but too slow.
+;; The one below works almost always.
+;;(defun scheme-let-indent (state indent-point)
+;; (if (would-be-symbol (next-sexp-as-string))
+;; (scheme-indent-specform 2 state indent-point)
+;; (scheme-indent-specform 1 state indent-point)))
+
+(defun scheme-let-indent (state indent-point)
+ (skip-chars-forward " \t")
+ (if (looking-at "[a-zA-Z0-9+-*/?!@$%^&_:~]")
+ (scheme-indent-specform 2 state indent-point)
+ (scheme-indent-specform 1 state indent-point)))
+
+;; (put 'begin 'scheme-indent-hook 0), say, causes begin to be indented
+;; like defun if the first form is placed on the next line, otherwise
+;; it is indented like any other form (i.e. forms line up under first).
+
+(put 'begin 'scheme-indent-hook 0)
+(put 'case 'scheme-indent-hook 1)
+(put 'delay 'scheme-indent-hook 0)
+(put 'do 'scheme-indent-hook 2)
+(put 'lambda 'scheme-indent-hook 1)
+(put 'let 'scheme-indent-hook 'scheme-let-indent)
+(put 'let* 'scheme-indent-hook 1)
+(put 'letrec 'scheme-indent-hook 1)
+(put 'sequence 'scheme-indent-hook 0)
+
+(put 'call-with-input-file 'scheme-indent-hook 1)
+(put 'with-input-from-file 'scheme-indent-hook 1)
+(put 'with-input-from-port 'scheme-indent-hook 1)
+(put 'call-with-output-file 'scheme-indent-hook 1)
+(put 'with-output-to-file 'scheme-indent-hook 1)
+(put 'with-output-to-port 'scheme-indent-hook 1)
+\f
+;;;; MIT Scheme specific indentation.
+
+(if scheme-mit-dialect
+ (progn
+ (put 'fluid-let 'scheme-indent-hook 1)
+ (put 'in-package 'scheme-indent-hook 1)
+ (put 'let-syntax 'scheme-indent-hook 1)
+ (put 'local-declare 'scheme-indent-hook 1)
+ (put 'macro 'scheme-indent-hook 1)
+ (put 'make-environment 'scheme-indent-hook 0)
+ (put 'named-lambda 'scheme-indent-hook 1)
+ (put 'using-syntax 'scheme-indent-hook 1)
+
+ (put 'with-input-from-string 'scheme-indent-hook 1)
+ (put 'with-output-to-string 'scheme-indent-hook 0)
+ (put 'with-values 'scheme-indent-hook 1)
+
+ (put 'syntax-table-define 'scheme-indent-hook 2)
+ (put 'list-transform-positive 'scheme-indent-hook 1)
+ (put 'list-transform-negative 'scheme-indent-hook 1)
+ (put 'list-search-positive 'scheme-indent-hook 1)
+ (put 'list-search-negative 'scheme-indent-hook 1)
+
+ (put 'access-components 'scheme-indent-hook 1)
+ (put 'assignment-components 'scheme-indent-hook 1)
+ (put 'combination-components 'scheme-indent-hook 1)
+ (put 'comment-components 'scheme-indent-hook 1)
+ (put 'conditional-components 'scheme-indent-hook 1)
+ (put 'disjunction-components 'scheme-indent-hook 1)
+ (put 'declaration-components 'scheme-indent-hook 1)
+ (put 'definition-components 'scheme-indent-hook 1)
+ (put 'delay-components 'scheme-indent-hook 1)
+ (put 'in-package-components 'scheme-indent-hook 1)
+ (put 'lambda-components 'scheme-indent-hook 1)
+ (put 'lambda-components* 'scheme-indent-hook 1)
+ (put 'lambda-components** 'scheme-indent-hook 1)
+ (put 'open-block-components 'scheme-indent-hook 1)
+ (put 'pathname-components 'scheme-indent-hook 1)
+ (put 'procedure-components 'scheme-indent-hook 1)
+ (put 'sequence-components 'scheme-indent-hook 1)
+ (put 'unassigned\?-components 'scheme-indent-hook 1)
+ (put 'unbound\?-components 'scheme-indent-hook 1)
+ (put 'variable-components 'scheme-indent-hook 1)))
+\f
+(defun scheme-indent-sexp ()
+ "Indent each line of the list starting just after point."
+ (interactive)
+ (let ((indent-stack (list nil)) (next-depth 0) bol
+ outer-loop-done inner-loop-done state this-indent)
+ (save-excursion (forward-sexp 1))
+ (save-excursion
+ (setq outer-loop-done nil)
+ (while (not outer-loop-done)
+ (setq last-depth next-depth
+ innerloop-done nil)
+ (while (and (not innerloop-done)
+ (not (setq outer-loop-done (eobp))))
+ (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
+ nil nil state))
+ (setq next-depth (car state))
+ (if (car (nthcdr 4 state))
+ (progn (indent-for-comment)
+ (end-of-line)
+ (setcar (nthcdr 4 state) nil)))
+ (if (car (nthcdr 3 state))
+ (progn
+ (forward-line 1)
+ (setcar (nthcdr 5 state) nil))
+ (setq innerloop-done t)))
+ (if (setq outer-loop-done (<= next-depth 0))
+ nil
+ (while (> last-depth next-depth)
+ (setq indent-stack (cdr indent-stack)
+ last-depth (1- last-depth)))
+ (while (< last-depth next-depth)
+ (setq indent-stack (cons nil indent-stack)
+ last-depth (1+ last-depth)))
+ (forward-line 1)
+ (setq bol (point))
+ (skip-chars-forward " \t")
+ (if (or (eobp) (looking-at "[;\n]"))
+ nil
+ (if (and (car indent-stack)
+ (>= (car indent-stack) 0))
+ (setq this-indent (car indent-stack))
+ (let ((val (calculate-scheme-indent
+ (if (car indent-stack) (- (car indent-stack))))))
+ (if (integerp val)
+ (setcar indent-stack
+ (setq this-indent val))
+ (setcar indent-stack (- (car (cdr val))))
+ (setq this-indent (car val)))))
+ (if (/= (current-column) this-indent)
+ (progn (delete-region bol (point))
+ (indent-to this-indent)))))))))
--- /dev/null
+;; scribe mode, and its ideosyncratic commands.
+;; Copyright (C) 1985 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.
+
+
+(defvar scribe-mode-syntax-table nil
+ "Syntax table used while in scribe mode.")
+
+(defvar scribe-mode-abbrev-table nil
+ "Abbrev table used while in scribe mode.")
+
+(defvar scribe-fancy-paragraphs nil
+ "*Non-NIL makes Scribe mode use a different style of paragraph separation.")
+
+(defvar scribe-electric-quote nil
+ "*Non-NIL makes insert of double quote use `` or '' depending on context.")
+
+(defvar scribe-electric-parenthesis nil
+ "*Non-NIL makes parenthesis char ( (]}> ) automatically insert its close
+if typed after an @Command form.")
+
+(defconst scribe-open-parentheses "[({<"
+ "Open parenthesis characters for Scribe.")
+
+(defconst scribe-close-parentheses "])}>"
+ "Close parenthesis characters for Scribe. These should match up with
+scribe-open-parenthesis.")
+
+(if (null scribe-mode-syntax-table)
+ (let ((st (syntax-table)))
+ (unwind-protect
+ (progn
+ (setq scribe-mode-syntax-table (copy-syntax-table
+ text-mode-syntax-table))
+ (set-syntax-table scribe-mode-syntax-table)
+ (modify-syntax-entry ?\" " ")
+ (modify-syntax-entry ?\\ " ")
+ (modify-syntax-entry ?@ "w ")
+ (modify-syntax-entry ?< "(> ")
+ (modify-syntax-entry ?> ")< ")
+ (modify-syntax-entry ?[ "(] ")
+ (modify-syntax-entry ?] ")[ ")
+ (modify-syntax-entry ?{ "(} ")
+ (modify-syntax-entry ?} "){ ")
+ (modify-syntax-entry ?' "w "))
+ (set-syntax-table st))))
+
+(defvar scribe-mode-map nil)
+
+(if scribe-mode-map
+ nil
+ (setq scribe-mode-map (make-sparse-keymap))
+ (define-key scribe-mode-map "\t" 'scribe-tab)
+ (define-key scribe-mode-map "\e\t" 'tab-to-tab-stop)
+ (define-key scribe-mode-map "\es" 'center-line)
+ (define-key scribe-mode-map "\e}" 'up-list)
+ (define-key scribe-mode-map "\eS" 'center-paragraph)
+ (define-key scribe-mode-map "\"" 'scribe-insert-quote)
+ (define-key scribe-mode-map "(" 'scribe-parenthesis)
+ (define-key scribe-mode-map "[" 'scribe-parenthesis)
+ (define-key scribe-mode-map "{" 'scribe-parenthesis)
+ (define-key scribe-mode-map "<" 'scribe-parenthesis)
+ (define-key scribe-mode-map "\^cc" 'scribe-chapter)
+ (define-key scribe-mode-map "\^cS" 'scribe-section)
+ (define-key scribe-mode-map "\^cs" 'scribe-subsection)
+ (define-key scribe-mode-map "\^ce" 'scribe-insert-environment)
+ (define-key scribe-mode-map "\^c\^e" 'scribe-bracket-region-be)
+ (define-key scribe-mode-map "\^c[" 'scribe-begin)
+ (define-key scribe-mode-map "\^c]" 'scribe-end)
+ (define-key scribe-mode-map "\^ci" 'scribe-italicize-word)
+ (define-key scribe-mode-map "\^cb" 'scribe-bold-word)
+ (define-key scribe-mode-map "\^cu" 'scribe-underline-word))
+
+(defun scribe-mode ()
+ "Major mode for editing files of Scribe (a text formatter) source.
+Scribe-mode is similar text-mode, with a few extra commands added.
+\\{scribe-mode-map}
+
+Interesting variables:
+
+scribe-fancy-paragraphs
+ Non-nil makes Scribe mode use a different style of paragraph separation.
+
+scribe-electric-quote
+ Non-nil makes insert of double quote use `` or '' depending on context.
+
+scribe-electric-parenthesis
+ Non-nil makes an open-parenthesis char (one of `([<{')
+ automatically insert its close if typed after an @Command form."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map scribe-mode-map)
+ (setq mode-name "Scribe")
+ (setq major-mode 'scribe-mode)
+ (define-abbrev-table 'scribe-mode-abbrev-table ())
+ (setq local-abbrev-table scribe-mode-abbrev-table)
+ (make-local-variable 'comment-start)
+ (setq comment-start "@Comment[")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip (concat "@Comment[" scribe-open-parentheses "]"))
+ (make-local-variable 'comment-column)
+ (setq comment-column 0)
+ (make-local-variable 'comment-end)
+ (setq comment-end "]")
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "\\(^[\n\f]\\)\\|\\(^@\\w+["
+ scribe-open-parentheses
+ "].*["
+ scribe-close-parentheses
+ "]$\\)"))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate (if scribe-fancy-paragraphs
+ paragraph-start "^$"))
+ (make-local-variable 'compile-command)
+ (setq compile-command (concat "scribe " (buffer-file-name)))
+ (set-syntax-table scribe-mode-syntax-table)
+ (run-hooks 'text-mode-hook 'scribe-mode-hook))
+
+(defun scribe-tab ()
+ (interactive)
+ (insert "@\\"))
+
+;; This algorithm could probably be improved somewhat.
+;; Right now, it loses seriously...
+
+(defun scribe ()
+ "Run Scribe on the current buffer."
+ (interactive)
+ (call-interactively 'compile))
+
+(defun scribe-envelop-word (string count)
+ "Surround current word with Scribe construct @STRING[...]. COUNT
+specifies how many words to surround. A negative count means to skip
+backward."
+ (let ((spos (point)) (epos (point)) (ccoun 0) noparens)
+ (if (not (zerop count))
+ (progn (if (= (char-syntax (preceding-char)) ?w)
+ (forward-sexp (min -1 count)))
+ (setq spos (point))
+ (if (looking-at (concat "@\\w[" scribe-open-parentheses "]"))
+ (forward-char 2)
+ (goto-char epos)
+ (skip-chars-backward "\\W")
+ (forward-char -1))
+ (forward-sexp (max count 1))
+ (setq epos (point))))
+ (goto-char spos)
+ (while (and (< ccoun (length scribe-open-parentheses))
+ (save-excursion
+ (or (search-forward (char-to-string
+ (aref scribe-open-parentheses ccoun))
+ epos t)
+ (search-forward (char-to-string
+ (aref scribe-close-parentheses ccoun))
+ epos t)))
+ (setq ccoun (1+ ccoun))))
+ (if (>= ccoun (length scribe-open-parentheses))
+ (progn (goto-char epos)
+ (insert "@end(" string ")")
+ (goto-char spos)
+ (insert "@begin(" string ")"))
+ (goto-char epos)
+ (insert (aref scribe-close-parentheses ccoun))
+ (goto-char spos)
+ (insert "@" string (aref scribe-open-parentheses ccoun))
+ (goto-char epos)
+ (forward-char 3)
+ (skip-chars-forward scribe-close-parentheses))))
+
+(defun scribe-underline-word (count)
+ "Underline COUNT words around point by means of Scribe constructs."
+ (interactive "p")
+ (scribe-envelop-word "u" count))
+
+(defun scribe-bold-word (count)
+ "Boldface COUNT words around point by means of Scribe constructs."
+ (interactive "p")
+ (scribe-envelop-word "b" count))
+
+(defun scribe-italicize-word (count)
+ "Italicize COUNT words around point by means of Scribe constructs."
+ (interactive "p")
+ (scribe-envelop-word "i" count))
+
+(defun scribe-begin ()
+ (interactive)
+ (insert "\n")
+ (forward-char -1)
+ (scribe-envelop-word "Begin" 0)
+ (re-search-forward (concat "[" scribe-open-parentheses "]")))
+
+(defun scribe-end ()
+ (interactive)
+ (insert "\n")
+ (forward-char -1)
+ (scribe-envelop-word "End" 0)
+ (re-search-forward (concat "[" scribe-open-parentheses "]")))
+
+(defun scribe-chapter ()
+ (interactive)
+ (insert "\n")
+ (forward-char -1)
+ (scribe-envelop-word "Chapter" 0)
+ (re-search-forward (concat "[" scribe-open-parentheses "]")))
+
+(defun scribe-section ()
+ (interactive)
+ (insert "\n")
+ (forward-char -1)
+ (scribe-envelop-word "Section" 0)
+ (re-search-forward (concat "[" scribe-open-parentheses "]")))
+
+(defun scribe-subsection ()
+ (interactive)
+ (insert "\n")
+ (forward-char -1)
+ (scribe-envelop-word "SubSection" 0)
+ (re-search-forward (concat "[" scribe-open-parentheses "]")))
+
+(defun scribe-bracket-region-be (env min max)
+ (interactive "sEnvironment: \nr")
+ (save-excursion
+ (goto-char max)
+ (insert "@end(" env ")\n")
+ (goto-char min)
+ (insert "@begin(" env ")\n")))
+
+(defun scribe-insert-environment (env)
+ (interactive "sEnvironment: ")
+ (scribe-bracket-region-be env (point) (point))
+ (forward-line 1)
+ (insert ?\n)
+ (forward-char -1))
+
+(defun scribe-insert-quote (count)
+ "If scribe-electric-quote is non-NIL, insert ``, '' or \" according
+to preceding character. With numeric arg N, always insert N \" characters.
+Else just insert \"."
+ (interactive "P")
+ (if (or count (not scribe-electric-quote))
+ (self-insert-command (prefix-numeric-value count))
+ (let (lastfore lastback lastquote)
+ (insert
+ (cond
+ ((= (preceding-char) ?\\) ?\")
+ ((bobp) "``")
+ (t
+ (setq lastfore (save-excursion (and (search-backward
+ "``" (- (point) 1000) t)
+ (point)))
+ lastback (save-excursion (and (search-backward
+ "''" (- (point) 1000) t)
+ (point)))
+ lastquote (save-excursion (and (search-backward
+ "\"" (- (point) 100) t)
+ (point))))
+ (if (not lastquote)
+ (cond ((not lastfore) "``")
+ ((not lastback) "''")
+ ((> lastfore lastback) "''")
+ (t "``"))
+ (cond ((and (not lastback) (not lastfore)) "\"")
+ ((and lastback (not lastfore) (> lastquote lastback)) "\"")
+ ((and lastback (not lastfore) (> lastback lastquote)) "``")
+ ((and lastfore (not lastback) (> lastquote lastfore)) "\"")
+ ((and lastfore (not lastback) (> lastfore lastquote)) "''")
+ ((and (> lastquote lastfore) (> lastquote lastback)) "\"")
+ ((> lastfore lastback) "''")
+ (t "``")))))))))
+
+(defun scribe-parenthesis (count)
+ "If scribe-electric-parenthesis is non-NIL, insertion of an open-parenthesis
+character inserts the following close parenthesis character if the
+preceding text is of the form @Command."
+ (interactive "P")
+ (self-insert-command (prefix-numeric-value count))
+ (let (at-command paren-char point-save)
+ (if (or count (not scribe-electric-parenthesis))
+ nil
+ (save-excursion
+ (forward-char -1)
+ (setq point-save (point))
+ (skip-chars-backward (concat "^ \n\t\f" scribe-open-parentheses))
+ (setq at-command (and (equal (following-char) ?@)
+ (/= (point) (1- point-save)))))
+ (if (and at-command
+ (setq paren-char
+ (string-match (regexp-quote
+ (char-to-string (preceding-char)))
+ scribe-open-parentheses)))
+ (save-excursion
+ (insert (aref scribe-close-parentheses paren-char)))))))