From: CRDGW2::CRDGW2::MRGATE::"SMTP::PREP.AI.MIT.EDU::INFO-GNU-EMACS-REQUEST" 29-AUG-1989 23:55 To: MRGATE::"ARISIA::EVERHART" Subj: GNU/Common Lisp interface (2 of 2) Received: by life.ai.mit.edu (4.1/AI-4.10) id AA09267; Tue, 29 Aug 89 19:15:53 EDT Return-Path: Received: from tut.cis.ohio-state.edu by life.ai.mit.edu (4.1/AI-4.10) id AA09091; Tue, 29 Aug 89 18:59:45 EDT Received: by tut.cis.ohio-state.edu (5.61/4.890725) id AA09617; Tue, 29 Aug 89 17:01:10 -0400 Received: from USENET by tut.cis.ohio-state.edu with netnews for info-gnu-emacs@prep.ai.mit.edu (info-gnu-emacs@prep.ai.mit.edu) (contact usenet@tut.cis.ohio-state.edu if you have questions) Date: 29 Aug 89 20:20:44 GMT From: segre@cu-arpa.cs.cornell.edu (Alberto M. Segre) Organization: Cornell Univ. CS Dept, Ithaca NY Subject: GNU/Common Lisp interface (2 of 2) Message-Id: <31526@cornell.UUCP> Sender: info-gnu-emacs-request@prep.ai.mit.edu To: info-gnu-emacs@prep.ai.mit.edu # This is a shell archive. # Remove everything above and including the cut line. # Then run the rest of the file through sh. #----cut here-----cut here-----cut here-----cut here----# #!/bin/sh # shar: Shell Archiver # Run the following text with /bin/sh to create: # Help # clisp.el # This archive created: Fri Aug 18 12:43:10 1989 cat << \SHAR_EOF > Help The file clisp.el establishes a set of key bindings and functions to support one or more Common Lisp processes running either locally or remotely in inferior shells. You may run Lucid in one buffer, KCL in another, Allegro in a third, and BBN Common Lisp in yet a fourth lisp buffer if you wish. There are two sets of key bindings established, one for editing lisp code and the other for interacting with a lisp listener. Both sets of bindings are available via the C-c prefix. Editing any file in lisp mode will cause an the default inferior lisp to be started automatically. Normally this is accomplished by setting the auto-mode-alist variable in your ".emacs" file to key off of a filename extension. While editing a file in lisp mode: C-c l switches to the last inferior lisp process visited (see C-c e) M-C-l spawns a new lisp buffer; prompts for image from table. You can start as many lisp listeners as you like, each with a distinct value space. We use this feature to start a lisp on a remote machine that is presumably faster or has more memory. You may run different images or even different types of lisps (e.g., KCL vs Lucid vs Allegro) in the different buffers as per current value of *clisp-image-table*. Prefix arg to M-C-l specifies the nth image in the table. A 0 prefix arg starts the default image (which may not even be in *clisp-image-table*). The notion of "last lisp process" corresponds to the last lisp listener whose GNU window appeared on the screen. You can switch to any lisp process by giving a prefix argument to C-c l specifying which *lispN* buffer to select; the "last lisp process" notion only controls the behavior of C-c l (and other keybindings) when no prefix is given. To pass code from GNU to lisp: C-c d evals current defun in last inferior lisp process C-c C-d = (C-c d) + (C-c l) C-c c compiles current defun in last inferior lisp process C-c C-c = (C-c c) + (C-c l) C-c s evals last sexpr in last inferior lisp process C-c C-s = (C-c s) + (C-c l) C-c r evals current region in last inferior lisp process C-c C-r = (C-c r) + (C-c l) C-c b evals current buffer in last inferior lisp process C-c C-b = (C-c b) + (C-c l) C-c t traces current defun in last inferior lisp process C-c C-t = (C-c t) + (C-c l) C-c p profile current defun in last inferior lisp process C-c C-p = (C-c p) + (C-c l) C-c C-a beginning of current defun C-c C-e end of current defun The GNU emacs tags facility is used to cross index your source code. Special bindings to support this feature include: C-c . finds defun for current function in other window C-c , looks for next matching defun (C-c .) M-. finds defun for current function (std GNU) M-, looks for next matching defun (std GNU) C-c ? lists files indexed by (C-c .) C-c / recomputes lookup table for (C-c .) and (M-C-,) In addition, there are a few bindings that are specific to Common lisp support. C-c m shows Common Lisp macro expansion of current form C-c f shows Common Lisp documentation for current function C-c v shows Common Lisp documentation for current variable C-c a shows Common Lisp arglist for current function (LUCID ONLY!) M-q reindents current comment or defun M-p set package for current buffer C-c = interactive definition facility (prefix arg inserts separator) Indentation has been adapted to properly indent the Interlisp-style FOR macro distributed by segre@cs.cornell.edu; also works reasonably well for the Zetalisp-style LOOP macro. I also distribute a Common Lisp profiler if your lisp doesn't have one. Note that the "[" and "]" characters can be used as "super-parens" in either mode. A "]" closes as many open "(" exist up to and including an open "[". If no open "[" exists, "]" closes up to the top level. The square brackets are replaced by the appropriate number of "(" and ")" in the buffer, since Common Lisp doesn't understand super-parens. N.B.; To insert explicit square brackets, they must be prefaced by C-q. While typing to an inferior lisp process buffer: C-c e returns to last edited file of lisp code (see C-c l) M-C-l spawns a new lisp buffer, prompting for a host. C-c l with a prefix argument switches to that inferior lisp. The notion of "last edit buffer" is the analogue to "last lisp buffer". The last GNU buffer visible that was not a lisp process buffer is the "last edit buffer". To go to a different buffer, use the apporpriate GNU command (C-x b). There are some "ksh"-like features available in the inferior lisp buffers: C-c h show history C-c C-p previous form in history list C-c C-n next form in history list C-c C-a position at previous prompt C-c C-r search backwards in history C-c C-s search forward in history Finally, while running in an inferior lisp buffer, if you position the point after a previous input to lisp and hit return, the old input will be copied to the end of the buffer and resubmitted to lisp. SHAR_EOF cat << \SHAR_EOF > clisp.el ;;; clisp.el establishes a set of key bindings and functions to support ;;; a Common Lisp running in an inferior shell. (provide 'clisp) (defvar *clisp-version* "August 15, 1989") ;;; To use, set your lisp-mode-hook to: ;;; (lambda () (require 'clisp)(start-lisp)) ;;; See the "Help" file for an explanation and a list of key bindings. ;;; Authors: Alberto Segre (segre@cs.cornell.edu) ;;; David Hubbell (hubbell@cs.cornell.edu) ;;; Riad Mohammed (mohammed@cs.cornell.edu) ;;; Department of Computer Science ;;; Cornell University ;;; Upson Hall ;;; Ithaca, NY 14853-7501 ;;; Copyright (c) 1988, 1989 Alberto M. Segre, David L. Hubbell, ;;; Riad Mohammed. ;;; A portion of this code was adapted from code originally in the GNU ;;; distribution in file simple.el. ;;; A portion of this code was adapted by David Hubbell ;;; (hubbell@cs.cornell.edu) from code originally written by Wolfgang ;;; Rupprecht (wolfgang@mgm.mit.edu). ;;; A portion of this code was adapted by Riad Mohammed ;;; (mohammed@cs.cornell.edu) from code originally written by Rick ;;; Palmer (rick@cs.cornell.edu). ;;; A portion of this code was adapted by Alberto Segre ;;; (segre@cs.cornell.edu) from code originally written by ;;; Jean-Francois Lamy (lamy@ai.toronto.ca) and Reed Hasting ;;; (hastings@spar.slb.com). ;;; Copying is permitted under those conditions described by the GNU ;;; Emacs General Public License as clarified 11 February 1988, which ;;; is incorporated here by reference. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; System-dependent variables. You should reset these to whatever is ;;; appropriate on your own system. ;;; Machine for running the lisp process. Defaults to current machine. (defvar inferior-lisp-host (system-name) "Name of host") ;;; Set the Common Lisp to be the lisp that's run as the default ;;; inferior process. Any Common Lisp will do; we'll set the default ;;; to be Lucid Common Lisp. Non-Common Lisps will not support macro ;;; expansion and documentation search. (defvar inferior-lisp-program "/usr/local/bin/lisp" "Lisp program to run.") ;;; String regexps to match the Lisp prompt string for various Common ;;; Lisps. (defvar *clisp-kcl-prompt* "^[A-Za-z]*>+") (defvar *clisp-allegro-prompt* "^\\(\\[[0-9]+\\] \\)? ") (defvar *clisp-cmu-prompt* "\\*") (defvar *clisp-bbn-prompt* "^\\([0-9] \\)?[A-Za-z]*\\(-\\|]=\\)>") ;;;(defvar *clisp-lucid-prompt* "^.?> ") (defvar *clisp-lucid-prompt* "^[--->]*> ") ;;; Inferior lisp prompt. We'll set the default value to be the Lucid ;;; prompt, since the default value for inferior-lisp-program is a ;;; Lucid image. (defvar inferior-lisp-prompt *clisp-lucid-prompt* "Lisp prompt string regexp.") ;;; Remote shell program; used for starting a remote inferior lisp. ;;; Most of the time, an installation will have a standard place for ;;; rsh on all systems. In case yours doesn't, you can have this ;;; pointer vary from machine to machine. (defvar remote-shell-program "/usr/ucb/rsh" "The program that starts a remote shell.") ;;; Table used to determine which image to run. Each entry has form: ;;; (name lisp-program prompt-string rsh-program) where each of these ;;; four components is eval'd before use (thus (system-name) refers ;;; to the current system). (defvar *clisp-image-table* '(("bullwinkle" "/usr/local/bin/lisp" *clisp-lucid-prompt* "/usr/ucb/rsh") ("bullwinkle" "/usr/local/bin/lisp-pcl" *clisp-lucid-prompt* "/usr/ucb/rsh") ("bullwinkle" "/usr/local/bin/lisp-clx" *clisp-lucid-prompt* "/usr/ucb/rsh") ((system-name) "/usr/local/bin/lisp-pcl" *clisp-lucid-prompt* nil) ((system-name) "/usr/local/bin/lisp-clx" *clisp-lucid-prompt* nil) ((system-name) "/usr/u/cap/akcl/xbin/kcl" *clisp-kcl-prompt* nil) ("iron" "/usr/blisp/mach/bin/common-lisp" *clisp-bbn-prompt* "/usr/ucb/rsh"))) ;;; File containing the "message of the day." Will be displayed at the ;;; top of the first buffer running an inferior lisp. (defvar *clisp-motd-file* "/usr/u/cap/.motd" "The filename for the motd to be displayed in the first lisp buffer.") ;;; Filename extension for lisp files. Set to ".lsp" for KCL or CMU ;;; Lisp, ".cl" for Allegro, while Lucid expects ".lisp" (the default). (defvar *lisp-filename-extension* ".lisp" "Extension used to indicate lisp file. Used by tags mechanism.") ;;; Location of temporary filespace. Must be read/writeable by user. (defvar *clisp-temporary-directory* "/tmp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utilities to make writing elisp code easier. (defmacro when (condition &rest body) (list 'and condition (cons 'progn body))) (defmacro unless (condition &rest body) (list 'or condition (cons 'progn body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Load the x-mouse stuff if you're using x-windows. (cond ((eq window-system 'x) (load-library "/usr/u/cap/.elisp/xmouse"))) ;;; Make sure this is properly set to nil. (setq parse-sexp-ignore-comments nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ignore compiled lisp files in filename completion. (setq completion-ignored-extensions (append '(".o" ".fasl" ".lbin" ".sbin") completion-ignored-extensions)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; INFERIOR-LISP-MODE-MAP. Much of this is copied from shell.el; ;;; since we don't need the generality of shell.el we copy just what ;;; we need from there. Establish all of the keybindings for the ;;; inferior lisp process, starting with the basic lisp-mode commands. (defvar inferior-lisp-mode-map nil) (unless inferior-lisp-mode-map (setq inferior-lisp-mode-map (make-sparse-keymap)) (lisp-mode-commands inferior-lisp-mode-map) (define-key inferior-lisp-mode-map "\C-c\C-c" 'clisp-interrupt-process) (define-key inferior-lisp-mode-map "\C-ce" 'clisp-buffer-deselect) (define-key inferior-lisp-mode-map "\C-cl" 'clisp-buffer-select) (define-key inferior-lisp-mode-map "\M-\C-l" 'clisp-create-lisp-buffer) (define-key inferior-lisp-mode-map "\C-m" 'clisp-shell-send-input-if-sexpr) (define-key inferior-lisp-mode-map "\C-c\C-p" 'clisp-shell-previous-command) (define-key inferior-lisp-mode-map "\C-c\C-n" 'clisp-shell-next-command) (define-key inferior-lisp-mode-map "\C-c\C-a" 'clisp-shell-previous-prompt) (define-key inferior-lisp-mode-map "\C-c\C-r" 'clisp-shell-history-search-backward) (define-key inferior-lisp-mode-map "\C-c\C-s" 'clisp-shell-history-search-forward) (define-key inferior-lisp-mode-map "\C-ch" 'clisp-shell-list-history) (define-key inferior-lisp-mode-map "]" 'super-close-paren) (define-key inferior-lisp-mode-map "\C-ca" 'clisp-show-arglist) (define-key inferior-lisp-mode-map "\C-cf" 'clisp-show-function-documentation) (define-key inferior-lisp-mode-map "\C-cv" 'clisp-show-variable-documentation)) ;;; We also need to modify LISP-MODE-MAP which is set up in ;;; lisp-mode.el; we will add many of the same features of the ;;; inferior-lisp-mode-map to lisp-mode-map as well. Some features in ;;; lisp-mode-map will also need to be removed. (define-key lisp-mode-map "\M-\C-x" nil) (define-key lisp-mode-map "]" 'super-close-paren) (define-key lisp-mode-map "\M-q" 'clisp-reindent-form) (define-key lisp-mode-map "\M-p" 'clisp-set-package) (define-key lisp-mode-map "\C-cl" 'clisp-buffer-select) (define-key lisp-mode-map "\M-\C-l" 'clisp-create-lisp-buffer) (define-key lisp-mode-map "\C-cd" 'clisp-eval-defun) (define-key lisp-mode-map "\C-c\C-d" 'clisp-eval-defun-and-go) (define-key lisp-mode-map "\C-cc" 'clisp-compile-defun) (define-key lisp-mode-map "\C-c\C-c" 'clisp-compile-defun-and-go) (define-key lisp-mode-map "\C-cs" 'clisp-eval-last-sexpr) (define-key lisp-mode-map "\C-c\C-s" 'clisp-eval-last-sexpr-and-go) (define-key lisp-mode-map "\C-cr" 'clisp-eval-region) (define-key lisp-mode-map "\C-c\C-r" 'clisp-eval-region-and-go) (define-key lisp-mode-map "\C-cb" 'clisp-eval-buffer) (define-key lisp-mode-map "\C-c\C-b" 'clisp-eval-buffer-and-go) (define-key lisp-mode-map "\C-ct" 'clisp-trace-defun) (define-key lisp-mode-map "\C-c\C-t" 'clisp-trace-defun-and-go) (define-key lisp-mode-map "\C-cp" 'clisp-profile-defun) (define-key lisp-mode-map "\C-c\C-p" 'clisp-profile-defun-and-go) (define-key lisp-mode-map "\C-c\C-a" 'beginning-of-defun) (define-key lisp-mode-map "\C-c\C-e" 'end-of-defun) (define-key lisp-mode-map "\C-c." 'find-tag-other-window) (define-key lisp-mode-map "\C-c," 'tags-loop-continue) (define-key lisp-mode-map "\C-c?" 'clisp-list-tag-files) (define-key lisp-mode-map "\C-c/" 'clisp-recompute-tag-table) (define-key lisp-mode-map "\C-cm" 'clisp-show-macro-expansion) (define-key lisp-mode-map "\C-c=" 'clisp-make-template) (define-key lisp-mode-map "\C-ca" 'clisp-show-arglist) (define-key lisp-mode-map "\C-cf" 'clisp-show-function-documentation) (define-key lisp-mode-map "\C-cv" 'clisp-show-variable-documentation) ;;; Make "[" a kind of open paren so that scan-sexps won't ignore it. (modify-syntax-entry 91 "(" lisp-mode-syntax-table) ;;; Interrupts the lisp job. Normally puts you in a break loop. Copied ;;; from shell.el (this is the only function we really need from ;;; there). (defun clisp-interrupt-process () "Interrupt the lisp process." (interactive) (interrupt-process nil t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Startup function called on lisp-mode-hook. Sets the ;;; lisp-indent-hook to a function that recognizes Common Lisp forms. (defun start-lisp () "Called by lisp-mode-hook to start lisp." (save-excursion (or (get-process "lisp") (progn (message "Starting lisp...") (start-lisp-process-and-buffer "*lisp*" nil) (setq lisp-indent-hook 'common-lisp-indent-hook) (message "Starting lisp...done."))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Create and switch to a new Lisp process buffer. This will reuse ;;; any killed lisp buffers, or, if none are found, will create a ;;; new lisp buffer. (defun clisp-create-lisp-buffer (&optional image) "Create and switch to a new Lisp process buffer." (interactive "P") (cond ((setq image (cond ((and image (< 0 image) (>= (length *clisp-image-table*) image)) (nth (1- image) *clisp-image-table*)) ((and image (zerop image)) t) ((null image) (clisp-interactive-image-select *clisp-image-table*)))) (message "Starting new lisp process...") (let ((lisp-number 1)) (while (and (<= lisp-number (1+ *max-lisp-buffer-number*)) (get-buffer (clisp-number-to-buffer-name lisp-number))) (setq lisp-number (1+ lisp-number))) (setq *max-lisp-buffer-number* (max *max-lisp-buffer-number* lisp-number)) (let ((newbuffername (clisp-number-to-buffer-name lisp-number))) (mark-edit-buffer (current-buffer)) (save-excursion (start-lisp-process-and-buffer newbuffername image)) (clisp-buffer-select lisp-number) (message "Starting new lisp process...done.")))) (t (message "No lisp image selected.")))) ;;; Walk through *clisp-image-table* until the user selects one of the ;;; entries. (defun clisp-interactive-image-select (table) (when table (cond ((y-or-n-p (format "Run %s:%s? " (upcase (eval (nth 0 (car table)))) (eval (nth 1 (car table))))) (car table)) (t (clisp-interactive-image-select (cdr table)))))) ;;; Start up lisp process in a new *lispN* buffer unless the process ;;; already exists. If there is a *clisp-motd-file*, insert it at the ;;; beginning of the buffer. Don't complain if *clisp-motd-file* is ;;; not set. If the image argument is not eq to t, override the default ;;; values of inferior-lisp-program and the like with values from ;;; the image, a *clisp-image-table* entry. (defun start-lisp-process-and-buffer (buffername image) (let ((buffer (get-buffer-create buffername)) (processname (substring buffername 1 (1- (length buffername)))) process) (cond ((null (get-process processname)) (switch-to-buffer buffer) (erase-buffer) (make-local-variable 'inferior-lisp-host) (make-local-variable 'inferior-lisp-program) (make-local-variable 'inferior-lisp-prompt) (make-local-variable 'remote-shell-program) (cond ((eq t image) (setq inferior-lisp-host (default-value 'inferior-lisp-host)) (setq inferior-lisp-program (default-value 'inferior-lisp-program)) (setq inferior-lisp-prompt (default-value 'inferior-lisp-prompt)) (setq remote-shell-program (default-value 'remote-shell-program))) (image (setq inferior-lisp-host (eval (nth 0 image))) (setq inferior-lisp-program (eval (nth 1 image))) (setq inferior-lisp-prompt (eval (nth 2 image))) (setq remote-shell-program (eval (nth 3 image))))) (cond ((equal inferior-lisp-host (system-name)) (insert "Local lisp host\n\n")) (t (insert (format "Remote lisp host %s\n\n" (upcase inferior-lisp-host))))) (when (equal processname "lisp") (condition-case () (insert-file *clisp-motd-file*) (error nil))) (mark-lisp-buffer buffer) (buffer-flush-undo buffer) (setq process (cond ((equal inferior-lisp-host (system-name)) (start-process processname buffername inferior-lisp-program)) (t (start-process processname buffername remote-shell-program inferior-lisp-host (format "cd %s ; %s" default-directory inferior-lisp-program))))) (set-process-filter process 'clisp-startup-filter) (set-process-buffer process (get-buffer buffername)) (process-kill-without-query process) (setq major-mode 'inferior-lisp-mode) (setq mode-name "Inferior Lisp") (setq mode-line-process '(": %s")) (use-local-map inferior-lisp-mode-map))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The process filters allow communication from Common Lisp to GNU (GNU to ;;; Common Lisp is supplied by GNU buffer mechanism). ;;; CLISP-STARTUP-FILTER is a temporary filter used only until the ;;; first lisp prompt. It sets the value of process-mark, which is ;;; subsequently used to output from lisp. (defun clisp-startup-filter (proc string) "Startup filter function for inferior lisp process. Looks for first prompt and switches control thereafter to clisp-filter." (let ((buffer (process-buffer proc))) (save-window-excursion (set-buffer buffer) (goto-char (point-max)) (cond ((string-match inferior-lisp-prompt string) (insert string) (set-marker (process-mark proc) (point)) (set-process-filter proc 'clisp-filter)) (t (insert string)))))) ;;; CLISP-FILTER is the normally used filter. It simply echoes all ;;; output from Common Lisp to the lisp buffer, unless that output is ;;; marked with a special tag indicating GNU should intercept it. Any ;;; output that looks like (:GNU-DIVERT output-sexpr) will change ;;; the process filter to clisp-diverting-filter until the next lisp ;;; prompt. We can't rely on the output for GNU coming in a single ;;; string. We can, however, rely on the fact that it starts near the ;;; beginning of a string (usually in positions 1 or 2, depending on ;;; leading carriage returns and the like). ;;; CLISP-FILTER also flushes any output that looks like (:GNU-FLUSH ;;; output-sexpr). Note that flushed output cannot be nested inside ;;; trapped (e.g., :GNU-DIVERT) output. (defun clisp-filter (proc string) "Filter function for inferior lisp process. Looks for any sexprs output from process beginning with the atoms :GNU-DIVERT or :GNU-FLUSH and intercepts them." (let ((buffer (process-buffer proc))) (cond ((string-match ":GNU-FLUSH" string) (set-process-filter proc 'clisp-flushing-filter) (clisp-flushing-filter proc (substring string (match-end 0)))) ((string-match ":GNU-DIVERT" string) (set-process-filter proc 'clisp-diverting-filter) ;;; Flush the leading double quote. (clisp-diverting-filter proc (substring string (1+ (string-match "\"" string (match-end 0)))))) (t (save-window-excursion (set-buffer buffer) (let ((old-point (point))) (goto-char (process-mark proc)) (insert string) (set-marker (process-mark proc) (point)) (goto-char (+ (length string) old-point)))))))) ;;; CLISP-DIVERTING-FILTER hijacks the output from process and dumps ;;; it in the buffer cached in *clisp-diversion-buffer*. When it ;;; reaches a lisp prompt, it stops diverting output. Note ;;; that we must still switch buffers, if only to get the proper ;;; inferior-lisp-prompt string. (defun clisp-diverting-filter (proc string) "Filter function that diverts output from process to a different buffer. When the inferior-lisp-prompt is found, the process filter is reset to clisp-filter." (let ((buffer (process-buffer proc)) prompt-position prompt-end) (save-window-excursion (set-buffer buffer) (setq prompt-position (string-match inferior-lisp-prompt string)) (setq prompt-end (match-end 0))) (cond (prompt-position (save-window-excursion (set-buffer *clisp-diversion-buffer*) (save-excursion (goto-char (point-max)) (insert (substring string 0 prompt-position)) ;;; Remove the trailing double quote and paren from the backquoted expr. (and (search-backward "\")" 0 t) (delete-region (point) (point-max))) (set-buffer-modified-p nil))) (display-buffer *clisp-diversion-buffer*) (set-process-filter proc 'clisp-filter) (clisp-filter proc (substring string prompt-end))) (*clisp-diversion-buffer* (save-window-excursion (set-buffer *clisp-diversion-buffer*) (goto-char (point-max)) (insert string)))))) ;;; CLISP-FLUSHING-FILTER hijacks the output from process and flushes ;;; it. When it reaches a lisp prompt, it stops flushing output. Note ;;; that we must still switch buffers, if only to get the proper ;;; inferior-lisp-prompt string. (defun clisp-flushing-filter (proc string) "Filter function that flushes output from process. When the inferior-lisp-prompt is found, the process filter is reset to clisp-filter." (let ((buffer (process-buffer proc)) prompt-position prompt-end) (save-window-excursion (set-buffer buffer) (setq prompt-position (string-match inferior-lisp-prompt string)) (setq prompt-end (match-end 0))) (when prompt-position (set-process-filter proc 'clisp-filter) (clisp-filter proc (substring string prompt-end))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Variables. (defvar *last-lisp-buffer* nil "The last Lisp process buffer that the user selected, NOT its name.") (defvar *last-edit-buffer* nil "The last edit (non-Lisp) buffer that the user selected.") (defvar *max-lisp-buffer-number* 1 "The number of the last Lisp buffer created.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MARK-EDIT-BUFFER updates the pointer to the last edit buffer ;;; selected unless the buffer is a lisp process buffer. (defun mark-edit-buffer (buffer) (unless (equal (substring (buffer-name buffer) 0 5) "*lisp") (setq *last-edit-buffer* buffer))) ;;; MARK-LISP-BUFFER updates the pointer to the last edit buffer ;;; selected only when the buffer is a lisp process buffer. (defun mark-lisp-buffer (buffer) (when (equal (substring (buffer-name buffer) 0 5) "*lisp") (setq *last-lisp-buffer* buffer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Select the appropriate Lisp process buffer. (defun clisp-buffer-select (&optional buffernum) "Select the Lisp process buffer. If the optional argument is n, select Lisp process buffer n. If that buffer does not exist, print an error message and give up. If there is no optional argument, select the last Lisp buffer selected." (interactive "P") (cond ((and buffernum (or (<= buffernum 0) (> buffernum *max-lisp-buffer-number*))) (beep) (message (format "Unknown lisp buffer %s." (clisp-number-to-buffer-name buffernum)))) (t (let ((buffer-to-select (clisp-find-lisp-buffer buffernum)) lisp-window) (when buffer-to-select (mark-edit-buffer (current-buffer)) (mark-lisp-buffer buffer-to-select) (cond ((setq lisp-window (get-buffer-window buffer-to-select)) (select-window lisp-window)) (t (switch-to-buffer buffer-to-select))) (goto-char (point-max))))))) ;;; CLISP-FIND-LISP-BUFFER takes a buffernum and returns a pointer to ;;; a lisp buffer. If buffernum does not correspond to a legal lisp buffer, ;;; then CLISP-FIND-BUFFER finds the "next" legal lisp buffer. (defun clisp-find-lisp-buffer (buffernum) (let ((buffer-to-select (cond ((and (not (integerp buffernum)) (buffer-name *last-lisp-buffer*)) *last-lisp-buffer*) ((not (integerp buffernum)) (setq buffernum *max-lisp-buffer-number*) nil) ((and (<= buffernum *max-lisp-buffer-number*) (> buffernum 0)) (get-buffer (clisp-number-to-buffer-name buffernum))))) (final-buffer (cond ((or (not (integerp buffernum)) (= 1 buffernum)) *max-lisp-buffer-number*) (t (- buffernum 1))))) (unless buffer-to-select (let ((message (format "Buffer %s not found" (clisp-number-to-buffer-name buffernum)))) (while (and (not (= buffernum final-buffer)) (not (setq buffer-to-select (progn (setq buffernum (cond ((= *max-lisp-buffer-number* buffernum) 1) (t (+ buffernum 1)))) (get-buffer (clisp-number-to-buffer-name buffernum))))))) (beep) (cond (buffer-to-select (message (format "%s; selecting %s." message (buffer-name buffer-to-select)))) (t (message (format "%s; no other lisp buffers found." message)))))) buffer-to-select)) ;;; Return to previous edit buffer from Lisp process buffer. (defun clisp-buffer-deselect () "Return to previous edit buffer from Lisp process buffer." (interactive) (let (lisp-window) (cond ((buffer-name *last-edit-buffer*) (mark-lisp-buffer (current-buffer)) (cond ((setq lisp-window (get-buffer-window *last-edit-buffer*)) (select-window lisp-window)) (t (switch-to-buffer *last-edit-buffer*)))) (t (beep) (message "The last edit buffer has been killed."))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sends current buffer to specified Lisp process and evals it. ;;; Defaults to last selected lisp process. If the buffer isn't ;;; modified, load the original file instead. (defun clisp-eval-buffer (&optional lispnum) "Sends the current buffer to the Lisp process and evals it." (interactive "P") (cond ((buffer-modified-p) (message "Evaling buffer...") (save-excursion (goto-char (point-min)) (clisp-create-temp-file (buffer-string) (clisp-current-package)) (clisp-load-temp-file t lispnum) (message "Evaling buffer...done.") t)) (t (clisp-eval-file lispnum)))) ;;; Sends current buffer to specified Lisp process, evals it, and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-eval-buffer-and-go (&optional lispnum) "Send the current buffer to the Lisp process, evals it, and switches to lisp buffer." (interactive "P") (when (clisp-eval-buffer lispnum) (clisp-buffer-select lispnum))) ;;; Sends current buffer to specified Lisp process and compiles it. ;;; Defaults to last selected lisp process. If the buffer isn't ;;; modified, compile the original file instead. (defun clisp-compile-buffer (&optional lispnum) "Sends the current buffer to the Lisp process and compiles it." (interactive "P") (cond ((buffer-modified-p) (message "Compiling buffer...") (save-excursion (goto-char (point-min)) (clisp-create-temp-file (buffer-string) (clisp-current-package)) (clisp-compile-and-load-temp-file t lispnum) (message "Compiling buffer...done.") t)) (t (clisp-compile-file lispnum)))) ;;; Sends current buffer to specified Lisp process, compiles it, and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-compile-buffer-and-go (&optional lispnum) "Send the current buffer to the Lisp process, compiles it, and switches to lisp buffer." (interactive "P") (when (clisp-compile-buffer lispnum) (clisp-buffer-select lispnum))) ;;; Sends current region to the specified Lisp process and evals it. ;;; Defaults to last selected lisp process. (defun clisp-eval-region (&optional lispnum) "Send the current region to the specified Lisp process and evals it." (interactive "P") (cond ((and (mark) (= (mark)(point))) (message "Null region.") nil) ((mark) (message "Evaling region...") (let ((bor (min (point)(mark))) (eor (max (point)(mark)))) (save-excursion (goto-char bor) (clisp-create-temp-file (buffer-substring bor eor) (clisp-current-package)) (clisp-load-temp-file t lispnum) (message "Evaling region...done.") t))) (t (message "No mark set.") nil))) ;;; Sends current region to the specified Lisp process, evals it, and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-eval-region-and-go (&optional lispnum) "Send the current region to the specified Lisp process, evals it, and switches to lisp buffer." (interactive "P") (when (clisp-eval-region lispnum) (clisp-buffer-select lispnum))) ;;; Sends current region to the specified Lisp process and compiles it. ;;; Defaults to last selected lisp process. (defun clisp-compile-region (&optional lispnum) "Send the current region to the specified Lisp process and evals it." (interactive "P") (cond ((and (mark) (= (mark)(point))) (message "Null region.") nil) ((mark) (message "Compiling region...") (let ((bor (min (point)(mark))) (eor (max (point)(mark)))) (save-excursion (goto-char bor) (clisp-create-temp-file (buffer-substring bor eor) (clisp-current-package)) (clisp-compile-and-load-temp-file t lispnum) (message "Compiling region...done.") t))) (t (message "No mark set.") nil))) ;;; Sends current region to the specified Lisp process, compiles it, and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-compile-region-and-go (&optional lispnum) "Send the current region to the specified Lisp process, compiles it, and switches to lisp buffer." (interactive "P") (when (clisp-compile-region lispnum) (clisp-buffer-select lispnum))) ;;; Sends current defun to specified Lisp process and evals it. ;;; Defaults to last selected lisp process. (defun clisp-eval-defun (&optional lispnum) "Send the current defun to the specified Lisp process and evals it." (interactive "P") (message "Evaling defun...") (when (clisp-send-to-lisp (clisp-extract-defun) (or lispnum 0) (clisp-current-package)) (message "Evaling defun...done.") t)) ;;; Sends current defun to specified Lisp process, evals it, and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-eval-defun-and-go (&optional lispnum) "Send the current defun to the specified Lisp process, evals it, and switches to lisp buffer." (interactive "P") (when (clisp-eval-defun lispnum) (clisp-buffer-select lispnum))) ;;; Sends current defun to the specified Lisp process and compiles it. ;;; Defaults to last selected lisp process. (defun clisp-compile-defun (&optional lispnum) "Send the current defun to the specified Lisp process and compiles it." (interactive "P") (cond ((defun-p) (message "Compiling defun...") (when (clisp-send-to-lisp (format "(progn %s (user::compile '%s))" (clisp-extract-defun) (clisp-extract-defun-name)) (or lispnum 0) (clisp-current-package)) (message "Compiling defun...done.") t)) (t (message "Compiling form...") (clisp-create-temp-file (clisp-extract-defun) (clisp-current-package)) (clisp-compile-and-load-temp-file (clisp-extract-defun-name) lispnum) (message "Compiling form...done.") t))) ;;; Sends current defun to the specified Lisp process, compiles it, ;;; and switches to lisp buffer. Defaults to last selected lisp ;;; process. (defun clisp-compile-defun-and-go (&optional lispnum) "Send the current defun to the specified Lisp process, evals it, and switches to lisp buffer." (interactive "P") (when (clisp-compile-defun lispnum) (clisp-buffer-select lispnum))) ;;; Sends last sexpr to he specified Lisp process and evals it. ;;; Defaults to last selected lisp process. (defun clisp-eval-last-sexpr (&optional lispnum) "Send the last sexpr to the specified Lisp process and evals it." (interactive "P") (message "Evaling sexpr...") (save-excursion (mark-sexp -1) (when (clisp-send-to-lisp (buffer-substring (point)(mark)) (or lispnum 0) (clisp-current-package)) (message "Evaling sexpr...done.") t))) ;;; Sends last sexpr to the specified Lisp process, evals it, and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-eval-last-sexpr-and-go (&optional lispnum) "Send the last sexp to the specified Lisp process, evals it, and switches to lisp buffer." (interactive "P") (when (clisp-eval-last-sexpr lispnum) (clisp-buffer-select lispnum))) ;;; Trace the current defun in the specified Lisp process. Defaults to ;;; last selected lisp process. (defun clisp-trace-defun (&optional lispnum) "Trace the current defun in the specified Lisp process." (interactive "P") (when (defun-p) (message "Tracing defun...") (when (clisp-send-to-lisp (format "(user::trace %s)" (clisp-extract-defun-name)) (or lispnum 0) (clisp-current-package)) (message "Tracing defun...done.") t))) ;;; Trace the current defun in the specified Lisp process and switches ;;; to lisp buffer. Defaults to last selected lisp process. (defun clisp-trace-defun-and-go (&optional lispnum) "Trace the current defun in the specified Lisp process and switches to lisp buffer." (interactive "P") (when (clisp-trace-defun lispnum) (clisp-buffer-select lispnum))) ;;; Profile the current defun in the specified Lisp process. Defaults ;;; to last selected lisp process. (defun clisp-profile-defun (&optional lispnum) "Profile the current defun in the specified Lisp process." (interactive "P") (when (defun-p) (message "Profiling defun...") (when (clisp-send-to-lisp (format "(user::profile %s)" (clisp-extract-defun-name)) (or lispnum 0) (clisp-current-package)) (message "Profiling defun...done.") t))) ;;; Profile the current defun in the specified Lisp process and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-profile-defun-and-go (&optional lispnum) "Profile the current defun in the specified Lisp process and switches to lisp buffer." (interactive "P") (when (clisp-profile-defun lispnum) (clisp-buffer-select lispnum))) ;;; Loads the current file in the specified Lisp process. Defaults ;;; to last selected lisp process. (defun clisp-eval-file (&optional lispnum) "Loads the current file in the specified Lisp process." (interactive "P") (cond ((buffer-modified-p) (message "Loading ORIGINAL file...")) (t (message "Loading file..."))) (when (clisp-load-file (buffer-file-name) t (or lispnum 0)) (cond ((buffer-modified-p) (message "Loading ORIGINAL file...done.")) (t (message "Loading file...done."))) t)) ;;; Loads the current file into the specified Lisp process and ;;; switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-eval-file-and-go (&optional lispnum) "Loads the current file into the specified Lisp process and switches to lisp buffer." (interactive "P") (when (clisp-eval-file lispnum) (clisp-buffer-select lispnum))) ;;; Compiles and loads the current file in the specified Lisp process. ;;; Defaults to last selected lisp process. (defun clisp-compile-file (&optional lispnum) "Compiles and loads the current file in the specified Lisp process." (interactive "P") (cond ((buffer-modified-p) (message "Compiling ORIGINAL file...")) (t (message "Compiling file..."))) (when (clisp-compile-and-load-file (buffer-file-name) t (or lispnum 0)) (cond ((buffer-modified-p) (message "Compiling ORIGINAL file...done.")) (t (message "Compiling file...done."))) t)) ;;; Compiles and loads the current file into the specified Lisp process ;;; and switches to lisp buffer. Defaults to last selected lisp process. (defun clisp-compile-file-and-go (&optional lispnum) "Compiles and loads the current file into the specified Lisp process and switches to lisp buffer." (interactive "P") (when (clisp-compile-file lispnum) (clisp-buffer-select lispnum))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Temporary file operations. Some items that must be sent to lisp ;;; require the use of the file system. For example, a CLOS defmethod ;;; form is a macro that expands to multiple forms. If it is to be ;;; compiled, it is not sufficient to invoke compile on the name of ;;; the method; rather it should be written to a temporary directory ;;; and the file compiled and loaded. ;;; *CLISP-FILESTEM* will be the filename used for transfers. This ;;; will be a unique value for each incarnation of emacs; thus many users ;;; can share the same temporary directory without fear of nuking each ;;; other's forms. (defvar *clisp-filestem* (make-temp-name "lsp")) ;;; Removes all files with filestem *clisp-filestem* (regardless of ;;; extension) from the temporary directory. Ideally, we could rm the ;;; temporary file after its loaded and/or compiled and loaded, but to ;;; do that we'd have to have emacs block until lisp is done. This ;;; way, we know there is at most one temp file in the temporary ;;; directory. (defun clisp-clean-temp-directory () (mapcar '(lambda (filename) (when (string-match *clisp-filestem* filename) (delete-file (expand-file-name filename *clisp-temporary-directory*)))) (directory-files *clisp-temporary-directory*))) ;;; Temporary source filename. (defun clisp-temporary-source () (format "%s%s" (expand-file-name *clisp-filestem* *clisp-temporary-directory*) *lisp-filename-extension*)) ;;; Creates a temporary source file with the proper package containing ;;; the specified string. (defun clisp-create-temp-file (string package) (clisp-clean-temp-directory) (let ((buffer (create-file-buffer (clisp-temporary-source)))) (save-window-excursion (set-buffer buffer) (insert (format "(in-package \"%s\")\n%s\n" package string)) (append-to-file (point-min)(point-max)(clisp-temporary-source)) (kill-buffer buffer) *clisp-filestem*))) ;;; Loads source file named filestem from temporary directory into ;;; lisp process lispnum. Returns value in inferior lisp. Note that we ;;; don't need to worry about packages, since the load command is not ;;; going to reset the current package anyway. (defun clisp-load-temp-file (value lispnum) (clisp-load-file (clisp-temporary-source) value lispnum)) (defun clisp-load-file (filename value lispnum) (clisp-send-to-lisp (format "(progn (user::load \"%s\") '%s)" filename value) (or lispnum 0))) ;;; Causes lisp process lispnum to compile file named filestem in ;;; temporary directory and load the compiled version. Returns value ;;; in inferior lisp. Again, ignore package manipulations. (defun clisp-compile-and-load-temp-file (value lispnum) (clisp-compile-and-load-file (clisp-temporary-source) (expand-file-name *clisp-filestem* *clisp-temporary-directory*) value lispnum)) (defun clisp-compile-and-load-file (filename filename-no-ext value lispnum) (clisp-send-to-lisp (format "(progn (user::compile-file \"%s\")(user::load \"%s\") '%s)" filename filename-no-ext value) (or lispnum 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CLISP-SEND-TO-LISP is the low-level function that sends an ;;; expression to a lisp process. Careful to switch lisp to be in the ;;; proper package. Some error checking is done in case the package ;;; given is bogus. Returns t if successful, nil if lisp process does ;;; not exist. Note that if no package is given or if the string ;;; matches "in-package", the string is sent without the package ;;; mechanism. This is important, as otherwise you couldn't send an ;;; in-package form over to lisp! (defun clisp-send-to-lisp (string lispnum &optional package) "Send STRING to lisp process LISPNUM. If LISPNUM is zero, send to *last-lisp-buffer*." (let ((buffer (get-buffer (clisp-number-to-buffer-name lispnum)))) (cond ((get-buffer-process buffer) (save-excursion (cond ((or (null package) (string-match *clisp-package-switch-regexp* string)) (process-send-string (clisp-buffer-to-process-name buffer) (format "%s\n" string))) (package (process-send-string (clisp-buffer-to-process-name buffer) (format "`(:GNU-FLUSH ,(format nil \"~A\" (unless (equalp (setq user::*old-package* (package-name user::*package*)) \"%s\")(in-package \"%s\") nil)))\n" package package)) (process-send-string (clisp-buffer-to-process-name buffer) (format "(prog1 (progn %s)(unless (equalp (package-name user::*package*) user::*old-package*)(in-package user::*old-package*)))\n" string))))) t) (t (beep) (message "Buffer %s not found." (clisp-number-to-buffer-name lispnum)) nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to handle Common Lisp packages. (defvar *clisp-package-switch-regexp* "(in-package") (defvar *clisp-buffer-package* nil) (make-variable-buffer-local '*clisp-buffer-package*) ;;; When invoked in a buffer containing Lisp code will determine ;;; package specification in force at point. (defun clisp-current-package () "Returns package for current buffer at point." (interactive) (or (clisp-scan-back-for-in-package) *clisp-buffer-package* (setq *clisp-buffer-package* (car (clisp-get-package-name))))) ;;; Sets the package for the current buffer. Defaults to USER. (defun clisp-set-package (&optional name) "Sets package for current buffer. Won't change current buffer if no package name is given. Defaults to package USER." (interactive "sPackage for current buffer: ") (make-variable-buffer-local '*clisp-buffer-package*) (cond ((equal name "") (unless (cdr (assoc '*clisp-buffer-package* (buffer-local-variables))) (setq *clisp-buffer-package* "USER"))) (t (setq *clisp-buffer-package* (upcase name))))) ;;; Looks at the mode line (top line of the buffer) in order to ;;; extract package information. (defun clisp-get-package-name () "Parses modeline for package name." (save-excursion (goto-char (point-min)) (let ((end (progn (end-of-line) (point))) begin (package-name "USER") package-use) (beginning-of-line) (cond ((search-forward "-*-" end t) (beginning-of-line) (cond ((re-search-forward "package." end t) (clisp-flush-whitespace) (cond ((char-equal (char-after (point)) ?\( ) (clisp-flush-whitespace) (setq begin (point)) (setq end (progn (forward-sexp) (point))) (goto-char (+ begin 1)) (clisp-flush-whitespace) (setq package-name (buffer-substring (point) (progn (clisp-forward-symbol) (point)))) (when (search-forward "(" (- end 1) t) (goto-char (- (point) 1)) (setq package-use (buffer-substring (point) (progn (forward-sexp) (point)))))) (t (setq begin (point)) (clisp-forward-symbol) (when (char-equal (preceding-char) ?\; ) (forward-char -1)) (setq package-name (buffer-substring begin (point))))))))) (cons (upcase package-name) package-use)))) ;;; Finds the preceeding in-package command by searching backwards ;;; from current point for an in-package command. Argument to ;;; in-package should be a string or a symbol; if its a symbol it ;;; should be coerced to upper case (a string is read as is). (defun clisp-scan-back-for-in-package () (save-excursion (let ((parse-sexp-ignore-comments nil)) (when (re-search-backward "( *in-package" (point-min) t) (forward-char 1) (clisp-flush-whitespace) (clisp-forward-symbol) (clisp-flush-whitespace) (cond ((looking-at "'") (forward-char 1) (upcase (buffer-substring (point) (progn (clisp-forward-symbol) (point))))) ((looking-at "\"") (forward-char 1) (buffer-substring (point) (progn (while (not (looking-at "\"")) (clisp-forward-char)) (point))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Tags are used to support indexing of functions in lisp files. This ;;; is similar to the Symbolics META-. function. The major difference ;;; is that you must have a tag table constructed ahead of time. The ;;; tag table is stored in the file TAGS in the same directory as the ;;; lisp files it indexes. ;;; This function shows you which files are indexed in the current tag ;;; table. (defun clisp-list-tag-files () "Lists all files currently in tag table." (interactive) (or tags-file-name (visit-tags-table "TAGS")) (tag-table-files) (with-output-to-temp-buffer "*Help*" (princ "Files indexed by current tag table:\n") (mapcar '(lambda (file) (terpri)(princ " ")(princ file)) tag-table-files))) ;;; Builds a new tags table in file TAGS, containing all def forms for ;;; all lisp files in the current directory. (defun clisp-recompute-tag-table () "Recomputes tags for all files in current directory." (interactive) (message "Computing tags...") (shell-command (format "etags *%s" *lisp-filename-extension*)) (visit-tags-table default-directory) (message "Computing tags...done.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Diversion functions. These functions send something to Lisp for ;;; evaluation and divert the output from this form to a given buffer. ;;; As far as the user can tell, Lisp hasn't seen these forms at all. ;;; Useful for getting info from current Lisp environment into the ;;; editor. ;;; *CLISP-DIVERSION-BUFFER* tells GNU where to stuff the diverted ;;; output. (defvar *clisp-diversion-buffer* nil "Indicates buffer for clisp-diverting-filter.") ;;; Open a new buffer containing the argument list of the current ;;; form. Send a backquoted form to current Lisp for evaluation, where ;;; the header of the form tells GNU to intercept it. WARNING: This ;;; function is LUCID-SPECIFIC. KCL and Allegro show the argument list ;;; as part of the function documentation (more in line with CLtL), ;;; but Lucid fails to implement the documentation function specified ;;; by CLtL. (defun clisp-show-arglist (&optional lispnum) "Show Common Lisp argument list for current sexpr in temporary buffer. WARNING: Lucid-specific." (interactive "P") (message "Computing arglist...") (let ((fnname (clisp-extract-function-name))) (save-window-excursion (setq *clisp-diversion-buffer* (get-buffer-create "*Documentation Buffer*")) (set-buffer *clisp-diversion-buffer*) (erase-buffer) (insert (format "%s: " (upcase fnname)))) (save-excursion (clisp-send-to-lisp (format "`(:GNU-DIVERT ,(let ((*print-pretty* t)) (format nil \"~A\" (user::arglist '%s))))\n" fnname) (or lispnum 0) (clisp-current-package)) (message "Computing arglist...done.")))) ;;; The following two functions are bound to keys. They tell ;;; CLISP-SHOW-DOCUMENTATION which kind of symbol to search for and ;;; document. (defun clisp-show-function-documentation (&optional lispnum) "Look for first symbol name before point and show its documentation." (interactive "P") (clisp-show-documentation 'function lispnum)) (defun clisp-show-variable-documentation (&optional lispnum) "Look for first symbol name before point and show its documentation" (interactive "P") (clisp-show-documentation 'variable lispnum)) ;;; Open a new buffer to show the doc-string for the current function ;;; or variable from Common Lisp. Send a backquoted form to current ;;; Lisp for evaluation, where the header of the form tells GNU to ;;; intercept it. The documentation shown is whatever is returned by ;;; the Common Lisp DOCUMENTATION function. (defun clisp-show-documentation (symtype lispnum) "Show Common Lisp documentation for current symbol in temporary buffer." (message "Fetching documentation...") (save-excursion (let ((symname (cond ((equal symtype 'function) (upcase (clisp-extract-function-name))) ((equal symtype 'variable) (upcase (clisp-extract-variable-name)))))) (setq *clisp-diversion-buffer* (get-buffer-create "*Documentation Buffer*")) (save-window-excursion (set-buffer *clisp-diversion-buffer*) (erase-buffer) (insert (format "%s %s: " (capitalize (symbol-name symtype)) symname))) (and (equal symtype 'variable) (clisp-send-to-lisp (format "`(:GNU-DIVERT ,(let ((*print-pretty* t)) (format nil \"~A\" (cond ((boundp (intern \"%s\")) (eval (intern \"%s\"))) (t \"Unbound\")))))\n" symname symname symname) (or lispnum 0) (clisp-current-package))) (clisp-send-to-lisp (format "`(:GNU-DIVERT ,(format nil \"~2%%~A\" (user::documentation '%s '%s)))\n" symname symtype symname) (or lispnum 0) (clisp-current-package)) (message "Fetching documentation...done.") (sit-for 1) (message "Type C-x 1 to remove documentation window.")))) ;;; Open a new buffer containing the macroexpansion of the current ;;; form. Send a backquoted form to current Lisp for evaluation, where ;;; the header of the form tells GNU to intercept it. (defun clisp-show-macro-expansion (&optional lispnum) "Show Common Lisp macro expansion for current sexpr in temporary buffer." (interactive "P") (message "Computing macro expansion...") (save-window-excursion (setq *clisp-diversion-buffer* (get-buffer-create "*Macroexpansion Buffer*")) (set-buffer *clisp-diversion-buffer*) (erase-buffer)) (save-excursion (clisp-send-to-lisp (format "`(:GNU-DIVERT ,(let ((*print-pretty* t)) (format nil \"~A\" (user::macroexpand-1 '%s))))\n" (clisp-extract-sexpr)) (or lispnum 0) (clisp-current-package)) (message "Computing macro expansion...done."))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utility functions for showing macro expansion and Common Lisp ;;; definition information. ;;; CLISP-FLUSH-WHITESPACE moves point up until it's looking at something ;;; interesting (e.g., non-blank). (defun clisp-flush-whitespace () (while (looking-at " ") (forward-char 1))) ;;; CLISP-FORWARD-CHAR moves point forward one character at a time, ;;; taking into account the "\" escape character, which causes point ;;; to move up two characters instead. (defun clisp-forward-char () "Moves forward one character from a Common Lisp symbol." (cond ((char-equal (following-char) ?\\ )(forward-char 2)) (t (forward-char 1)))) ;;; CLISP-FORWARD-SYMBOL moves the point forward one Common Lisp ;;; symbol. Common Lisp allows all sorts of strange things in a ;;; symbol; GNUemacs' idea of a word is not the same as Common Lisp's ;;; idea of a symbol. All sorts of special terminators have to be ;;; accounted for. (defun clisp-forward-symbol () "Moves point forward one Common Lisp symbol." (clisp-flush-whitespace) (when (looking-at "|") (clisp-forward-char) (while (not (looking-at "|")) (clisp-forward-char))) (while (not (or (looking-at " ") (looking-at "(") (looking-at ")") (looking-at "'") (looking-at "`") (looking-at " "))) (clisp-forward-char))) ;;; Returns a string like "defun", "defmethod", "defstruct", etc. ;;; indicating what kind of defun form you're in. (defun clisp-defun-type () "Returns the type of the current defun-like form." (save-excursion (when (looking-at "(") (forward-char 1)) (beginning-of-defun) (forward-char 1) (let ((begin (point))) (clisp-forward-symbol) (downcase (buffer-substring begin (point)))))) ;;; Checks if you're in a defun. (defmacro defun-p () (list 'string-equal "defun" '(clisp-defun-type))) ;;; Extracts the current defun-like form. Note that if you are at ;;; beginning left-paren, you must forward one char or run the risk of ;;; getting the previous defun. (defun clisp-extract-defun () "Returns current defun-like form." (save-excursion (when (looking-at "(") (forward-char 1)) (beginning-of-defun) (let ((begin (point))) (end-of-defun) (buffer-substring begin (point))))) ;;; Returns the function name of current defun. Note that if you are at ;;; beginning left-paren, you must forward one char or run the risk of ;;; getting the previous defun. (defun clisp-extract-defun-name () "Returns the function name of current defun." (save-excursion (when (looking-at "(") (forward-char 1)) (beginning-of-defun) (forward-char 1) (forward-sexp 1) (clisp-flush-whitespace) (buffer-substring (point) (progn (clisp-forward-symbol) (point))))) ;;; Returns nearest symbol behind the point. Keep moving backward ;;; until you find a character that is either alphanumeric or another ;;; symbol-name character. (defun clisp-extract-variable-name () "Returns nearest symbol behing the point." (save-excursion (while (and (/= (char-syntax (char-after (point))) 119) (/= (char-syntax (char-after (point))) 95)) (backward-char 1)) (buffer-substring (progn (backward-sexp 1)(point)) (progn (forward-sexp 1)(point))))) ;;; Returns the function name (car position) of the current sexpr. (defun clisp-extract-function-name () "Returns function name from current non-atomic sexpr." (save-excursion (cond ((looking-at "(") (forward-char 2)) ((looking-at ")") (forward-char 1) (backward-sexp 1) (forward-char 2)) (t (search-backward "(") (forward-char 2))) (buffer-substring (progn (backward-sexp 1)(point)) (progn (forward-sexp 1)(point))))) ;;; Extracts the current non-atomic sexpr. (defun clisp-extract-sexpr () "Returns current non-atomic sexpr." (save-excursion (cond ((looking-at "(") (buffer-substring (point) (progn (forward-sexp 1)(point)))) ((looking-at ")") (forward-char 1) (buffer-substring (progn (backward-sexp 1)(point)) (progn (forward-sexp 1)(point)))) (t (search-backward "(") (buffer-substring (point) (progn (forward-sexp 1)(point))))))) ;;; Returns the process name corresponding to a lisp buffer. (defun clisp-buffer-to-process-name (buffer) (let ((buffername (buffer-name buffer))) (substring buffername 1 (1- (length buffername))))) ;;; Returns the name string for the given lisp buffer. (defun clisp-number-to-buffer-name (buffernum) (cond ((zerop buffernum) *last-lisp-buffer*) ((= buffernum 1) "*lisp*") (t (format "*lisp%d*" buffernum)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indentation commands. ;;; CLISP-REINDENT-FORM should rejustify a comment if it is called from ;;; within a comment line. Otherwise, if called from within a lisp ;;; form, it should reindent the entire lisp form. (defun clisp-reindent-form () "Reindents the current form, whether it be comment or code." (interactive) (save-excursion (back-to-indentation) (cond ((looking-at ";") (clisp-set-prefix-string) (beginning-of-comment) (let ((begin (point))) (end-of-comment) (fill-region-as-paragraph begin (point)))) (t (beginning-of-defun) (next-line 1) (message "Reindenting...") (while (not (or (eobp) (let ((indent (calculate-lisp-indent))) (cond ((consp indent) (zerop (car indent))) (t (zerop indent)))))) (lisp-indent-line) (next-line 1)) (lisp-indent-line) (message "Reindenting...done."))))) ;;; CLISP-SET-PREFIX-STRING is used to set the fill prefix string to the ;;; right thing for each type of comment. (defun clisp-set-prefix-string () "Determines what the fill-prefix should be depending on the comment type." (cond ((looking-at ";;; ") (setq fill-prefix ";;; ")) ((looking-at ";; ") (setq fill-prefix ";; ")) ((looking-at "; ") (setq fill-prefix "; ")) (t (setq fill-prefix "")))) ;;; BEGINNING-OF-COMMENT and END-OF-COMMENT move the point to the beginning ;;; and end of the commented section, respectively. (defun beginning-of-comment () "Moves to first comment line surrounding point." (while (and (not (bobp)) (progn (back-to-indentation) (looking-at ";"))) (previous-line 1)) (next-line 1) (back-to-indentation)) (defun end-of-comment () "Moves to last comment line surrounding point." (while (and (not (eobp)) (progn (back-to-indentation) (looking-at ";"))) (next-line 1)) (previous-line 1) (end-of-line) (forward-char 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fix the indentation of FOR macro and other forms that are not normally ;;; well indented by GNU. (put 'for 'common-lisp-indent-hook 'lisp-indent-for) (put 'bind 'common-lisp-indent-hook 'lisp-indent-for) (put 'while 'common-lisp-indent-hook 'lisp-indent-for) (put 'until 'common-lisp-indent-hook 'lisp-indent-for) (put 'repeatwhile 'common-lisp-indent-hook 'lisp-indent-for) (put 'repeatuntil 'common-lisp-indent-hook 'lisp-indent-for) ;;; LISP-INDENT-FOR also works pretty well for the Zeta-lisp LOOP ;;; macro, currently before the ANSI Common Lisp committee as a ;;; proposed standard. (put 'loop 'common-lisp-indent-hook 'lisp-indent-for) (setq lisp-indent-maximum-backtracking 6) ;;; Other Common Lisp forms. (put 'merge 'common-lisp-indent-hook 1) (put 'defclass 'common-lisp-indent-hook 'defun) (put 'defmacro 'common-lisp-indent-hook 'defun) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions and variables for Interlisp FOR macro indentation. (defvar lisp-for-keyword-indentation 2 "Indentation of FOR macro keywords relative to containing list. This variable is used by the function lisp-indent-for.") (defvar lisp-for-body-indentation t "Indentation of forms after FOR macro keywords relative to containing list. This variable is used by the function lisp-indent-for to indent normal lines (lines without FOR macro keywords). The indentation is relative to the indentation of the parenthesis enclosing the special form. If the value is t, the body of tags will be indented as a block at the same indentation as the first s-expression following the tag. In this case, any forms before the first tag are indented by lisp-body-indent.") ;;; LISP-INDENT-FOR is almost exactly like LISP-INDENT-TAGBODY except that ;;; it uses the above-defined variables for indenting a FOR macro and indents ;;; keywords even if you use some on the same line as the FOR. (defun lisp-indent-for (path state indent-point sexp-column normal-indent) (save-excursion (goto-char indent-point) (beginning-of-line) (skip-chars-forward " \t") (list (cond ((looking-at "\\sw\\|\\s_") ;;; a FOR macro keyword (+ sexp-column lisp-for-keyword-indentation)) ((integerp lisp-for-body-indentation) (+ sexp-column lisp-for-body-indentation)) ((eq lisp-for-body-indentation 't) (condition-case () (progn (backward-sexp 1) (current-column)) (error (1+ sexp-column)))) (t (+ sexp-column lisp-body-indent))) (elt state 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Superparen functions. These are adapted from functions in ;;; simple.el, part of the standard GNU distribution. ;;; DOES-NOT-MATCH-CLOSE-PAREN-P returns t if the character at the ;;; given character position is not a match for a close paren. (defun does-not-match-close-paren-p (charpos) "Returns t if the character at the point doesn't match a close paren." ;;; 41 is the character code for a close paren. (/= 41 (logand ;;; The character that the one at charpos matches is stored in the ;;; upper 8 bits of its syntax table entry. (lsh (aref (syntax-table) (char-after charpos)) -8) ?\177))) ;;; SHOW-MATCHING-CONTEXT will either blink the (visible) open paren ;;; matching the current close paren, or print the part of this line ;;; containing the matching open paren in the minibuffer if it isn't ;;; visible in the current window. (defun show-matching-context (lastopenpos) (save-excursion (goto-char lastopenpos) ;;; If the last-matched open paren is on the screen, just move the ;;; cursor to it temporarily. (cond ((pos-visible-in-window-p) (sit-for 1)) ;;; Otherwise, print part of the line containing the last-matched open ;;; paren. (t (goto-char lastopenpos) (message "Matches %s" (cond ((save-excursion (skip-chars-backward " \t") (not (bolp))) (buffer-substring (progn (beginning-of-line) (point)) (1+ lastopenpos))) (t (buffer-substring lastopenpos (progn (forward-char 1) (skip-chars-forward "\n \t") (end-of-line) (point)))))))))) ;;; SUPER-CLOSE-PAREN searches backwards for open parens and inserts ;;; matching close parens at the point. If an open bracket is ;;; encountered, it is replaced with an open paren and matched, but ;;; the matching stops. ;;; If you are in Common Lisp mode, open parens within comments will ;;; be matched, so you should begin top level forms with an open bracket ;;; to keep from matching parens in comments. (defun super-close-paren () "Insert close parentheses as necessary to balance unmatched open parens." (interactive) ;;; If the character before the point is a quote, just insert a close ;;; bracket. If not, don't bother looking for open parens if the ;;; point is at the beginning of the buffer. (cond ((= (char-syntax (char-after (- (point) 2))) ?\\ ) (insert "]")) ((when (> (point) (1+ (point-min))) ;;; If you're not at the beginning of the buffer, start looking for ;;; open parens. (let* ((openpos t) ; must be t to pass the while test (mismatch) (lastopenpos t)) ; used to signal 1st iteration ;;; Insert a close paren to keep scan-sexps from returning the left ;;; end of a symbol instead of a list. (insert ")") (while openpos ;;; Keep looking for unmatched open parens to the left and inserting ;;; matching close parens until there are no unmatched parens. ;;; Condition-case traps errors quietly. (condition-case () (setq openpos (scan-sexps (point) -1)) (error nil)) ;;; If no new open paren has been found, then the new position will be ;;; the same as the old one. In this case, the while loop should be ;;; terminated, so openpos should be set to nil. Setting lastopenpos ;;; to nil signals that no open parens at all were found. (when (equal openpos lastopenpos) (setq openpos nil) (when (equal lastopenpos t) (setq lastopenpos nil))) ;;; If you have found an open paren, but the syntax table says that it ;;; isn't a "paired delimiter" and doesn't match a close paren, that ;;; open paren is either mismatched or is really a open bracket. (if (and openpos (/= (char-syntax (char-after openpos)) ?\$)) (setq mismatch (does-not-match-close-paren-p openpos))) ;;; If you have found a mismatch or open bracket, terminate the while ;;; loop. If the last "paren" found was actually an open bracket, it ;;; should be replaced replaced with an open paren and matched with a ;;; close paren. The open bracket is not a mismatch, but the while ;;; loop should still be exited. (when mismatch ;;; 91 is the character code for open bracket (when (= 91 (char-after openpos)) (setq lastopenpos openpos) (save-excursion (goto-char openpos) (delete-char 1) (insert "(")) (insert ")") (setq mismatch nil)) (setq openpos nil)) ;;; If you've found a matchable open paren, insert a close paren. ;;; Otherwise, get rid of the extra paren inserted earlier. (cond (openpos (insert ")") (setq lastopenpos openpos)) (t (delete-backward-char 1)))) ;;; If you found mismatched parens, complain. Otherwise, show what ;;; the last paren inserted matches. (cond (mismatch (message "Mismatched parentheses")) (lastopenpos (show-matching-context lastopenpos)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This part of the file provides an interactive template-based ;;; definition facility. Prompts the user for the different parts of ;;; each definition. Adapted by Riad Mohammed ;;; (mohammed@cs.cornell.edu) from code originally written by Rick ;;; Palmer (rick@cs.cornell.edu). ;;; *TEMPLATE-ALIST* describes the types of templates this facility ;;; knows about. The car is the type of the thing being defined, while ;;; the cdr is a string that is concatenated with "def" to get the ;;; defining form. (defvar *template-alist* '(("function" . "un") ("macro" . "macro") ("structure" . "struct") ("variable" . "var") ("constant" . "constant") ("parameter" . "parameter") ("class" . "class") ("generic" . "generic") ("method" . "method"))) ;;; If set to t, then *clisp-separator-string* will be placed before ;;; every template. If set to nil, then *clisp-separator-string* will ;;; be set only if a prefix argument is given to clisp-make-template. (defvar *clisp-default-separate* nil) ;;; Sets width (in characters) of the separator and header. Defaults ;;; to 74 (+ the leading ";;;"). (defvar *clisp-separator-width* 74) (defvar *clisp-separator-character* ?;) (defvar *clisp-separator-string* (format "\n;;;%s\n" (make-string *clisp-separator-width* *clisp-separator-character*))) (defvar *clisp-default-doc-string* "Undocumented.") ;;; The following strings are used to define the template. (defvar *clisp-header-string* (concat ";;; %s: %s%sAuthor: " (user-login-name) "\n;;; Created: %s\n\n")) (defvar *clisp-defn-string* "(def%s %s") ;;; CLISP-TEMPLATE-GET-TYPE returns a consed pair from ;;; *template-alist* with the type and the letters required following ;;; "def" to define type. (defun clisp-template-get-type () (let* ((type (completing-read "Type? " *template-alist* nil t))) (cond ((= (length type) 0) '("function" . "un")) (t (assoc type *template-alist*))))) ;;; CLISP-PROMPT-USER prompts the user with prompt-string in the ;;; minibuffer and accepts a reply. If reply is not equal to ;;; null-reply, it is returned; else default is returned. (defun clisp-prompt-user (prompt-string &optional null-reply default) (let ((reply (read-string prompt-string))) (cond ((string= reply null-reply) default) (t reply)))) ;;; CLISP-MAKE-TEMPLATE does the brunt of the work setting up the ;;; template. If called with a prefix arg (or if ;;; *clisp-default-separate* is t), the *clisp-separator* (initially a row ;;; of semicolons) is inserted before the template. (defun clisp-make-template (&optional separate) "Creates a template interactively for the appropriate defun, defvar, defconstant, defparamater, defstruct, defclass, or defmethod." (interactive "P") (let ((type (clisp-template-get-type)) postfix header) (setq postfix (cdr type)) (setq type (car type)) (let ((name (clisp-prompt-user (concat (capitalize type) " name? ") "" (upcase (concat "UNNAMED-" (upcase type)))))) (or (bolp) (progn (end-of-line 1) (insert "\n"))) (insert "\n") (setq header (concat (cond ((or separate *clisp-default-separate*) *clisp-separator-string*) (t "")) (format *clisp-header-string* (capitalize type) (upcase name) (make-string (- *clisp-separator-width* (+ 19 (length type)(length name))) ?\ ) (current-time-string)) (format *clisp-defn-string* postfix name))) (cond ((string= type "function") (clisp-make-function-template name header)) ((or (string= type "variable") (string= type "constant") (string= type "parameter")) (clisp-make-variable-template name header)) ((string= type "macro") (clisp-make-macro-template name header)) ((string= type "structure") (clisp-make-structure-template name header)) ((string= type "class") (clisp-make-class-template name header)) ((string= type "generic") (clisp-make-generic-template name header)) ((string= type "method") (clisp-make-method-template name header)))))) ;;; Each of the following functions writes out the proper template for ;;; a particular type of defining form. (defun clisp-make-function-template (name header) (let ((args (clisp-prompt-user "Arguments? ")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (insert (format " (%s) \n\"%s\"\n)" args doc)) (clisp-reindent-form) (backward-char 1))) (defun clisp-make-macro-template (name header) (let ((args (clisp-prompt-user "Arguments? ")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (insert (format " (%s) \n\"%s\"\n)" args doc)) (clisp-reindent-form) (backward-char 1))) (defun clisp-make-variable-template (name header) (let ((value (clisp-prompt-user "Value? " "" "nil")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (insert (format " %s \"%s\")" value doc)))) (defun clisp-make-structure-template (name header) (let ((slots (clisp-prompt-user "Slots? ")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (or (string= doc *clisp-default-doc-string*) (progn (beginning-of-line) (insert (format ";;; %s" doc)) (clisp-reindent-form) (insert "\n\n") (end-of-line 1))) (let ((index 0)) (while (< index (length slots)) (setq index (read-from-string slots index)) (newline-and-indent) (insert (format " %s" (car index))) (setq index (cdr index)))) (insert ")") (backward-char 1) (clisp-reindent-form) (end-of-line))) (defun clisp-make-class-template (name header) (let ((supers (clisp-prompt-user "Supers? ")) (slots (clisp-prompt-user "Slots? ")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (insert (format " (%s)\n ()\n" supers)) (backward-char 2) (clisp-add-slots slots) (forward-char 1) (insert (format "\n (:documentation \"%s\"))\n" doc)) (clisp-reindent-form) (end-of-line) (insert "\n") (insert (format "(defun make-%s ()\n (let ((self (make-instance '%s)))\n self))\n\n" name name)) (clisp-reindent-form) (insert (format "(defmacro %s-p (self)\n`(eq (class-name (class-of ,self)) '%s))\n" name name)) (clisp-reindent-form))) (defun clisp-add-slot (var-name var-val) (insert (format "(%s :initform %s :initarg :%s :accessor %s-%s)\n " var-name var-val var-name name var-name))) (defun clisp-add-slots (slot-specifications) (unless (zerop (length slots)) (let ((index 0) var-name var-val) (while (< index (length slots)) (setq index (read-from-string slots index)) (setq var-name (car index)) (setq var-val "nil") (and (consp var-name) (progn (setq var-val (car (cdr var-name))) (setq var-name (car var-name)))) (setq index (cdr index)) (clisp-add-slot var-name var-val)) (delete-char -2)))) (defun clisp-make-generic-template (name header) (let ((args (clisp-prompt-user "Arguments? ")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (insert (format " (%s)\n#+CLOS (:documentation \"%s\")\n )" args doc)) (backward-char 1) (clisp-reindent-form) (forward-char 2))) (defun clisp-make-method-template (name header) (let ((classes (clisp-prompt-user "Class(es)? ")) (doc (clisp-prompt-user "Documentation? " "" *clisp-default-doc-string*))) (insert header) (insert " (") (clisp-add-class-specifiers classes) (insert (format ")\n \"%s\"\n)" doc)) (clisp-reindent-form) (backward-char 1))) (defun clisp-add-class-specifiers (classes) (unless (zerop (length classes)) (let ((index 0) name) (while (< index (length classes)) (setq index (read-from-string classes index)) (setq name (car index)) (setq index (cdr index)) (insert (format "(%s %s)\n " name name))) (delete-char -2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Part of the remainder of this file was adapted by David ;;; Hubbell (hubbell@svax.cs.cornell.edu) from code ;;; written by Wolfgang Rupprecht (wolfgang@mgm.mit.edu). The original file ;;; (shellext.el) provided ksh-like extensions to shell.el; we've ;;; usurped the history mechanism and some of the shell options from ;;; Wolfgang's code, and have added much of our own code. ;;; This is a ksh-like extension to shell.el. These extensions ;;; implement command history (backwards, forwards, back-search, ;;; forward-srearch) and history printout for an emacs shell window. ;;; The one glaring difference between this and ksh, is that all of ;;; the shell-mode commands are bound to the Control-C prefix map. ;;; (Eg. previous command is C-c C-p). (defvar clisp-shell-last-search "" "Last shell search string.") (defvar clisp-shell-max-history 60 "*Max shell history retained") (defvar clisp-shell-history-list nil "History list of past shell commands.") (defvar clisp-shell-history-index -1 "Where we are on the history list. It is -1 unless currently walking up/down the list") ;;; CLISP-SHELL-PREVIOUS-COMMAND walks back the history list, placing ;;; the entry at the current buffer position. If repeated, it replaces ;;; the last history entry with the previous entry (if one exists). ;;; Successive calls to CLISP-SHELL-PREVIOUS-COMMAND therefore produce ;;; successively older entries in the history list. Note that if you ;;; aren't past the last prompt, it puts you at point-max. (defun clisp-shell-previous-command () "Insert the previous command on the history list into the Lisp buffer." (interactive) (let ((history (nthcdr (1+ clisp-shell-history-index) clisp-shell-history-list))) (cond (history (delete-region (process-mark (get-buffer-process (current-buffer))) (point-max)) (goto-char (point-max)) (insert (car history)) (setq clisp-shell-history-index (1+ clisp-shell-history-index))) (t (error "Beginning of history list (%d entries)" (1+ clisp-shell-history-index)))))) ;;; CLISP-SHELL-NEXT-COMMAND replaces the region between the last ;;; character output from the shell and the end of the buffer with the ;;; (clisp-shell-history-index)th element in the history list, if this ;;; element exists, and decrements clisp-shell-history-index. ;;; Successive calls to CLISP-SHELL-NEXT-COMMAND therefore produce ;;; successively younger entries in the history list. (defun clisp-shell-next-command () "Insert the next command from the history list into the Lisp buffer." (interactive) (cond ((< 0 clisp-shell-history-index) (delete-region (process-mark (get-buffer-process (current-buffer))) (point-max)) (goto-char (point-max)) (insert (nth (setq clisp-shell-history-index (1- clisp-shell-history-index)) clisp-shell-history-list))) (t (error "End of history list")))) ;;; CLISP-SHELL-PREVIOUS-PROMPT positions the point at the beginning ;;; of the current line but after the prompt, if any. (defun clisp-shell-previous-prompt () (interactive) (beginning-of-line) (re-search-forward inferior-lisp-prompt (save-excursion (end-of-line) (point)) t)) ;;; CLISP-SHELL-HISTORY-SEARCH-BACKWARD searches chronologically ;;; backward (not structurally) through the history list for a string ;;; that is a superstring of the argument. If such a string is found, ;;; it replaces the text between the last prompt and the end of the ;;; buffer and clisp-shell-history-index is changed to the index of ;;; this string in the history list. If such a string is not found, ;;; clisp-shell-history-index remains unaltered. (defun clisp-shell-history-search-backward (string) "Search backwards through the history list for STRING and inserts it if the search is successful." (interactive (list (setq clisp-shell-last-search (read-string "History search for: " clisp-shell-last-search)))) (let* ((index (1+ clisp-shell-history-index)) ; start at next command (history (nthcdr index clisp-shell-history-list))) (while (and history (null (string-match string (car history)))) (setq index (1+ index) history (cdr history))) (cond (history (setq clisp-shell-history-index index) (delete-region (process-mark (get-buffer-process (current-buffer))) (point-max)) (goto-char (point-max)) (insert (car history))) (t (error "No match found, now at entry %d" clisp-shell-history-index))))) ;;; CLISP-SHELL-HISTORY-SEARCH-FORWARD searches chronologically ;;; forward (not structurally) through the history list for a string ;;; that is a superstring of the argument. If such a string is found, ;;; it replaces the text between the last prompt and the end of the ;;; buffer and clisp-shell-history-index is changed to the index of ;;; this string in the history list. If such a string is not found, ;;; clisp-shell-history-index remains unaltered. (defun clisp-shell-history-search-forward (string) "Search forwards through the history list for STRING and inserts it if the search is successful." (interactive (list (setq clisp-shell-last-search (read-string "History search for: " clisp-shell-last-search)))) ;;; Reversing the list now is asymptotically more efficient than ;;; doing nth n times, where n is the length of the history list. (let* ((index (- history-length clisp-shell-history-index 1)) (history-length (length clisp-shell-history-list)) (reverse-history-list (nthcdr index (reverse clisp-shell-history-list)))) (while (and reverse-history-list (null (string-match string (car reverse-history-list)))) (setq index (1+ index) reverse-history-list (cdr reverse-history-list))) (cond (reverse-history-list (setq clisp-shell-history-index (- history-length index 1)) (delete-region (process-mark (get-buffer-process (current-buffer))) (point-max)) (goto-char (point-max)) (insert (car reverse-history-list))) (t (error "No match found, now at entry %d" clisp-shell-history-index))))) ;;; CLISP-SHELL-LIST-HISTORY prints the contents of the history list ;;; to a temporary *History* buffer, most recent entry first, with a ;;; '*' at the current position. (defun clisp-shell-list-history () "List the history in the *History* buffer. A '*' indicates current position on the history list." (interactive) (with-output-to-temp-buffer "*History*" (let ((history clisp-shell-history-list) (index 0)) (while history (princ (format " %c[%d] %s\n" (if (= index clisp-shell-history-index) ?* ?\ ) index (car history))) (setq history (cdr history) index (1+ index))))) (message "Type C-x 1 to remove history window.")) ;;; CLISP-SHELL-SAVE-HISTORY saves the region between the last prompt ;;; and the end of buffer onto the history list, and sets the ;;; clisp-shell-history-index to the start (most recent entry) of the ;;; list. (defun clisp-shell-save-history (start end) "Save this command on the clisp-shell-history-list." (let ((command (buffer-substring start end))) (if (or (string-match "^[ \t]*$" command) (string-equal command (car clisp-shell-history-list))) nil ; don't hang dups on list (setq clisp-shell-history-list (cons command clisp-shell-history-list)) (let ((prune-pt (nthcdr clisp-shell-max-history clisp-shell-history-list))) (and prune-pt (rplacd prune-pt nil))))) (setq clisp-shell-history-index -1)) ;;; CLISP-SHELL-SEND-INPUT-IF-SEXPR, if after the last prompt, sends ;;; all text after last output as input to the subshell if that text ;;; was an s-expression, including a newline inserted at the end. If ;;; before last prompt, copies current line to the end of the buffer ;;; and sends it (if it was an s-expression). (defun clisp-shell-send-input-if-sexpr () "Send input to subshell if the last input was an s-expression." (interactive) (let* ((proc (get-buffer-process (current-buffer))) (old-mark (marker-position (process-mark proc))) (current (point)) start end) (or proc (error "Current buffer has no process")) ;;; If not at past the last process mark, copy everything from the ;;; last prompt to the end of buffer and treat that as the input ;;; region. (save-excursion (when (> old-mark current) (setq end current) (setq start (save-excursion (condition-case () (scan-sexps (point) -1) (error nil)))) (goto-char (point-max)) (insert (buffer-substring start end)) (setq current (point))) ;;; Send all complete s-expressions after the process mark and before ;;; the current point to the lisp process as possible. (goto-char (setq start old-mark)) (while (and (setq end (condition-case () (scan-sexps start 1) (error nil))) (<= end current)) (clisp-shell-save-history start end) (setq start end)) ;;; If there is a partial sexpr, go to beginning of that sexpr and ;;; process complete sexprs before it. Leaves point at end of buffer. ;;; If there are no complete sexprs, just insert the newline wherever ;;; you were. (cond ((= start old-mark) (goto-char current) (newline)) (t (goto-char start) (newline) (move-marker (process-mark proc) (setq end (point))) (process-send-region proc old-mark end)))) (goto-char (point-max)))) SHAR_EOF # End of shell archive exit 0