home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / lisp-fns.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  11.0 KB  |  279 lines
  1. ;;;; Russell Ritchie, Scottish HCI Centre, <russell@uk.ac.strath.hci>. Tue Nov  8 13:02:17 1988
  2. ;;;; Various utilities and modifications specific to Lisp. Incorporates 'lisp-eval' also.
  3.  
  4. (require 'shell)
  5. (require 'utilities)
  6. (provide 'lisp-fns)
  7.  
  8. (defvar inferior-lisp-program "lisp"
  9.   "*The program to invoke in the Lisp buffer. 
  10. A buffer-local variable, in order to allow different dialects 
  11. of Lisp to be edited and run simultaneously. Defaults to \"lisp\".")
  12.  
  13. (defvar inferior-lisp-buffer nil
  14.   "The buffer the inferior Lisp process is running in.
  15. Do NOT set this variable, it is bound automatically after determination of which program to run.")
  16.  
  17. (defun run-lisp ()
  18.   "The same as the distribution run-lisp, but uses inferior-lisp-program for the name of the Lisp buffer.
  19. Binds the buffer-local variable  inferior-lisp-buffer  to the name of the Lisp buffer."
  20.   (interactive)
  21.   (make-shell (file-name-nondirectory inferior-lisp-program)
  22.           (if (string-match "~" inferior-lisp-program)
  23.           ;; User has specified a ~-relative program, so...
  24.           (expand-file-name inferior-lisp-program)
  25.         inferior-lisp-program))
  26.   (setq inferior-lisp-buffer (concat "*" (file-name-nondirectory inferior-lisp-program) "*"))
  27.   (switch-to-buffer inferior-lisp-buffer)
  28.   (inferior-lisp-mode))
  29.  
  30. (defun inferior-lisp-call (func-and-args &optional go-afterwards)
  31.   "Pass FUNC-AND-ARGS to inferior-lisp process and do a (shell-send-input).
  32. Create LISP if necessary. 
  33. If optional 2nd arg. GO-AFTERWARDS is t pop to LISP buffer after
  34.  (shell-send-input) to see what is happening."
  35.   (if (or (string= func-and-args "") (white-spacep func-and-args))
  36.       (error "Empty or white-space function call passed to inferior-lisp-call.")
  37.     (if (> (length func-and-args) 255)
  38.     (error "Inferior-lisp-call can only send s-expressions of less than 256 characters.")
  39.       (if go-afterwards 
  40.       (progn
  41.         (run-lisp)            ; Create LISP (if none) & goto end.
  42.         (process-send-string (get-buffer-process (current-buffer)) func-and-args)
  43.         (shell-send-input))
  44.     (save-excursion
  45.       (run-lisp)
  46.       (process-send-string (get-buffer-process (current-buffer)) func-and-args)
  47.       (shell-send-input))))))
  48.  
  49. (defun allegro-lisp-mode ()
  50.   "Major mode for editing Allegro Common Lisp code."
  51.   (interactive)
  52.   (lisp-mode)
  53.   (setq mode-name "Allegro Common Lisp")
  54.   (make-local-variable 'inferior-lisp-program)
  55.   (setq inferior-lisp-program "cl")
  56.   (make-local-variable 'inferior-lisp-load-command)
  57.   (setq inferior-lisp-load-command
  58.     "(progn (load \"%s\" :verbose nil :print t) (values))\n")
  59.   (make-local-variable 'inferior-lisp-buffer) ; Set by #'run-lisp, when the buffer is actually created.
  60.   (run-hooks 'allegro-lisp-mode-hook))
  61.  
  62. (defun franz-lisp-mode ()
  63.   "Major mode for editing Franz Lisp code."
  64.   (interactive)
  65.   (lisp-mode)
  66.   (setq mode-name "Franz Lisp")
  67.   (make-local-variable 'inferior-lisp-program)
  68.   (setq inferior-lisp-program "lisp")
  69.   (make-local-variable 'inferior-lisp-load-command)
  70.   (setq inferior-lisp-load-command "(load \"%s\")\n")
  71.   (make-local-variable 'inferior-lisp-buffer) ; Set by #'run-lisp, when the buffer is actually created.
  72.   (run-hooks 'franz-lisp-mode-hook))
  73.  
  74. (defun kyoto-lisp-mode ()
  75.   "Major mode for editing Kyoto Common Lisp code."
  76.   (interactive)
  77.   (lisp-mode)
  78.   (setq mode-name "Kyoto Common Lisp")
  79.   (make-local-variable 'inferior-lisp-program)
  80.   (setq inferior-lisp-program "kcl")
  81.   (make-local-variable 'inferior-lisp-load-command)
  82.   (setq inferior-lisp-load-command
  83.     "(progn (load \"%s\" :verbose nil :print t) (values))\n") 
  84.   (make-local-variable 'inferior-lisp-buffer) ; Set by #'run-lisp, when the buffer is actually created.
  85.   (run-hooks 'kyoto-lisp-mode-hook))
  86.  
  87. (defun start-allegro-lisp ()
  88.   "
  89. Called when a file ending in \".cl\" is visited. Starts
  90. an inferior lisp process (using (run-lisp))
  91. in another window and displays that and the file, leaving the
  92. cursor at the top of the file buffer."
  93.   (interactive)
  94.   (allegro-lisp-mode)            ; Turn on lisp-mode in the ".cl" file.
  95.   (let ((this (current-buffer))
  96.     (pop-up-windows t))
  97.     (run-lisp)                ; Start up a lisp process.
  98.     (pop-to-buffer this)))
  99.  
  100. (defun start-franz-lisp ()
  101.   "
  102. Called when a file ending in \".l\" is visited. Starts an
  103. inferior lisp process (using (run-lisp inferior-lisp-program))
  104. in another window and displays that and the file, leaving 
  105. the cursor at the top of the file buffer."
  106.   (interactive)
  107.   (franz-lisp-mode)            ; Turn on franz-mode in the ".l" file.
  108.   (let ((this (current-buffer))
  109.     (pop-up-windows t))
  110.     (run-lisp)                ; Start up a lisp process.
  111.     (pop-to-buffer this)))
  112.  
  113. (defun start-kyoto-lisp ()
  114.   "
  115. Called when a file ending in \".lsp\" is visited. Starts an
  116. inferior lisp process (using (run-lisp inferior-lisp-program))
  117. in another window and displays that and the file, leaving 
  118. the cursor at the top of the file buffer."
  119.   (interactive)
  120.   (kyoto-lisp-mode)            ; Turn on kyoto-mode in the ".lsp" file.
  121.   (let ((this (current-buffer))
  122.     (pop-up-windows t))
  123.     (run-lisp)                ; Start up a lisp process.
  124.     (pop-to-buffer this)))
  125.  
  126. (or (fboundp 'common-lisp-mode) (fset 'common-lisp-mode 'kyoto-lisp-mode)) ; Default Common LISP
  127. (or (fboundp 'start-common-lisp) (fset 'start-common-lisp 'start-kyoto-lisp)) ; is KCL.
  128.  
  129. (defun lisp-send-region (beg end &optional display-flag)
  130.   "Send the current region to the Lisp process.
  131. With argument, force redisplay and scrolling of the buffer 
  132. the inferior Lisp process is running in (note that there may
  133. be more than 1 inferior Lisp process). 
  134. Variable `inferior-lisp-load-command' controls formatting of
  135. the `load' form that is set to the Lisp process."
  136.   (interactive "r\nP")
  137.   (message "Sending region...")
  138.   (save-excursion
  139.     (let* ((inferior-lisp-program
  140.         (file-name-nondirectory inferior-lisp-program))
  141.        (filename
  142.         (if (and inferior-lisp-buffer ; We've started one...
  143.              (get-process inferior-lisp-program)) ; It's still going.
  144.         (format "/tmp/emlisp%d"
  145.             (process-id (get-process inferior-lisp-program)))
  146.           (let ((mesg (format "%starting %s process..."
  147.                   (if inferior-lisp-buffer "Res" "S")
  148.                   inferior-lisp-program)))
  149.         (message mesg)               
  150.         (save-excursion (run-lisp))
  151.         (sit-for 1)        ; Give Lisp time to start up....
  152.         (message (concat mesg "done"))
  153.         (format "/tmp/emlisp%d"
  154.             (process-id (get-process inferior-lisp-program)))))))
  155.       (write-region beg end filename nil 'nomessage)
  156.       (process-send-string inferior-lisp-program
  157.                (format inferior-lisp-load-command filename))
  158.       (if display-flag
  159.       (let* ((process (get-process inferior-lisp-program))
  160.          (buffer (process-buffer process))
  161.          (w (or (get-buffer-window buffer) (display-buffer buffer)))
  162.          (height (window-height w))
  163.          (end))
  164.         (save-excursion
  165.           (set-buffer buffer)
  166.           (setq end (point-max))
  167.           (while (progn
  168.                (accept-process-output process)
  169.                (goto-char (point-max))
  170.                (beginning-of-line)
  171.                (or (= (point-max) end)
  172.                (not (looking-at inferior-lisp-prompt)))))
  173.           (setq end (point-max))
  174.           (vertical-motion (- 4 height))
  175.           (set-window-start w (point)))
  176.         (set-window-point w end)))
  177.       (message "Sent region!"))))
  178.  
  179. (defun lisp-send-region-and-go (beg end &optional ignored)
  180.   "Send to current region and go to Lisp process."
  181.   (interactive "r\nP")
  182.   (lisp-send-region beg end nil)
  183.   (switch-to-buffer-other-window inferior-lisp-buffer)
  184.   (goto-char (point-max)))
  185.  
  186. (defun lisp-send-buffer (display-flag)
  187.   "Send the current buffer to the Lisp process, if prefix arg non-nil redisplay too.
  188.  
  189. Bound to \\<lisp-mode-map>\\[lisp-send-buffer]"
  190.   (interactive "P")
  191.   (message (concat "Sending contents of " (buffer-name) "..."))
  192.   (save-excursion
  193.     (mark-whole-buffer)
  194.     (lisp-send-region (point) (mark) display-flag))
  195.   (message (concat "Sent " (buffer-name) "!")))
  196.  
  197. (defun lisp-send-buffer-and-go (&optional ignored)
  198.   "Send the current buffer to the Lisp process and go to the Lisp process.
  199.  
  200. Bound to \\<lisp-mode-map>\\[lisp-send-buffer-and-go]"
  201.   (interactive)
  202.   (lisp-send-buffer nil)
  203.   (switch-to-buffer-other-window inferior-lisp-buffer)
  204.   (goto-char (point-max)))
  205.  
  206. (defun lisp-send-defun (display-flag)
  207.   "Send the current defun to the Lisp process made by M-x run-lisp.
  208. With argument, force redisplay and scrolling of the Lisp buffer.
  209. Variable `inferior-lisp-load-command' controls formatting of
  210. the `load' form that is set to the Lisp process."
  211.   (interactive "P")
  212.   (save-excursion
  213.    (mark-defun)
  214.    (lisp-send-region (point) (mark) display-flag)))
  215.  
  216. (defun lisp-send-defun-and-go ()
  217.   "Send the current defun to the inferior Lisp, and switch to Lisp buffer."
  218.   (interactive)
  219.   (lisp-send-defun nil)
  220.   (switch-to-buffer-other-window inferior-lisp-buffer)
  221.   (goto-char (point-max)))
  222.  
  223. (define-key lisp-mode-map "\C-c\C-d" 'lisp-send-defun-and-go)
  224. (define-key lisp-mode-map "\C-cd" 'lisp-send-defun)
  225. (define-key lisp-mode-map "\C-c\C-r" 'lisp-send-region-and-go)
  226. (define-key lisp-mode-map "\C-cr" 'lisp-send-region)
  227. (define-key lisp-mode-map "\C-c\C-b" 'lisp-send-buffer-and-go)
  228. (define-key lisp-mode-map "\C-cb" 'lisp-send-buffer)
  229.  
  230. ;;; Inferior Lisp Eval region. Author: Russell A. Ritchie, Scottish HCI Centre.
  231.  
  232. ;;; Allow evaluation of region AS IF IT WAS TYPED to an inferior lisp. 
  233. ;;; To solve buffering problems, lisp-send-defun and friends create a temp file
  234. ;;; and tell the inferior lisp to load this. For Franz LISP (possibly others)
  235. ;;; this does not have the same effect for arbitrary s-expressions as typing
  236. ;;; them to the top-level, since only the value of the load is returned (and
  237. ;;; hence printed).
  238.  
  239. (defun lisp-eval-send (beg end show)
  240.   "Make a string from BEG to END and do a show-output-from-shell after sending 
  241. it to the inferior lisp if SHOW is non-nil."
  242.   (lisp-eval-call (buffer-substring beg end) show))
  243.  
  244. (defun lisp-eval-call (string show)
  245.   (if (or (string= string "") (white-spacep string))
  246.       (error "Region is empty or white space only.")
  247.     (if (> (length string) 255)
  248.     (error "Lisp-eval cannot send more than 255 characters without blocking irretrievably.")
  249.       (save-excursion
  250.     (set-buffer inferior-lisp-buffer)
  251.     (set-mark (point-max))
  252.     (process-send-string (get-buffer-process (current-buffer)) string)
  253.     (shell-send-input)
  254.     (if show (show-output-from-shell))))))
  255.  
  256. (defun lisp-eval-send-region (arg beg end)
  257.   "Evaluate current region in the inferior lisp buffer as if it were typed.
  258. If prefix arg is greater than 1 then show output from shell afterwards.
  259.  
  260. Bound to \\[lisp-eval-send-region] by default.
  261. Trying to send regions larger than 255 characters will block irretrievably."
  262.   (interactive "p\nr")
  263.   (lisp-eval-send beg end (> arg 1)))
  264.  
  265. (defun lisp-eval-send-region-and-go (arg beg end)
  266.   "Evaluate current region in the inferior lisp buffer as if it were typed.
  267. If prefix arg is greater than 1 then show output from shell afterwards.
  268. After evaluating region, go to inferior lisp buffer.
  269.  
  270. Bound to \\<lisp-mode-map>\\[lisp-eval-send-region-and-go] by default.
  271. Trying to send regions larger than 255 characters will block irretrievably."
  272.   (interactive "p\nr")
  273.   (lisp-eval-send beg end (> arg 1))
  274.   (pop-to-buffer inferior-lisp-buffer))
  275.  
  276. (define-key lisp-mode-map "\C-c\C-e"     'lisp-eval-send-region-and-go)
  277. (define-key lisp-mode-map "\C-ce"     'lisp-eval-send-region)
  278.  
  279.