home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / interfaces / Emacs-cl-shell / cl-shell.el < prev    next >
Encoding:
Text File  |  1991-04-05  |  53.8 KB  |  1,259 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; FILE:          cl-shell.el
  3. ;;; DESCRIPTION:   Extensions to the code in shell.el for running a Common
  4. ;;;                Lisp sub-process in a GnuEmacs buffer.
  5. ;;; AUTHOR:        Eero Simoncelli, 
  6. ;;;                Vision Science Group, 
  7. ;;;                MIT Media Laboratory.
  8. ;;; CREATED:       December, 1989
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY.  No author or distributor accepts
  13. ;; responsibility to anyone for the consequences of using it or for
  14. ;; whether it serves any particular purpose or works at all, unless he
  15. ;; says so in writing.  Refer to the GNU Emacs General Public License
  16. ;; for full details.
  17.  
  18. ;; Everyone is granted permission to copy, modify and redistribute GNU
  19. ;; Emacs, but only under the conditions described in the GNU Emacs
  20. ;; General Public License.  A copy of this license is supposed to have
  21. ;; been given to you along with GNU Emacs so you can know your rights
  22. ;; and responsibilities.  It should be in a file named COPYING.  Among
  23. ;; other things, the copyright notice and this notice must be
  24. ;; preserved on all copies.
  25.  
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. ;;; The code in this file has been influenced by three other attempts
  30. ;;; to provide a useful interface between Gnu Emacs and a Common Lisp
  31. ;;; (CL) subprocess.  The first was written by Leigh Stoller and
  32. ;;; Robert Kessler of the University of Utah for running HPCL or PCLS
  33. ;;; on HP Bobcats.  It is HP-specific and somewhat limited in
  34. ;;; functionality.  The second comes with Franz's Allegro CL.  This
  35. ;;; one is a fairly hairy set of low-level extensions which set up
  36. ;;; multiple communication streams (Unix TCP sockets) between Emacs
  37. ;;; and Allegro CL.  The third was developed at Thinking Machines
  38. ;;; Corporation for use with Lucid Common Lisp on SUN machines, and is
  39. ;;; designed to simulate the Symbolics lispm environment.  It is
  40. ;;; large and is quite Lucid-dependent.
  41.  
  42. ;;; We provide a simple portable interface between Emacs and CL which
  43. ;;; allows CL to send messages to Emacs without the use of
  44. ;;; (non-Common-Lisp) multiple processes or special stream
  45. ;;; connections.  We view the standard output stream as a
  46. ;;; concatenation of non-nested special-purpose streams.  Emacs
  47. ;;; separates out the various substreams and treats them accordingly.
  48. ;;; In this sense, it achieves most of the functionality of the Franz
  49. ;;; code, without low-level modifications to Emacs.  We provide a
  50. ;;; mechanism for CL to send commands to Emacs, to display strings in
  51. ;;; the minibuffer or pop-up help buffers, or just to insert strings
  52. ;;; at the point.
  53.  
  54. ;;; We also provide a set of functions which improve interaction with
  55. ;;; the lisp process when editing the *lisp* or lisp-mode buffers.
  56. ;;; These include direct (ie not through a temp file) evaluation and
  57. ;;; in-package compilation of forms from lisp-mode buffers with
  58. ;;; optional echo into the *lisp* buffer, type-ahead with multi-line
  59. ;;; editing and a history mechanism for the *lisp* buffer, and pop-up
  60. ;;; help facilities for the CL functions documentation, macroexpand
  61. ;;; and describe.  There is an additional file of extensions for Lucid
  62. ;;; Common Lisp which provide pop-up arglists and source file editing,
  63. ;;; including a sort of buffer menu to let the user choose from
  64. ;;; multiple definitions.  There are also extensions to do source
  65. ;;; files correctly (ie, let the user choose which method to edit) for
  66. ;;; FLAVORS, CLOS, or PCL.
  67.  
  68. ;;; This code should be compatible with any implementation of Common
  69. ;;; Lisp -- the extensions for Lucid, FLAVORS, CLOS and PCL are only
  70. ;;; loaded (automatically) if these features are present in your CL
  71. ;;; environment -- and it requires no special code to be loaded into
  72. ;;; the CL environment.  CL can tell that this code is loaded by
  73. ;;; looking at the value of the global variable user::*emacs-cl-shell*
  74. ;;; which is set by run-cl.  See comments below (in the CL output
  75. ;;; filter section) on how to talk to Emacs from CL.  You should be
  76. ;;; aware that when you start up lisp, Emacs tells the CL process to
  77. ;;; define the macro user::compile-def for use in compiling top-level
  78. ;;; forms.
  79.  
  80. ;;; To use this code, you should either copy this file and the files
  81. ;;; shell-history.el, cl-lucid.el, cl-clos.el, cl-pcl.el and
  82. ;;; cl-flavors.el into your main emacs/lisp directory, or add the
  83. ;;; directory containing these files to the Emacs variable load-path.
  84. ;;; Put the following lines in your .emacs file:
  85.  
  86. ;;;   (setq load-path (cons "<directory-containint-this-file>" load-path))
  87. ;;;   (setq *cl-program* <pathname-of-your-lisp-program>)
  88. ;;;   (autoload 'run-cl "<pathname-of-this-file>" "" t) 
  89.  
  90. ;;; To run lisp, type "M-x run-cl" in emacs.  Lisp will start up in a
  91. ;;; buffer called *lisp*, and after it comes up, a set of blank
  92. ;;; prompts will appear.  This is normal and occurs because emacs is
  93. ;;; sending initialization commands to the lisp process.  Lisp images
  94. ;;; other than the default one bound to the variable *cl-program* may
  95. ;;; be specified interactively by using a prefix arg.  You can get
  96. ;;; help on key bindings and a brief page of documentation by doing
  97. ;;; "C-h f cl-shell-mode". The files cl-lucid.el, cl-clos.el
  98. ;;; cl-pcl.el, and/or cl-flavors.el will be loaded automatically if
  99. ;;; the corresponding features are present in your lisp environment,
  100. ;;; but these files are not necessary for the code in this file to
  101. ;;; work.  If you want to add more key bindings, define a function
  102. ;;; called cl-shell-hook to do this.  Only bindings that everyone
  103. ;;; agrees on should be put in this file!
  104.  
  105. ;;; NOTE: Known bugs or questionable behaviors are marked in this file
  106. ;;; and in the accompanying files with the string "***".
  107.  
  108.  
  109.  
  110. (require 'shell)
  111. (require 'tags)
  112.  
  113. (provide 'cl-shell)
  114.  
  115. ;;;; -------------------- General stuff -------------------
  116.  
  117. ;;; This is similar to the code in shell.el which defines inferior-lisp-mode.
  118. ;;; We introduce a cl-shell-mode so as not to clobber inferior-lisp-mode.
  119. ;;; Some of the defvars and defuns may need to be altered for different lisps.
  120.  
  121. (defvar *cl-pop-up* t
  122.   "*If non-nil, the *lisp* buffer pops up whenever it recieves output
  123. from the Common Lisp process.  If the user variable pop-up-windows is
  124. non-nil, then the window will be split if necessary.")
  125.  
  126. (defvar *cl-echo-commands* t
  127.   "*If non-nil, commands being sent to Common Lisp are echoed into the
  128. CL-shell output buffer.")
  129.  
  130. (defvar *cl-replacement-prompt* nil
  131.   "*If stringp, this is used to replace the top-level prompts in the 
  132. Common Lisp output buffer.  Can be the empty string.  If nil, then
  133. leave them as they are.  This variable is used to set the value of the
  134. local variable cl-replacement-prompt when a CL shell buffer is created.")
  135.  
  136. (defvar *cl-program* "lisp"
  137.   "*Program name for invoking a Common Lisp subshell with run-cl.")
  138.  
  139. ;;; This regexp is used to recognize and parse the CL process prompts.
  140. ;;; This particular string is correct for Lucid CL.  Be careful that
  141. ;;; this does not conflict with the special-purpose stream tags
  142. ;;; defined below.
  143. (defvar *cl-prompt* "^> "
  144.   "Regular expression describing the Common Lisp prompt.")
  145.  
  146. ;;; This is correct for Lucid CL.
  147. (defvar *cl-error-prompt* "^\\(->\\)+ "
  148.   "Regular expression describing the Common Lisp error prompt.")
  149.  
  150. ;;; Quick debugger commands.  These are correct for Lucid CL.
  151. (defun cl-abort () (interactive) (cl-send-string ":a\n"))
  152.  
  153. (defun cl-backtrace () (interactive) (cl-send-string ":b\n"))
  154.  
  155. ;;; Replace the load command defined in shell.el with one for Common Lisp
  156. ;;; which is a little quieter.  For use in cl-compile-form.
  157. (setq inferior-lisp-load-command "(load \"%s\" :verbose nil)\n")
  158.  
  159. ;;; This is used by the cl-load-file command.
  160. (setq cl-load-command "(load \"%s\")\n")
  161.  
  162. (defvar cl-fast-compile-regexp "(def\\(un\\|macro\\)[ \t\n]+"
  163.   "Regular expression which determines whether to compile a top-level
  164. s-expression by sending directly to the lisp process inside of a call
  165. to user::compile-def, or by saving to a file and compiling the file.")
  166.  
  167. ;;; This string is sent to CL at startup.  It defines the
  168. ;;; user::compile-def macro which is used by cl-compile-form to
  169. ;;; compile forms which match the cl-fast-compile-regexp.  Since
  170. ;;; compile-def will only be called for macros and defuns (see
  171. ;;; cl-fast-compile-regexp), we can just call compile on thing.
  172. (defvar *cl-compile-def-definition*
  173.   "(or (fboundp 'user::compile-def)    ;don't bash it if it's already defined.
  174.        (defmacro user::compile-def (thing)
  175.          `(compile ,thing)))\n")
  176.  
  177. (defvar cl-compile-command "(compile-file \"%s\")\n"
  178.   "CL compile-file command for use in compiling expressions that do
  179. not match cl-fast-compile-regexp.")
  180.  
  181. (defvar *cl-default-buffer-package* t
  182.   "*Default buffer package used by cl-set-buffer-package when 
  183.  (in-package ...) cannot be found in the buffer.  Should typically 
  184. be \"'user\" or t.  If t, then the buffer package will be the 
  185. contents of the CL variable *package*.  Use cl-set-buffer-package 
  186. to change the package of a buffer, and cl-get-buffer-package to get 
  187. (and possibly set to the default) the package of a buffer.")
  188.  
  189. ;;; This is used in lisps that have a source-file recording
  190. ;;; capability.  See cl-lucid.el for an example.
  191. (defvar *cl-definition-regexp-alist* nil
  192.   "An alist which keys off of definition types to give a regular
  193. expression which Emacs uses to search for the definition.  The cdr
  194. of each pair is either 1) a string suitable for an arg to a format
  195. statement which inserts the symbol, or 2) a function which will be
  196. called with the symbol and type-spec and should return a regexp.")
  197.  
  198. ;;; Is this unnecessarily hairy?  NOTE: run-hooks should be the last
  199. ;;; command.
  200. (defvar *cl-required-el-code-list*
  201.   '(
  202.     "#+:LUCID %s"   "(load \\\"cl-lucid\\\")"
  203.     "#+:PCL %s"     "(load \\\"cl-pcl\\\")"
  204.     "#+(and :LCL4.0 :CLOS) %s"   "(load \\\"cl-clos\\\")"
  205.     "#+:FLAVORS %s" "(load \\\"cl-flavors\\\")"
  206.     "%s"  "(progn (set-buffer (cl-buffer))
  207.               (run-hooks 'shell-mode-hook 'lisp-mode-hook 'cl-shell-mode-hook))"
  208.     )
  209.   "A plist containing predicate strings which are to be evaluated in the
  210. CL environment and command strings which will be executed in emacs-lisp 
  211. if the predicates are non-nil.  The command will be inserted into the
  212. predicate with a call to format.  These are executed (by run-cl) when emacs
  213. receives the first prompt from the CL process.")
  214.  
  215. ;;; This is called at startup time, after Lisp comes back with a prompt!
  216. (defun cl-send-startup-commands ()
  217.   (cl-send-string " \n (progn\n")
  218.   (cl-send-string
  219.    "(format *standard-output* \"~%;;; Receiving startup commands from Emacs ...~%\")")
  220.   ;; Define with-package and compile-def macros
  221.   (cl-send-string *cl-compile-def-definition*)
  222.   ;; Tell CL that Emacs is there.
  223.   (cl-send-string "(setq user::*emacs-cl-shell* t)\n")
  224.   (cl-send-string "(values))\n")    ;end of progn
  225.   ;; Load other emacs-lisp files according to features in CL
  226.   (cl-load-required-el-code *cl-required-el-code-list*))
  227.  
  228. (defun cl-load-required-el-code (plist)
  229.   (let (cl-command)
  230.     (while plist
  231.       (setq cl-command (concat "(format *standard-output* \""
  232.                    (car (cdr plist))
  233.                    "\")\n"))
  234.       (cl-send-string
  235.        (format (car plist)
  236.            (cl-concatenate-stream-id cl-command cl-eval-stream-id t)))
  237.       (setq plist (cdr (cdr plist))))))
  238.  
  239. ;;; Like copy-alist, but does it recursively so there are no shared structures.
  240. (defun copy-tree (tree)
  241.   (cond ((consp tree) (cons (copy-tree (car tree)) (copy-tree (cdr tree))))
  242.     ((sequencep tree) (copy-sequence tree))    ;string or vector, but not list
  243.     (t tree)))            ;non-sequence atoms
  244.  
  245. (defvar cl-shell-mode-map 
  246.   (let ((the-map (make-sparse-keymap))) ;(copy-tree inferior-lisp-mode-map)
  247.     (lisp-mode-commands the-map)
  248.  
  249.     (define-key the-map "\C-cb" 'cl-backtrace)
  250.     (define-key the-map "\C-ca" 'cl-abort)
  251.  
  252.     (define-key the-map "\C-c\C-c" 'cl-interrupt-process)
  253.     (define-key the-map "\C-c\C-p" 'cl-set-buffer-package)
  254.  
  255.     ;; In addition, arglists are defined for Lucid in the file cl-lucid.el
  256.     (define-key the-map "\C-c\C-d" 'cl-documentation)
  257.     (define-key the-map "\C-c\C-m" 'cl-macroexpand-1)
  258.     (define-key the-map "\C-c\C-h" 'cl-describe)
  259.  
  260.     (define-key the-map "\C-c\C-q" 'cl-bury-help)
  261.  
  262.     (define-key the-map "\C-a" 'cl-beginning-of-line)
  263.     (define-key the-map "\C-m" 'cl-shell-send-input)  ;Carriage Return
  264.  
  265.     (define-key the-map "\M-\C-y" 'shell-yank-history)
  266.     (define-key the-map "\M-\C-z" 'shell-yank-history-forward)
  267.  
  268.     (define-key the-map "\M-p" 'shell-yank-matching-history)
  269.     (define-key the-map "\M-n" 'shell-yank-matching-history-forward)
  270.  
  271.     the-map))
  272.  
  273. (defun cl-add-lisp-mode-key-bindings ()
  274.   "Add key bindings to lisp-mode-map for use with cl-shell-mode."
  275.   (let ((the-map lisp-mode-map))
  276.     (define-key the-map "\C-ce" 'cl-eval-form)
  277.     (define-key the-map "\C-cr" 'cl-eval-region)
  278.     (define-key the-map "\C-cc" 'cl-compile-form)
  279.  
  280.     (define-key the-map "\C-c\C-p" 'cl-set-buffer-package)
  281.     (define-key the-map "\C-cl" 'cl-load-file)
  282.     (define-key the-map "\C-cx" 'cl-compile-file)
  283.  
  284.     (define-key the-map "\C-c\C-d" 'cl-documentation)
  285.     (define-key the-map "\C-c\C-m" 'cl-macroexpand-1)
  286.     (define-key the-map "\C-c\C-h" 'cl-describe)
  287.  
  288.     (define-key the-map "\C-c\C-q" 'cl-bury-help)
  289.  
  290.     (define-key the-map "\C-ca" 'cl-abort)
  291.     (define-key the-map "\C-cb" 'cl-backtrace)
  292.     the-map))
  293.  
  294.  
  295. ;;;; -------------------- cl-shell-mode stuff -------------------
  296.  
  297. ;;; *** Should define the markers last-input-start and last-input-end
  298. ;;; (see shell-mode) since some inferior-lisp-mode-map bindings rely
  299. ;;; on them.  
  300.  
  301. ;;; We define a new mode instead of bashing the standard Emacs lisp
  302. ;;; interaction mode (inferior-lisp-mode).
  303. (defun cl-shell-mode (&optional dont-run-hooks)
  304.   "Major mode for interacting with a Common Lisp process.  This mode
  305. should be entered using the command run-cl, which runs a Lisp 
  306. interpreter as a subprocess of Emacs, with Lisp I/O through a buffer
  307. named *lisp*.  Run-cl takes an optional argument which defaults to the
  308. value of the variable *cl-program*.  
  309. Variable *cl-pop-up* determines whether the *lisp* buffer pops up on
  310. output from the CL process.
  311. Variable *cl-echo-commands* determines whether commands being sent to
  312. Common Lisp are echoed in the *lisp* buffer. 
  313. Variable *cl-replacement-prompt* determines whether the CL prompts
  314. should be replaced. 
  315. Variables *cl-prompt* and *cl-error-prompt* should be customized for
  316. the specific implementation of Common Lisp.  The defaults are correct
  317. for Lucid.
  318.  
  319. Commands:
  320. Return at end of the *lisp* buffer sends line as input.
  321. Return not at end sends the top-level sexp starting at or before the
  322. cursor.  
  323. C-M-a goes to previous top-level form (as in lisp-mode buffers),
  324. and C-a respects the listener prompt. 
  325. The following commands are provided from within the *lisp* buffer:
  326. In general, the C-c C-<char> commands do not change the state of the 
  327. CL environment, and the C-c <char> do.
  328. \\{cl-shell-mode-map}
  329. Most of the C-c commands are also provided in lisp-mode buffers.  In
  330. addition, the following bindings are added to lisp-mode buffers for
  331. sending things to the CL process:
  332.  
  333. C-c e           cl-eval-form
  334. C-c r           cl-eval-region
  335. C-c c           cl-compile-form
  336. C-c l           cl-load-file
  337. C-c x           cl-compile-file
  338.  
  339. NOTE: Compilations are performed in the package of the lisp-mode buffer!
  340.  
  341. Entry to cl-shell-mode calls the functions shell-mode-hook, lisp-mode-hook
  342. and cl-shell-mode-hook with no arguments, if any of these are non-nil."
  343.   (interactive "P")
  344.   (kill-all-local-variables)        ;clean up previously existing mode.
  345.   (setq major-mode 'cl-shell-mode)
  346.   (setq mode-name "cl-shell")
  347.   (setq mode-line-process '(": %s"))
  348.   (lisp-mode-variables t)
  349.   (make-local-variable 'cl-replacement-prompt)
  350.   (setq cl-replacement-prompt *cl-replacement-prompt*)
  351.   (make-local-variable 'cl-filter-state)
  352.   (setq cl-filter-state nil)
  353.   (make-local-variable 'cl-filter-string)
  354.   (setq cl-filter-string "")
  355.   (make-local-variable 'cl-shell-initialized-p)
  356.   (setq cl-shell-initialized-p nil)
  357.   (use-local-map cl-shell-mode-map)
  358.   (cl-add-lisp-mode-key-bindings)    ;add key bindings to lisp-mode-map
  359.   (if (null dont-run-hooks)
  360.       (run-hooks 'shell-mode-hook 'lisp-mode-hook 'cl-shell-mode-hook)))
  361.  
  362. ;;; Use the same name as standard lisp-mode.   Currently, we assume only
  363. ;;; one lisp process.
  364. (defconst *cl-process-name* "lisp")
  365.  
  366. ;;; Returns the current CL subshell process.  We abstract this out for
  367. ;;; future extensions which may allow multiple lisp processes, in
  368. ;;; which this would return the "current" cl process.
  369. (defun cl-process () (get-process *cl-process-name*))
  370.  
  371. (defun cl-buffer () 
  372.   (let ((proc (cl-process)))
  373.     (if proc 
  374.     (process-buffer proc)
  375.     nil)))
  376.  
  377. ;;; Useful top-level function.  I usually bind it globally to C-M-l.
  378. (defun cl-goto-lisp-buffer ()
  379.   "Makes the *lisp* buffer the current buffer, running lisp if necessary"
  380.   (interactive)
  381.   (let ((buf (cl-buffer)))
  382.     (if buf (pop-to-buffer buf) (run-cl))))
  383.  
  384. ;;; Replacement for the standard Emacs run-lisp.  We assume there is
  385. ;;; only one lisp process running and that its name is
  386. ;;; *cl-process-name*.  This is the simplest behavior to deal with
  387. ;;; when evaluating commands from lisp-mode buffers.  It should,
  388. ;;; however, be easy to extend the code to work with multiple lisps.
  389. ;;; The initialization command cl-send-startup-commands is run when
  390. ;;; the CL process comes to top-level (ie when Emacs sees the prompt).
  391. ;;; This runs the mode hooks.
  392. (defun run-cl (&optional cl-program)
  393.   "Run Common Lisp as a subshell process.  With a prefix argument, prompts
  394. for a pathname for the Lisp program to run.  Otherwise, uses the default
  395. pathname specified by the global variable *cl-program*."
  396.   (interactive "P")            ;takes a prefix arg
  397.   (cond ((null cl-program)        ;use default program
  398.      (setq cl-program *cl-program*))
  399.     ((numberp cl-program)        ;user called with prefix argument
  400.      (setq cl-program (read-string "Common Lisp Program: " *cl-program*))))
  401.   (cond ((cl-buffer)
  402.      (let ((buf (current-buffer)))
  403.        (pop-to-buffer (cl-buffer))
  404.        (cl-shell-mode)        ;set up mode, running hooks
  405.        (set-process-filter (cl-process) 'cl-output-filter)
  406.        (set-buffer buf))
  407.      (error "Process %s already exists." (process-name (cl-process))))
  408.     (t
  409.      ;; This will split the window if global var pop-up-windows is non-nil:
  410.      (pop-to-buffer 
  411.       (let ((process-connection-type nil)) ;pipes have better buffering
  412.         (make-shell *cl-process-name* cl-program)))
  413.      ;; set up local variables, keymap, modeline, etc.
  414.      (cl-shell-mode t)        ;set up mode, don't run hooks
  415.      ;; Filter parses special purpose output streams from CL.
  416.      (set-process-filter (cl-process) 'cl-output-filter))))
  417.  
  418. ;;; The usual one for the shell only interrupts the current subjob.
  419. (defun cl-interrupt-process ()
  420.   "Send an interrupt to the lisp process created by run-cl."
  421.   (interactive)
  422.   (interrupt-process (cl-process)))
  423.  
  424. ;;; We replace the standard kill-buffer function with one that is more
  425. ;;; careful about killing the CL process.
  426. (defvar standard-kill-buffer (symbol-function 'kill-buffer))
  427.  
  428. ;;; Ask user if they are sure, and then make sure lisp dies.  This is
  429. ;;; especially important for lisps that can run multiple processes.
  430. (defun kill-buffer (the-buffer)
  431.   (interactive "bKill buffer: ")    ;prompt for a buffer, default to current
  432.   (let ((the-process (cl-process)))
  433.     (if (and the-process        ;if lisp is running in this buffer
  434.          ;; *** Should also check if process is active.
  435.          (eq the-process (get-buffer-process the-buffer)))
  436.     (if (yes-or-no-p "Are you sure you want to kill the Common Lisp process? ")
  437.         (progn
  438.           ;; get rid of filter, in case it is screwing up
  439.           (set-process-filter (cl-process) nil)
  440.           (interrupt-process the-process t)
  441.           (message "Killing Common Lisp process ...")
  442.           (sleep-for 1)    ;wait a few seconds for death
  443.           (condition-case ()
  444.           (delete-process the-process)
  445.         (error nil))
  446.           (funcall standard-kill-buffer the-buffer)
  447.           (message "Killing Common Lisp process ... done.")))
  448.     (funcall standard-kill-buffer the-buffer))))    ;otherwise, do the usual
  449.     
  450.  
  451.  
  452. ;;;; ----------------- cl-shell-mode buffer commands ------------------
  453.  
  454. ;;; Similar to shell-send-input in shell.el, this function is called
  455. ;;; when the user types a newline in the interactive buffer.  The
  456. ;;; process-mark points to the place where CL inserts its output, or
  457. ;;; the end of the last input that was sent to CL (if output has not
  458. ;;; yet been received).  It is pushed forward when output is received
  459. ;;; from CL (see cl-filter).  Expressions sent to CL using
  460. ;;; cl-send-string-with-echo are echoed at this point.  If
  461. ;;; cl-shell-send-input is called with the point beyond the
  462. ;;; process-mark, it sends everything between process-mark and
  463. ;;; point-max (end of buffer) to the Lisp process, as long as there is
  464. ;;; at least one s-expression in that region and all sexps are
  465. ;;; complete.  [*** Might be better to send all complete sexp's and
  466. ;;; set process mark after the last one].  If any sexps are not not
  467. ;;; complete, then nothing is sent, but a newline is inserted at the
  468. ;;; point.  If cl-shell-send-input is called with the point before the
  469. ;;; process-mark, we copy the previous top-level sexp to the end of
  470. ;;; the buffer, and send it to CL.  If the sexp is not complete, it
  471. ;;; just beeps [*** Would be nice if return in middle of buffer
  472. ;;; inserted a newline too].
  473. (defun cl-shell-send-input ()
  474.   "Send input from the *lisp* buffer to the Common Lisp subshell."
  475.   (interactive)
  476.   (let ((original-point (point))
  477.     (complete-p nil)
  478.     (process-mark (process-mark (cl-process))))
  479.     (cond ((>= original-point process-mark) ;at end of buffer, so try to send sexps.
  480.        (goto-char process-mark)
  481.        (setq complete-p        ;check if all sexps typed are complete.
  482.          (condition-case ()    ;catch eof errors
  483.              (and (scan-sexps (point) 1) ;at least one sexp
  484.               (progn (while (scan-sexps (point) 1) 
  485.                    (goto-char (scan-sexps (point) 1)))
  486.                  t))
  487.            (error        ;incomplete sexp or extra parens
  488.             (if (looking-at "[ \t\n]*)") ;extra parens
  489.             (progn (setq original-point (point))
  490.                    (beep)
  491.                    (message "Unbalanced parentheses!")))
  492.             nil)))
  493.        ;; Point is now at end of last sexp
  494.        (cond (complete-p
  495.           (delete-region (point) (point-max)) ;get rid of extra spaces
  496.           (shell-add-history (buffer-substring process-mark (point-max)))
  497.           (insert ?\n)        ;leaving a single newline
  498.           (cl-send-region process-mark (point-max)) ;send it.
  499.           (set-marker process-mark (point-max)))
  500.          (t (goto-char original-point) ;insert a newline if not complete-p
  501.             (lisp-newline))))
  502.       (t (end-of-line)        ;if right on defun, don't go backwards
  503.          (beginning-of-defun)    ;goto start of top-level sexp
  504.          (cl-send-string-with-echo
  505.           (buffer-substring        ;dies on incomplete sexp
  506.            (point) (progn (forward-sexp 1) (point))))
  507.          (goto-char process-mark)))))
  508.  
  509. ;;; This function calls whatever function <carriage-return> is bound
  510. ;;; to in lisp-mode.  We do this so that users can redefine newline to
  511. ;;; auto-indent things and get the same behavior in the *lisp*
  512. ;;; buffer...
  513. (defun lisp-newline () 
  514.   (interactive)
  515.   (funcall (or (lookup-key lisp-mode-map "\C-m")
  516.            'newline)))
  517.  
  518. ;;; Modified beginning-of-line that ignores prompts.
  519. (defun cl-beginning-of-line (&optional arg)
  520.   "Move point to beginning of current line of cl-shell buffer, 
  521. ignoring prompts.  With argument ARG not nil or 1, move forward
  522. ARG - 1 lines first.  If scan reaches end of buffer, stop there 
  523. without error."
  524.   (interactive "p")
  525.   (let ((the-regexp
  526.          (cond ((null cl-replacement-prompt)
  527.             (format "\\(%s\\|%s\\)" *cl-prompt* *cl-error-prompt*))
  528.            ((string= cl-replacement-prompt "")
  529.             *cl-error-prompt*)
  530.            (t 
  531.             (format "\\(^%s\\|%s\\)" cl-replacement-prompt
  532.                 *cl-error-prompt*)))))
  533.     (beginning-of-line arg)
  534.     (if (looking-at the-regexp) (goto-char (match-end 0)))))
  535.  
  536. ;;; We replace the usual definition for beginning-of-defun.  This is much
  537. ;;; easier than having to rewrite end-of-defun (see lisp.el).
  538. (defvar standard-beginning-of-defun (symbol-function 'beginning-of-defun))
  539.  
  540. ;;; Tries to find a prompt followed by left paren or a word (symbol).
  541. ;;; *** Doesn't do the right thing with comments.
  542. (defun beginning-of-defun (&optional arg)
  543.   "Move backward to next beginning-of-defun, ignoring prompts if
  544. in a cl-shell buffer.  With argument, do this that many times.
  545. Returns t unless search stops due to end of buffer."
  546.   (interactive "p")
  547.   (if (eq major-mode 'cl-shell-mode)
  548.       (let* ((cl-prompt (or (and cl-replacement-prompt
  549.                  (concat "^" cl-replacement-prompt))
  550.                 *cl-prompt*))
  551.          (the-regexp 
  552.           (cond ((string= cl-prompt "")
  553.              (format "\\(^\\|%s[ \t\n]*\\)[^ \t\n]" *cl-error-prompt*))
  554.             (t
  555.              (format "\\(%s\\|%s\\)[ \t\n]*[^ \t\n]"
  556.                  cl-prompt *cl-error-prompt*)))))
  557.     (and arg (< arg 0) (forward-char 1))
  558.     (and (re-search-backward the-regexp nil 'move (or arg 1))
  559.          (progn (goto-char (1- (match-end 0))) t)))
  560.       (funcall standard-beginning-of-defun arg)))
  561.  
  562.  
  563. ;;;; ----------------- Buffer packages -----------------------
  564.  
  565. ;;; *** Should we only take in-package at or near top of file?
  566. (defun cl-set-buffer-package (&optional pkg)
  567.   "Set the package of a lisp buffer.  PKG argument is optional:
  568. it can be nil, t, or a string.  If nil, package is found by
  569. searching for in-package command in buffer, using the value of
  570. *cl-default-buffer-package* if it is not found.  If t, the current
  571. package will be used when compiling things from this buffer.  If
  572. a string, it will be used as a package name. If prefix arg is given
  573. with command, user will be prompted for an argument, which should
  574. be string which can be used as a CL package name."
  575.   (interactive "sCL package: ")        ;prompt for string
  576.   (if (string= pkg "") (setq pkg nil))    ;interactive, with no arg passed.
  577.   (if (or (string= pkg "t") (string= pkg "T")) ;interactive t typed
  578.       (setq pkg t))
  579.   (if (stringp pkg) (setq pkg (cl-add-quote pkg))) ;make sure quoted
  580.   (let ((the-buf (current-buffer)))
  581.     (if (null (assq 'buffer-package (buffer-local-variables the-buf)))
  582.     (progn
  583.       (make-local-variable 'buffer-package)
  584.       (make-local-variable 'mode-line-buffer-identification)))
  585.     (if pkg                ;t or string.
  586.     (setq buffer-package pkg)
  587.     (if (eq (current-buffer) (cl-buffer))    ;if *lisp* buffer
  588.         (setq buffer-package t)
  589.         (save-excursion
  590.           (beginning-of-buffer)
  591.           (if (re-search-forward "^(in-package[ \t\n]+" nil t)
  592.           (let ((start (point)))
  593.             (forward-sexp)
  594.             (setq buffer-package (buffer-substring start (point))))
  595.           (setq buffer-package (or *cl-default-buffer-package* t))
  596.           (beep)
  597.           (message "Warning: can't find in-package command in buffer.")))))
  598.     (setq mode-line-buffer-identification
  599.       (list "" (default-value 'mode-line-buffer-identification)
  600.         (format " (Pkg: %s)"
  601.             (if (stringp buffer-package)
  602.                 buffer-package
  603.                 "*package*"))))
  604.     (cl-get-buffer-package)))
  605.  
  606. ;;; Use this function to get the package of a buffer.  This must
  607. ;;; return a string that can be sent inside an in-package command to
  608. ;;; the CL process.
  609. (defun cl-get-buffer-package ()
  610.   (cond ((null buffer-package) (cl-set-buffer-package))    ;hasn't been computed
  611.     ((stringp buffer-package) buffer-package)
  612.     (t "(package-name *package*)")))      ;if t, use current package.
  613.         
  614. ;;; A buffer variable containing a string which is the Common Lisp
  615. ;;; package of the file.  If t the file has no package and evaluation
  616. ;;; uses the package *package*.
  617. (setq-default buffer-package nil)
  618.  
  619. ;;; Take a string that is meant to be sent to CL for execution, and
  620. ;;; wrap stuff around it so that it will be read in the given package.
  621. ;;; A bit hairy, but I don't know how else to do it...  This is used
  622. ;;; for compiling, documentation, macroexpansion, arglists, etc.
  623. (defun cl-with-package (package body-string)
  624.   (concat "(let ((pkg lisp:*package*)
  625.                  val)
  626.              (in-package "  package  ")
  627.              (unwind-protect
  628.               (setq val (eval (read-from-string
  629.                     " (cl-make-readable-string body-string) ")))
  630.         (in-package (package-name pkg))
  631.                 val))\n"))
  632.  
  633.  
  634. ;;;; ----------------- lisp-mode buffer commands -----------------
  635.  
  636. ;;; This is called to evaluate top-level expressions in lisp-mode
  637. ;;; buffers.  If *cl-echo-commands* is non-nil, the expression is
  638. ;;; echoed into the listener (*lisp*) buffer.  Unlike lisp-send-defun
  639. ;;; (defined in shell.el), we send the form directly to the CL
  640. ;;; process. We do not do this in the package of the current buffer -
  641. ;;; it is as if the user typed the form to the listener.  The
  642. ;;; elaborate args to buffer-substring are to ensure that a newline is
  643. ;;; not included with the string.
  644. (defun cl-eval-form ()
  645.   "Send the current top-level sexp to the CL process created by
  646. M-x run-cl, moving to end of sexp.  If *cl-echo-commands* is non-nil,
  647. echo the sexp into cl-shell buffer."
  648.   (interactive)
  649.   (end-of-defun)            ;move to end of defun
  650.   (let ((the-string 
  651.      (save-excursion        ;leave point at end of defun
  652.        (buffer-substring (progn (beginning-of-defun) (point))
  653.                  (progn (forward-sexp 1) (point))))))
  654.     (if *cl-echo-commands*
  655.     (cl-send-string-with-echo the-string)
  656.     (cl-send-string (concat the-string "\n")))))
  657.  
  658. ;;; Send the marked region to CL.  This is usually used to send large
  659. ;;; numbers of forms at once (otherwise, you could use cl-eval-form)
  660. ;;; and so does not echo into the listener.
  661. (defun cl-eval-region ()
  662.   "Send region between point and mark to CL process, without echoing."
  663.   (interactive)
  664.   ;; check that expressions are complete.  Take overhanging ones.
  665.   (let ((start (min (point) (mark)))
  666.     (end (max (point) (mark))))
  667.     (save-excursion
  668.       (goto-char start)
  669.       (setq end (progn
  670.           (while (and (< (point) end)
  671.                   (scan-sexps (point) 1))
  672.             (goto-char (scan-sexps (point) 1))
  673.             (skip-chars-forward " \t\n" end))
  674.           (point)))
  675.       (cl-send-string "(progn\n")
  676.       (cl-send-region start end)
  677.       (cl-send-string "\n(values))\n")))) ;send final newline
  678.  
  679. ;;; If the beginning of the form doesn't match cl-fast-compile-regexp,
  680. ;;; we save it to a file (with an in-package statement at the top),
  681. ;;; compile it using cl-compile-command, and load it using
  682. ;;; inferior-lisp-load-command.  Otherwise, we send it directly to CL,
  683. ;;; relying on a CL macro called compile-def, which is defined by
  684. ;;; run-cl.  This macro may be redefined in a given lisp environment
  685. ;;; to allow compilation of things like methods (see cl-clos.el and
  686. ;;; cl-pcl.el).  Compilation occurs in the package of the buffer.  We
  687. ;;; echo a shorthand expression into the CL-shell buffer, which
  688. ;;; indicates the symbol being compiled and the package.  *** BUG:
  689. ;;; Behavior is different when compilation happens through a file: the
  690. ;;; value of the compilation is not returned...
  691. (defun cl-compile-form ()
  692.   "Send the current top-level sexp to the CL process created by M-x
  693. run-cl, and compile it in the package of the current buffer.  The
  694. point is moved to the end of the sexp, and if *cl-echo-commands* is
  695. non-nil a shorthand expression is echoed to the *lisp* buffer."
  696.   (interactive)
  697.   (or (cl-process) (error "CL process is not running!"))
  698.   (end-of-defun)            ;move to end of sexp
  699.   (let ((cl-package (cl-get-buffer-package))
  700.     the-string
  701.     fn-name)
  702.     (save-excursion            ;leave point at end of defun
  703.       (beginning-of-defun)
  704.       (setq the-string 
  705.         (buffer-substring (point) (save-excursion (forward-sexp 1) (point))))
  706.       ;; Set up fn-name and the-string, depending on compiling mode:
  707.       (if (null (looking-at cl-fast-compile-regexp))
  708.       (let ((filename (format "/tmp/emlisp%d" (process-id (cl-process))))
  709.         (buf (current-buffer)))
  710.         (setq fn-name 
  711.           (buffer-substring
  712.            (point)
  713.            (progn (forward-char 1) (forward-sexp 2) (point))))
  714.         (setq fn-name (concat fn-name " ... )"))
  715.         (set-buffer (get-buffer-create "*CL compilation*"))
  716.         (erase-buffer)
  717.         (insert (format "(in-package %s)\n\n" cl-package))
  718.         (insert the-string)
  719.         (insert "\n")
  720.         (write-region (point-min) (point-max) filename nil 'nomessage)
  721.         (setq the-string
  722.           (concat "(progn "
  723.               (format cl-compile-command filename)
  724.               (format inferior-lisp-load-command filename)
  725.               "(values))\n"))
  726.         (set-buffer buf))
  727.       (forward-char 1)        ;skip open paren
  728.       (forward-sexp 1)        ;skip "defun"
  729.       (skip-chars-forward " \t\n")    ;skip whitespace to function name
  730.       (setq fn-name (buffer-substring (point) (progn (forward-sexp 1) (point))))
  731.       (setq the-string
  732.         (cl-with-package cl-package
  733.                  (concat "(user::compile-def " the-string ")")))))
  734.     (if *cl-echo-commands*
  735.     (cl-send-string-with-echo
  736.      the-string
  737.      (concat "(compile-def '" fn-name " :pkg " cl-package ")")
  738.      t)                ;no history recording
  739.     (cl-send-string (concat the-string "\n")))))
  740.  
  741. (defun cl-load-file (pathname)
  742.   "Load file of current buffer into the CL process."
  743.   (interactive
  744.    (let ((default-file-name (cl-strip-file-extension buffer-file-name)))
  745.      (list
  746.       (read-file-name "CL load file: " default-file-name default-file-name t))))
  747.   (let ((buffer (get-file-buffer pathname)))
  748.     (if (and buffer 
  749.          (buffer-modified-p buffer)
  750.          (yes-or-no-p 
  751.           (concat "Buffer " (buffer-name buffer) " modified, save it first? ")))
  752.     (save-buffer buffer)))
  753.   (if *cl-echo-commands*
  754.       (cl-send-string-with-echo (format cl-load-command pathname))
  755.       (cl-send-string
  756.        (concat "(progn "
  757.            (format cl-load-command pathname)
  758.            "(values))\n"))))
  759.    
  760. (defun cl-compile-file (pathname)
  761.   "Ask CL to compile file of current buffer."
  762.   (interactive 
  763.    (list
  764.     (expand-file-name
  765.      (read-file-name "CL compile file: " buffer-file-name buffer-file-name t))))
  766.   (let ((buffer (get-file-buffer pathname)))
  767.     (if (and buffer 
  768.          (buffer-modified-p buffer)
  769.          (yes-or-no-p 
  770.           (concat "Buffer " (buffer-name buffer) " modified, save it first? ")))
  771.     (save-buffer buffer)))
  772.   (if *cl-echo-commands*
  773.       (cl-send-string-with-echo (format cl-compile-command pathname))
  774.       (cl-send-string
  775.        (concat "(progn "
  776.            (format cl-compile-command pathname)
  777.            "(values))\n"))))
  778.  
  779.  
  780. ;;;; ----------------- CL utilities ------------------
  781. ;;; This stuff is specific to Common Lisp (as opposed to other Lisps).
  782.  
  783. ;;; Ask CL to macroexpand-1 the current sexp in the package of the buffer.
  784. (defun cl-macroexpand-1 (&optional in-situ)
  785.   "Ask the cl-shell process to call macroexpand-1 on the sexp surrounding
  786. or following the point.  With a prefix arg, insert the lowercase macroexpansion
  787. at the point.  Otherwise, display uppercase macroexpansion in a pop-up help
  788. buffer."
  789.   (interactive "P")            ;takes a prefix arg
  790.   (if (numberp in-situ)        ;with prefix, insert at point
  791.       (cl-send-request cl-input-stream-id (cl-get-buffer-package)
  792.                (concat "(write (macroexpand-1 '"
  793.                    (cl-get-sexp)
  794.                    ") :pretty t :level nil :length nil :case :downcase)"))
  795.       (cl-send-request cl-help-stream-id (cl-get-buffer-package)
  796.                (concat "(write (macroexpand-1 '"
  797.                    (cl-get-sexp)
  798.                    ") :pretty t :level nil :length nil)"))))
  799.  
  800. ;;; *** Would be nice if response about symbol being unbound told you
  801. ;;; what package was looked in.
  802. (defun cl-documentation (symbol)
  803.   "Ask the cl-shell process for documentation on the given symbol (a string)."
  804.   (interactive (cl-ask-for-symbol "CL documentation of: "))
  805.   (cl-send-request cl-help-stream-id (cl-get-buffer-package)
  806.            (format "(let ((*print-length* nil))
  807.                (format t \"~A:~%%~A\" %s
  808.              (cond ((fboundp %s) (documentation %s 'function))
  809.                        ((boundp %s)  (documentation %s 'variable))
  810.                        (t (format nil \"~A is unbound.\" %s)))))"
  811.                symbol symbol symbol symbol symbol symbol)))
  812.  
  813. ;;; *** If fbound and bound, should we describe the value AND the function?
  814. (defun cl-describe (sym)
  815.   "Ask the cl-shell process for a description of the contents of symbol."
  816.   (interactive (cl-ask-for-symbol "CL describe: "))
  817.   (cl-send-request cl-help-stream-id (cl-get-buffer-package)
  818.     (format "(if (and (boundp %s) (not (fboundp %s)))
  819.                  (describe (symbol-value %s))
  820.                  (describe %s))"
  821.         sym sym sym sym)))
  822.  
  823. ;;; Ask the user for a symbol, taking as a default the symbol closest
  824. ;;; to the cursor.  Return a list containing the symbol, suitable for
  825. ;;; use by the interactive function.
  826. (defun cl-ask-for-symbol (&optional prompt)
  827.   (list (cl-add-quote (car (find-tag-tag (or prompt "Symbol: "))))))
  828.  
  829. ;;; Could use tmc/utils.el or allegro/keys.el versions.
  830. ;;; Get the surrounding sexp, or if the point is on a paren, the
  831. ;;; sexp associated with that paren.  Gives an error if sexps are incomplete.
  832. (defun cl-get-sexp ()
  833.   (save-excursion
  834.     (cond ((= (following-char) ?\() nil) ;great
  835.       ((= (preceding-char) ?\)) (backward-sexp 1))  ;goto start of sexp
  836.       ((looking-at "[ \t\n]*(") (goto-char (1- (match-end 0))))
  837.       (t (backward-up-list 1)))
  838.     (buffer-substring (point) (progn (forward-sexp 1) (point)))))
  839.  
  840. ;;; Should use this for cl-describe
  841. (defun cl-get-sexp-or-symbol ()
  842.   (save-excursion
  843.     (cond ((= (preceding-char) ?\() nil)
  844.       ((or (= (char-syntax (following-char)) ?_)  ;symbol constituent
  845.            (= (char-syntax (following-char)) ?w)) ;word constituent
  846.        (backward-sexp 1))
  847.       (t (skip-chars-forward " \t\n")))
  848.     (buffer-substring (point) (progn (forward-sexp 1) (point)))))
  849.  
  850. ;;; Make sure the-string starts with a single quote, and turn single
  851. ;;; colon into double colon so that non-exported symbols don't cause
  852. ;;; problems.
  853. (defun cl-add-quote (the-string)
  854.   (let ((colon-pos (string-match ":+" the-string)))
  855.     (if (and colon-pos            ;found one
  856.          (> colon-pos 0)        ;not at beginning (not a keyword)
  857.          (= (1+ colon-pos) (match-end 0))) ;only one
  858.     (setq the-string
  859.           (concat (substring the-string 0 colon-pos)
  860.               ":"
  861.               (substring the-string colon-pos))))
  862.     (if (char-equal (aref the-string 0) ?\') ;check for quote
  863.     the-string
  864.     (concat "'" the-string))))
  865.  
  866. ;;; Arg can be a symbol or a string.  Returns string of symbol without
  867. ;;; package prefix, and without quote.  Also slashifies all characters
  868. ;;; which are special Emacs regexp characters, since the returned
  869. ;;; string is go be used in a regexp.  We also throw in a downcase
  870. ;;; to cover the situations when case-fold-search is nil.
  871. (defun cl-strip-package (symbol)
  872.   (let ((the-string (regexp-quote (downcase (format "%s" symbol)))))
  873.     (if (char-equal (aref the-string 0) ?\')
  874.     (setq the-string (substring the-string 1)))
  875.     (if (and (not (char-equal (aref the-string 0) ?\:))
  876.          (string-match ":+" the-string))
  877.     (setq the-string (substring the-string (match-end 0))))
  878.     the-string))
  879.  
  880. ;;; *** Breaks if there is a "." in one of the subdirectory names!
  881. (defun cl-strip-file-extension (filename)
  882.   (let ((fullname (expand-file-name filename)))
  883.     (if (string-match "\\.[^ ]*" fullname)
  884.     (substring fullname 0 (match-beginning 0))
  885.     fullname)))
  886.  
  887. ;;; Take a string, and return a string which can be read by the CL
  888. ;;; reader.  Basically, inserts a backslash in front of every
  889. ;;; quotation mark or backslash.  DO NOT use the resulting string in a
  890. ;;; format statement.  If it has a % character in it, it will fail!
  891. (defun cl-make-readable-string (the-string)
  892.   (save-excursion
  893.     (set-buffer (get-buffer-create "*CL compilation*"))
  894.     (erase-buffer)
  895.     (insert the-string)
  896.     (goto-char (point-min))
  897.     (insert ?\")            ;put quotation mark at beginning
  898.     (while (re-search-forward "\\(\"\\|\\\\\\)" nil 'move) 
  899.       (backward-char 1)
  900.       (insert ?\\)
  901.       (forward-char 1))
  902.     (goto-char (point-max))
  903.     (insert ?\")            ;put quotation mark at end
  904.     (buffer-string)))      
  905.  
  906.  
  907. ;;;; ----------------- Low-level CL input functions -----------------
  908.  
  909. ;;; Echo string to *lisp* buffer with reindentation, and then send to
  910. ;;; CL.  Adds a newline.  Marker handling should be the same as for
  911. ;;; complete sexps in cl-shell-send-input.
  912. (defun cl-send-string-with-echo (the-string &optional the-echo-string no-history)
  913.   (if (null the-echo-string) (setq the-echo-string the-string))
  914.   (let ((buf (current-buffer))
  915.     (cl-buf (cl-buffer)))
  916.     (if (and (null (get-buffer-window cl-buf)) *cl-pop-up*)
  917.     (display-buffer cl-buf))    ;splits window if pop-up-windows is non-nil
  918.     (set-buffer cl-buf)
  919.     (goto-char (process-mark (cl-process)))
  920.     (insert-before-markers the-echo-string) ;insert, pushing markers forward
  921.     (insert-before-markers "\n")
  922.     (save-excursion (backward-sexp 1) (indent-sexp)) ;reindent the expression
  923.     (if (get-buffer-window cl-buf)    ;this seems to be necessary...
  924.     (set-window-point (get-buffer-window cl-buf) (point)))
  925.     (set-buffer buf)
  926.     (if (null no-history) (shell-add-history the-string cl-buf))
  927.     (setq the-string (concat the-string "\n"))
  928.     (cl-send-string the-string)))
  929.  
  930. ;;; This kludge seems to be necessary to avoid dropping data...
  931. (defvar *cl-packet-size* 255
  932.   "Size of chunks sent to the CL subprocess.")
  933.  
  934. ;;; Low-level function for sending a region from the current buffer to 
  935. ;;; the CL process.
  936. (defun cl-send-region (start end)
  937.   (let ((packet-end (min end (+ start *cl-packet-size*))))
  938.     (if (and (condition-case nil
  939.          (progn (process-send-region 
  940.              (cl-process)
  941.              start packet-end)
  942.             t)
  943.            (error 
  944.         (error "cl-send-region: Error sending region to Common Lisp.")
  945.         nil))
  946.          (< packet-end end))
  947.     (cl-send-region packet-end end))))
  948.  
  949. ;;; Low-level function for sending a string to the CL process.  Tacks
  950. ;;; a newline onto the end.
  951. (defun cl-send-string (string)
  952.   (let ((start 0)
  953.     (end (length string)))
  954.     (while (and (< start end)
  955.         (condition-case nil
  956.             (progn (process-send-string
  957.                 (cl-process)
  958.                 (substring string start 
  959.                        (min end (+ start *cl-packet-size*))))
  960.                t)
  961.           (error
  962.            (error "cl-send-string: Error sending string to Common Lisp.")
  963.            nil)))
  964.       (setq start (+ start *cl-packet-size*)))))
  965.  
  966. ;;; The-string should be a common lisp command.  It will be evaluated by CL and
  967. ;;; should print the desired help information to *standard-output*.
  968. ;;; NOTE: this function is now obsolete.  Use cl-send-request.
  969. (defun cl-send-help-request (the-string)
  970.   (cl-send-string
  971.    (cl-concatenate-stream-id the-string cl-help-stream-id)))
  972.  
  973. ;;; Send string to CL, to be evaluated in package, with output printed
  974. ;;; between markers for the given stream-id.  This is used to request
  975. ;;; information from CL such as macroexpansion, documentation, etc.
  976. ;;; It could be shadowed in multi-processing lisps to talk to a help
  977. ;;; process.
  978. (defun cl-send-request (stream-id package string)               
  979.   (cl-send-string
  980.    (cl-concatenate-stream-id
  981.     (cl-with-package package string)
  982.     stream-id)))
  983.  
  984. ;;; Produces a string to which may be sent to CL.  The cl-command should be
  985. ;;; a string containing a CL command which prints to standard output.  Don't
  986. ;;; bother sending the resulting string is to be sent to CL at top-level.
  987. (defun cl-concatenate-stream-id (cl-command stream-id &optional close-marker)
  988.   (if close-marker
  989.       (format "(progn 
  990.              (format *standard-output* \"[[%s>>\")
  991.                  (force-output *standard-output*)
  992.                  %s
  993.                  (force-output *standard-output*)
  994.                  (format *standard-output* \"<<%s]]\")
  995.                  (force-output *standard-output*)
  996.                  (values))\n"
  997.           stream-id cl-command stream-id)
  998.       (format "(progn 
  999.              (format *standard-output* \"[[%s>>\")
  1000.                  (force-output *standard-output*)
  1001.                  %s
  1002.                  (force-output *standard-output*)
  1003.                  (values))\n"            ;used to return T for parsing
  1004.           stream-id cl-command)))
  1005.  
  1006.  
  1007. ;;;; ----------------- CL output filter ------------------
  1008.  
  1009. ;;; CL can talk to emacs by sending strings to standard-output inside
  1010. ;;; of special-purpose markers.  There are four different markers
  1011. ;;; defined below.  The input-stream inserts the string at the point
  1012. ;;; (as if the user had typed it), the message-stream marker inserts
  1013. ;;; the string into the minibuffer, the help-stream inserts the string
  1014. ;;; into a pop-up help buffer, and the eval stream causes Emacs to
  1015. ;;; read from the string and eval the result.  You should make an
  1016. ;;; effort to ensure that the stream markers are sent un-interrupted.
  1017. ;;; Example usage:
  1018. ;;;   (progn
  1019. ;;;     (format *standard-output* "[[MESSAGE-STREAM>>")
  1020. ;;;     (force-output *standard-output*)
  1021. ;;;     (format *standard-output* "Stick this string in the minibuffer")
  1022. ;;;     (force-output *standard-output*)
  1023. ;;;     (format *standard-output* "<<MESSAGE-STREAM]]")
  1024. ;;;     (force-output *standard-output*))
  1025.  
  1026. ;;; Strings identifying the various lisp filter states.  The states
  1027. ;;; allow parsing of special purpose information coming from the lisp
  1028. ;;; process.  We could make do with a single type of stream (the
  1029. ;;; eval-stream): the others are here for convenience and historical
  1030. ;;; reasons!  NOTE: These strings must consist of all Capital letters
  1031. ;;; and hyphens.  They must be sent unbroken to the lisp filter: the
  1032. ;;; parsing done in the following routines is crude and will not
  1033. ;;; recognize the markers if they are segmented!!
  1034. (defconst cl-input-stream-id "INPUT-STREAM")  ;insert stuff at point for use as input
  1035. (defconst cl-message-stream-id "MESSAGE-STREAM") ;insert stuff in minibuffer
  1036. (defconst cl-help-stream-id "HELP-STREAM")   ;display in pop-up help buffer.
  1037. (defconst cl-eval-stream-id "EVAL-STREAM") ;stuff to be evaluated by emacs
  1038.  
  1039. ;;; This function does the right thing with special purpose streams.
  1040. (defun cl-handle-special-stream (the-state the-string)
  1041.   (cond ((string= the-state cl-input-stream-id)
  1042.      (insert the-string))
  1043.     ((string= the-state cl-message-stream-id)
  1044.      (message the-string))
  1045.     ((string= the-state cl-help-stream-id)
  1046.      (cl-pop-up-help the-string))
  1047.     ((string= the-state cl-eval-stream-id)
  1048.      (eval (cl-read-from-string the-string)))
  1049.     (t (beep) (message (format "Unknown filter state: %s" the-state)))))
  1050.  
  1051. ;;; Extension of Emacs reader to allow reading of CL pathnames!
  1052. (defun cl-read-from-string (the-string)
  1053.   (let ((pos 0))
  1054.     (while (setq pos (string-match "#P" the-string pos))
  1055.       (setq the-string (concat (substring the-string 0 pos)
  1056.                    (substring the-string (+ pos 2)))))
  1057.     (read the-string)))
  1058.  
  1059. ;;; Pop up help text in the *CL Help* buffer.  User can hit space to
  1060. ;;; bury.  If you have only one window, it will be split, and the new
  1061. ;;; window will be shring-wrapped around the help string.  If you
  1062. ;;; don't bury it with by hitting space, it will be un-shrink-wrapped,
  1063. ;;; so as not to leave around windows of annoying sizes.
  1064. (defun cl-pop-up-help (text)
  1065.   (if (< (length text) (screen-width))
  1066.       (message (cl-shrink-whitespace text))
  1067.       (let ((orig-window (selected-window))
  1068.         (window-config (current-window-configuration))
  1069.         (one-p (one-window-p t))
  1070.         (help-buffer (get-buffer-create "*CL Help*"))
  1071.         (pop-up-windows t)
  1072.         char string)
  1073.     (save-excursion
  1074.       (pop-to-buffer help-buffer)
  1075.       (setq buffer-read-only nil)
  1076.       (erase-buffer)
  1077.       (insert text)
  1078.       (goto-char (point-min))
  1079.       (if one-p (shrink-window-if-larger-than-buffer (selected-window)))
  1080.       (set-buffer-modified-p nil)
  1081.       (setq buffer-read-only t)
  1082.       (select-window orig-window)
  1083.       (message (substitute-command-keys
  1084.             "<<< Press Space to bury *CL Help* buffer now (\\[cl-bury-help] later) >>>")))
  1085.     (if (= (setq char (read-char)) ?\ )
  1086.         (progn (message "")
  1087.            (set-window-configuration window-config)
  1088.            ;; explicitly bury help buffer, AFTER doing set-configuration, since
  1089.            ;; it may have been showing in the original window config.
  1090.            (cl-bury-help))
  1091.         (progn (message "")
  1092.            (set-window-configuration window-config)
  1093.            (display-buffer help-buffer) ;re-display it, not shrunken
  1094.            (setq unread-command-char char)
  1095.            (setq last-command-char char)
  1096.            (setq last-input-char char)
  1097.            (setq string (read-key-sequence nil))
  1098.            (call-interactively (key-binding string)))))))
  1099.  
  1100. (defun cl-bury-help ()
  1101.   (interactive)
  1102.   (let ((help-buffer (get-buffer "*CL Help*"))) 
  1103.     (if (null help-buffer)
  1104.     nil
  1105.       (replace-buffer-in-windows help-buffer)
  1106.       (bury-buffer help-buffer))))
  1107.  
  1108. (defun cl-shrink-whitespace (the-string)
  1109.   "Replace each whitespace substring of THE-STRING by a single space."
  1110.   (let ((start 0))
  1111.     (while (setq start (string-match "[ \t\n]+" the-string start))
  1112.       (setq the-string
  1113.         (concat (substring the-string 0 start)
  1114.             " "
  1115.             (substring the-string (match-end 0) (length the-string))))
  1116.       (setq start (+ 1 start)))
  1117.     the-string))
  1118.  
  1119. ;;; The function is passed strings which are output from the CL
  1120. ;;; process.  All strings are written into the CL shell buffer, and
  1121. ;;; then cl-parse-output is called to remove prompts and determine
  1122. ;;; whether the string is normal output or needs to be handled in a
  1123. ;;; special manner.  In general, the current buffer and point are
  1124. ;;; preserved, except that if any part of the string is real output
  1125. ;;; from CL and *cl-pop-up* is non-nil, the CL shell buffer will be
  1126. ;;; popped up.  
  1127. (defun cl-output-filter (proc the-string)
  1128.   (let* ((buf (current-buffer))
  1129.      (buf-point (point-marker))    ;necessary if buf = cl-buf!
  1130.      (cl-buf (process-buffer proc))
  1131.      (process-mark (process-mark proc))
  1132.      start-point            ;a temporary variable
  1133.      cl-output-p)
  1134.     (set-buffer cl-buf)            ;don't pop up CL buffer yet.
  1135.     (goto-char process-mark)
  1136.     (setq start-point (point))
  1137.     (insert-before-markers the-string) ;move process-mark forward
  1138.     (goto-char start-point)         ;can't use save-excursion here!
  1139.     (while (< (point) (marker-position process-mark))
  1140.       (if (cl-parse-output process-mark) ;returns end-of-segment-p
  1141.       (cond ((null cl-filter-state)    ;end of real lisp output segment
  1142.          (if cl-shell-initialized-p
  1143.              (setq cl-output-p t)    ;real lisp output
  1144.              (cl-send-startup-commands)    ;*** should not do this if error prompt
  1145.              (setq cl-shell-initialized-p t)
  1146.              (setq cl-output-p t)))
  1147.         (t (let ((the-state cl-filter-state)
  1148.              (the-string cl-filter-string))
  1149.              (setq cl-filter-state nil)
  1150.              (let ((cl-buff-point (point)))
  1151.                (set-buffer buf)
  1152.                (goto-char buf-point)
  1153.                (cl-handle-special-stream the-state the-string)
  1154.                (set-buffer buf)
  1155.                (set-marker buf-point (point))
  1156.                (set-buffer cl-buf)
  1157.                (goto-char cl-buff-point)))))))
  1158.     (set-buffer buf)            ;reset point in original buffer
  1159.     (goto-char buf-point)
  1160.     (set-buffer (window-buffer))    ;set buffer to be one in selected window
  1161.     (if (and *cl-pop-up*        ;pop up if there was real output
  1162.          cl-output-p        ;and user likes pop-up
  1163.          (null (get-buffer-window cl-buf))) ;and lisp buffer isn't showing
  1164.       (display-buffer cl-buf))))    ;show it, but don't select it
  1165.  
  1166. ;;; Parse the buffer starting at the point and going no further than
  1167. ;;; end-mark.  Clean up prompts and look for special purpose streams.
  1168. ;;; Set buffer variables cl-filter-state and cl-filter-string.  Leave
  1169. ;;; point at end of parsed material, and return non-nil if cl-prompt
  1170. ;;; or state-close has been reached (indicating end-of-segment) or nil
  1171. ;;; otherwise.
  1172. (defun cl-parse-output (end-mark)
  1173.   (let ((start-point (point)))        ;start of inserted string
  1174.     (if (null cl-filter-state)    ;not in the middle of parsing special stream
  1175.     (if (and (re-search-forward (format "\\(%s\\|%s\\|%s\\|%s\\)"
  1176.                         cl-filter-state-open
  1177.                         *cl-prompt* *cl-error-prompt*
  1178.                         cl-filter-state-close)
  1179.                     end-mark 'move)
  1180.          (goto-char (match-beginning 0)))
  1181.         (cond ((looking-at *cl-prompt*)
  1182.            (if (null cl-replacement-prompt)
  1183.                (goto-char (match-end 0))
  1184.              (replace-match "")
  1185.              (insert-before-markers cl-replacement-prompt))
  1186.            t)            ;end-of-segment
  1187.           ((looking-at *cl-error-prompt*)  (goto-char (match-end 0)) t)
  1188.           ((looking-at cl-filter-state-open)
  1189.            (setq cl-filter-state (cl-grab-state-id))
  1190.            (setq cl-filter-string "")
  1191.            nil)            ;not end-of-segment
  1192.           ((looking-at cl-filter-state-close)
  1193.            (cond ((null (re-search-backward cl-filter-state-open
  1194.                             (- (point) 1000) t))
  1195.               (message "Unmatched closing SPECIAL TAG")
  1196.               (setq cl-filter-state (cl-grab-state-id))
  1197.               (setq cl-filter-string (cl-grab-region start-point (point))))
  1198.              (t        ;set up to parse it on next pass...
  1199.               (setq cl-filter-state (cl-grab-state-id))
  1200.               (setq cl-filter-string "")
  1201.               nil)))))    ;not end-of-segment
  1202.     (cond ((re-search-forward cl-filter-state-close end-mark t) 
  1203.            (if (not (string= cl-filter-state (cl-grab-state-id)))
  1204.            (message "Non-matching closing stream marker: %s."
  1205.                 cl-filter-state))
  1206.            (setq cl-filter-string 
  1207.              (concat cl-filter-string (cl-grab-region start-point (point))))
  1208.            t)            ;end-of-segment
  1209.           ((re-search-forward (format "\n%s" *cl-error-prompt*) end-mark t)
  1210.            (setq cl-filter-string
  1211.              (concat cl-filter-string
  1212.                  (cl-grab-region start-point (match-beginning 0))))
  1213.            t)             ;end of segment
  1214.           ((re-search-forward *cl-prompt* end-mark t)
  1215.            (let ((the-string (cl-grab-region start-point (point)))
  1216.              (extra-prompt-re    ;find optional T and prompt
  1217.               (format "[ \t\n]*\\(t\\|T\\)?[ \t\n]*\\(%s\\|%s\\)"
  1218.                   *cl-prompt* *cl-error-prompt*)))
  1219.          (setq the-string (concat cl-filter-string the-string))
  1220.          (setq cl-filter-string
  1221.                (substring the-string 0
  1222.                   (string-match extra-prompt-re the-string))))
  1223.            t)             ;end of segment
  1224.           ((re-search-forward cl-filter-state-open end-mark t)
  1225.            (message "Attempted nested SPECIAL STREAMS")
  1226.            (cl-grab-state-id)    ;remove marker
  1227.            (setq cl-filter-string 
  1228.              (concat cl-filter-string (cl-grab-region start-point (point))))
  1229.            nil)            ;not end-of-segment
  1230.           (t (goto-char end-mark)
  1231.          (setq cl-filter-string 
  1232.                (concat cl-filter-string (cl-grab-region start-point (point))))
  1233.          nil)))))        ;not end-of-segment
  1234.  
  1235. ;;; Variables containing regular expressions which flag the beginning 
  1236. ;;; and end of special purpose input to the lisp process.
  1237. ;;; Syntax is [[input-identifier>>input-string<<input-identifier]]
  1238. ;;; The close marker is not necessary if CL will print a prompt at the end
  1239. ;;; (ie if CL is at top-level).
  1240. (defconst cl-filter-state-open "\\[\\[[A-Z---]+>>")
  1241. (defconst cl-filter-state-close "<<[A-Z---]+\\]\\]")
  1242.  
  1243. ;;; Assume the last re-search matched a state-id, return the string identifying
  1244. ;;; the state, and erase the match from the buffer.
  1245. (defun cl-grab-state-id ()
  1246.   (let ((the-state-id (buffer-substring (+ (match-beginning 0) 2)
  1247.                     (- (match-end 0) 2))))
  1248.     (replace-match "")
  1249.     the-state-id))
  1250.  
  1251. ;;; Delete region, returning as a string
  1252. (defun cl-grab-region (start end)
  1253.   (let ((the-string (buffer-substring start end)))
  1254.     (delete-region start end)
  1255.     the-string))
  1256.  
  1257. ;;; Add shell history mechanism.
  1258. (load "shell-history")
  1259.