Mercurial > emacs
changeset 267:d83efd759350
Initial revision
| author | Jim Blandy <jimb@redhat.com> |
|---|---|
| date | Mon, 13 May 1991 21:21:58 +0000 |
| parents | e0142855e083 |
| children | 2dd411fe2f72 |
| files | lisp/=gnuspost.el lisp/cmuscheme.el lisp/dabbrev.el lisp/progmodes/inf-lisp.el |
| diffstat | 4 files changed, 1961 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=gnuspost.el Mon May 13 21:21:58 1991 +0000 @@ -0,0 +1,672 @@ +;;; Post news commands for GNUS newsreader +;; Copyright (C) 1989 Fujitsu Laboratories LTD. +;; Copyright (C) 1989, 1990 Masanobu UMEDA +;; $Header: gnuspost.el,v 1.2 90/03/23 13:25:16 umerin Locked $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +(provide 'gnuspost) +(require 'gnus) + +(defvar gnus-organization-file "/usr/lib/news/organization" + "*Local news organization file.") + +(defvar gnus-post-news-buffer "*post-news*") +(defvar gnus-winconf-post-news nil) + +(autoload 'news-reply-mode "rnewspost") + +;;; Post news commands of GNUS Group Mode and Subject Mode + +(defun gnus-Group-post-news () + "Post an article." + (interactive) + ;; Save window configuration. + (setq gnus-winconf-post-news (current-window-configuration)) + (unwind-protect + (gnus-post-news) + (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) + (not (zerop (buffer-size)))) + ;; Restore last window configuration. + (set-window-configuration gnus-winconf-post-news))) + ;; We don't want to return to Subject buffer nor Article buffer later. + (if (get-buffer gnus-Subject-buffer) + (bury-buffer gnus-Subject-buffer)) + (if (get-buffer gnus-Article-buffer) + (bury-buffer gnus-Article-buffer))) + +(defun gnus-Subject-post-news () + "Post an article." + (interactive) + (gnus-Subject-select-article t nil) + ;; Save window configuration. + (setq gnus-winconf-post-news (current-window-configuration)) + (unwind-protect + (progn + (switch-to-buffer gnus-Article-buffer) + (widen) + (delete-other-windows) + (gnus-post-news)) + (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) + (not (zerop (buffer-size)))) + ;; Restore last window configuration. + (set-window-configuration gnus-winconf-post-news))) + ;; We don't want to return to Article buffer later. + (bury-buffer gnus-Article-buffer)) + +(defun gnus-Subject-post-reply (yank) + "Post a reply article. +If prefix argument YANK is non-nil, original article is yanked automatically." + (interactive "P") + (gnus-Subject-select-article t nil) + ;; Check Followup-To: poster. + (set-buffer gnus-Article-buffer) + (if (and gnus-use-followup-to + (string-equal "poster" (gnus-fetch-field "followup-to")) + (or (not (eq gnus-use-followup-to t)) + (not (y-or-n-p "Do you want to ignore `Followup-To: poster'? ")))) + ;; Mail to the poster. GNUS is now RFC1036 compliant. + (gnus-Subject-mail-reply yank) + ;; Save window configuration. + (setq gnus-winconf-post-news (current-window-configuration)) + (unwind-protect + (progn + (switch-to-buffer gnus-Article-buffer) + (widen) + (delete-other-windows) + (gnus-news-reply yank)) + (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) + (not (zerop (buffer-size)))) + ;; Restore last window configuration. + (set-window-configuration gnus-winconf-post-news))) + ;; We don't want to return to Article buffer later. + (bury-buffer gnus-Article-buffer))) + +(defun gnus-Subject-post-reply-with-original () + "Post a reply article with original article." + (interactive) + (gnus-Subject-post-reply t)) + +(defun gnus-Subject-cancel-article () + "Cancel an article you posted." + (interactive) + (gnus-Subject-select-article t nil) + (gnus-eval-in-buffer-window gnus-Article-buffer + (gnus-cancel-news))) + + +;;; Post a News using NNTP + +;;;###autoload +(fset 'sendnews 'gnus-post-news) +;;;###autoload +(fset 'postnews 'gnus-post-news) +;;;###autoload +(defun gnus-post-news () + "Begin editing a new USENET news article to be posted. +Type \\[describe-mode] once editing the article to get a list of commands." + (interactive) + (if (or (not gnus-novice-user) + (y-or-n-p "Are you sure you want to post to all of USENET? ")) + (let ((artbuf (current-buffer)) + (newsgroups ;Default newsgroup. + (if (eq major-mode 'gnus-Article-mode) gnus-newsgroup-name)) + (subject nil) + (distribution nil)) + (save-restriction + (and (not (zerop (buffer-size))) + ;;(equal major-mode 'news-mode) + (equal major-mode 'gnus-Article-mode) + (progn + ;;(news-show-all-headers) + (gnus-Article-show-all-headers) + (narrow-to-region (point-min) + (progn (goto-char (point-min)) + (search-forward "\n\n") + (point))))) + (setq news-reply-yank-from (mail-fetch-field "from")) + (setq news-reply-yank-message-id (mail-fetch-field "message-id"))) + (pop-to-buffer gnus-post-news-buffer) + (news-reply-mode) + (gnus-overload-functions) + (if (and (buffer-modified-p) + (> (buffer-size) 0) + (not (y-or-n-p "Unsent article being composed; erase it? "))) + ;; Continue composition. + ;; Make news-reply-yank-original work on the current article. + (setq mail-reply-buffer artbuf) + (erase-buffer) + (if gnus-interactive-post + ;; Newsgroups, subject and distribution are asked for. + ;; Suggested by yuki@flab.fujitsu.junet. + (progn + ;; Subscribed newsgroup names are required for + ;; completing read of newsgroup. + (or gnus-newsrc-assoc + (gnus-read-newsrc-file)) + ;; Which do you like? (UMERIN) + ;; (setq newsgroups (read-string "Newsgroups: " "general")) + (or newsgroups ;Use the default newsgroup. + (setq newsgroups + (completing-read "Newsgroup: " gnus-newsrc-assoc + nil 'require-match + newsgroups ;Default newsgroup. + ))) + (setq subject (read-string "Subject: ")) + (setq distribution + (substring newsgroups 0 (string-match "\\." newsgroups))) + (if (string-equal distribution newsgroups) + ;; Newsgroup may be general or control. In this + ;; case, use default distribution. + (setq distribution gnus-default-distribution)) + (setq distribution + (read-string "Distribution: " distribution)) + ;; An empty string is ok to ignore gnus-default-distribution. + ;;(if (string-equal distribution "") + ;; (setq distribution nil)) + )) + (news-setup () subject () newsgroups artbuf) + ;; Make sure the article is posted by GNUS. + ;;(mail-position-on-field "Posting-Software") + ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") + ;; Insert Distribution: field. + ;; Suggested by ichikawa@flab.fujitsu.junet. + (mail-position-on-field "Distribution") + (insert (or distribution gnus-default-distribution "")) + ;; Handle author copy using FCC field. + (if gnus-author-copy + (progn + (mail-position-on-field "FCC") + (insert gnus-author-copy))) + (if gnus-interactive-post + ;; All fields are filled in. + (goto-char (point-max)) + ;; Move point to Newsgroup: field. + (goto-char (point-min)) + (end-of-line)) + )) + (message ""))) + +(defun gnus-news-reply (&optional yank) + "Compose and post a reply (aka a followup) to the current article on USENET. +While composing the followup, use \\[news-reply-yank-original] to yank the +original message into it." + (interactive) + (if (or (not gnus-novice-user) + (y-or-n-p "Are you sure you want to followup to all of USENET? ")) + (let (from cc subject date to followup-to newsgroups message-of + references distribution message-id + (artbuf (current-buffer))) + (save-restriction + (and (not (zerop (buffer-size))) + ;;(equal major-mode 'news-mode) + (equal major-mode 'gnus-Article-mode) + (progn + ;; (news-show-all-headers) + (gnus-Article-show-all-headers) + (narrow-to-region (point-min) + (progn (goto-char (point-min)) + (search-forward "\n\n") + (point))))) + (setq from (mail-fetch-field "from")) + (setq news-reply-yank-from from) + (setq subject (mail-fetch-field "subject")) + (setq date (mail-fetch-field "date")) + (setq followup-to (mail-fetch-field "followup-to")) + ;; Ignore Followup-To: poster. + (if (or (null gnus-use-followup-to) ;Ignore followup-to: field. + (string-equal "" followup-to) ;Bogus header. + (string-equal "poster" followup-to)) + (setq followup-to nil)) + (setq newsgroups (or followup-to (mail-fetch-field "newsgroups"))) + (setq references (mail-fetch-field "references")) + (setq distribution (mail-fetch-field "distribution")) + (setq message-id (mail-fetch-field "message-id")) + (setq news-reply-yank-message-id message-id)) + (pop-to-buffer gnus-post-news-buffer) + (news-reply-mode) + (gnus-overload-functions) + (if (and (buffer-modified-p) + (> (buffer-size) 0) + (not (y-or-n-p "Unsent article being composed; erase it? "))) + ;; Continue composition. + ;; Make news-reply-yank-original work on current article. + (setq mail-reply-buffer artbuf) + (erase-buffer) + (and subject + (setq subject + (concat "Re: " (gnus-simplify-subject subject 're-only)))) + (and from + (progn + (let ((stop-pos + (string-match " *at \\| *@ \\| *(\\| *<" from))) + (setq message-of + (concat + (if stop-pos (substring from 0 stop-pos) from) + "'s message of " + date))))) + (news-setup nil subject message-of newsgroups artbuf) + (if followup-to + (progn (news-reply-followup-to) + (insert followup-to))) + ;; Fold long references line to follow RFC1036. + (mail-position-on-field "References") + (let ((begin (point)) + (fill-column 79) + (fill-prefix "\t")) + (if references + (insert references)) + (if (and references message-id) + (insert " ")) + (if message-id + (insert message-id)) + ;; The region must end with a newline to fill the region + ;; without inserting extra newline. + (fill-region-as-paragraph begin (1+ (point)))) + ;; Make sure the article is posted by GNUS. + ;;(mail-position-on-field "Posting-Software") + ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") + ;; Distribution must be the same as original article. + (mail-position-on-field "Distribution") + (insert (or distribution "")) + ;; Handle author copy using FCC field. + (if gnus-author-copy + (progn + (mail-position-on-field "FCC") + (insert gnus-author-copy))) + (goto-char (point-max))) + ;; Yank original article automatically. + (if yank + (let ((last (point))) + (goto-char (point-max)) + (news-reply-yank-original nil) + (goto-char last))) + ) + (message ""))) + +(defun gnus-inews-news () + "Send a news message." + (interactive) + (let* ((case-fold-search nil) + (server-running (gnus-server-opened))) + (save-excursion + ;; It is possible to post a news without reading news using + ;; `gnus' before. + ;; Suggested by yuki@flab.fujitsu.junet. + (gnus-start-news-server) ;Use default server. + ;; NNTP server must be opened before current buffer is modified. + (widen) + (goto-char (point-min)) + (run-hooks 'news-inews-hook) + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n")) + (replace-match "\n\n") + (goto-char (point-max)) + ;; require a newline at the end for inews to append .signature to + (or (= (preceding-char) ?\n) + (insert ?\n)) + (message "Posting to USENET...") + ;; Post to NNTP server. + (if (gnus-inews-article) + (message "Posting to USENET... done") + ;; We cannot signal an error. + (ding) (message "Article rejected: %s" (gnus-status-message))) + (goto-char (point-min)) ;restore internal header separator + (search-forward "\n\n") + (replace-match (concat "\n" mail-header-separator "\n")) + (set-buffer-modified-p nil)) + ;; If NNTP server is opened by gnus-inews-news, close it by myself. + (or server-running + (gnus-close-server)) + (and (fboundp 'bury-buffer) (bury-buffer)) + ;; Restore last window configuration. + (and gnus-winconf-post-news + (set-window-configuration gnus-winconf-post-news)) + (setq gnus-winconf-post-news nil) + )) + +(defun gnus-cancel-news () + "Cancel an article you posted." + (interactive) + (if (yes-or-no-p "Do you really want to cancel this article? ") + (let ((from nil) + (newsgroups nil) + (message-id nil) + (distribution nil)) + (save-excursion + ;; Get header info. from original article. + (save-restriction + (gnus-Article-show-all-headers) + (goto-char (point-min)) + (search-forward "\n\n") + (narrow-to-region (point-min) (point)) + (setq from (mail-fetch-field "from")) + (setq newsgroups (mail-fetch-field "newsgroups")) + (setq message-id (mail-fetch-field "message-id")) + (setq distribution (mail-fetch-field "distribution"))) + ;; Verify if the article is absolutely user's by comparing + ;; user id with value of its From: field. + (if (not + (string-equal + (downcase (mail-strip-quoted-names from)) + (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) + (progn + (ding) (message "This article is not yours")) + ;; Make control article. + (set-buffer (get-buffer-create " *GNUS-posting*")) + (buffer-flush-undo (current-buffer)) + (erase-buffer) + (insert "Newsgroups: " newsgroups "\n" + "Subject: cancel " message-id "\n" + "Control: cancel " message-id "\n" + ;; We should not use the value of + ;; `gnus-default-distribution' as default value, + ;; because distribution must be as same as original + ;; article. + "Distribution: " (or distribution "") "\n" + ) + ;; Prepare article headers. + (gnus-inews-insert-headers) + (goto-char (point-max)) + ;; Insert empty line. + (insert "\n") + ;; Send the control article to NNTP server. + (message "Canceling your article...") + (if (gnus-request-post) + (message "Canceling your article... done") + (ding) (message "Failed to cancel your article")) + (kill-buffer (current-buffer)) + ))) + )) + + +;;; Lowlevel inews interface + +(defun gnus-inews-article () + "NNTP inews interface." + (let ((signature + (if gnus-signature-file + (expand-file-name gnus-signature-file nil))) + (distribution nil) + (artbuf (current-buffer)) + (tmpbuf (get-buffer-create " *GNUS-posting*"))) + (save-excursion + (set-buffer tmpbuf) + (buffer-flush-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring artbuf) + ;; Get distribution. + (save-restriction + (goto-char (point-min)) + (search-forward "\n\n") + (narrow-to-region (point-min) (point)) + (setq distribution (mail-fetch-field "distribution"))) + (widen) + (if signature + (progn + ;; Change signature file by distribution. + ;; Suggested by hyoko@flab.fujitsu.junet. + (if (file-exists-p (concat signature "-" distribution)) + (setq signature (concat signature "-" distribution))) + ;; Insert signature. + (if (file-exists-p signature) + (progn + (goto-char (point-max)) + (insert "--\n") + (insert-file-contents signature))) + )) + ;; Prepare article headers. + (save-restriction + (goto-char (point-min)) + (search-forward "\n\n") + (narrow-to-region (point-min) (point)) + (gnus-inews-insert-headers) + ;; Save author copy of posted article. The article must be + ;; copied before being posted because `gnus-request-post' + ;; modifies the buffer. + (let ((case-fold-search t)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" nil t) + (gnus-inews-do-fcc)))) + (widen) + ;; Run final inews hooks. + (run-hooks 'gnus-Inews-article-hook) + ;; Post an article to NNTP server. + ;; Return NIL if post failed. + (prog1 + (gnus-request-post) + (kill-buffer (current-buffer))) + ))) + +(defun gnus-inews-do-fcc () + "Process FCC: fields." + (let ((fcc-list nil) + (fcc-file nil) + (case-fold-search t)) ;Should ignore case. + (save-excursion + (save-restriction + (goto-char (point-min)) + (while (re-search-forward "^FCC:[ \t]*" nil t) + (setq fcc-list (cons (buffer-substring (point) + (progn + (end-of-line) + (skip-chars-backward " \t") + (point))) + fcc-list)) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + ;; Process FCC operations. + (widen) + (while fcc-list + (setq fcc-file (car fcc-list)) + (setq fcc-list (cdr fcc-list)) + (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file) + (let ((program (substring fcc-file + (match-beginning 1) (match-end 1)))) + ;; Suggested by yuki@flab.fujitsu.junet. + ;; Send article to named program. + (call-process-region (point-min) (point-max) shell-file-name + nil nil nil "-c" program) + )) + (t + ;; Suggested by hyoko@flab.fujitsu.junet. + ;; Save article in Unix mail format by default. + (funcall (or gnus-author-copy-saver 'rmail-output) fcc-file) + )) + ) + )) + )) + +(defun gnus-inews-insert-headers () + "Prepare article headers. +Path:, From:, Subject: and Distribution: are generated. +Message-ID:, Date: and Organization: are optional." + (save-excursion + (let ((date (gnus-inews-date)) + (message-id (gnus-inews-message-id)) + (organization (gnus-inews-organization))) + ;; Insert from the top of headers. + (goto-char (point-min)) + (insert "Path: " (gnus-inews-path) "\n") + (insert "From: " (gnus-inews-user-name) "\n") + ;; If there is no subject, make Subject: field. + (or (mail-fetch-field "subject") + (insert "Subject: \n")) + ;; Insert random headers. + (if message-id + (insert "Message-ID: " message-id "\n")) + (if date + (insert "Date: " date "\n")) + (if organization + (let ((begin (point)) + (fill-column 79) + (fill-prefix "\t")) + (insert "Organization: " organization "\n") + (fill-region-as-paragraph begin (point)))) + (or (mail-fetch-field "distribution") + (insert "Distribution: \n")) + ))) + +(defun gnus-inews-path () + "Return uucp path." + (let ((login-name (gnus-inews-login-name))) + (cond ((null gnus-use-generic-path) + (concat gnus-nntp-server "!" login-name)) + ((stringp gnus-use-generic-path) + ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. + (concat gnus-use-generic-path "!" login-name)) + (t login-name)) + )) + +(defun gnus-inews-user-name () + "Return user's network address as `NAME@DOMAIN (FULL NAME)'." + (let ((login-name (gnus-inews-login-name)) + (full-name (gnus-inews-full-name))) + (concat login-name "@" (gnus-inews-domain-name gnus-use-generic-from) + ;; User's full name. + (cond ((string-equal full-name "") "") + ((string-equal full-name "&") ;Unix hack. + (concat " (" login-name ")")) + (t + (concat " (" full-name ")"))) + ))) + +(defun gnus-inews-login-name () + "Return user login name. +Got from the variable `gnus-user-login-name', the environment variables +USER and LOGNAME, and the function `user-login-name'." + (or gnus-user-login-name + (getenv "USER") (getenv "LOGNAME") (user-login-name))) + +(defun gnus-inews-full-name () + "Return user full name. +Got from the variable `gnus-user-full-name', the environment variable +NAME, and the function `user-full-name'." + (or gnus-user-full-name + (getenv "NAME") (user-full-name))) + +(defun gnus-inews-domain-name (&optional genericfrom) + "Return user's domain name. +If optional argument GENERICFROM is a string, use it as the domain +name; if it is non-nil, strip of local host name from the domain name. +If the function `system-name' returns full internet name and the +domain is undefined, the domain name is got from it." + (let ((domain (or (if (stringp genericfrom) genericfrom) + (getenv "DOMAINNAME") + gnus-your-domain + ;; Function `system-name' may return full internet name. + ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>. + (if (string-match "\\." (system-name)) + (substring (system-name) (match-end 0))) + (read-string "Domain name (no host): "))) + (host (or (if (string-match "\\." (system-name)) + (substring (system-name) 0 (match-beginning 0))) + (system-name)))) + (if (string-equal "." (substring domain 0 1)) + (setq domain (substring domain 1))) + (if (null gnus-your-domain) + (setq gnus-your-domain domain)) + ;; Support GENERICFROM as same as standard Bnews system. + ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com. + (cond ((null genericfrom) + (concat host "." domain)) + ;;((stringp genericfrom) genericfrom) + (t domain)) + )) + +(defun gnus-inews-message-id () + "Generate unique Message-ID for user." + ;; Message-ID should not contain a slash and should be terminated by + ;; a number. I don't know the reason why it is so. + (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-domain-name) ">")) + +(defun gnus-inews-unique-id () + "Generate unique ID from user name and current time." + (let ((date (current-time-string)) + (name (gnus-inews-login-name))) + (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) [0-9][0-9]\\([0-9][0-9]\\)" + date) + (concat (upcase name) "." + (substring date (match-beginning 6) (match-end 6)) ;Year + (substring date (match-beginning 1) (match-end 1)) ;Month + (substring date (match-beginning 2) (match-end 2)) ;Day + (substring date (match-beginning 3) (match-end 3)) ;Hour + (substring date (match-beginning 4) (match-end 4)) ;Minute + (substring date (match-beginning 5) (match-end 5)) ;Second + ) + (error "Cannot understand current-time-string: %s." date)) + )) + +(defun gnus-inews-date () + "Bnews date format string of today. Time zone is ignored." + ;; Insert buggy date (time zone is ignored), but I don't worry about + ;; it since inews will rewrite it. + (let ((date (current-time-string))) + (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9:]+\\) [0-9][0-9]\\([0-9][0-9]\\)" + date) + (concat (substring date (match-beginning 2) (match-end 2)) ;Day + " " + (substring date (match-beginning 1) (match-end 1)) ;Month + " " + (substring date (match-beginning 4) (match-end 4)) ;Year + " " + (substring date (match-beginning 3) (match-end 3))) ;Time + (error "Cannot understand current-time-string: %s." date)) + )) + +(defun gnus-inews-organization () + "Return user's organization. +The ORGANIZATION environment variable is used if defined. +If not, the variable `gnus-your-organization' is used instead. +If the value begins with a slash, it is taken as the name of a file +containing the organization." + ;; The organization must be got in this order since the ORGANIZATION + ;; environment variable is intended for user specific while + ;; gnus-your-organization is for machine or organization specific. + (let ((organization (or (getenv "ORGANIZATION") + gnus-your-organization + (expand-file-name "~/.organization" nil)))) + (and (stringp organization) + (string-equal (substring organization 0 1) "/") + ;; Get it from the user and system file. + ;; Suggested by roland@wheaties.ai.mit.edu (Roland McGrath). + (let ((dist (mail-fetch-field "distribution"))) + (setq organization + (cond ((file-exists-p (concat organization "-" dist)) + (concat organization "-" dist)) + ((file-exists-p organization) organization) + ((file-exists-p gnus-organization-file) + gnus-organization-file) + (t organization))) + )) + (cond ((not (stringp organization)) nil) + ((and (string-equal (substring organization 0 1) "/") + (file-exists-p organization)) + ;; If the first character is `/', assume it is the name of + ;; a file containing the organization. + (save-excursion + (let ((tmpbuf (get-buffer-create " *GNUS organization*"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-file-contents organization) + (prog1 (buffer-string) + (kill-buffer tmpbuf)) + ))) + (t organization)) + ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cmuscheme.el Mon May 13 21:21:58 1991 +0000 @@ -0,0 +1,430 @@ +;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el. +;;; Copyright Olin Shivers (1988) +;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright +;;; notice appearing here to the effect that you may use this code any +;;; way you like, as long as you don't charge money for it, remove this +;;; notice, or hold me liable for its results. +;;; +;;; This is a customisation of comint-mode (see comint.el) +;;; +;;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces +;;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al.. +;;; 8/88 +;;; +;;; Please send me bug reports, bug fixes, and extensions, so that I can +;;; merge them into the master source. +;;; +;;; The changelog is at the end of this file. +;;; +;;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user +;;; interface that communicates process state back to the superior emacs by +;;; outputting special control sequences. The gnumacs package, xscheme.el, has +;;; lots and lots of special purpose code to read these control sequences, and +;;; so is very tightly integrated with the cscheme process. The cscheme +;;; interrupt handler and debugger read single character commands in cbreak +;;; mode; when this happens, xscheme.el switches to special keymaps that bind +;;; the single letter command keys to emacs functions that directly send the +;;; character to the scheme process. Cmuscheme mode does *not* provide this +;;; functionality. If you are a cscheme user, you may prefer to use the +;;; xscheme.el/cscheme -emacs interaction. +;;; +;;; Here's a summary of the pros and cons, as I see them. +;;; xscheme: Tightly integrated with inferior cscheme process! A few commands +;;; not in cmuscheme. But. Integration is a bit of a hack. Input +;;; history only keeps the immediately prior input. Bizarre +;;; keybindings. +;;; +;;; cmuscheme: Not tightly integrated with inferior cscheme process. But. +;;; Carefully integrated functionality with the entire suite of +;;; comint-derived CMU process modes. Keybindings reminiscent of +;;; Zwei and Hemlock. Good input history. A few commands not in +;;; xscheme. +;;; +;;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme +;;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very* +;;; Cscheme-specific; you must use cmuscheme.el. Interested parties are +;;; invited to port xscheme functionality on top of comint mode... + +;; YOUR .EMACS FILE +;;============================================================================= +;; Some suggestions for your .emacs file. +;; +;; ; If cmuscheme lives in some non-standard directory, you must tell emacs +;; ; where to get it. This may or may not be necessary. +;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) +;; +;; ; Autoload run-scheme from file cmuscheme.el +;; (autoload 'run-scheme "cmuscheme" +;; "Run an inferior Scheme process." +;; t) +;; +;; ; Files ending in ".scm" are Scheme source, +;; ; so put their buffers in scheme-mode. +;; (setq auto-mode-alist +;; (cons '("\\.scm$" . scheme-mode) +;; auto-mode-alist)) +;; +;; ; Define C-c t to run my favorite command in inferior scheme mode: +;; (setq cmuscheme-load-hook +;; '((lambda () (define-key inferior-scheme-mode-map "\C-ct" +;; 'favorite-cmd)))) +;;; +;;; Unfortunately, scheme.el defines run-scheme to autoload from xscheme.el. +;;; This will womp your declaration to autoload run-scheme from cmuscheme.el +;;; if you haven't loaded cmuscheme in before scheme. Three fixes: +;;; - Put the autoload on your scheme mode hook and in your .emacs toplevel: +;;; (setq scheme-mode-hook +;;; '((lambda () (autoload 'run-scheme "cmuscheme" +;;; "Run an inferior Scheme" t)))) +;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) +;;; Now when scheme.el autoloads, it will restore the run-scheme autoload. +;;; - Load cmuscheme.el in your .emacs: (load-library 'cmuscheme) +;;; - Change autoload declaration in scheme.el to point to cmuscheme.el: +;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) +;;; *or* just delete the autoload declaration from scheme.el altogether, +;;; which will allow the autoload in your .emacs to have its say. + +(provide 'cmuscheme) +(require 'scheme) +(require 'comint) + +;;; INFERIOR SCHEME MODE STUFF +;;;============================================================================ + +(defvar inferior-scheme-mode-hook nil + "*Hook for customising inferior-scheme mode.") +(defvar inferior-scheme-mode-map nil) + +(cond ((not inferior-scheme-mode-map) + (setq inferior-scheme-mode-map + (full-copy-sparse-keymap comint-mode-map)) + (define-key inferior-scheme-mode-map "\M-\C-x" ;gnu convention + 'scheme-send-definition) + (define-key inferior-scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp) + (define-key inferior-scheme-mode-map "\C-c\C-l" 'scheme-load-file) + (define-key inferior-scheme-mode-map "\C-c\C-k" 'scheme-compile-file) + (scheme-mode-commands inferior-scheme-mode-map))) + +;; Install the process communication commands in the scheme-mode keymap. +(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention +(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention +(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition) +(define-key scheme-mode-map "\C-c\M-e" 'scheme-send-definition-and-go) +(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region) +(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go) +(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition) +(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) +(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme) +(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file) +(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile" + +(defun inferior-scheme-mode () + "Major mode for interacting with an inferior Scheme process. + +The following commands are available: +\\{inferior-scheme-mode-map} + +A Scheme process can be fired up with M-x run-scheme. + +Customisation: Entry to this mode runs the hooks on comint-mode-hook and +inferior-scheme-mode-hook (in that order). + +You can send text to the inferior Scheme process from other buffers containing +Scheme source. + switch-to-scheme switches the current buffer to the Scheme process buffer. + scheme-send-definition sends the current definition to the Scheme process. + scheme-compile-definition compiles the current definition. + scheme-send-region sends the current region to the Scheme process. + scheme-compile-region compiles the current region. + + scheme-send-definition-and-go, scheme-compile-definition-and-go, + scheme-send-region-and-go, and scheme-compile-region-and-go + switch to the Scheme process buffer after sending their text. +For information on running multiple processes in multiple buffers, see +documentation for variable scheme-buffer. + +Commands: +Return after the end of the process' output sends the text from the + end of process to point. +Return before the end of the process' output copies the sexp ending at point + to the end of the process' output, and sends it. +Delete converts tabs to spaces as it moves back. +Tab indents for Scheme; with argument, shifts rest + of expression rigidly with the current line. +C-M-q does Tab on each line starting within following expression. +Paragraphs are separated only by blank lines. Semicolons start comments. +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." + (interactive) + (comint-mode) + ;; Customise in inferior-scheme-mode-hook + (setq comint-prompt-regexp "^[^>]*>+ *") ; OK for cscheme, oaklisp, T,... + (scheme-mode-variables) + (setq major-mode 'inferior-scheme-mode) + (setq mode-name "Inferior Scheme") + (setq mode-line-process '(": %s")) + (use-local-map inferior-scheme-mode-map) + (setq comint-input-filter (function scheme-input-filter)) + (setq comint-input-sentinel (function ignore)) + (setq comint-get-old-input (function scheme-get-old-input)) + (run-hooks 'inferior-scheme-mode-hook)) + +(defun scheme-input-filter (str) + "Don't save anything matching inferior-scheme-filter-regexp" + (not (string-match inferior-scheme-filter-regexp str))) + +(defvar inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" + "*Input matching this regexp are not saved on the history list. +Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters.") + +(defun scheme-get-old-input () + "Snarf the sexp ending at point" + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end)))) + +(defun scheme-args-to-list (string) + (let ((where (string-match "[ \t]" string))) + (cond ((null where) (list string)) + ((not (= where 0)) + (cons (substring string 0 where) + (scheme-args-to-list (substring string (+ 1 where) + (length string))))) + (t (let ((pos (string-match "[^ \t]" string))) + (if (null pos) + nil + (scheme-args-to-list (substring string pos + (length string))))))))) + +(defvar scheme-program-name "scheme" + "*Program invoked by the run-scheme command") + +;;; Obsolete +(defun scheme (&rest foo) + "Use run-scheme" + (interactive) + (message "Use run-scheme") + (ding)) + +(defun run-scheme (cmd) + "Run an inferior Scheme process, input and output via buffer *scheme*. +If there is a process already running in *scheme*, just switch to that buffer. +With argument, allows you to edit the command line (default is value +of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook +\(after the comint-mode-hook is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + + (interactive (list (if current-prefix-arg + (read-string "Run Scheme: " scheme-program-name) + scheme-program-name))) + (if (not (comint-check-proc "*scheme*")) + (let ((cmdlist (scheme-args-to-list cmd))) + (set-buffer (apply 'make-comint "scheme" (car cmdlist) + nil (cdr cmdlist))) + (inferior-scheme-mode))) + (setq scheme-buffer "*scheme*") + (switch-to-buffer "*scheme*")) + + +(defun scheme-send-region (start end) + "Send the current region to the inferior Scheme process." + (interactive "r") + (comint-send-region (scheme-proc) start end) + (comint-send-string (scheme-proc) "\n")) + +(defun scheme-send-definition () + "Send the current definition to the inferior Scheme process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (scheme-send-region (point) end)))) + +(defun scheme-send-last-sexp () + "Send the previous sexp to the inferior Scheme process." + (interactive) + (scheme-send-region (save-excursion (backward-sexp) (point)) (point))) + +(defvar scheme-compile-exp-command "(compile '%s)" + "*Template for issuing commands to compile arbitrary Scheme expressions.") + +(defun scheme-compile-region (start end) + "Compile the current region in the inferior Scheme process +\(A BEGIN is wrapped around the region: (BEGIN <region>))" + (interactive "r") + (comint-send-string (scheme-proc) (format scheme-compile-exp-command + (format "(begin %s)" + (buffer-substring start end)))) + (comint-send-string (scheme-proc) "\n")) + +(defun scheme-compile-definition () + "Compile the current definition in the inferior Scheme process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (scheme-compile-region (point) end)))) + +(defun switch-to-scheme (eob-p) + "Switch to the scheme process buffer. +With argument, positions cursor at end of buffer." + (interactive "P") + (if (get-buffer scheme-buffer) + (pop-to-buffer scheme-buffer) + (error "No current process buffer. See variable scheme-buffer.")) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + +(defun scheme-send-region-and-go (start end) + "Send the current region to the inferior Scheme process, +and switch to the process buffer." + (interactive "r") + (scheme-send-region start end) + (switch-to-scheme t)) + +(defun scheme-send-definition-and-go () + "Send the current definition to the inferior Scheme, +and switch to the process buffer." + (interactive) + (scheme-send-definition) + (switch-to-scheme t)) + +(defun scheme-compile-definition-and-go () + "Compile the current definition in the inferior Scheme, +and switch to the process buffer." + (interactive) + (scheme-compile-definition) + (switch-to-scheme t)) + +(defun scheme-compile-region-and-go (start end) + "Compile the current region in the inferior Scheme, +and switch to the process buffer." + (interactive "r") + (scheme-compile-region start end) + (switch-to-scheme t)) + +(defvar scheme-source-modes '(scheme-mode) + "*Used to determine if a buffer contains Scheme source code. +If it's loaded into a buffer that is in one of these major modes, it's +considered a scheme source file by scheme-load-file and scheme-compile-file. +Used by these commands to determine defaults.") + +(defvar scheme-prev-l/c-dir/file nil + "Caches the (directory . file) pair used in the last scheme-load-file or +scheme-compile-file command. Used for determining the default in the +next one.") + +(defun scheme-load-file (file-name) + "Load a Scheme file into the inferior Scheme process." + (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file + scheme-source-modes t)) ; T because LOAD + ; needs an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (scheme-proc) (concat "(load \"" + file-name + "\"\)\n"))) + +(defun scheme-compile-file (file-name) + "Compile a Scheme file in the inferior Scheme process." + (interactive (comint-get-source "Compile Scheme file: " + scheme-prev-l/c-dir/file + scheme-source-modes + nil)) ; NIL because COMPILE doesn't + ; need an exact name. + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (scheme-proc) (concat "(compile-file \"" + file-name + "\"\)\n"))) + + +(defvar scheme-buffer nil "*The current scheme process buffer. + +MULTIPLE PROCESS SUPPORT +=========================================================================== +Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme +processes. To run multiple Scheme processes, you start the first up with +\\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer +with \\[rename-buffer]. You may now start up a new process with another +\\[run-scheme]. It will be in a new buffer, named *scheme*. You can +switch between the different process buffers with \\[switch-to-buffer]. + +Commands that send text from source buffers to Scheme processes -- +like scheme-send-definition or scheme-compile-region -- have to choose a +process to send to, when you have more than one Scheme process around. This +is determined by the global variable scheme-buffer. Suppose you +have three inferior Schemes running: + Buffer Process + foo scheme + bar scheme<2> + *scheme* scheme<3> +If you do a \\[scheme-send-definition-and-go] command on some Scheme source +code, what process do you send it to? + +- If you're in a process buffer (foo, bar, or *scheme*), + you send it to that process. +- If you're in some other buffer (e.g., a source file), you + send it to the process attached to buffer scheme-buffer. +This process selection is performed by function scheme-proc. + +Whenever \\[run-scheme] fires up a new process, it resets scheme-buffer +to be the new process's buffer. If you only run one process, this will +do the right thing. If you run multiple processes, you can change +scheme-buffer to another process buffer with \\[set-variable]. + +More sophisticated approaches are, of course, possible. If you find youself +needing to switch back and forth between multiple processes frequently, +you may wish to consider ilisp.el, a larger, more sophisticated package +for running inferior Lisp and Scheme processes. The approach taken here is +for a minimal, simple implementation. Feel free to extend it.") + +(defun scheme-proc () + "Returns the current scheme process. See variable scheme-buffer." + (let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode) + (current-buffer) + scheme-buffer)))) + (or proc + (error "No current process. See variable scheme-buffer")))) + + +;;; Do the user's customisation... + +(defvar cmuscheme-load-hook nil + "This hook is run when cmuscheme is loaded in. +This is a good place to put keybindings.") + +(run-hooks 'cmuscheme-load-hook) + + +;;; CHANGE LOG +;;; =========================================================================== +;;; 8/88 Olin +;;; Created. +;;; +;;; 2/15/89 Olin +;;; Removed -emacs flag from process invocation. It's only useful for +;;; cscheme, and makes cscheme assume it's running under xscheme.el, +;;; which messes things up royally. A bug. +;;; +;;; 5/22/90 Olin +;;; - Upgraded to use comint-send-string and comint-send-region. +;;; - run-scheme now offers to let you edit the command line if +;;; you invoke it with a prefix-arg. M-x scheme is redundant, and +;;; has been removed. +;;; - Explicit references to process "scheme" have been replaced with +;;; (scheme-proc). This allows better handling of multiple process bufs. +;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention. +;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist +;;; and friends, but interested hackers might find a useful application +;;; of this facility. +;;; +;;; 3/12/90 Olin +;;; - scheme-load-file and scheme-compile-file no longer switch-to-scheme. +;;; Tale suggested this.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/dabbrev.el Mon May 13 21:21:58 1991 +0000 @@ -0,0 +1,258 @@ +;; Dynamic abbreviation package for GNU Emacs. +;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +; DABBREVS - "Dynamic abbreviations" hack, originally written by Don Morrison +; for Twenex Emacs. Converted to mlisp by Russ Fish. Supports the table +; feature to avoid hitting the same expansion on re-expand, and the search +; size limit variable. Bugs fixed from the Twenex version are flagged by +; comments starting with ;;; . +; +; converted to elisp by Spencer Thomas. +; Thoroughly cleaned up by Richard Stallman. +; +; If anyone feels like hacking at it, Bob Keller (Keller@Utah-20) first +; suggested the beast, and has some good ideas for its improvement, but +; doesn?tknow TECO (the lucky devil...). One thing that should definitely +; be done is adding the ability to search some other buffer(s) if you can?t +; find the expansion you want in the current one. + +;; (defun dabbrevs-help () +;; "Give help about dabbrevs." +;; (interactive) +;; (&info "emacs" "dabbrevs") ; Select the specific info node. +;; ) +(provide 'dabbrevs) + +(defvar dabbrevs-limit nil + "*Limits region searched by `dabbrevs-expand' to this many chars away.") +(make-variable-buffer-local 'dabbrevs-limit) + +(defvar dabbrevs-backward-only nil + "*If non-NIL, `dabbrevs-expand' only looks backwards.") + +; State vars for dabbrevs-re-expand. +(defvar last-dabbrevs-table nil + "Table of expansions seen so far (local)") +(make-variable-buffer-local 'last-dabbrevs-table) + +(defvar last-dabbrevs-abbreviation "" + "Last string we tried to expand (local).") +(make-variable-buffer-local 'last-dabbrevs-abbreviation) + +(defvar last-dabbrevs-direction 0 + "Direction of last dabbrevs search (local)") +(make-variable-buffer-local 'last-dabbrevs-direction) + +(defvar last-dabbrevs-abbrev-location nil + "Location last abbreviation began (local).") +(make-variable-buffer-local 'last-dabbrevs-abbrev-location) + +(defvar last-dabbrevs-expansion nil + "Last expansion of an abbreviation. (local)") +(make-variable-buffer-local 'last-dabbrevs-expansion) + +(defvar last-dabbrevs-expansion-location nil + "Location the last expansion was found. (local)") +(make-variable-buffer-local 'last-dabbrevs-expansion-location) + +;;;###autoload +(defun dabbrev-expand (arg) + "Expand previous word \"dynamically\". +Expands to the most recent, preceding word for which this is a prefix. +If no suitable preceding word is found, words following point are considered. + +If `case-fold-search' and `case-replace' are non-nil (usually true) +then the substituted word may be case-adjusted to match the abbreviation +that you had typed. This takes place if the substituted word, as found, +is all lower case, or if it is at the beginning of a sentence and only +its first letter was upper case. + +A positive prefix arg N says to take the Nth backward DISTINCT +possibility. A negative argument says search forward. The variable +`dabbrev-backward-only' may be used to limit the direction of search to +backward if set non-nil. + +If the cursor has not moved from the end of the previous expansion and +no argument is given, replace the previously-made expansion +with the next possible expansion not yet tried." + (interactive "*P") + (let (abbrev expansion old which loc n pattern + (do-case (and case-fold-search case-replace))) + ;; abbrev -- the abbrev to expand + ;; expansion -- the expansion found (eventually) or nil until then + ;; old -- the text currently in the buffer + ;; (the abbrev, or the previously-made expansion) + ;; loc -- place where expansion is found + ;; (to start search there for next expansion if requested later) + ;; do-case -- non-nil if should transform case when substituting. + (save-excursion + (if (and (null arg) + (eq last-command this-command) + last-dabbrevs-abbrev-location) + (progn + (setq abbrev last-dabbrevs-abbreviation) + (setq old last-dabbrevs-expansion) + (setq which last-dabbrevs-direction)) + (setq which (if (null arg) + (if dabbrevs-backward-only 1 0) + (prefix-numeric-value arg))) + (setq loc (point)) + (forward-word -1) + (setq last-dabbrevs-abbrev-location (point)) ; Original location. + (setq abbrev (buffer-substring (point) loc)) + (setq old abbrev) + (setq last-dabbrevs-expansion-location nil) + (setq last-dabbrev-table nil)) ; Clear table of things seen. + + (setq pattern (concat "\\b" (regexp-quote abbrev) "\\(\\sw\\|\\s_\\)+")) + ;; Try looking backward unless inhibited. + (if (>= which 0) + (progn + (setq n (max 1 which)) + (if last-dabbrevs-expansion-location + (goto-char last-dabbrevs-expansion-location)) + (while (and (> n 0) + (setq expansion (dabbrevs-search pattern t do-case))) + (setq loc (point-marker)) + (setq last-dabbrev-table (cons expansion last-dabbrev-table)) + (setq n (1- n))) + (or expansion + (setq last-dabbrevs-expansion-location nil)) + (setq last-dabbrevs-direction (min 1 which)))) + + (if (and (<= which 0) (not expansion)) ; Then look forward. + (progn + (setq n (max 1 (- which))) + (if last-dabbrevs-expansion-location + (goto-char last-dabbrevs-expansion-location)) + (while (and (> n 0) + (setq expansion (dabbrevs-search pattern nil do-case))) + (setq loc (point-marker)) + (setq last-dabbrev-table (cons expansion last-dabbrev-table)) + (setq n (1- n))) + (setq last-dabbrevs-direction -1)))) + + (if (not expansion) + (let ((first (string= abbrev old))) + (setq last-dabbrevs-abbrev-location nil) + (if (not first) + (progn (undo-boundary) + (delete-backward-char (length old)) + (insert abbrev))) + (error (if first + "No dynamic expansion for \"%s\" found." + "No further dynamic expansions for \"%s\" found.") + abbrev)) + ;; Success: stick it in and return. + (undo-boundary) + (search-backward old) + ;; Make case of replacement conform to case of abbreviation + ;; provided (1) that kind of thing is enabled in this buffer + ;; and (2) the replacement itself is all lower case. + ;; First put back the original abbreviation with its original + ;; case pattern. + (save-excursion + (replace-match abbrev t 'literal)) + (search-forward abbrev) + (let ((do-case (and do-case + (string= (substring expansion 1) + (downcase (substring expansion 1)))))) + ;; First put back the original abbreviation with its original + ;; case pattern. + (save-excursion + (replace-match abbrev t 'literal)) + (search-forward abbrev) + (replace-match (if do-case (downcase expansion) expansion) + (not do-case) + 'literal)) + ;; Save state for re-expand. + (setq last-dabbrevs-abbreviation abbrev) + (setq last-dabbrevs-expansion expansion) + (setq last-dabbrevs-expansion-location loc)))) + +;;;###autoload +(define-key esc-map "/" 'dabbrev-expand) + + +;; Search function used by dabbrevs library. +;; First arg is string to find as prefix of word. Second arg is +;; t for reverse search, nil for forward. Variable dabbrevs-limit +;; controls the maximum search region size. + +;; Table of expansions already seen is examined in buffer last-dabbrev-table, +;; so that only distinct possibilities are found by dabbrevs-re-expand. +;; Note that to prevent finding the abbrev itself it must have been +;; entered in the table. + +;; IGNORE-CASE non-nil means treat case as insignificant while +;; looking for a match and when comparing with previous matches. +;; Also if that's non-nil and the match is found at the beginning of a sentence +;; and is in lower case except for the initial +;; then it is converted to all lower case for return. + +;; Value is the expansion, or nil if not found. After a successful +;; search, point is left right after the expansion found. + +(defun dabbrevs-search (pattern reverse ignore-case) + (let (missing result (case-fold-search ignore-case)) + (save-restriction ; Uses restriction for limited searches. + (if dabbrevs-limit + (narrow-to-region last-dabbrevs-abbrev-location + (+ (point) + (* dabbrevs-limit (if reverse -1 1))))) + ;; Keep looking for a distinct expansion. + (setq result nil) + (setq missing nil) + (while (and (not result) (not missing)) + ; Look for it, leave loop if search fails. + (setq missing + (not (if reverse + (re-search-backward pattern nil t) + (re-search-forward pattern nil t)))) + + (if (not missing) + (progn + (setq result (buffer-substring (match-beginning 0) + (match-end 0))) + (let* ((test last-dabbrev-table)) + (while (and test + (not + (if ignore-case + (string= (downcase (car test)) + (downcase result)) + (string= (car test) result)))) + (setq test (cdr test))) + (if test (setq result nil)))))) ; if already in table, ignore + (if result + (save-excursion + (let ((beg (match-beginning 0))) + (goto-char beg) + (and ignore-case + (string= (substring result 1) + (downcase (substring result 1))) + (if (string= paragraph-start + (concat "^$\\|" page-delimiter)) + (and (re-search-backward sentence-end nil t) + (= (match-end 0) beg)) + (forward-char 1) + (backward-sentence) + (= (point) beg)) + (setq result (downcase result)))))) + result)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/inf-lisp.el Mon May 13 21:21:58 1991 +0000 @@ -0,0 +1,601 @@ +;;; -*-Emacs-Lisp-*- cmulisp.el +;;; Copyright Olin Shivers (1988). +;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright +;;; notice appearing here to the effect that you may use this code any +;;; way you like, as long as you don't charge money for it, remove this +;;; notice, or hold me liable for its results. + +;;; This replaces the standard inferior-lisp mode. +;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 +;;; Please send me bug reports, bug fixes, and extensions, so that I can +;;; merge them into the master source. +;;; +;;; Change log at end of file. + +;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top +;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its +;;; counterpart in the standard gnu emacs release. This replacements is more +;;; featureful, robust, and uniform than the released version. The key +;;; bindings are also more compatible with the bindings of Hemlock and Zwei +;;; (the Lisp Machine emacs). + +;;; Since this mode is built on top of the general command-interpreter-in- +;;; a-buffer mode (comint mode), it shares a common base functionality, +;;; and a common set of bindings, with all modes derived from comint mode. +;;; This makes these modes easier to use. + +;;; For documentation on the functionality provided by comint mode, and +;;; the hooks available for customising it, see the file comint.el. +;;; For further information on cmulisp mode, see the comments below. + +;;; Needs fixin: +;;; The load-file/compile-file default mechanism could be smarter -- it +;;; doesn't know about the relationship between filename extensions and +;;; whether the file is source or executable. If you compile foo.lisp +;;; with compile-file, then the next load-file should use foo.bin for +;;; the default, not foo.lisp. This is tricky to do right, particularly +;;; because the extension for executable files varies so much (.o, .bin, +;;; .lbin, .mo, .vo, .ao, ...). +;;; +;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes +;;; had a verbose minor mode wherein sending or compiling defuns, etc. +;;; would be reflected in the transcript with suitable comments, e.g. +;;; ";;; redefining fact". Several ways to do this. Which is right? +;;; +;;; When sending text from a source file to a subprocess, the process-mark can +;;; move off the window, so you can lose sight of the process interactions. +;;; Maybe I should ensure the process mark is in the window when I send +;;; text to the process? Switch selectable? + +(require 'comint) +(provide 'cmulisp) + +;; YOUR .EMACS FILE +;;============================================================================= +;; Some suggestions for your .emacs file. +;; +;; ; If cmulisp lives in some non-standard directory, you must tell emacs +;; ; where to get it. This may or may not be necessary. +;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) +;; +;; ; Autoload cmulisp from file cmulisp.el +;; (autoload 'cmulisp "cmulisp" +;; "Run an inferior Lisp process." +;; t) +;; +;; ; Define C-c t to run my favorite command in cmulisp mode: +;; (setq cmulisp-load-hook +;; '((lambda () +;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd)))) + + +;;; Brief Command Documentation: +;;;============================================================================ +;;; Comint Mode Commands: (common to cmulisp and all comint-derived modes) +;;; +;;; m-p comint-previous-input Cycle backwards in input history +;;; m-n comint-next-input Cycle forwards +;;; m-c-r comint-previous-input-matching Search backwards in input history +;;; return comint-send-input +;;; c-a comint-bol Beginning of line; skip prompt. +;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. +;;; c-c c-u comint-kill-input ^u +;;; c-c c-w backward-kill-word ^w +;;; c-c c-c comint-interrupt-subjob ^c +;;; c-c c-z comint-stop-subjob ^z +;;; c-c c-\ comint-quit-subjob ^\ +;;; c-c c-o comint-kill-output Delete last batch of process output +;;; c-c c-r comint-show-output Show last batch of process output +;;; send-invisible Read line w/o echo & send to proc +;;; comint-continue-subjob Useful if you accidentally suspend +;;; top-level job. +;;; comint-mode-hook is the comint mode hook. + +;;; CMU Lisp Mode Commands: +;;; c-m-x lisp-send-defun This binding is a gnu convention. +;;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it. +;;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it. +;;; Filename completion is available, of course. +;;; +;;; Additionally, these commands are added to the key bindings of Lisp mode: +;;; c-m-x lisp-eval-defun This binding is a gnu convention. +;;; c-c c-e lisp-eval-defun Send the current defun to Lisp process. +;;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process. +;;; c-c m-e lisp-eval-defun-and-go After sending the defun, switch-to-lisp. +;;; c-c c-r lisp-eval-region Send the current region to Lisp process. +;;; c-c m-r lisp-eval-region-and-go After sending the region, switch-to-lisp. +;;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process. +;;; c-c m-c lisp-compile-defun-and-go After compiling defun, switch-to-lisp. +;;; c-c c-z switch-to-lisp Switch to the Lisp process buffer. +;;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default +;;; c-c c-k lisp-compile-file is to load/compile the current file.) +;;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description. +;;; c-c c-a lisp-show-arglist Query Lisp for function's arglist. +;;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc. +;;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc. + +;;; cmulisp Fires up the Lisp process. +;;; lisp-compile-region Compile all forms in the current region. +;;; lisp-compile-region-and-go After compiling region, switch-to-lisp. +;;; +;;; CMU Lisp Mode Variables: +;;; cmulisp-filter-regexp Match this => don't get saved on input hist +;;; inferior-lisp-program Name of Lisp program run-lisp executes +;;; inferior-lisp-load-command Customises lisp-load-file +;;; cmulisp-mode-hook +;;; inferior-lisp-prompt Initialises comint-prompt-regexp. +;;; Backwards compatibility. +;;; lisp-source-modes Anything loaded into a buffer that's in +;;; one of these modes is considered Lisp +;;; source by lisp-load/compile-file. + +;;; Read the rest of this file for more information. + +(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" + "*What not to save on inferior Lisp's input history +Input matching this regexp is not saved on the input history in cmulisp +mode. Default is whitespace followed by 0 or 1 single-letter :keyword +(as in :a, :c, etc.)") + +(defvar cmulisp-mode-map nil) +(cond ((not cmulisp-mode-map) + (setq cmulisp-mode-map + (full-copy-sparse-keymap comint-mode-map)) + (lisp-mode-commands cmulisp-mode-map) + (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) + (define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file) + (define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file) + (define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist) + (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym) + (define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) + (define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation))) + +;;; These commands augment Lisp mode, so you can process Lisp code in +;;; the source files. +(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention +(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention +(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) +(define-key lisp-mode-map "\C-c\M-e" 'lisp-eval-defun-and-go) +(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) +(define-key lisp-mode-map "\C-c\M-r" 'lisp-eval-region-and-go) +(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) +(define-key lisp-mode-map "\C-c\M-c" 'lisp-compile-defun-and-go) +(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) +(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) +(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file +(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) +(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) +(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) +(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) + + +(defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with `cmulisp'.") + +(defvar inferior-lisp-load-command "(load \"%s\")\n" + "*Format-string for building a Lisp expression to load a file. +This format string should use %s to substitute a file name +and should result in a Lisp expression that will command the inferior Lisp +to load that file. The default works acceptably on most Lisps. +The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\" +produces cosmetically superior output for this application, +but it works only in Common Lisp.") + +(defvar inferior-lisp-prompt "^[^> ]*>+:? *" + "Regexp to recognise prompts in the inferior Lisp. +Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl, +and franz. This variable is used to initialise comint-prompt-regexp in the +cmulisp buffer. + +More precise choices: +Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" +franz: \"^\\(->\\|<[0-9]*>:\\) *\" +kcl: \"^>+ *\" + +This is a fine thing to set in your .emacs file.") + +(defvar cmulisp-mode-hook '() + "*Hook for customising cmulisp mode") + +(defun cmulisp-mode () + "Major mode for interacting with an inferior Lisp process. +Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an +Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter +is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and +inferior-lisp-load-command can customize this mode for different Lisp +interpreters. + +For information on running multiple processes in multiple buffers, see +documentation for variable cmulisp-buffer. + +\\{cmulisp-mode-map} + +Customisation: Entry to this mode runs the hooks on comint-mode-hook and +cmulisp-mode-hook (in that order). + +You can send text to the inferior Lisp process from other buffers containing +Lisp source. + switch-to-lisp switches the current buffer to the Lisp process buffer. + lisp-eval-defun sends the current defun to the Lisp process. + lisp-compile-defun compiles the current defun. + lisp-eval-region sends the current region to the Lisp process. + lisp-compile-region compiles the current region. + + lisp-eval-defun-and-go, lisp-compile-defun-and-go, + lisp-eval-region-and-go, and lisp-compile-region-and-go + switch to the Lisp process buffer after sending their text. + +Commands: +Return after the end of the process' output sends the text from the + end of process to point. +Return before the end of the process' output copies the sexp ending at point + to the end of the process' output, and sends it. +Delete converts tabs to spaces as it moves back. +Tab indents for Lisp; with argument, shifts rest + of expression rigidly with the current line. +C-M-q does Tab on each line starting within following expression. +Paragraphs are separated only by blank lines. Semicolons start comments. +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." + (interactive) + (comint-mode) + (setq comint-prompt-regexp inferior-lisp-prompt) + (setq major-mode 'cmulisp-mode) + (setq mode-name "CMU Lisp") + (setq mode-line-process '(": %s")) + (if (string-match "^18.4" emacs-version) ; hack. + (lisp-mode-variables) ; This is right for 18.49 + (lisp-mode-variables t)) ; This is right for 18.50 + (use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file + (setq comint-get-old-input (function lisp-get-old-input)) + (setq comint-input-filter (function lisp-input-filter)) + (setq comint-input-sentinel 'ignore) + (run-hooks 'cmulisp-mode-hook)) + +(defun lisp-get-old-input () + "Snarf the sexp ending at point" + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end)))) + +(defun lisp-input-filter (str) + "Don't save anything matching cmulisp-filter-regexp" + (not (string-match cmulisp-filter-regexp str))) + +(defun cmulisp () + "Run an inferior Lisp process, input and output via buffer *cmulisp*. +If there is a process already running in *cmulisp*, just switch to that buffer. +Takes the program name from the variable inferior-lisp-program. +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + (interactive) + (cond ((not (comint-check-proc "*cmulisp*")) + (set-buffer (make-comint "cmulisp" inferior-lisp-program)) + (cmulisp-mode))) + (setq cmulisp-buffer "*cmulisp*") + (switch-to-buffer "*cmulisp*")) + +(defun lisp-eval-region (start end) + "Send the current region to the inferior Lisp process." + (interactive "r") + (comint-send-region (cmulisp-proc) start end) + (comint-send-string (cmulisp-proc) "\n")) + +(defun lisp-eval-defun () + "Send the current defun to the inferior Lisp process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (lisp-eval-region (point) end)))) + +(defun lisp-eval-last-sexp () + "Send the previous sexp to the inferior Lisp process." + (interactive) + (lisp-eval-region (save-excursion (backward-sexp) (point)) (point))) + +;;; CommonLisp COMPILE sux. +(defun lisp-compile-region (start end) + "Compile the current region in the inferior Lisp process." + (interactive "r") + (comint-send-string (cmulisp-proc) + (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" + (buffer-substring start end)))) + +(defun lisp-compile-defun () + "Compile the current defun in the inferior Lisp process." + (interactive) + (save-excursion + (end-of-defun) + (let ((e (point))) + (beginning-of-defun) + (lisp-compile-region (point) e)))) + +(defun switch-to-lisp (eob-p) + "Switch to the inferior Lisp process buffer. +With argument, positions cursor at end of buffer." + (interactive "P") + (if (get-buffer cmulisp-buffer) + (pop-to-buffer cmulisp-buffer) + (error "No current process buffer. See variable cmulisp-buffer.")) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + +(defun lisp-eval-region-and-go (start end) + "Send the current region to the inferior Lisp, +and switch to the process buffer." + (interactive "r") + (lisp-eval-region start end) + (switch-to-lisp t)) + +(defun lisp-eval-defun-and-go () + "Send the current defun to the inferior Lisp, +and switch to the process buffer." + (interactive) + (lisp-eval-defun) + (switch-to-lisp t)) + +(defun lisp-compile-region-and-go (start end) + "Compile the current region in the inferior Lisp, +and switch to the process buffer." + (interactive "r") + (lisp-compile-region start end) + (switch-to-lisp t)) + +(defun lisp-compile-defun-and-go () + "Compile the current defun in the inferior Lisp, +and switch to the process buffer." + (interactive) + (lisp-compile-defun) + (switch-to-lisp t)) + +;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. +;(defun lisp-compile-sexp (start end) +; "Compile the s-expression bounded by START and END in the inferior lisp. +;If the sexp isn't a DEFUN form, it is evaluated instead." +; (cond ((looking-at "(defun\\s +") +; (goto-char (match-end 0)) +; (let ((name-start (point))) +; (forward-sexp 1) +; (process-send-string "cmulisp" (format "(compile '%s #'(lambda " +; (buffer-substring name-start +; (point))))) +; (let ((body-start (point))) +; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. +; (process-send-region "cmulisp" (buffer-substring body-start (point)))) +; (process-send-string "cmulisp" ")\n")) +; (t (lisp-eval-region start end))))) +; +;(defun lisp-compile-region (start end) +; "Each s-expression in the current region is compiled (if a DEFUN) +;or evaluated (if not) in the inferior lisp." +; (interactive "r") +; (save-excursion +; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check +; (if (< (point) start) (error "region begins in middle of defun")) +; (goto-char start) +; (let ((s start)) +; (end-of-defun) +; (while (<= (point) end) ; Zip through +; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. +; (setq s (point)) +; (end-of-defun)) +; (if (< s end) (lisp-compile-sexp s end))))) +;;; +;;; End of HS-style code + + +(defvar lisp-prev-l/c-dir/file nil + "Saves the (directory . file) pair used in the last lisp-load-file or +lisp-compile-file command. Used for determining the default in the +next one.") + +(defvar lisp-source-modes '(lisp-mode) + "*Used to determine if a buffer contains Lisp source code. +If it's loaded into a buffer that is in one of these major modes, it's +considered a Lisp source file by lisp-load-file and lisp-compile-file. +Used by these commands to determine defaults.") + +(defun lisp-load-file (file-name) + "Load a Lisp file into the inferior Lisp process." + (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file + lisp-source-modes nil)) ; NIL because LOAD + ; doesn't need an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (cmulisp-proc) + (format inferior-lisp-load-command file-name))) + + +(defun lisp-compile-file (file-name) + "Compile a Lisp file in the inferior Lisp process." + (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file + lisp-source-modes nil)) ; NIL = don't need + ; suffix .lisp + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (cmulisp-proc) (concat "(compile-file \"" + file-name + "\"\)\n"))) + + + +;;; Documentation functions: function doc, var doc, arglist, and +;;; describe symbol. +;;; =========================================================================== + +;;; Command strings +;;; =============== + +(defvar lisp-function-doc-command + "(let ((fn '%s)) + (format t \"Documentation for ~a:~&~a\" + fn (documentation fn 'function)) + (values))\n" + "Command to query inferior Lisp for a function's documentation.") + +(defvar lisp-var-doc-command + "(let ((v '%s)) + (format t \"Documentation for ~a:~&~a\" + v (documentation v 'variable)) + (values))\n" + "Command to query inferior Lisp for a variable's documentation.") + +(defvar lisp-arglist-command + "(let ((fn '%s)) + (format t \"Arglist for ~a: ~a\" fn (arglist fn)) + (values))\n" + "Command to query inferior Lisp for a function's arglist.") + +(defvar lisp-describe-sym-command + "(describe '%s)\n" + "Command to query inferior Lisp for a variable's documentation.") + + +;;; Ancillary functions +;;; =================== + +;;; Reads a string from the user. +(defun lisp-symprompt (prompt default) + (list (let* ((prompt (if default + (format "%s (default %s): " prompt default) + (concat prompt ": "))) + (ans (read-string prompt))) + (if (zerop (length ans)) default ans)))) + + +;;; Adapted from function-called-at-point in help.el. +(defun lisp-fn-called-at-pt () + "Returns the name of the function called in the current call. +Nil if it can't find one." + (condition-case nil + (save-excursion + (save-restriction + (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) + (backward-up-list 1) + (forward-char 1) + (let ((obj (read (current-buffer)))) + (and (symbolp obj) obj)))) + (error nil))) + + +;;; Adapted from variable-at-point in help.el. +(defun lisp-var-at-pt () + (condition-case () + (save-excursion + (forward-sexp -1) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) obj))) + (error nil))) + + +;;; Documentation functions: fn and var doc, arglist, and symbol describe. +;;; ====================================================================== + +(defun lisp-show-function-documentation (fn) + "Send a command to the inferior Lisp to give documentation for function FN. +See variable lisp-function-doc-command." + (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn))) + +(defun lisp-show-variable-documentation (var) + "Send a command to the inferior Lisp to give documentation for function FN. +See variable lisp-var-doc-command." + (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var))) + +(defun lisp-show-arglist (fn) + "Sends an query to the inferior Lisp for the arglist for function FN. +See variable lisp-arglist-command." + (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn))) + +(defun lisp-describe-sym (sym) + "Send a command to the inferior Lisp to describe symbol SYM. +See variable lisp-describe-sym-command." + (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym))) + + +(defvar cmulisp-buffer nil "*The current cmulisp process buffer. + +MULTIPLE PROCESS SUPPORT +=========================================================================== +Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp +processes. To run multiple Lisp processes, you start the first up with +\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer +with \\[rename-buffer]. You may now start up a new process with another +\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can +switch between the different process buffers with \\[switch-to-buffer]. + +Commands that send text from source buffers to Lisp processes -- +like lisp-eval-defun or lisp-show-arglist -- have to choose a process +to send to, when you have more than one Lisp process around. This +is determined by the global variable cmulisp-buffer. Suppose you +have three inferior lisps running: + Buffer Process + foo cmulisp + bar cmulisp<2> + *cmulisp* cmulisp<3> +If you do a \\[lisp-eval-defun-and-go] command on some Lisp source code, +what process do you send it to? + +- If you're in a process buffer (foo, bar, or *cmulisp*), + you send it to that process. +- If you're in some other buffer (e.g., a source file), you + send it to the process attached to buffer cmulisp-buffer. +This process selection is performed by function cmulisp-proc. + +Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer +to be the new process's buffer. If you only run one process, this will +do the right thing. If you run multiple processes, you can change +cmulisp-buffer to another process buffer with \\[set-variable]. + +More sophisticated approaches are, of course, possible. If you find youself +needing to switch back and forth between multiple processes frequently, +you may wish to consider ilisp.el, a larger, more sophisticated package +for running inferior Lisp processes. The approach taken here is for a +minimal, simple implementation. Feel free to extend it.") + +(defun cmulisp-proc () + "Returns the current cmulisp process. See variable cmulisp-buffer." + (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) + (current-buffer) + cmulisp-buffer)))) + (or proc + (error "No current process. See variable cmulisp-buffer")))) + + +;;; Do the user's customisation... +;;;=============================== +(defvar cmulisp-load-hook nil + "This hook is run when cmulisp is loaded in. +This is a good place to put keybindings.") + +(run-hooks 'cmulisp-load-hook) + +;;; CHANGE LOG +;;; =========================================================================== +;;; 5/24/90 Olin +;;; - Split cmulisp and cmushell modes into separate files. +;;; Not only is this a good idea, it's apparently the way it'll be rel 19. +;;; - Upgraded process sends to use comint-send-string instead of +;;; process-send-string. +;;; - Explicit references to process "cmulisp" have been replaced with +;;; (cmulisp-proc). This allows better handling of multiple process bufs. +;;; - Added process query and var/function/symbol documentation +;;; commands. Based on code written by Douglas Roberts. +;;; - Added lisp-eval-last-sexp, bound to C-x C-e. +;;; +;;; 9/20/90 Olin +;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix +;;; reported by Lennart Staflin. +;;; +;;; 3/12/90 Olin +;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. +;;; Tale suggested this.