diff options
| author | Jim Blandy | 1991-05-13 21:21:58 +0000 |
|---|---|---|
| committer | Jim Blandy | 1991-05-13 21:21:58 +0000 |
| commit | 2f790b20af84fdca382193f16a9fb116dd12777a (patch) | |
| tree | c55dbf33d2feae9a9ebd0d85d4676a88dcff3a32 | |
| parent | e2ab0aa6a12be39993899860046aa6b15e4cb9fc (diff) | |
| download | emacs-2f790b20af84fdca382193f16a9fb116dd12777a.tar.gz emacs-2f790b20af84fdca382193f16a9fb116dd12777a.zip | |
Initial revision
| -rw-r--r-- | lisp/cmuscheme.el | 430 | ||||
| -rw-r--r-- | lisp/dabbrev.el | 258 | ||||
| -rw-r--r-- | lisp/gnuspost.el | 672 | ||||
| -rw-r--r-- | lisp/progmodes/inf-lisp.el | 601 |
4 files changed, 1961 insertions, 0 deletions
diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el new file mode 100644 index 00000000000..a2f4d0e7d88 --- /dev/null +++ b/lisp/cmuscheme.el | |||
| @@ -0,0 +1,430 @@ | |||
| 1 | ;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el. | ||
| 2 | ;;; Copyright Olin Shivers (1988) | ||
| 3 | ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright | ||
| 4 | ;;; notice appearing here to the effect that you may use this code any | ||
| 5 | ;;; way you like, as long as you don't charge money for it, remove this | ||
| 6 | ;;; notice, or hold me liable for its results. | ||
| 7 | ;;; | ||
| 8 | ;;; This is a customisation of comint-mode (see comint.el) | ||
| 9 | ;;; | ||
| 10 | ;;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces | ||
| 11 | ;;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al.. | ||
| 12 | ;;; 8/88 | ||
| 13 | ;;; | ||
| 14 | ;;; Please send me bug reports, bug fixes, and extensions, so that I can | ||
| 15 | ;;; merge them into the master source. | ||
| 16 | ;;; | ||
| 17 | ;;; The changelog is at the end of this file. | ||
| 18 | ;;; | ||
| 19 | ;;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user | ||
| 20 | ;;; interface that communicates process state back to the superior emacs by | ||
| 21 | ;;; outputting special control sequences. The gnumacs package, xscheme.el, has | ||
| 22 | ;;; lots and lots of special purpose code to read these control sequences, and | ||
| 23 | ;;; so is very tightly integrated with the cscheme process. The cscheme | ||
| 24 | ;;; interrupt handler and debugger read single character commands in cbreak | ||
| 25 | ;;; mode; when this happens, xscheme.el switches to special keymaps that bind | ||
| 26 | ;;; the single letter command keys to emacs functions that directly send the | ||
| 27 | ;;; character to the scheme process. Cmuscheme mode does *not* provide this | ||
| 28 | ;;; functionality. If you are a cscheme user, you may prefer to use the | ||
| 29 | ;;; xscheme.el/cscheme -emacs interaction. | ||
| 30 | ;;; | ||
| 31 | ;;; Here's a summary of the pros and cons, as I see them. | ||
| 32 | ;;; xscheme: Tightly integrated with inferior cscheme process! A few commands | ||
| 33 | ;;; not in cmuscheme. But. Integration is a bit of a hack. Input | ||
| 34 | ;;; history only keeps the immediately prior input. Bizarre | ||
| 35 | ;;; keybindings. | ||
| 36 | ;;; | ||
| 37 | ;;; cmuscheme: Not tightly integrated with inferior cscheme process. But. | ||
| 38 | ;;; Carefully integrated functionality with the entire suite of | ||
| 39 | ;;; comint-derived CMU process modes. Keybindings reminiscent of | ||
| 40 | ;;; Zwei and Hemlock. Good input history. A few commands not in | ||
| 41 | ;;; xscheme. | ||
| 42 | ;;; | ||
| 43 | ;;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme | ||
| 44 | ;;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very* | ||
| 45 | ;;; Cscheme-specific; you must use cmuscheme.el. Interested parties are | ||
| 46 | ;;; invited to port xscheme functionality on top of comint mode... | ||
| 47 | |||
| 48 | ;; YOUR .EMACS FILE | ||
| 49 | ;;============================================================================= | ||
| 50 | ;; Some suggestions for your .emacs file. | ||
| 51 | ;; | ||
| 52 | ;; ; If cmuscheme lives in some non-standard directory, you must tell emacs | ||
| 53 | ;; ; where to get it. This may or may not be necessary. | ||
| 54 | ;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) | ||
| 55 | ;; | ||
| 56 | ;; ; Autoload run-scheme from file cmuscheme.el | ||
| 57 | ;; (autoload 'run-scheme "cmuscheme" | ||
| 58 | ;; "Run an inferior Scheme process." | ||
| 59 | ;; t) | ||
| 60 | ;; | ||
| 61 | ;; ; Files ending in ".scm" are Scheme source, | ||
| 62 | ;; ; so put their buffers in scheme-mode. | ||
| 63 | ;; (setq auto-mode-alist | ||
| 64 | ;; (cons '("\\.scm$" . scheme-mode) | ||
| 65 | ;; auto-mode-alist)) | ||
| 66 | ;; | ||
| 67 | ;; ; Define C-c t to run my favorite command in inferior scheme mode: | ||
| 68 | ;; (setq cmuscheme-load-hook | ||
| 69 | ;; '((lambda () (define-key inferior-scheme-mode-map "\C-ct" | ||
| 70 | ;; 'favorite-cmd)))) | ||
| 71 | ;;; | ||
| 72 | ;;; Unfortunately, scheme.el defines run-scheme to autoload from xscheme.el. | ||
| 73 | ;;; This will womp your declaration to autoload run-scheme from cmuscheme.el | ||
| 74 | ;;; if you haven't loaded cmuscheme in before scheme. Three fixes: | ||
| 75 | ;;; - Put the autoload on your scheme mode hook and in your .emacs toplevel: | ||
| 76 | ;;; (setq scheme-mode-hook | ||
| 77 | ;;; '((lambda () (autoload 'run-scheme "cmuscheme" | ||
| 78 | ;;; "Run an inferior Scheme" t)))) | ||
| 79 | ;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) | ||
| 80 | ;;; Now when scheme.el autoloads, it will restore the run-scheme autoload. | ||
| 81 | ;;; - Load cmuscheme.el in your .emacs: (load-library 'cmuscheme) | ||
| 82 | ;;; - Change autoload declaration in scheme.el to point to cmuscheme.el: | ||
| 83 | ;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) | ||
| 84 | ;;; *or* just delete the autoload declaration from scheme.el altogether, | ||
| 85 | ;;; which will allow the autoload in your .emacs to have its say. | ||
| 86 | |||
| 87 | (provide 'cmuscheme) | ||
| 88 | (require 'scheme) | ||
| 89 | (require 'comint) | ||
| 90 | |||
| 91 | ;;; INFERIOR SCHEME MODE STUFF | ||
| 92 | ;;;============================================================================ | ||
| 93 | |||
| 94 | (defvar inferior-scheme-mode-hook nil | ||
| 95 | "*Hook for customising inferior-scheme mode.") | ||
| 96 | (defvar inferior-scheme-mode-map nil) | ||
| 97 | |||
| 98 | (cond ((not inferior-scheme-mode-map) | ||
| 99 | (setq inferior-scheme-mode-map | ||
| 100 | (full-copy-sparse-keymap comint-mode-map)) | ||
| 101 | (define-key inferior-scheme-mode-map "\M-\C-x" ;gnu convention | ||
| 102 | 'scheme-send-definition) | ||
| 103 | (define-key inferior-scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp) | ||
| 104 | (define-key inferior-scheme-mode-map "\C-c\C-l" 'scheme-load-file) | ||
| 105 | (define-key inferior-scheme-mode-map "\C-c\C-k" 'scheme-compile-file) | ||
| 106 | (scheme-mode-commands inferior-scheme-mode-map))) | ||
| 107 | |||
| 108 | ;; Install the process communication commands in the scheme-mode keymap. | ||
| 109 | (define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention | ||
| 110 | (define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention | ||
| 111 | (define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition) | ||
| 112 | (define-key scheme-mode-map "\C-c\M-e" 'scheme-send-definition-and-go) | ||
| 113 | (define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region) | ||
| 114 | (define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go) | ||
| 115 | (define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition) | ||
| 116 | (define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) | ||
| 117 | (define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme) | ||
| 118 | (define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file) | ||
| 119 | (define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile" | ||
| 120 | |||
| 121 | (defun inferior-scheme-mode () | ||
| 122 | "Major mode for interacting with an inferior Scheme process. | ||
| 123 | |||
| 124 | The following commands are available: | ||
| 125 | \\{inferior-scheme-mode-map} | ||
| 126 | |||
| 127 | A Scheme process can be fired up with M-x run-scheme. | ||
| 128 | |||
| 129 | Customisation: Entry to this mode runs the hooks on comint-mode-hook and | ||
| 130 | inferior-scheme-mode-hook (in that order). | ||
| 131 | |||
| 132 | You can send text to the inferior Scheme process from other buffers containing | ||
| 133 | Scheme source. | ||
| 134 | switch-to-scheme switches the current buffer to the Scheme process buffer. | ||
| 135 | scheme-send-definition sends the current definition to the Scheme process. | ||
| 136 | scheme-compile-definition compiles the current definition. | ||
| 137 | scheme-send-region sends the current region to the Scheme process. | ||
| 138 | scheme-compile-region compiles the current region. | ||
| 139 | |||
| 140 | scheme-send-definition-and-go, scheme-compile-definition-and-go, | ||
| 141 | scheme-send-region-and-go, and scheme-compile-region-and-go | ||
| 142 | switch to the Scheme process buffer after sending their text. | ||
| 143 | For information on running multiple processes in multiple buffers, see | ||
| 144 | documentation for variable scheme-buffer. | ||
| 145 | |||
| 146 | Commands: | ||
| 147 | Return after the end of the process' output sends the text from the | ||
| 148 | end of process to point. | ||
| 149 | Return before the end of the process' output copies the sexp ending at point | ||
| 150 | to the end of the process' output, and sends it. | ||
| 151 | Delete converts tabs to spaces as it moves back. | ||
| 152 | Tab indents for Scheme; with argument, shifts rest | ||
| 153 | of expression rigidly with the current line. | ||
| 154 | C-M-q does Tab on each line starting within following expression. | ||
| 155 | Paragraphs are separated only by blank lines. Semicolons start comments. | ||
| 156 | If you accidentally suspend your process, use \\[comint-continue-subjob] | ||
| 157 | to continue it." | ||
| 158 | (interactive) | ||
| 159 | (comint-mode) | ||
| 160 | ;; Customise in inferior-scheme-mode-hook | ||
| 161 | (setq comint-prompt-regexp "^[^>]*>+ *") ; OK for cscheme, oaklisp, T,... | ||
| 162 | (scheme-mode-variables) | ||
| 163 | (setq major-mode 'inferior-scheme-mode) | ||
| 164 | (setq mode-name "Inferior Scheme") | ||
| 165 | (setq mode-line-process '(": %s")) | ||
| 166 | (use-local-map inferior-scheme-mode-map) | ||
| 167 | (setq comint-input-filter (function scheme-input-filter)) | ||
| 168 | (setq comint-input-sentinel (function ignore)) | ||
| 169 | (setq comint-get-old-input (function scheme-get-old-input)) | ||
| 170 | (run-hooks 'inferior-scheme-mode-hook)) | ||
| 171 | |||
| 172 | (defun scheme-input-filter (str) | ||
| 173 | "Don't save anything matching inferior-scheme-filter-regexp" | ||
| 174 | (not (string-match inferior-scheme-filter-regexp str))) | ||
| 175 | |||
| 176 | (defvar inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" | ||
| 177 | "*Input matching this regexp are not saved on the history list. | ||
| 178 | Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters.") | ||
| 179 | |||
| 180 | (defun scheme-get-old-input () | ||
| 181 | "Snarf the sexp ending at point" | ||
| 182 | (save-excursion | ||
| 183 | (let ((end (point))) | ||
| 184 | (backward-sexp) | ||
| 185 | (buffer-substring (point) end)))) | ||
| 186 | |||
| 187 | (defun scheme-args-to-list (string) | ||
| 188 | (let ((where (string-match "[ \t]" string))) | ||
| 189 | (cond ((null where) (list string)) | ||
| 190 | ((not (= where 0)) | ||
| 191 | (cons (substring string 0 where) | ||
| 192 | (scheme-args-to-list (substring string (+ 1 where) | ||
| 193 | (length string))))) | ||
| 194 | (t (let ((pos (string-match "[^ \t]" string))) | ||
| 195 | (if (null pos) | ||
| 196 | nil | ||
| 197 | (scheme-args-to-list (substring string pos | ||
| 198 | (length string))))))))) | ||
| 199 | |||
| 200 | (defvar scheme-program-name "scheme" | ||
| 201 | "*Program invoked by the run-scheme command") | ||
| 202 | |||
| 203 | ;;; Obsolete | ||
| 204 | (defun scheme (&rest foo) | ||
| 205 | "Use run-scheme" | ||
| 206 | (interactive) | ||
| 207 | (message "Use run-scheme") | ||
| 208 | (ding)) | ||
| 209 | |||
| 210 | (defun run-scheme (cmd) | ||
| 211 | "Run an inferior Scheme process, input and output via buffer *scheme*. | ||
| 212 | If there is a process already running in *scheme*, just switch to that buffer. | ||
| 213 | With argument, allows you to edit the command line (default is value | ||
| 214 | of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook | ||
| 215 | \(after the comint-mode-hook is run). | ||
| 216 | \(Type \\[describe-mode] in the process buffer for a list of commands.)" | ||
| 217 | |||
| 218 | (interactive (list (if current-prefix-arg | ||
| 219 | (read-string "Run Scheme: " scheme-program-name) | ||
| 220 | scheme-program-name))) | ||
| 221 | (if (not (comint-check-proc "*scheme*")) | ||
| 222 | (let ((cmdlist (scheme-args-to-list cmd))) | ||
| 223 | (set-buffer (apply 'make-comint "scheme" (car cmdlist) | ||
| 224 | nil (cdr cmdlist))) | ||
| 225 | (inferior-scheme-mode))) | ||
| 226 | (setq scheme-buffer "*scheme*") | ||
| 227 | (switch-to-buffer "*scheme*")) | ||
| 228 | |||
| 229 | |||
| 230 | (defun scheme-send-region (start end) | ||
| 231 | "Send the current region to the inferior Scheme process." | ||
| 232 | (interactive "r") | ||
| 233 | (comint-send-region (scheme-proc) start end) | ||
| 234 | (comint-send-string (scheme-proc) "\n")) | ||
| 235 | |||
| 236 | (defun scheme-send-definition () | ||
| 237 | "Send the current definition to the inferior Scheme process." | ||
| 238 | (interactive) | ||
| 239 | (save-excursion | ||
| 240 | (end-of-defun) | ||
| 241 | (let ((end (point))) | ||
| 242 | (beginning-of-defun) | ||
| 243 | (scheme-send-region (point) end)))) | ||
| 244 | |||
| 245 | (defun scheme-send-last-sexp () | ||
| 246 | "Send the previous sexp to the inferior Scheme process." | ||
| 247 | (interactive) | ||
| 248 | (scheme-send-region (save-excursion (backward-sexp) (point)) (point))) | ||
| 249 | |||
| 250 | (defvar scheme-compile-exp-command "(compile '%s)" | ||
| 251 | "*Template for issuing commands to compile arbitrary Scheme expressions.") | ||
| 252 | |||
| 253 | (defun scheme-compile-region (start end) | ||
| 254 | "Compile the current region in the inferior Scheme process | ||
| 255 | \(A BEGIN is wrapped around the region: (BEGIN <region>))" | ||
| 256 | (interactive "r") | ||
| 257 | (comint-send-string (scheme-proc) (format scheme-compile-exp-command | ||
| 258 | (format "(begin %s)" | ||
| 259 | (buffer-substring start end)))) | ||
| 260 | (comint-send-string (scheme-proc) "\n")) | ||
| 261 | |||
| 262 | (defun scheme-compile-definition () | ||
| 263 | "Compile the current definition in the inferior Scheme process." | ||
| 264 | (interactive) | ||
| 265 | (save-excursion | ||
| 266 | (end-of-defun) | ||
| 267 | (let ((end (point))) | ||
| 268 | (beginning-of-defun) | ||
| 269 | (scheme-compile-region (point) end)))) | ||
| 270 | |||
| 271 | (defun switch-to-scheme (eob-p) | ||
| 272 | "Switch to the scheme process buffer. | ||
| 273 | With argument, positions cursor at end of buffer." | ||
| 274 | (interactive "P") | ||
| 275 | (if (get-buffer scheme-buffer) | ||
| 276 | (pop-to-buffer scheme-buffer) | ||
| 277 | (error "No current process buffer. See variable scheme-buffer.")) | ||
| 278 | (cond (eob-p | ||
| 279 | (push-mark) | ||
| 280 | (goto-char (point-max))))) | ||
| 281 | |||
| 282 | (defun scheme-send-region-and-go (start end) | ||
| 283 | "Send the current region to the inferior Scheme process, | ||
| 284 | and switch to the process buffer." | ||
| 285 | (interactive "r") | ||
| 286 | (scheme-send-region start end) | ||
| 287 | (switch-to-scheme t)) | ||
| 288 | |||
| 289 | (defun scheme-send-definition-and-go () | ||
| 290 | "Send the current definition to the inferior Scheme, | ||
| 291 | and switch to the process buffer." | ||
| 292 | (interactive) | ||
| 293 | (scheme-send-definition) | ||
| 294 | (switch-to-scheme t)) | ||
| 295 | |||
| 296 | (defun scheme-compile-definition-and-go () | ||
| 297 | "Compile the current definition in the inferior Scheme, | ||
| 298 | and switch to the process buffer." | ||
| 299 | (interactive) | ||
| 300 | (scheme-compile-definition) | ||
| 301 | (switch-to-scheme t)) | ||
| 302 | |||
| 303 | (defun scheme-compile-region-and-go (start end) | ||
| 304 | "Compile the current region in the inferior Scheme, | ||
| 305 | and switch to the process buffer." | ||
| 306 | (interactive "r") | ||
| 307 | (scheme-compile-region start end) | ||
| 308 | (switch-to-scheme t)) | ||
| 309 | |||
| 310 | (defvar scheme-source-modes '(scheme-mode) | ||
| 311 | "*Used to determine if a buffer contains Scheme source code. | ||
| 312 | If it's loaded into a buffer that is in one of these major modes, it's | ||
| 313 | considered a scheme source file by scheme-load-file and scheme-compile-file. | ||
| 314 | Used by these commands to determine defaults.") | ||
| 315 | |||
| 316 | (defvar scheme-prev-l/c-dir/file nil | ||
| 317 | "Caches the (directory . file) pair used in the last scheme-load-file or | ||
| 318 | scheme-compile-file command. Used for determining the default in the | ||
| 319 | next one.") | ||
| 320 | |||
| 321 | (defun scheme-load-file (file-name) | ||
| 322 | "Load a Scheme file into the inferior Scheme process." | ||
| 323 | (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file | ||
| 324 | scheme-source-modes t)) ; T because LOAD | ||
| 325 | ; needs an exact name | ||
| 326 | (comint-check-source file-name) ; Check to see if buffer needs saved. | ||
| 327 | (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) | ||
| 328 | (file-name-nondirectory file-name))) | ||
| 329 | (comint-send-string (scheme-proc) (concat "(load \"" | ||
| 330 | file-name | ||
| 331 | "\"\)\n"))) | ||
| 332 | |||
| 333 | (defun scheme-compile-file (file-name) | ||
| 334 | "Compile a Scheme file in the inferior Scheme process." | ||
| 335 | (interactive (comint-get-source "Compile Scheme file: " | ||
| 336 | scheme-prev-l/c-dir/file | ||
| 337 | scheme-source-modes | ||
| 338 | nil)) ; NIL because COMPILE doesn't | ||
| 339 | ; need an exact name. | ||
| 340 | (comint-check-source file-name) ; Check to see if buffer needs saved. | ||
| 341 | (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) | ||
| 342 | (file-name-nondirectory file-name))) | ||
| 343 | (comint-send-string (scheme-proc) (concat "(compile-file \"" | ||
| 344 | file-name | ||
| 345 | "\"\)\n"))) | ||
| 346 | |||
| 347 | |||
| 348 | (defvar scheme-buffer nil "*The current scheme process buffer. | ||
| 349 | |||
| 350 | MULTIPLE PROCESS SUPPORT | ||
| 351 | =========================================================================== | ||
| 352 | Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme | ||
| 353 | processes. To run multiple Scheme processes, you start the first up with | ||
| 354 | \\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer | ||
| 355 | with \\[rename-buffer]. You may now start up a new process with another | ||
| 356 | \\[run-scheme]. It will be in a new buffer, named *scheme*. You can | ||
| 357 | switch between the different process buffers with \\[switch-to-buffer]. | ||
| 358 | |||
| 359 | Commands that send text from source buffers to Scheme processes -- | ||
| 360 | like scheme-send-definition or scheme-compile-region -- have to choose a | ||
| 361 | process to send to, when you have more than one Scheme process around. This | ||
| 362 | is determined by the global variable scheme-buffer. Suppose you | ||
| 363 | have three inferior Schemes running: | ||
| 364 | Buffer Process | ||
| 365 | foo scheme | ||
| 366 | bar scheme<2> | ||
| 367 | *scheme* scheme<3> | ||
| 368 | If you do a \\[scheme-send-definition-and-go] command on some Scheme source | ||
| 369 | code, what process do you send it to? | ||
| 370 | |||
| 371 | - If you're in a process buffer (foo, bar, or *scheme*), | ||
| 372 | you send it to that process. | ||
| 373 | - If you're in some other buffer (e.g., a source file), you | ||
| 374 | send it to the process attached to buffer scheme-buffer. | ||
| 375 | This process selection is performed by function scheme-proc. | ||
| 376 | |||
| 377 | Whenever \\[run-scheme] fires up a new process, it resets scheme-buffer | ||
| 378 | to be the new process's buffer. If you only run one process, this will | ||
| 379 | do the right thing. If you run multiple processes, you can change | ||
| 380 | scheme-buffer to another process buffer with \\[set-variable]. | ||
| 381 | |||
| 382 | More sophisticated approaches are, of course, possible. If you find youself | ||
| 383 | needing to switch back and forth between multiple processes frequently, | ||
| 384 | you may wish to consider ilisp.el, a larger, more sophisticated package | ||
| 385 | for running inferior Lisp and Scheme processes. The approach taken here is | ||
| 386 | for a minimal, simple implementation. Feel free to extend it.") | ||
| 387 | |||
| 388 | (defun scheme-proc () | ||
| 389 | "Returns the current scheme process. See variable scheme-buffer." | ||
| 390 | (let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode) | ||
| 391 | (current-buffer) | ||
| 392 | scheme-buffer)))) | ||
| 393 | (or proc | ||
| 394 | (error "No current process. See variable scheme-buffer")))) | ||
| 395 | |||
| 396 | |||
| 397 | ;;; Do the user's customisation... | ||
| 398 | |||
| 399 | (defvar cmuscheme-load-hook nil | ||
| 400 | "This hook is run when cmuscheme is loaded in. | ||
| 401 | This is a good place to put keybindings.") | ||
| 402 | |||
| 403 | (run-hooks 'cmuscheme-load-hook) | ||
| 404 | |||
| 405 | |||
| 406 | ;;; CHANGE LOG | ||
| 407 | ;;; =========================================================================== | ||
| 408 | ;;; 8/88 Olin | ||
| 409 | ;;; Created. | ||
| 410 | ;;; | ||
| 411 | ;;; 2/15/89 Olin | ||
| 412 | ;;; Removed -emacs flag from process invocation. It's only useful for | ||
| 413 | ;;; cscheme, and makes cscheme assume it's running under xscheme.el, | ||
| 414 | ;;; which messes things up royally. A bug. | ||
| 415 | ;;; | ||
| 416 | ;;; 5/22/90 Olin | ||
| 417 | ;;; - Upgraded to use comint-send-string and comint-send-region. | ||
| 418 | ;;; - run-scheme now offers to let you edit the command line if | ||
| 419 | ;;; you invoke it with a prefix-arg. M-x scheme is redundant, and | ||
| 420 | ;;; has been removed. | ||
| 421 | ;;; - Explicit references to process "scheme" have been replaced with | ||
| 422 | ;;; (scheme-proc). This allows better handling of multiple process bufs. | ||
| 423 | ;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention. | ||
| 424 | ;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist | ||
| 425 | ;;; and friends, but interested hackers might find a useful application | ||
| 426 | ;;; of this facility. | ||
| 427 | ;;; | ||
| 428 | ;;; 3/12/90 Olin | ||
| 429 | ;;; - scheme-load-file and scheme-compile-file no longer switch-to-scheme. | ||
| 430 | ;;; Tale suggested this. | ||
diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el new file mode 100644 index 00000000000..51e7d4954cb --- /dev/null +++ b/lisp/dabbrev.el | |||
| @@ -0,0 +1,258 @@ | |||
| 1 | ;; Dynamic abbreviation package for GNU Emacs. | ||
| 2 | ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. | ||
| 3 | |||
| 4 | ;; This file is part of GNU Emacs. | ||
| 5 | |||
| 6 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 7 | ;; it under the terms of the GNU General Public License as published by | ||
| 8 | ;; the Free Software Foundation; either version 1, or (at your option) | ||
| 9 | ;; any later version. | ||
| 10 | |||
| 11 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 12 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;; GNU General Public License for more details. | ||
| 15 | |||
| 16 | ;; You should have received a copy of the GNU General Public License | ||
| 17 | ;; along with GNU Emacs; see the file COPYING. If not, write to | ||
| 18 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 19 | |||
| 20 | |||
| 21 | ; DABBREVS - "Dynamic abbreviations" hack, originally written by Don Morrison | ||
| 22 | ; for Twenex Emacs. Converted to mlisp by Russ Fish. Supports the table | ||
| 23 | ; feature to avoid hitting the same expansion on re-expand, and the search | ||
| 24 | ; size limit variable. Bugs fixed from the Twenex version are flagged by | ||
| 25 | ; comments starting with ;;; . | ||
| 26 | ; | ||
| 27 | ; converted to elisp by Spencer Thomas. | ||
| 28 | ; Thoroughly cleaned up by Richard Stallman. | ||
| 29 | ; | ||
| 30 | ; If anyone feels like hacking at it, Bob Keller (Keller@Utah-20) first | ||
| 31 | ; suggested the beast, and has some good ideas for its improvement, but | ||
| 32 | ; doesn?tknow TECO (the lucky devil...). One thing that should definitely | ||
| 33 | ; be done is adding the ability to search some other buffer(s) if you can?t | ||
| 34 | ; find the expansion you want in the current one. | ||
| 35 | |||
| 36 | ;; (defun dabbrevs-help () | ||
| 37 | ;; "Give help about dabbrevs." | ||
| 38 | ;; (interactive) | ||
| 39 | ;; (&info "emacs" "dabbrevs") ; Select the specific info node. | ||
| 40 | ;; ) | ||
| 41 | (provide 'dabbrevs) | ||
| 42 | |||
| 43 | (defvar dabbrevs-limit nil | ||
| 44 | "*Limits region searched by `dabbrevs-expand' to this many chars away.") | ||
| 45 | (make-variable-buffer-local 'dabbrevs-limit) | ||
| 46 | |||
| 47 | (defvar dabbrevs-backward-only nil | ||
| 48 | "*If non-NIL, `dabbrevs-expand' only looks backwards.") | ||
| 49 | |||
| 50 | ; State vars for dabbrevs-re-expand. | ||
| 51 | (defvar last-dabbrevs-table nil | ||
| 52 | "Table of expansions seen so far (local)") | ||
| 53 | (make-variable-buffer-local 'last-dabbrevs-table) | ||
| 54 | |||
| 55 | (defvar last-dabbrevs-abbreviation "" | ||
| 56 | "Last string we tried to expand (local).") | ||
| 57 | (make-variable-buffer-local 'last-dabbrevs-abbreviation) | ||
| 58 | |||
| 59 | (defvar last-dabbrevs-direction 0 | ||
| 60 | "Direction of last dabbrevs search (local)") | ||
| 61 | (make-variable-buffer-local 'last-dabbrevs-direction) | ||
| 62 | |||
| 63 | (defvar last-dabbrevs-abbrev-location nil | ||
| 64 | "Location last abbreviation began (local).") | ||
| 65 | (make-variable-buffer-local 'last-dabbrevs-abbrev-location) | ||
| 66 | |||
| 67 | (defvar last-dabbrevs-expansion nil | ||
| 68 | "Last expansion of an abbreviation. (local)") | ||
| 69 | (make-variable-buffer-local 'last-dabbrevs-expansion) | ||
| 70 | |||
| 71 | (defvar last-dabbrevs-expansion-location nil | ||
| 72 | "Location the last expansion was found. (local)") | ||
| 73 | (make-variable-buffer-local 'last-dabbrevs-expansion-location) | ||
| 74 | |||
| 75 | ;;;###autoload | ||
| 76 | (defun dabbrev-expand (arg) | ||
| 77 | "Expand previous word \"dynamically\". | ||
| 78 | Expands to the most recent, preceding word for which this is a prefix. | ||
| 79 | If no suitable preceding word is found, words following point are considered. | ||
| 80 | |||
| 81 | If `case-fold-search' and `case-replace' are non-nil (usually true) | ||
| 82 | then the substituted word may be case-adjusted to match the abbreviation | ||
| 83 | that you had typed. This takes place if the substituted word, as found, | ||
| 84 | is all lower case, or if it is at the beginning of a sentence and only | ||
| 85 | its first letter was upper case. | ||
| 86 | |||
| 87 | A positive prefix arg N says to take the Nth backward DISTINCT | ||
| 88 | possibility. A negative argument says search forward. The variable | ||
| 89 | `dabbrev-backward-only' may be used to limit the direction of search to | ||
| 90 | backward if set non-nil. | ||
| 91 | |||
| 92 | If the cursor has not moved from the end of the previous expansion and | ||
| 93 | no argument is given, replace the previously-made expansion | ||
| 94 | with the next possible expansion not yet tried." | ||
| 95 | (interactive "*P") | ||
| 96 | (let (abbrev expansion old which loc n pattern | ||
| 97 | (do-case (and case-fold-search case-replace))) | ||
| 98 | ;; abbrev -- the abbrev to expand | ||
| 99 | ;; expansion -- the expansion found (eventually) or nil until then | ||
| 100 | ;; old -- the text currently in the buffer | ||
| 101 | ;; (the abbrev, or the previously-made expansion) | ||
| 102 | ;; loc -- place where expansion is found | ||
| 103 | ;; (to start search there for next expansion if requested later) | ||
| 104 | ;; do-case -- non-nil if should transform case when substituting. | ||
| 105 | (save-excursion | ||
| 106 | (if (and (null arg) | ||
| 107 | (eq last-command this-command) | ||
| 108 | last-dabbrevs-abbrev-location) | ||
| 109 | (progn | ||
| 110 | (setq abbrev last-dabbrevs-abbreviation) | ||
| 111 | (setq old last-dabbrevs-expansion) | ||
| 112 | (setq which last-dabbrevs-direction)) | ||
| 113 | (setq which (if (null arg) | ||
| 114 | (if dabbrevs-backward-only 1 0) | ||
| 115 | (prefix-numeric-value arg))) | ||
| 116 | (setq loc (point)) | ||
| 117 | (forward-word -1) | ||
| 118 | (setq last-dabbrevs-abbrev-location (point)) ; Original location. | ||
| 119 | (setq abbrev (buffer-substring (point) loc)) | ||
| 120 | (setq old abbrev) | ||
| 121 | (setq last-dabbrevs-expansion-location nil) | ||
| 122 | (setq last-dabbrev-table nil)) ; Clear table of things seen. | ||
| 123 | |||
| 124 | (setq pattern (concat "\\b" (regexp-quote abbrev) "\\(\\sw\\|\\s_\\)+")) | ||
| 125 | ;; Try looking backward unless inhibited. | ||
| 126 | (if (>= which 0) | ||
| 127 | (progn | ||
| 128 | (setq n (max 1 which)) | ||
| 129 | (if last-dabbrevs-expansion-location | ||
| 130 | (goto-char last-dabbrevs-expansion-location)) | ||
| 131 | (while (and (> n 0) | ||
| 132 | (setq expansion (dabbrevs-search pattern t do-case))) | ||
| 133 | (setq loc (point-marker)) | ||
| 134 | (setq last-dabbrev-table (cons expansion last-dabbrev-table)) | ||
| 135 | (setq n (1- n))) | ||
| 136 | (or expansion | ||
| 137 | (setq last-dabbrevs-expansion-location nil)) | ||
| 138 | (setq last-dabbrevs-direction (min 1 which)))) | ||
| 139 | |||
| 140 | (if (and (<= which 0) (not expansion)) ; Then look forward. | ||
| 141 | (progn | ||
| 142 | (setq n (max 1 (- which))) | ||
| 143 | (if last-dabbrevs-expansion-location | ||
| 144 | (goto-char last-dabbrevs-expansion-location)) | ||
| 145 | (while (and (> n 0) | ||
| 146 | (setq expansion (dabbrevs-search pattern nil do-case))) | ||
| 147 | (setq loc (point-marker)) | ||
| 148 | (setq last-dabbrev-table (cons expansion last-dabbrev-table)) | ||
| 149 | (setq n (1- n))) | ||
| 150 | (setq last-dabbrevs-direction -1)))) | ||
| 151 | |||
| 152 | (if (not expansion) | ||
| 153 | (let ((first (string= abbrev old))) | ||
| 154 | (setq last-dabbrevs-abbrev-location nil) | ||
| 155 | (if (not first) | ||
| 156 | (progn (undo-boundary) | ||
| 157 | (delete-backward-char (length old)) | ||
| 158 | (insert abbrev))) | ||
| 159 | (error (if first | ||
| 160 | "No dynamic expansion for \"%s\" found." | ||
| 161 | "No further dynamic expansions for \"%s\" found.") | ||
| 162 | abbrev)) | ||
| 163 | ;; Success: stick it in and return. | ||
| 164 | (undo-boundary) | ||
| 165 | (search-backward old) | ||
| 166 | ;; Make case of replacement conform to case of abbreviation | ||
| 167 | ;; provided (1) that kind of thing is enabled in this buffer | ||
| 168 | ;; and (2) the replacement itself is all lower case. | ||
| 169 | ;; First put back the original abbreviation with its original | ||
| 170 | ;; case pattern. | ||
| 171 | (save-excursion | ||
| 172 | (replace-match abbrev t 'literal)) | ||
| 173 | (search-forward abbrev) | ||
| 174 | (let ((do-case (and do-case | ||
| 175 | (string= (substring expansion 1) | ||
| 176 | (downcase (substring expansion 1)))))) | ||
| 177 | ;; First put back the original abbreviation with its original | ||
| 178 | ;; case pattern. | ||
| 179 | (save-excursion | ||
| 180 | (replace-match abbrev t 'literal)) | ||
| 181 | (search-forward abbrev) | ||
| 182 | (replace-match (if do-case (downcase expansion) expansion) | ||
| 183 | (not do-case) | ||
| 184 | 'literal)) | ||
| 185 | ;; Save state for re-expand. | ||
| 186 | (setq last-dabbrevs-abbreviation abbrev) | ||
| 187 | (setq last-dabbrevs-expansion expansion) | ||
| 188 | (setq last-dabbrevs-expansion-location loc)))) | ||
| 189 | |||
| 190 | ;;;###autoload | ||
| 191 | (define-key esc-map "/" 'dabbrev-expand) | ||
| 192 | |||
| 193 | |||
| 194 | ;; Search function used by dabbrevs library. | ||
| 195 | ;; First arg is string to find as prefix of word. Second arg is | ||
| 196 | ;; t for reverse search, nil for forward. Variable dabbrevs-limit | ||
| 197 | ;; controls the maximum search region size. | ||
| 198 | |||
| 199 | ;; Table of expansions already seen is examined in buffer last-dabbrev-table, | ||
| 200 | ;; so that only distinct possibilities are found by dabbrevs-re-expand. | ||
| 201 | ;; Note that to prevent finding the abbrev itself it must have been | ||
| 202 | ;; entered in the table. | ||
| 203 | |||
| 204 | ;; IGNORE-CASE non-nil means treat case as insignificant while | ||
| 205 | ;; looking for a match and when comparing with previous matches. | ||
| 206 | ;; Also if that's non-nil and the match is found at the beginning of a sentence | ||
| 207 | ;; and is in lower case except for the initial | ||
| 208 | ;; then it is converted to all lower case for return. | ||
| 209 | |||
| 210 | ;; Value is the expansion, or nil if not found. After a successful | ||
| 211 | ;; search, point is left right after the expansion found. | ||
| 212 | |||
| 213 | (defun dabbrevs-search (pattern reverse ignore-case) | ||
| 214 | (let (missing result (case-fold-search ignore-case)) | ||
| 215 | (save-restriction ; Uses restriction for limited searches. | ||
| 216 | (if dabbrevs-limit | ||
| 217 | (narrow-to-region last-dabbrevs-abbrev-location | ||
| 218 | (+ (point) | ||
| 219 | (* dabbrevs-limit (if reverse -1 1))))) | ||
| 220 | ;; Keep looking for a distinct expansion. | ||
| 221 | (setq result nil) | ||
| 222 | (setq missing nil) | ||
| 223 | (while (and (not result) (not missing)) | ||
| 224 | ; Look for it, leave loop if search fails. | ||
| 225 | (setq missing | ||
| 226 | (not (if reverse | ||
| 227 | (re-search-backward pattern nil t) | ||
| 228 | (re-search-forward pattern nil t)))) | ||
| 229 | |||
| 230 | (if (not missing) | ||
| 231 | (progn | ||
| 232 | (setq result (buffer-substring (match-beginning 0) | ||
| 233 | (match-end 0))) | ||
| 234 | (let* ((test last-dabbrev-table)) | ||
| 235 | (while (and test | ||
| 236 | (not | ||
| 237 | (if ignore-case | ||
| 238 | (string= (downcase (car test)) | ||
| 239 | (downcase result)) | ||
| 240 | (string= (car test) result)))) | ||
| 241 | (setq test (cdr test))) | ||
| 242 | (if test (setq result nil)))))) ; if already in table, ignore | ||
| 243 | (if result | ||
| 244 | (save-excursion | ||
| 245 | (let ((beg (match-beginning 0))) | ||
| 246 | (goto-char beg) | ||
| 247 | (and ignore-case | ||
| 248 | (string= (substring result 1) | ||
| 249 | (downcase (substring result 1))) | ||
| 250 | (if (string= paragraph-start | ||
| 251 | (concat "^$\\|" page-delimiter)) | ||
| 252 | (and (re-search-backward sentence-end nil t) | ||
| 253 | (= (match-end 0) beg)) | ||
| 254 | (forward-char 1) | ||
| 255 | (backward-sentence) | ||
| 256 | (= (point) beg)) | ||
| 257 | (setq result (downcase result)))))) | ||
| 258 | result))) | ||
diff --git a/lisp/gnuspost.el b/lisp/gnuspost.el new file mode 100644 index 00000000000..d40982d1def --- /dev/null +++ b/lisp/gnuspost.el | |||
| @@ -0,0 +1,672 @@ | |||
| 1 | ;;; Post news commands for GNUS newsreader | ||
| 2 | ;; Copyright (C) 1989 Fujitsu Laboratories LTD. | ||
| 3 | ;; Copyright (C) 1989, 1990 Masanobu UMEDA | ||
| 4 | ;; $Header: gnuspost.el,v 1.2 90/03/23 13:25:16 umerin Locked $ | ||
| 5 | |||
| 6 | ;; This file is part of GNU Emacs. | ||
| 7 | |||
| 8 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 9 | ;; but WITHOUT ANY WARRANTY. No author or distributor | ||
| 10 | ;; accepts responsibility to anyone for the consequences of using it | ||
| 11 | ;; or for whether it serves any particular purpose or works at all, | ||
| 12 | ;; unless he says so in writing. Refer to the GNU Emacs General Public | ||
| 13 | ;; License for full details. | ||
| 14 | |||
| 15 | ;; Everyone is granted permission to copy, modify and redistribute | ||
| 16 | ;; GNU Emacs, but only under the conditions described in the | ||
| 17 | ;; GNU Emacs General Public License. A copy of this license is | ||
| 18 | ;; supposed to have been given to you along with GNU Emacs so you | ||
| 19 | ;; can know your rights and responsibilities. It should be in a | ||
| 20 | ;; file named COPYING. Among other things, the copyright notice | ||
| 21 | ;; and this notice must be preserved on all copies. | ||
| 22 | |||
| 23 | (provide 'gnuspost) | ||
| 24 | (require 'gnus) | ||
| 25 | |||
| 26 | (defvar gnus-organization-file "/usr/lib/news/organization" | ||
| 27 | "*Local news organization file.") | ||
| 28 | |||
| 29 | (defvar gnus-post-news-buffer "*post-news*") | ||
| 30 | (defvar gnus-winconf-post-news nil) | ||
| 31 | |||
| 32 | (autoload 'news-reply-mode "rnewspost") | ||
| 33 | |||
| 34 | ;;; Post news commands of GNUS Group Mode and Subject Mode | ||
| 35 | |||
| 36 | (defun gnus-Group-post-news () | ||
| 37 | "Post an article." | ||
| 38 | (interactive) | ||
| 39 | ;; Save window configuration. | ||
| 40 | (setq gnus-winconf-post-news (current-window-configuration)) | ||
| 41 | (unwind-protect | ||
| 42 | (gnus-post-news) | ||
| 43 | (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) | ||
| 44 | (not (zerop (buffer-size)))) | ||
| 45 | ;; Restore last window configuration. | ||
| 46 | (set-window-configuration gnus-winconf-post-news))) | ||
| 47 | ;; We don't want to return to Subject buffer nor Article buffer later. | ||
| 48 | (if (get-buffer gnus-Subject-buffer) | ||
| 49 | (bury-buffer gnus-Subject-buffer)) | ||
| 50 | (if (get-buffer gnus-Article-buffer) | ||
| 51 | (bury-buffer gnus-Article-buffer))) | ||
| 52 | |||
| 53 | (defun gnus-Subject-post-news () | ||
| 54 | "Post an article." | ||
| 55 | (interactive) | ||
| 56 | (gnus-Subject-select-article t nil) | ||
| 57 | ;; Save window configuration. | ||
| 58 | (setq gnus-winconf-post-news (current-window-configuration)) | ||
| 59 | (unwind-protect | ||
| 60 | (progn | ||
| 61 | (switch-to-buffer gnus-Article-buffer) | ||
| 62 | (widen) | ||
| 63 | (delete-other-windows) | ||
| 64 | (gnus-post-news)) | ||
| 65 | (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) | ||
| 66 | (not (zerop (buffer-size)))) | ||
| 67 | ;; Restore last window configuration. | ||
| 68 | (set-window-configuration gnus-winconf-post-news))) | ||
| 69 | ;; We don't want to return to Article buffer later. | ||
| 70 | (bury-buffer gnus-Article-buffer)) | ||
| 71 | |||
| 72 | (defun gnus-Subject-post-reply (yank) | ||
| 73 | "Post a reply article. | ||
| 74 | If prefix argument YANK is non-nil, original article is yanked automatically." | ||
| 75 | (interactive "P") | ||
| 76 | (gnus-Subject-select-article t nil) | ||
| 77 | ;; Check Followup-To: poster. | ||
| 78 | (set-buffer gnus-Article-buffer) | ||
| 79 | (if (and gnus-use-followup-to | ||
| 80 | (string-equal "poster" (gnus-fetch-field "followup-to")) | ||
| 81 | (or (not (eq gnus-use-followup-to t)) | ||
| 82 | (not (y-or-n-p "Do you want to ignore `Followup-To: poster'? ")))) | ||
| 83 | ;; Mail to the poster. GNUS is now RFC1036 compliant. | ||
| 84 | (gnus-Subject-mail-reply yank) | ||
| 85 | ;; Save window configuration. | ||
| 86 | (setq gnus-winconf-post-news (current-window-configuration)) | ||
| 87 | (unwind-protect | ||
| 88 | (progn | ||
| 89 | (switch-to-buffer gnus-Article-buffer) | ||
| 90 | (widen) | ||
| 91 | (delete-other-windows) | ||
| 92 | (gnus-news-reply yank)) | ||
| 93 | (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) | ||
| 94 | (not (zerop (buffer-size)))) | ||
| 95 | ;; Restore last window configuration. | ||
| 96 | (set-window-configuration gnus-winconf-post-news))) | ||
| 97 | ;; We don't want to return to Article buffer later. | ||
| 98 | (bury-buffer gnus-Article-buffer))) | ||
| 99 | |||
| 100 | (defun gnus-Subject-post-reply-with-original () | ||
| 101 | "Post a reply article with original article." | ||
| 102 | (interactive) | ||
| 103 | (gnus-Subject-post-reply t)) | ||
| 104 | |||
| 105 | (defun gnus-Subject-cancel-article () | ||
| 106 | "Cancel an article you posted." | ||
| 107 | (interactive) | ||
| 108 | (gnus-Subject-select-article t nil) | ||
| 109 | (gnus-eval-in-buffer-window gnus-Article-buffer | ||
| 110 | (gnus-cancel-news))) | ||
| 111 | |||
| 112 | |||
| 113 | ;;; Post a News using NNTP | ||
| 114 | |||
| 115 | ;;;###autoload | ||
| 116 | (fset 'sendnews 'gnus-post-news) | ||
| 117 | ;;;###autoload | ||
| 118 | (fset 'postnews 'gnus-post-news) | ||
| 119 | ;;;###autoload | ||
| 120 | (defun gnus-post-news () | ||
| 121 | "Begin editing a new USENET news article to be posted. | ||
| 122 | Type \\[describe-mode] once editing the article to get a list of commands." | ||
| 123 | (interactive) | ||
| 124 | (if (or (not gnus-novice-user) | ||
| 125 | (y-or-n-p "Are you sure you want to post to all of USENET? ")) | ||
| 126 | (let ((artbuf (current-buffer)) | ||
| 127 | (newsgroups ;Default newsgroup. | ||
| 128 | (if (eq major-mode 'gnus-Article-mode) gnus-newsgroup-name)) | ||
| 129 | (subject nil) | ||
| 130 | (distribution nil)) | ||
| 131 | (save-restriction | ||
| 132 | (and (not (zerop (buffer-size))) | ||
| 133 | ;;(equal major-mode 'news-mode) | ||
| 134 | (equal major-mode 'gnus-Article-mode) | ||
| 135 | (progn | ||
| 136 | ;;(news-show-all-headers) | ||
| 137 | (gnus-Article-show-all-headers) | ||
| 138 | (narrow-to-region (point-min) | ||
| 139 | (progn (goto-char (point-min)) | ||
| 140 | (search-forward "\n\n") | ||
| 141 | (point))))) | ||
| 142 | (setq news-reply-yank-from (mail-fetch-field "from")) | ||
| 143 | (setq news-reply-yank-message-id (mail-fetch-field "message-id"))) | ||
| 144 | (pop-to-buffer gnus-post-news-buffer) | ||
| 145 | (news-reply-mode) | ||
| 146 | (gnus-overload-functions) | ||
| 147 | (if (and (buffer-modified-p) | ||
| 148 | (> (buffer-size) 0) | ||
| 149 | (not (y-or-n-p "Unsent article being composed; erase it? "))) | ||
| 150 | ;; Continue composition. | ||
| 151 | ;; Make news-reply-yank-original work on the current article. | ||
| 152 | (setq mail-reply-buffer artbuf) | ||
| 153 | (erase-buffer) | ||
| 154 | (if gnus-interactive-post | ||
| 155 | ;; Newsgroups, subject and distribution are asked for. | ||
| 156 | ;; Suggested by yuki@flab.fujitsu.junet. | ||
| 157 | (progn | ||
| 158 | ;; Subscribed newsgroup names are required for | ||
| 159 | ;; completing read of newsgroup. | ||
| 160 | (or gnus-newsrc-assoc | ||
| 161 | (gnus-read-newsrc-file)) | ||
| 162 | ;; Which do you like? (UMERIN) | ||
| 163 | ;; (setq newsgroups (read-string "Newsgroups: " "general")) | ||
| 164 | (or newsgroups ;Use the default newsgroup. | ||
| 165 | (setq newsgroups | ||
| 166 | (completing-read "Newsgroup: " gnus-newsrc-assoc | ||
| 167 | nil 'require-match | ||
| 168 | newsgroups ;Default newsgroup. | ||
| 169 | ))) | ||
| 170 | (setq subject (read-string "Subject: ")) | ||
| 171 | (setq distribution | ||
| 172 | (substring newsgroups 0 (string-match "\\." newsgroups))) | ||
| 173 | (if (string-equal distribution newsgroups) | ||
| 174 | ;; Newsgroup may be general or control. In this | ||
| 175 | ;; case, use default distribution. | ||
| 176 | (setq distribution gnus-default-distribution)) | ||
| 177 | (setq distribution | ||
| 178 | (read-string "Distribution: " distribution)) | ||
| 179 | ;; An empty string is ok to ignore gnus-default-distribution. | ||
| 180 | ;;(if (string-equal distribution "") | ||
| 181 | ;; (setq distribution nil)) | ||
| 182 | )) | ||
| 183 | (news-setup () subject () newsgroups artbuf) | ||
| 184 | ;; Make sure the article is posted by GNUS. | ||
| 185 | ;;(mail-position-on-field "Posting-Software") | ||
| 186 | ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") | ||
| 187 | ;; Insert Distribution: field. | ||
| 188 | ;; Suggested by ichikawa@flab.fujitsu.junet. | ||
| 189 | (mail-position-on-field "Distribution") | ||
| 190 | (insert (or distribution gnus-default-distribution "")) | ||
| 191 | ;; Handle author copy using FCC field. | ||
| 192 | (if gnus-author-copy | ||
| 193 | (progn | ||
| 194 | (mail-position-on-field "FCC") | ||
| 195 | (insert gnus-author-copy))) | ||
| 196 | (if gnus-interactive-post | ||
| 197 | ;; All fields are filled in. | ||
| 198 | (goto-char (point-max)) | ||
| 199 | ;; Move point to Newsgroup: field. | ||
| 200 | (goto-char (point-min)) | ||
| 201 | (end-of-line)) | ||
| 202 | )) | ||
| 203 | (message ""))) | ||
| 204 | |||
| 205 | (defun gnus-news-reply (&optional yank) | ||
| 206 | "Compose and post a reply (aka a followup) to the current article on USENET. | ||
| 207 | While composing the followup, use \\[news-reply-yank-original] to yank the | ||
| 208 | original message into it." | ||
| 209 | (interactive) | ||
| 210 | (if (or (not gnus-novice-user) | ||
| 211 | (y-or-n-p "Are you sure you want to followup to all of USENET? ")) | ||
| 212 | (let (from cc subject date to followup-to newsgroups message-of | ||
| 213 | references distribution message-id | ||
| 214 | (artbuf (current-buffer))) | ||
| 215 | (save-restriction | ||
| 216 | (and (not (zerop (buffer-size))) | ||
| 217 | ;;(equal major-mode 'news-mode) | ||
| 218 | (equal major-mode 'gnus-Article-mode) | ||
| 219 | (progn | ||
| 220 | ;; (news-show-all-headers) | ||
| 221 | (gnus-Article-show-all-headers) | ||
| 222 | (narrow-to-region (point-min) | ||
| 223 | (progn (goto-char (point-min)) | ||
| 224 | (search-forward "\n\n") | ||
| 225 | (point))))) | ||
| 226 | (setq from (mail-fetch-field "from")) | ||
| 227 | (setq news-reply-yank-from from) | ||
| 228 | (setq subject (mail-fetch-field "subject")) | ||
| 229 | (setq date (mail-fetch-field "date")) | ||
| 230 | (setq followup-to (mail-fetch-field "followup-to")) | ||
| 231 | ;; Ignore Followup-To: poster. | ||
| 232 | (if (or (null gnus-use-followup-to) ;Ignore followup-to: field. | ||
| 233 | (string-equal "" followup-to) ;Bogus header. | ||
| 234 | (string-equal "poster" followup-to)) | ||
| 235 | (setq followup-to nil)) | ||
| 236 | (setq newsgroups (or followup-to (mail-fetch-field "newsgroups"))) | ||
| 237 | (setq references (mail-fetch-field "references")) | ||
| 238 | (setq distribution (mail-fetch-field "distribution")) | ||
| 239 | (setq message-id (mail-fetch-field "message-id")) | ||
| 240 | (setq news-reply-yank-message-id message-id)) | ||
| 241 | (pop-to-buffer gnus-post-news-buffer) | ||
| 242 | (news-reply-mode) | ||
| 243 | (gnus-overload-functions) | ||
| 244 | (if (and (buffer-modified-p) | ||
| 245 | (> (buffer-size) 0) | ||
| 246 | (not (y-or-n-p "Unsent article being composed; erase it? "))) | ||
| 247 | ;; Continue composition. | ||
| 248 | ;; Make news-reply-yank-original work on current article. | ||
| 249 | (setq mail-reply-buffer artbuf) | ||
| 250 | (erase-buffer) | ||
| 251 | (and subject | ||
| 252 | (setq subject | ||
| 253 | (concat "Re: " (gnus-simplify-subject subject 're-only)))) | ||
| 254 | (and from | ||
| 255 | (progn | ||
| 256 | (let ((stop-pos | ||
| 257 | (string-match " *at \\| *@ \\| *(\\| *<" from))) | ||
| 258 | (setq message-of | ||
| 259 | (concat | ||
| 260 | (if stop-pos (substring from 0 stop-pos) from) | ||
| 261 | "'s message of " | ||
| 262 | date))))) | ||
| 263 | (news-setup nil subject message-of newsgroups artbuf) | ||
| 264 | (if followup-to | ||
| 265 | (progn (news-reply-followup-to) | ||
| 266 | (insert followup-to))) | ||
| 267 | ;; Fold long references line to follow RFC1036. | ||
| 268 | (mail-position-on-field "References") | ||
| 269 | (let ((begin (point)) | ||
| 270 | (fill-column 79) | ||
| 271 | (fill-prefix "\t")) | ||
| 272 | (if references | ||
| 273 | (insert references)) | ||
| 274 | (if (and references message-id) | ||
| 275 | (insert " ")) | ||
| 276 | (if message-id | ||
| 277 | (insert message-id)) | ||
| 278 | ;; The region must end with a newline to fill the region | ||
| 279 | ;; without inserting extra newline. | ||
| 280 | (fill-region-as-paragraph begin (1+ (point)))) | ||
| 281 | ;; Make sure the article is posted by GNUS. | ||
| 282 | ;;(mail-position-on-field "Posting-Software") | ||
| 283 | ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") | ||
| 284 | ;; Distribution must be the same as original article. | ||
| 285 | (mail-position-on-field "Distribution") | ||
| 286 | (insert (or distribution "")) | ||
| 287 | ;; Handle author copy using FCC field. | ||
| 288 | (if gnus-author-copy | ||
| 289 | (progn | ||
| 290 | (mail-position-on-field "FCC") | ||
| 291 | (insert gnus-author-copy))) | ||
| 292 | (goto-char (point-max))) | ||
| 293 | ;; Yank original article automatically. | ||
| 294 | (if yank | ||
| 295 | (let ((last (point))) | ||
| 296 | (goto-char (point-max)) | ||
| 297 | (news-reply-yank-original nil) | ||
| 298 | (goto-char last))) | ||
| 299 | ) | ||
| 300 | (message ""))) | ||
| 301 | |||
| 302 | (defun gnus-inews-news () | ||
| 303 | "Send a news message." | ||
| 304 | (interactive) | ||
| 305 | (let* ((case-fold-search nil) | ||
| 306 | (server-running (gnus-server-opened))) | ||
| 307 | (save-excursion | ||
| 308 | ;; It is possible to post a news without reading news using | ||
| 309 | ;; `gnus' before. | ||
| 310 | ;; Suggested by yuki@flab.fujitsu.junet. | ||
| 311 | (gnus-start-news-server) ;Use default server. | ||
| 312 | ;; NNTP server must be opened before current buffer is modified. | ||
| 313 | (widen) | ||
| 314 | (goto-char (point-min)) | ||
| 315 | (run-hooks 'news-inews-hook) | ||
| 316 | (goto-char (point-min)) | ||
| 317 | (search-forward (concat "\n" mail-header-separator "\n")) | ||
| 318 | (replace-match "\n\n") | ||
| 319 | (goto-char (point-max)) | ||
| 320 | ;; require a newline at the end for inews to append .signature to | ||
| 321 | (or (= (preceding-char) ?\n) | ||
| 322 | (insert ?\n)) | ||
| 323 | (message "Posting to USENET...") | ||
| 324 | ;; Post to NNTP server. | ||
| 325 | (if (gnus-inews-article) | ||
| 326 | (message "Posting to USENET... done") | ||
| 327 | ;; We cannot signal an error. | ||
| 328 | (ding) (message "Article rejected: %s" (gnus-status-message))) | ||
| 329 | (goto-char (point-min)) ;restore internal header separator | ||
| 330 | (search-forward "\n\n") | ||
| 331 | (replace-match (concat "\n" mail-header-separator "\n")) | ||
| 332 | (set-buffer-modified-p nil)) | ||
| 333 | ;; If NNTP server is opened by gnus-inews-news, close it by myself. | ||
| 334 | (or server-running | ||
| 335 | (gnus-close-server)) | ||
| 336 | (and (fboundp 'bury-buffer) (bury-buffer)) | ||
| 337 | ;; Restore last window configuration. | ||
| 338 | (and gnus-winconf-post-news | ||
| 339 | (set-window-configuration gnus-winconf-post-news)) | ||
| 340 | (setq gnus-winconf-post-news nil) | ||
| 341 | )) | ||
| 342 | |||
| 343 | (defun gnus-cancel-news () | ||
| 344 | "Cancel an article you posted." | ||
| 345 | (interactive) | ||
| 346 | (if (yes-or-no-p "Do you really want to cancel this article? ") | ||
| 347 | (let ((from nil) | ||
| 348 | (newsgroups nil) | ||
| 349 | (message-id nil) | ||
| 350 | (distribution nil)) | ||
| 351 | (save-excursion | ||
| 352 | ;; Get header info. from original article. | ||
| 353 | (save-restriction | ||
| 354 | (gnus-Article-show-all-headers) | ||
| 355 | (goto-char (point-min)) | ||
| 356 | (search-forward "\n\n") | ||
| 357 | (narrow-to-region (point-min) (point)) | ||
| 358 | (setq from (mail-fetch-field "from")) | ||
| 359 | (setq newsgroups (mail-fetch-field "newsgroups")) | ||
| 360 | (setq message-id (mail-fetch-field "message-id")) | ||
| 361 | (setq distribution (mail-fetch-field "distribution"))) | ||
| 362 | ;; Verify if the article is absolutely user's by comparing | ||
| 363 | ;; user id with value of its From: field. | ||
| 364 | (if (not | ||
| 365 | (string-equal | ||
| 366 | (downcase (mail-strip-quoted-names from)) | ||
| 367 | (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) | ||
| 368 | (progn | ||
| 369 | (ding) (message "This article is not yours")) | ||
| 370 | ;; Make control article. | ||
| 371 | (set-buffer (get-buffer-create " *GNUS-posting*")) | ||
| 372 | (buffer-flush-undo (current-buffer)) | ||
| 373 | (erase-buffer) | ||
| 374 | (insert "Newsgroups: " newsgroups "\n" | ||
| 375 | "Subject: cancel " message-id "\n" | ||
| 376 | "Control: cancel " message-id "\n" | ||
| 377 | ;; We should not use the value of | ||
| 378 | ;; `gnus-default-distribution' as default value, | ||
| 379 | ;; because distribution must be as same as original | ||
| 380 | ;; article. | ||
| 381 | "Distribution: " (or distribution "") "\n" | ||
| 382 | ) | ||
| 383 | ;; Prepare article headers. | ||
| 384 | (gnus-inews-insert-headers) | ||
| 385 | (goto-char (point-max)) | ||
| 386 | ;; Insert empty line. | ||
| 387 | (insert "\n") | ||
| 388 | ;; Send the control article to NNTP server. | ||
| 389 | (message "Canceling your article...") | ||
| 390 | (if (gnus-request-post) | ||
| 391 | (message "Canceling your article... done") | ||
| 392 | (ding) (message "Failed to cancel your article")) | ||
| 393 | (kill-buffer (current-buffer)) | ||
| 394 | ))) | ||
| 395 | )) | ||
| 396 | |||
| 397 | |||
| 398 | ;;; Lowlevel inews interface | ||
| 399 | |||
| 400 | (defun gnus-inews-article () | ||
| 401 | "NNTP inews interface." | ||
| 402 | (let ((signature | ||
| 403 | (if gnus-signature-file | ||
| 404 | (expand-file-name gnus-signature-file nil))) | ||
| 405 | (distribution nil) | ||
| 406 | (artbuf (current-buffer)) | ||
| 407 | (tmpbuf (get-buffer-create " *GNUS-posting*"))) | ||
| 408 | (save-excursion | ||
| 409 | (set-buffer tmpbuf) | ||
| 410 | (buffer-flush-undo (current-buffer)) | ||
| 411 | (erase-buffer) | ||
| 412 | (insert-buffer-substring artbuf) | ||
| 413 | ;; Get distribution. | ||
| 414 | (save-restriction | ||
| 415 | (goto-char (point-min)) | ||
| 416 | (search-forward "\n\n") | ||
| 417 | (narrow-to-region (point-min) (point)) | ||
| 418 | (setq distribution (mail-fetch-field "distribution"))) | ||
| 419 | (widen) | ||
| 420 | (if signature | ||
| 421 | (progn | ||
| 422 | ;; Change signature file by distribution. | ||
| 423 | ;; Suggested by hyoko@flab.fujitsu.junet. | ||
| 424 | (if (file-exists-p (concat signature "-" distribution)) | ||
| 425 | (setq signature (concat signature "-" distribution))) | ||
| 426 | ;; Insert signature. | ||
| 427 | (if (file-exists-p signature) | ||
| 428 | (progn | ||
| 429 | (goto-char (point-max)) | ||
| 430 | (insert "--\n") | ||
| 431 | (insert-file-contents signature))) | ||
| 432 | )) | ||
| 433 | ;; Prepare article headers. | ||
| 434 | (save-restriction | ||
| 435 | (goto-char (point-min)) | ||
| 436 | (search-forward "\n\n") | ||
| 437 | (narrow-to-region (point-min) (point)) | ||
| 438 | (gnus-inews-insert-headers) | ||
| 439 | ;; Save author copy of posted article. The article must be | ||
| 440 | ;; copied before being posted because `gnus-request-post' | ||
| 441 | ;; modifies the buffer. | ||
| 442 | (let ((case-fold-search t)) | ||
| 443 | ;; Find and handle any FCC fields. | ||
| 444 | (goto-char (point-min)) | ||
| 445 | (if (re-search-forward "^FCC:" nil t) | ||
| 446 | (gnus-inews-do-fcc)))) | ||
| 447 | (widen) | ||
| 448 | ;; Run final inews hooks. | ||
| 449 | (run-hooks 'gnus-Inews-article-hook) | ||
| 450 | ;; Post an article to NNTP server. | ||
| 451 | ;; Return NIL if post failed. | ||
| 452 | (prog1 | ||
| 453 | (gnus-request-post) | ||
| 454 | (kill-buffer (current-buffer))) | ||
| 455 | ))) | ||
| 456 | |||
| 457 | (defun gnus-inews-do-fcc () | ||
| 458 | "Process FCC: fields." | ||
| 459 | (let ((fcc-list nil) | ||
| 460 | (fcc-file nil) | ||
| 461 | (case-fold-search t)) ;Should ignore case. | ||
| 462 | (save-excursion | ||
| 463 | (save-restriction | ||
| 464 | (goto-char (point-min)) | ||
| 465 | (while (re-search-forward "^FCC:[ \t]*" nil t) | ||
| 466 | (setq fcc-list (cons (buffer-substring (point) | ||
| 467 | (progn | ||
| 468 | (end-of-line) | ||
| 469 | (skip-chars-backward " \t") | ||
| 470 | (point))) | ||
| 471 | fcc-list)) | ||
| 472 | (delete-region (match-beginning 0) | ||
| 473 | (progn (forward-line 1) (point)))) | ||
| 474 | ;; Process FCC operations. | ||
| 475 | (widen) | ||
| 476 | (while fcc-list | ||
| 477 | (setq fcc-file (car fcc-list)) | ||
| 478 | (setq fcc-list (cdr fcc-list)) | ||
| 479 | (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file) | ||
| 480 | (let ((program (substring fcc-file | ||
| 481 | (match-beginning 1) (match-end 1)))) | ||
| 482 | ;; Suggested by yuki@flab.fujitsu.junet. | ||
| 483 | ;; Send article to named program. | ||
| 484 | (call-process-region (point-min) (point-max) shell-file-name | ||
| 485 | nil nil nil "-c" program) | ||
| 486 | )) | ||
| 487 | (t | ||
| 488 | ;; Suggested by hyoko@flab.fujitsu.junet. | ||
| 489 | ;; Save article in Unix mail format by default. | ||
| 490 | (funcall (or gnus-author-copy-saver 'rmail-output) fcc-file) | ||
| 491 | )) | ||
| 492 | ) | ||
| 493 | )) | ||
| 494 | )) | ||
| 495 | |||
| 496 | (defun gnus-inews-insert-headers () | ||
| 497 | "Prepare article headers. | ||
| 498 | Path:, From:, Subject: and Distribution: are generated. | ||
| 499 | Message-ID:, Date: and Organization: are optional." | ||
| 500 | (save-excursion | ||
| 501 | (let ((date (gnus-inews-date)) | ||
| 502 | (message-id (gnus-inews-message-id)) | ||
| 503 | (organization (gnus-inews-organization))) | ||
| 504 | ;; Insert from the top of headers. | ||
| 505 | (goto-char (point-min)) | ||
| 506 | (insert "Path: " (gnus-inews-path) "\n") | ||
| 507 | (insert "From: " (gnus-inews-user-name) "\n") | ||
| 508 | ;; If there is no subject, make Subject: field. | ||
| 509 | (or (mail-fetch-field "subject") | ||
| 510 | (insert "Subject: \n")) | ||
| 511 | ;; Insert random headers. | ||
| 512 | (if message-id | ||
| 513 | (insert "Message-ID: " message-id "\n")) | ||
| 514 | (if date | ||
| 515 | (insert "Date: " date "\n")) | ||
| 516 | (if organization | ||
| 517 | (let ((begin (point)) | ||
| 518 | (fill-column 79) | ||
| 519 | (fill-prefix "\t")) | ||
| 520 | (insert "Organization: " organization "\n") | ||
| 521 | (fill-region-as-paragraph begin (point)))) | ||
| 522 | (or (mail-fetch-field "distribution") | ||
| 523 | (insert "Distribution: \n")) | ||
| 524 | ))) | ||
| 525 | |||
| 526 | (defun gnus-inews-path () | ||
| 527 | "Return uucp path." | ||
| 528 | (let ((login-name (gnus-inews-login-name))) | ||
| 529 | (cond ((null gnus-use-generic-path) | ||
| 530 | (concat gnus-nntp-server "!" login-name)) | ||
| 531 | ((stringp gnus-use-generic-path) | ||
| 532 | ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. | ||
| 533 | (concat gnus-use-generic-path "!" login-name)) | ||
| 534 | (t login-name)) | ||
| 535 | )) | ||
| 536 | |||
| 537 | (defun gnus-inews-user-name () | ||
| 538 | "Return user's network address as `NAME@DOMAIN (FULL NAME)'." | ||
| 539 | (let ((login-name (gnus-inews-login-name)) | ||
| 540 | (full-name (gnus-inews-full-name))) | ||
| 541 | (concat login-name "@" (gnus-inews-domain-name gnus-use-generic-from) | ||
| 542 | ;; User's full name. | ||
| 543 | (cond ((string-equal full-name "") "") | ||
| 544 | ((string-equal full-name "&") ;Unix hack. | ||
| 545 | (concat " (" login-name ")")) | ||
| 546 | (t | ||
| 547 | (concat " (" full-name ")"))) | ||
| 548 | ))) | ||
| 549 | |||
| 550 | (defun gnus-inews-login-name () | ||
| 551 | "Return user login name. | ||
| 552 | Got from the variable `gnus-user-login-name', the environment variables | ||
| 553 | USER and LOGNAME, and the function `user-login-name'." | ||
| 554 | (or gnus-user-login-name | ||
| 555 | (getenv "USER") (getenv "LOGNAME") (user-login-name))) | ||
| 556 | |||
| 557 | (defun gnus-inews-full-name () | ||
| 558 | "Return user full name. | ||
| 559 | Got from the variable `gnus-user-full-name', the environment variable | ||
| 560 | NAME, and the function `user-full-name'." | ||
| 561 | (or gnus-user-full-name | ||
| 562 | (getenv "NAME") (user-full-name))) | ||
| 563 | |||
| 564 | (defun gnus-inews-domain-name (&optional genericfrom) | ||
| 565 | "Return user's domain name. | ||
| 566 | If optional argument GENERICFROM is a string, use it as the domain | ||
| 567 | name; if it is non-nil, strip of local host name from the domain name. | ||
| 568 | If the function `system-name' returns full internet name and the | ||
| 569 | domain is undefined, the domain name is got from it." | ||
| 570 | (let ((domain (or (if (stringp genericfrom) genericfrom) | ||
| 571 | (getenv "DOMAINNAME") | ||
| 572 | gnus-your-domain | ||
| 573 | ;; Function `system-name' may return full internet name. | ||
| 574 | ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>. | ||
| 575 | (if (string-match "\\." (system-name)) | ||
| 576 | (substring (system-name) (match-end 0))) | ||
| 577 | (read-string "Domain name (no host): "))) | ||
| 578 | (host (or (if (string-match "\\." (system-name)) | ||
| 579 | (substring (system-name) 0 (match-beginning 0))) | ||
| 580 | (system-name)))) | ||
| 581 | (if (string-equal "." (substring domain 0 1)) | ||
| 582 | (setq domain (substring domain 1))) | ||
| 583 | (if (null gnus-your-domain) | ||
| 584 | (setq gnus-your-domain domain)) | ||
| 585 | ;; Support GENERICFROM as same as standard Bnews system. | ||
| 586 | ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com. | ||
| 587 | (cond ((null genericfrom) | ||
| 588 | (concat host "." domain)) | ||
| 589 | ;;((stringp genericfrom) genericfrom) | ||
| 590 | (t domain)) | ||
| 591 | )) | ||
| 592 | |||
| 593 | (defun gnus-inews-message-id () | ||
| 594 | "Generate unique Message-ID for user." | ||
| 595 | ;; Message-ID should not contain a slash and should be terminated by | ||
| 596 | ;; a number. I don't know the reason why it is so. | ||
| 597 | (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-domain-name) ">")) | ||
| 598 | |||
| 599 | (defun gnus-inews-unique-id () | ||
| 600 | "Generate unique ID from user name and current time." | ||
| 601 | (let ((date (current-time-string)) | ||
| 602 | (name (gnus-inews-login-name))) | ||
| 603 | (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) [0-9][0-9]\\([0-9][0-9]\\)" | ||
| 604 | date) | ||
| 605 | (concat (upcase name) "." | ||
| 606 | (substring date (match-beginning 6) (match-end 6)) ;Year | ||
| 607 | (substring date (match-beginning 1) (match-end 1)) ;Month | ||
| 608 | (substring date (match-beginning 2) (match-end 2)) ;Day | ||
| 609 | (substring date (match-beginning 3) (match-end 3)) ;Hour | ||
| 610 | (substring date (match-beginning 4) (match-end 4)) ;Minute | ||
| 611 | (substring date (match-beginning 5) (match-end 5)) ;Second | ||
| 612 | ) | ||
| 613 | (error "Cannot understand current-time-string: %s." date)) | ||
| 614 | )) | ||
| 615 | |||
| 616 | (defun gnus-inews-date () | ||
| 617 | "Bnews date format string of today. Time zone is ignored." | ||
| 618 | ;; Insert buggy date (time zone is ignored), but I don't worry about | ||
| 619 | ;; it since inews will rewrite it. | ||
| 620 | (let ((date (current-time-string))) | ||
| 621 | (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9:]+\\) [0-9][0-9]\\([0-9][0-9]\\)" | ||
| 622 | date) | ||
| 623 | (concat (substring date (match-beginning 2) (match-end 2)) ;Day | ||
| 624 | " " | ||
| 625 | (substring date (match-beginning 1) (match-end 1)) ;Month | ||
| 626 | " " | ||
| 627 | (substring date (match-beginning 4) (match-end 4)) ;Year | ||
| 628 | " " | ||
| 629 | (substring date (match-beginning 3) (match-end 3))) ;Time | ||
| 630 | (error "Cannot understand current-time-string: %s." date)) | ||
| 631 | )) | ||
| 632 | |||
| 633 | (defun gnus-inews-organization () | ||
| 634 | "Return user's organization. | ||
| 635 | The ORGANIZATION environment variable is used if defined. | ||
| 636 | If not, the variable `gnus-your-organization' is used instead. | ||
| 637 | If the value begins with a slash, it is taken as the name of a file | ||
| 638 | containing the organization." | ||
| 639 | ;; The organization must be got in this order since the ORGANIZATION | ||
| 640 | ;; environment variable is intended for user specific while | ||
| 641 | ;; gnus-your-organization is for machine or organization specific. | ||
| 642 | (let ((organization (or (getenv "ORGANIZATION") | ||
| 643 | gnus-your-organization | ||
| 644 | (expand-file-name "~/.organization" nil)))) | ||
| 645 | (and (stringp organization) | ||
| 646 | (string-equal (substring organization 0 1) "/") | ||
| 647 | ;; Get it from the user and system file. | ||
| 648 | ;; Suggested by roland@wheaties.ai.mit.edu (Roland McGrath). | ||
| 649 | (let ((dist (mail-fetch-field "distribution"))) | ||
| 650 | (setq organization | ||
| 651 | (cond ((file-exists-p (concat organization "-" dist)) | ||
| 652 | (concat organization "-" dist)) | ||
| 653 | ((file-exists-p organization) organization) | ||
| 654 | ((file-exists-p gnus-organization-file) | ||
| 655 | gnus-organization-file) | ||
| 656 | (t organization))) | ||
| 657 | )) | ||
| 658 | (cond ((not (stringp organization)) nil) | ||
| 659 | ((and (string-equal (substring organization 0 1) "/") | ||
| 660 | (file-exists-p organization)) | ||
| 661 | ;; If the first character is `/', assume it is the name of | ||
| 662 | ;; a file containing the organization. | ||
| 663 | (save-excursion | ||
| 664 | (let ((tmpbuf (get-buffer-create " *GNUS organization*"))) | ||
| 665 | (set-buffer tmpbuf) | ||
| 666 | (erase-buffer) | ||
| 667 | (insert-file-contents organization) | ||
| 668 | (prog1 (buffer-string) | ||
| 669 | (kill-buffer tmpbuf)) | ||
| 670 | ))) | ||
| 671 | (t organization)) | ||
| 672 | )) | ||
diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el new file mode 100644 index 00000000000..7f78c28d970 --- /dev/null +++ b/lisp/progmodes/inf-lisp.el | |||
| @@ -0,0 +1,601 @@ | |||
| 1 | ;;; -*-Emacs-Lisp-*- cmulisp.el | ||
| 2 | ;;; Copyright Olin Shivers (1988). | ||
| 3 | ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright | ||
| 4 | ;;; notice appearing here to the effect that you may use this code any | ||
| 5 | ;;; way you like, as long as you don't charge money for it, remove this | ||
| 6 | ;;; notice, or hold me liable for its results. | ||
| 7 | |||
| 8 | ;;; This replaces the standard inferior-lisp mode. | ||
| 9 | ;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 | ||
| 10 | ;;; Please send me bug reports, bug fixes, and extensions, so that I can | ||
| 11 | ;;; merge them into the master source. | ||
| 12 | ;;; | ||
| 13 | ;;; Change log at end of file. | ||
| 14 | |||
| 15 | ;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top | ||
| 16 | ;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its | ||
| 17 | ;;; counterpart in the standard gnu emacs release. This replacements is more | ||
| 18 | ;;; featureful, robust, and uniform than the released version. The key | ||
| 19 | ;;; bindings are also more compatible with the bindings of Hemlock and Zwei | ||
| 20 | ;;; (the Lisp Machine emacs). | ||
| 21 | |||
| 22 | ;;; Since this mode is built on top of the general command-interpreter-in- | ||
| 23 | ;;; a-buffer mode (comint mode), it shares a common base functionality, | ||
| 24 | ;;; and a common set of bindings, with all modes derived from comint mode. | ||
| 25 | ;;; This makes these modes easier to use. | ||
| 26 | |||
| 27 | ;;; For documentation on the functionality provided by comint mode, and | ||
| 28 | ;;; the hooks available for customising it, see the file comint.el. | ||
| 29 | ;;; For further information on cmulisp mode, see the comments below. | ||
| 30 | |||
| 31 | ;;; Needs fixin: | ||
| 32 | ;;; The load-file/compile-file default mechanism could be smarter -- it | ||
| 33 | ;;; doesn't know about the relationship between filename extensions and | ||
| 34 | ;;; whether the file is source or executable. If you compile foo.lisp | ||
| 35 | ;;; with compile-file, then the next load-file should use foo.bin for | ||
| 36 | ;;; the default, not foo.lisp. This is tricky to do right, particularly | ||
| 37 | ;;; because the extension for executable files varies so much (.o, .bin, | ||
| 38 | ;;; .lbin, .mo, .vo, .ao, ...). | ||
| 39 | ;;; | ||
| 40 | ;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes | ||
| 41 | ;;; had a verbose minor mode wherein sending or compiling defuns, etc. | ||
| 42 | ;;; would be reflected in the transcript with suitable comments, e.g. | ||
| 43 | ;;; ";;; redefining fact". Several ways to do this. Which is right? | ||
| 44 | ;;; | ||
| 45 | ;;; When sending text from a source file to a subprocess, the process-mark can | ||
| 46 | ;;; move off the window, so you can lose sight of the process interactions. | ||
| 47 | ;;; Maybe I should ensure the process mark is in the window when I send | ||
| 48 | ;;; text to the process? Switch selectable? | ||
| 49 | |||
| 50 | (require 'comint) | ||
| 51 | (provide 'cmulisp) | ||
| 52 | |||
| 53 | ;; YOUR .EMACS FILE | ||
| 54 | ;;============================================================================= | ||
| 55 | ;; Some suggestions for your .emacs file. | ||
| 56 | ;; | ||
| 57 | ;; ; If cmulisp lives in some non-standard directory, you must tell emacs | ||
| 58 | ;; ; where to get it. This may or may not be necessary. | ||
| 59 | ;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) | ||
| 60 | ;; | ||
| 61 | ;; ; Autoload cmulisp from file cmulisp.el | ||
| 62 | ;; (autoload 'cmulisp "cmulisp" | ||
| 63 | ;; "Run an inferior Lisp process." | ||
| 64 | ;; t) | ||
| 65 | ;; | ||
| 66 | ;; ; Define C-c t to run my favorite command in cmulisp mode: | ||
| 67 | ;; (setq cmulisp-load-hook | ||
| 68 | ;; '((lambda () | ||
| 69 | ;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd)))) | ||
| 70 | |||
| 71 | |||
| 72 | ;;; Brief Command Documentation: | ||
| 73 | ;;;============================================================================ | ||
| 74 | ;;; Comint Mode Commands: (common to cmulisp and all comint-derived modes) | ||
| 75 | ;;; | ||
| 76 | ;;; m-p comint-previous-input Cycle backwards in input history | ||
| 77 | ;;; m-n comint-next-input Cycle forwards | ||
| 78 | ;;; m-c-r comint-previous-input-matching Search backwards in input history | ||
| 79 | ;;; return comint-send-input | ||
| 80 | ;;; c-a comint-bol Beginning of line; skip prompt. | ||
| 81 | ;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. | ||
| 82 | ;;; c-c c-u comint-kill-input ^u | ||
| 83 | ;;; c-c c-w backward-kill-word ^w | ||
| 84 | ;;; c-c c-c comint-interrupt-subjob ^c | ||
| 85 | ;;; c-c c-z comint-stop-subjob ^z | ||
| 86 | ;;; c-c c-\ comint-quit-subjob ^\ | ||
| 87 | ;;; c-c c-o comint-kill-output Delete last batch of process output | ||
| 88 | ;;; c-c c-r comint-show-output Show last batch of process output | ||
| 89 | ;;; send-invisible Read line w/o echo & send to proc | ||
| 90 | ;;; comint-continue-subjob Useful if you accidentally suspend | ||
| 91 | ;;; top-level job. | ||
| 92 | ;;; comint-mode-hook is the comint mode hook. | ||
| 93 | |||
| 94 | ;;; CMU Lisp Mode Commands: | ||
| 95 | ;;; c-m-x lisp-send-defun This binding is a gnu convention. | ||
| 96 | ;;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it. | ||
| 97 | ;;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it. | ||
| 98 | ;;; Filename completion is available, of course. | ||
| 99 | ;;; | ||
| 100 | ;;; Additionally, these commands are added to the key bindings of Lisp mode: | ||
| 101 | ;;; c-m-x lisp-eval-defun This binding is a gnu convention. | ||
| 102 | ;;; c-c c-e lisp-eval-defun Send the current defun to Lisp process. | ||
| 103 | ;;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process. | ||
| 104 | ;;; c-c m-e lisp-eval-defun-and-go After sending the defun, switch-to-lisp. | ||
| 105 | ;;; c-c c-r lisp-eval-region Send the current region to Lisp process. | ||
| 106 | ;;; c-c m-r lisp-eval-region-and-go After sending the region, switch-to-lisp. | ||
| 107 | ;;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process. | ||
| 108 | ;;; c-c m-c lisp-compile-defun-and-go After compiling defun, switch-to-lisp. | ||
| 109 | ;;; c-c c-z switch-to-lisp Switch to the Lisp process buffer. | ||
| 110 | ;;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default | ||
| 111 | ;;; c-c c-k lisp-compile-file is to load/compile the current file.) | ||
| 112 | ;;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description. | ||
| 113 | ;;; c-c c-a lisp-show-arglist Query Lisp for function's arglist. | ||
| 114 | ;;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc. | ||
| 115 | ;;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc. | ||
| 116 | |||
| 117 | ;;; cmulisp Fires up the Lisp process. | ||
| 118 | ;;; lisp-compile-region Compile all forms in the current region. | ||
| 119 | ;;; lisp-compile-region-and-go After compiling region, switch-to-lisp. | ||
| 120 | ;;; | ||
| 121 | ;;; CMU Lisp Mode Variables: | ||
| 122 | ;;; cmulisp-filter-regexp Match this => don't get saved on input hist | ||
| 123 | ;;; inferior-lisp-program Name of Lisp program run-lisp executes | ||
| 124 | ;;; inferior-lisp-load-command Customises lisp-load-file | ||
| 125 | ;;; cmulisp-mode-hook | ||
| 126 | ;;; inferior-lisp-prompt Initialises comint-prompt-regexp. | ||
| 127 | ;;; Backwards compatibility. | ||
| 128 | ;;; lisp-source-modes Anything loaded into a buffer that's in | ||
| 129 | ;;; one of these modes is considered Lisp | ||
| 130 | ;;; source by lisp-load/compile-file. | ||
| 131 | |||
| 132 | ;;; Read the rest of this file for more information. | ||
| 133 | |||
| 134 | (defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" | ||
| 135 | "*What not to save on inferior Lisp's input history | ||
| 136 | Input matching this regexp is not saved on the input history in cmulisp | ||
| 137 | mode. Default is whitespace followed by 0 or 1 single-letter :keyword | ||
| 138 | (as in :a, :c, etc.)") | ||
| 139 | |||
| 140 | (defvar cmulisp-mode-map nil) | ||
| 141 | (cond ((not cmulisp-mode-map) | ||
| 142 | (setq cmulisp-mode-map | ||
| 143 | (full-copy-sparse-keymap comint-mode-map)) | ||
| 144 | (lisp-mode-commands cmulisp-mode-map) | ||
| 145 | (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) | ||
| 146 | (define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file) | ||
| 147 | (define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file) | ||
| 148 | (define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist) | ||
| 149 | (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym) | ||
| 150 | (define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) | ||
| 151 | (define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation))) | ||
| 152 | |||
| 153 | ;;; These commands augment Lisp mode, so you can process Lisp code in | ||
| 154 | ;;; the source files. | ||
| 155 | (define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention | ||
| 156 | (define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention | ||
| 157 | (define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) | ||
| 158 | (define-key lisp-mode-map "\C-c\M-e" 'lisp-eval-defun-and-go) | ||
| 159 | (define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) | ||
| 160 | (define-key lisp-mode-map "\C-c\M-r" 'lisp-eval-region-and-go) | ||
| 161 | (define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) | ||
| 162 | (define-key lisp-mode-map "\C-c\M-c" 'lisp-compile-defun-and-go) | ||
| 163 | (define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) | ||
| 164 | (define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) | ||
| 165 | (define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file | ||
| 166 | (define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) | ||
| 167 | (define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) | ||
| 168 | (define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) | ||
| 169 | (define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) | ||
| 170 | |||
| 171 | |||
| 172 | (defvar inferior-lisp-program "lisp" | ||
| 173 | "*Program name for invoking an inferior Lisp with `cmulisp'.") | ||
| 174 | |||
| 175 | (defvar inferior-lisp-load-command "(load \"%s\")\n" | ||
| 176 | "*Format-string for building a Lisp expression to load a file. | ||
| 177 | This format string should use %s to substitute a file name | ||
| 178 | and should result in a Lisp expression that will command the inferior Lisp | ||
| 179 | to load that file. The default works acceptably on most Lisps. | ||
| 180 | The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\" | ||
| 181 | produces cosmetically superior output for this application, | ||
| 182 | but it works only in Common Lisp.") | ||
| 183 | |||
| 184 | (defvar inferior-lisp-prompt "^[^> ]*>+:? *" | ||
| 185 | "Regexp to recognise prompts in the inferior Lisp. | ||
| 186 | Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl, | ||
| 187 | and franz. This variable is used to initialise comint-prompt-regexp in the | ||
| 188 | cmulisp buffer. | ||
| 189 | |||
| 190 | More precise choices: | ||
| 191 | Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" | ||
| 192 | franz: \"^\\(->\\|<[0-9]*>:\\) *\" | ||
| 193 | kcl: \"^>+ *\" | ||
| 194 | |||
| 195 | This is a fine thing to set in your .emacs file.") | ||
| 196 | |||
| 197 | (defvar cmulisp-mode-hook '() | ||
| 198 | "*Hook for customising cmulisp mode") | ||
| 199 | |||
| 200 | (defun cmulisp-mode () | ||
| 201 | "Major mode for interacting with an inferior Lisp process. | ||
| 202 | Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an | ||
| 203 | Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter | ||
| 204 | is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and | ||
| 205 | inferior-lisp-load-command can customize this mode for different Lisp | ||
| 206 | interpreters. | ||
| 207 | |||
| 208 | For information on running multiple processes in multiple buffers, see | ||
| 209 | documentation for variable cmulisp-buffer. | ||
| 210 | |||
| 211 | \\{cmulisp-mode-map} | ||
| 212 | |||
| 213 | Customisation: Entry to this mode runs the hooks on comint-mode-hook and | ||
| 214 | cmulisp-mode-hook (in that order). | ||
| 215 | |||
| 216 | You can send text to the inferior Lisp process from other buffers containing | ||
| 217 | Lisp source. | ||
| 218 | switch-to-lisp switches the current buffer to the Lisp process buffer. | ||
| 219 | lisp-eval-defun sends the current defun to the Lisp process. | ||
| 220 | lisp-compile-defun compiles the current defun. | ||
| 221 | lisp-eval-region sends the current region to the Lisp process. | ||
| 222 | lisp-compile-region compiles the current region. | ||
| 223 | |||
| 224 | lisp-eval-defun-and-go, lisp-compile-defun-and-go, | ||
| 225 | lisp-eval-region-and-go, and lisp-compile-region-and-go | ||
| 226 | switch to the Lisp process buffer after sending their text. | ||
| 227 | |||
| 228 | Commands: | ||
| 229 | Return after the end of the process' output sends the text from the | ||
| 230 | end of process to point. | ||
| 231 | Return before the end of the process' output copies the sexp ending at point | ||
| 232 | to the end of the process' output, and sends it. | ||
| 233 | Delete converts tabs to spaces as it moves back. | ||
| 234 | Tab indents for Lisp; with argument, shifts rest | ||
| 235 | of expression rigidly with the current line. | ||
| 236 | C-M-q does Tab on each line starting within following expression. | ||
| 237 | Paragraphs are separated only by blank lines. Semicolons start comments. | ||
| 238 | If you accidentally suspend your process, use \\[comint-continue-subjob] | ||
| 239 | to continue it." | ||
| 240 | (interactive) | ||
| 241 | (comint-mode) | ||
| 242 | (setq comint-prompt-regexp inferior-lisp-prompt) | ||
| 243 | (setq major-mode 'cmulisp-mode) | ||
| 244 | (setq mode-name "CMU Lisp") | ||
| 245 | (setq mode-line-process '(": %s")) | ||
| 246 | (if (string-match "^18.4" emacs-version) ; hack. | ||
| 247 | (lisp-mode-variables) ; This is right for 18.49 | ||
| 248 | (lisp-mode-variables t)) ; This is right for 18.50 | ||
| 249 | (use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file | ||
| 250 | (setq comint-get-old-input (function lisp-get-old-input)) | ||
| 251 | (setq comint-input-filter (function lisp-input-filter)) | ||
| 252 | (setq comint-input-sentinel 'ignore) | ||
| 253 | (run-hooks 'cmulisp-mode-hook)) | ||
| 254 | |||
| 255 | (defun lisp-get-old-input () | ||
| 256 | "Snarf the sexp ending at point" | ||
| 257 | (save-excursion | ||
| 258 | (let ((end (point))) | ||
| 259 | (backward-sexp) | ||
| 260 | (buffer-substring (point) end)))) | ||
| 261 | |||
| 262 | (defun lisp-input-filter (str) | ||
| 263 | "Don't save anything matching cmulisp-filter-regexp" | ||
| 264 | (not (string-match cmulisp-filter-regexp str))) | ||
| 265 | |||
| 266 | (defun cmulisp () | ||
| 267 | "Run an inferior Lisp process, input and output via buffer *cmulisp*. | ||
| 268 | If there is a process already running in *cmulisp*, just switch to that buffer. | ||
| 269 | Takes the program name from the variable inferior-lisp-program. | ||
| 270 | \(Type \\[describe-mode] in the process buffer for a list of commands.)" | ||
| 271 | (interactive) | ||
| 272 | (cond ((not (comint-check-proc "*cmulisp*")) | ||
| 273 | (set-buffer (make-comint "cmulisp" inferior-lisp-program)) | ||
| 274 | (cmulisp-mode))) | ||
| 275 | (setq cmulisp-buffer "*cmulisp*") | ||
| 276 | (switch-to-buffer "*cmulisp*")) | ||
| 277 | |||
| 278 | (defun lisp-eval-region (start end) | ||
| 279 | "Send the current region to the inferior Lisp process." | ||
| 280 | (interactive "r") | ||
| 281 | (comint-send-region (cmulisp-proc) start end) | ||
| 282 | (comint-send-string (cmulisp-proc) "\n")) | ||
| 283 | |||
| 284 | (defun lisp-eval-defun () | ||
| 285 | "Send the current defun to the inferior Lisp process." | ||
| 286 | (interactive) | ||
| 287 | (save-excursion | ||
| 288 | (end-of-defun) | ||
| 289 | (let ((end (point))) | ||
| 290 | (beginning-of-defun) | ||
| 291 | (lisp-eval-region (point) end)))) | ||
| 292 | |||
| 293 | (defun lisp-eval-last-sexp () | ||
| 294 | "Send the previous sexp to the inferior Lisp process." | ||
| 295 | (interactive) | ||
| 296 | (lisp-eval-region (save-excursion (backward-sexp) (point)) (point))) | ||
| 297 | |||
| 298 | ;;; CommonLisp COMPILE sux. | ||
| 299 | (defun lisp-compile-region (start end) | ||
| 300 | "Compile the current region in the inferior Lisp process." | ||
| 301 | (interactive "r") | ||
| 302 | (comint-send-string (cmulisp-proc) | ||
| 303 | (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" | ||
| 304 | (buffer-substring start end)))) | ||
| 305 | |||
| 306 | (defun lisp-compile-defun () | ||
| 307 | "Compile the current defun in the inferior Lisp process." | ||
| 308 | (interactive) | ||
| 309 | (save-excursion | ||
| 310 | (end-of-defun) | ||
| 311 | (let ((e (point))) | ||
| 312 | (beginning-of-defun) | ||
| 313 | (lisp-compile-region (point) e)))) | ||
| 314 | |||
| 315 | (defun switch-to-lisp (eob-p) | ||
| 316 | "Switch to the inferior Lisp process buffer. | ||
| 317 | With argument, positions cursor at end of buffer." | ||
| 318 | (interactive "P") | ||
| 319 | (if (get-buffer cmulisp-buffer) | ||
| 320 | (pop-to-buffer cmulisp-buffer) | ||
| 321 | (error "No current process buffer. See variable cmulisp-buffer.")) | ||
| 322 | (cond (eob-p | ||
| 323 | (push-mark) | ||
| 324 | (goto-char (point-max))))) | ||
| 325 | |||
| 326 | (defun lisp-eval-region-and-go (start end) | ||
| 327 | "Send the current region to the inferior Lisp, | ||
| 328 | and switch to the process buffer." | ||
| 329 | (interactive "r") | ||
| 330 | (lisp-eval-region start end) | ||
| 331 | (switch-to-lisp t)) | ||
| 332 | |||
| 333 | (defun lisp-eval-defun-and-go () | ||
| 334 | "Send the current defun to the inferior Lisp, | ||
| 335 | and switch to the process buffer." | ||
| 336 | (interactive) | ||
| 337 | (lisp-eval-defun) | ||
| 338 | (switch-to-lisp t)) | ||
| 339 | |||
| 340 | (defun lisp-compile-region-and-go (start end) | ||
| 341 | "Compile the current region in the inferior Lisp, | ||
| 342 | and switch to the process buffer." | ||
| 343 | (interactive "r") | ||
| 344 | (lisp-compile-region start end) | ||
| 345 | (switch-to-lisp t)) | ||
| 346 | |||
| 347 | (defun lisp-compile-defun-and-go () | ||
| 348 | "Compile the current defun in the inferior Lisp, | ||
| 349 | and switch to the process buffer." | ||
| 350 | (interactive) | ||
| 351 | (lisp-compile-defun) | ||
| 352 | (switch-to-lisp t)) | ||
| 353 | |||
| 354 | ;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. | ||
| 355 | ;(defun lisp-compile-sexp (start end) | ||
| 356 | ; "Compile the s-expression bounded by START and END in the inferior lisp. | ||
| 357 | ;If the sexp isn't a DEFUN form, it is evaluated instead." | ||
| 358 | ; (cond ((looking-at "(defun\\s +") | ||
| 359 | ; (goto-char (match-end 0)) | ||
| 360 | ; (let ((name-start (point))) | ||
| 361 | ; (forward-sexp 1) | ||
| 362 | ; (process-send-string "cmulisp" (format "(compile '%s #'(lambda " | ||
| 363 | ; (buffer-substring name-start | ||
| 364 | ; (point))))) | ||
| 365 | ; (let ((body-start (point))) | ||
| 366 | ; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. | ||
| 367 | ; (process-send-region "cmulisp" (buffer-substring body-start (point)))) | ||
| 368 | ; (process-send-string "cmulisp" ")\n")) | ||
| 369 | ; (t (lisp-eval-region start end))))) | ||
| 370 | ; | ||
| 371 | ;(defun lisp-compile-region (start end) | ||
| 372 | ; "Each s-expression in the current region is compiled (if a DEFUN) | ||
| 373 | ;or evaluated (if not) in the inferior lisp." | ||
| 374 | ; (interactive "r") | ||
| 375 | ; (save-excursion | ||
| 376 | ; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check | ||
| 377 | ; (if (< (point) start) (error "region begins in middle of defun")) | ||
| 378 | ; (goto-char start) | ||
| 379 | ; (let ((s start)) | ||
| 380 | ; (end-of-defun) | ||
| 381 | ; (while (<= (point) end) ; Zip through | ||
| 382 | ; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. | ||
| 383 | ; (setq s (point)) | ||
| 384 | ; (end-of-defun)) | ||
| 385 | ; (if (< s end) (lisp-compile-sexp s end))))) | ||
| 386 | ;;; | ||
| 387 | ;;; End of HS-style code | ||
| 388 | |||
| 389 | |||
| 390 | (defvar lisp-prev-l/c-dir/file nil | ||
| 391 | "Saves the (directory . file) pair used in the last lisp-load-file or | ||
| 392 | lisp-compile-file command. Used for determining the default in the | ||
| 393 | next one.") | ||
| 394 | |||
| 395 | (defvar lisp-source-modes '(lisp-mode) | ||
| 396 | "*Used to determine if a buffer contains Lisp source code. | ||
| 397 | If it's loaded into a buffer that is in one of these major modes, it's | ||
| 398 | considered a Lisp source file by lisp-load-file and lisp-compile-file. | ||
| 399 | Used by these commands to determine defaults.") | ||
| 400 | |||
| 401 | (defun lisp-load-file (file-name) | ||
| 402 | "Load a Lisp file into the inferior Lisp process." | ||
| 403 | (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file | ||
| 404 | lisp-source-modes nil)) ; NIL because LOAD | ||
| 405 | ; doesn't need an exact name | ||
| 406 | (comint-check-source file-name) ; Check to see if buffer needs saved. | ||
| 407 | (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) | ||
| 408 | (file-name-nondirectory file-name))) | ||
| 409 | (comint-send-string (cmulisp-proc) | ||
| 410 | (format inferior-lisp-load-command file-name))) | ||
| 411 | |||
| 412 | |||
| 413 | (defun lisp-compile-file (file-name) | ||
| 414 | "Compile a Lisp file in the inferior Lisp process." | ||
| 415 | (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file | ||
| 416 | lisp-source-modes nil)) ; NIL = don't need | ||
| 417 | ; suffix .lisp | ||
| 418 | (comint-check-source file-name) ; Check to see if buffer needs saved. | ||
| 419 | (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) | ||
| 420 | (file-name-nondirectory file-name))) | ||
| 421 | (comint-send-string (cmulisp-proc) (concat "(compile-file \"" | ||
| 422 | file-name | ||
| 423 | "\"\)\n"))) | ||
| 424 | |||
| 425 | |||
| 426 | |||
| 427 | ;;; Documentation functions: function doc, var doc, arglist, and | ||
| 428 | ;;; describe symbol. | ||
| 429 | ;;; =========================================================================== | ||
| 430 | |||
| 431 | ;;; Command strings | ||
| 432 | ;;; =============== | ||
| 433 | |||
| 434 | (defvar lisp-function-doc-command | ||
| 435 | "(let ((fn '%s)) | ||
| 436 | (format t \"Documentation for ~a:~&~a\" | ||
| 437 | fn (documentation fn 'function)) | ||
| 438 | (values))\n" | ||
| 439 | "Command to query inferior Lisp for a function's documentation.") | ||
| 440 | |||
| 441 | (defvar lisp-var-doc-command | ||
| 442 | "(let ((v '%s)) | ||
| 443 | (format t \"Documentation for ~a:~&~a\" | ||
| 444 | v (documentation v 'variable)) | ||
| 445 | (values))\n" | ||
| 446 | "Command to query inferior Lisp for a variable's documentation.") | ||
| 447 | |||
| 448 | (defvar lisp-arglist-command | ||
| 449 | "(let ((fn '%s)) | ||
| 450 | (format t \"Arglist for ~a: ~a\" fn (arglist fn)) | ||
| 451 | (values))\n" | ||
| 452 | "Command to query inferior Lisp for a function's arglist.") | ||
| 453 | |||
| 454 | (defvar lisp-describe-sym-command | ||
| 455 | "(describe '%s)\n" | ||
| 456 | "Command to query inferior Lisp for a variable's documentation.") | ||
| 457 | |||
| 458 | |||
| 459 | ;;; Ancillary functions | ||
| 460 | ;;; =================== | ||
| 461 | |||
| 462 | ;;; Reads a string from the user. | ||
| 463 | (defun lisp-symprompt (prompt default) | ||
| 464 | (list (let* ((prompt (if default | ||
| 465 | (format "%s (default %s): " prompt default) | ||
| 466 | (concat prompt ": "))) | ||
| 467 | (ans (read-string prompt))) | ||
| 468 | (if (zerop (length ans)) default ans)))) | ||
| 469 | |||
| 470 | |||
| 471 | ;;; Adapted from function-called-at-point in help.el. | ||
| 472 | (defun lisp-fn-called-at-pt () | ||
| 473 | "Returns the name of the function called in the current call. | ||
| 474 | Nil if it can't find one." | ||
| 475 | (condition-case nil | ||
| 476 | (save-excursion | ||
| 477 | (save-restriction | ||
| 478 | (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) | ||
| 479 | (backward-up-list 1) | ||
| 480 | (forward-char 1) | ||
| 481 | (let ((obj (read (current-buffer)))) | ||
| 482 | (and (symbolp obj) obj)))) | ||
| 483 | (error nil))) | ||
| 484 | |||
| 485 | |||
| 486 | ;;; Adapted from variable-at-point in help.el. | ||
| 487 | (defun lisp-var-at-pt () | ||
| 488 | (condition-case () | ||
| 489 | (save-excursion | ||
| 490 | (forward-sexp -1) | ||
| 491 | (skip-chars-forward "'") | ||
| 492 | (let ((obj (read (current-buffer)))) | ||
| 493 | (and (symbolp obj) obj))) | ||
| 494 | (error nil))) | ||
| 495 | |||
| 496 | |||
| 497 | ;;; Documentation functions: fn and var doc, arglist, and symbol describe. | ||
| 498 | ;;; ====================================================================== | ||
| 499 | |||
| 500 | (defun lisp-show-function-documentation (fn) | ||
| 501 | "Send a command to the inferior Lisp to give documentation for function FN. | ||
| 502 | See variable lisp-function-doc-command." | ||
| 503 | (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) | ||
| 504 | (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn))) | ||
| 505 | |||
| 506 | (defun lisp-show-variable-documentation (var) | ||
| 507 | "Send a command to the inferior Lisp to give documentation for function FN. | ||
| 508 | See variable lisp-var-doc-command." | ||
| 509 | (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) | ||
| 510 | (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var))) | ||
| 511 | |||
| 512 | (defun lisp-show-arglist (fn) | ||
| 513 | "Sends an query to the inferior Lisp for the arglist for function FN. | ||
| 514 | See variable lisp-arglist-command." | ||
| 515 | (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) | ||
| 516 | (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn))) | ||
| 517 | |||
| 518 | (defun lisp-describe-sym (sym) | ||
| 519 | "Send a command to the inferior Lisp to describe symbol SYM. | ||
| 520 | See variable lisp-describe-sym-command." | ||
| 521 | (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) | ||
| 522 | (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym))) | ||
| 523 | |||
| 524 | |||
| 525 | (defvar cmulisp-buffer nil "*The current cmulisp process buffer. | ||
| 526 | |||
| 527 | MULTIPLE PROCESS SUPPORT | ||
| 528 | =========================================================================== | ||
| 529 | Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp | ||
| 530 | processes. To run multiple Lisp processes, you start the first up with | ||
| 531 | \\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer | ||
| 532 | with \\[rename-buffer]. You may now start up a new process with another | ||
| 533 | \\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can | ||
| 534 | switch between the different process buffers with \\[switch-to-buffer]. | ||
| 535 | |||
| 536 | Commands that send text from source buffers to Lisp processes -- | ||
| 537 | like lisp-eval-defun or lisp-show-arglist -- have to choose a process | ||
| 538 | to send to, when you have more than one Lisp process around. This | ||
| 539 | is determined by the global variable cmulisp-buffer. Suppose you | ||
| 540 | have three inferior lisps running: | ||
| 541 | Buffer Process | ||
| 542 | foo cmulisp | ||
| 543 | bar cmulisp<2> | ||
| 544 | *cmulisp* cmulisp<3> | ||
| 545 | If you do a \\[lisp-eval-defun-and-go] command on some Lisp source code, | ||
| 546 | what process do you send it to? | ||
| 547 | |||
| 548 | - If you're in a process buffer (foo, bar, or *cmulisp*), | ||
| 549 | you send it to that process. | ||
| 550 | - If you're in some other buffer (e.g., a source file), you | ||
| 551 | send it to the process attached to buffer cmulisp-buffer. | ||
| 552 | This process selection is performed by function cmulisp-proc. | ||
| 553 | |||
| 554 | Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer | ||
| 555 | to be the new process's buffer. If you only run one process, this will | ||
| 556 | do the right thing. If you run multiple processes, you can change | ||
| 557 | cmulisp-buffer to another process buffer with \\[set-variable]. | ||
| 558 | |||
| 559 | More sophisticated approaches are, of course, possible. If you find youself | ||
| 560 | needing to switch back and forth between multiple processes frequently, | ||
| 561 | you may wish to consider ilisp.el, a larger, more sophisticated package | ||
| 562 | for running inferior Lisp processes. The approach taken here is for a | ||
| 563 | minimal, simple implementation. Feel free to extend it.") | ||
| 564 | |||
| 565 | (defun cmulisp-proc () | ||
| 566 | "Returns the current cmulisp process. See variable cmulisp-buffer." | ||
| 567 | (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) | ||
| 568 | (current-buffer) | ||
| 569 | cmulisp-buffer)))) | ||
| 570 | (or proc | ||
| 571 | (error "No current process. See variable cmulisp-buffer")))) | ||
| 572 | |||
| 573 | |||
| 574 | ;;; Do the user's customisation... | ||
| 575 | ;;;=============================== | ||
| 576 | (defvar cmulisp-load-hook nil | ||
| 577 | "This hook is run when cmulisp is loaded in. | ||
| 578 | This is a good place to put keybindings.") | ||
| 579 | |||
| 580 | (run-hooks 'cmulisp-load-hook) | ||
| 581 | |||
| 582 | ;;; CHANGE LOG | ||
| 583 | ;;; =========================================================================== | ||
| 584 | ;;; 5/24/90 Olin | ||
| 585 | ;;; - Split cmulisp and cmushell modes into separate files. | ||
| 586 | ;;; Not only is this a good idea, it's apparently the way it'll be rel 19. | ||
| 587 | ;;; - Upgraded process sends to use comint-send-string instead of | ||
| 588 | ;;; process-send-string. | ||
| 589 | ;;; - Explicit references to process "cmulisp" have been replaced with | ||
| 590 | ;;; (cmulisp-proc). This allows better handling of multiple process bufs. | ||
| 591 | ;;; - Added process query and var/function/symbol documentation | ||
| 592 | ;;; commands. Based on code written by Douglas Roberts. | ||
| 593 | ;;; - Added lisp-eval-last-sexp, bound to C-x C-e. | ||
| 594 | ;;; | ||
| 595 | ;;; 9/20/90 Olin | ||
| 596 | ;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix | ||
| 597 | ;;; reported by Lennart Staflin. | ||
| 598 | ;;; | ||
| 599 | ;;; 3/12/90 Olin | ||
| 600 | ;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. | ||
| 601 | ;;; Tale suggested this. | ||