Mercurial > emacs
changeset 42490:0715d86d229c
Extensive changes to support multiple xscheme buffers:
(run-scheme): Break up into new functions to facilitate starting
processes in other buffers.
(xscheme-start, xscheme-read-command-line): New functions.
(start-scheme, select-scheme)
(default-xscheme-runlight)
(global-set-scheme-interaction-buffer)
(local-set-scheme-interaction-buffer)
(local-clear-scheme-interaction-buffer)
(exit-scheme-interaction-mode)
(verify-xscheme-buffer): New functions.
(xscheme-process-name, xscheme-buffer-name)
(xscheme-runlight): New internal vars.
(default-xscheme-runlight): New const.
(xscheme-start-process): Add args for the process/buffer names.
(reset-scheme): Pass process/buffer names.
(scheme-interaction-mode): Initialize new local vars.
(reset-scheme, xscheme-send-string-2, xscheme-process-running-p)
(xscheme-select-process-buffer, xscheme-process-buffer)
(xscheme-send-region, xscheme-send-char, xscheme-send-interrupt)
(xscheme-goto-output-point, xscheme-write-message-1): Use new
var xscheme-process-name.
(xscheme-start-process): Initialize xscheme-process-name and
xscheme-buffer-name in the process buffer. Pass buffer name to
xscheme-modeline-initialize.
(xscheme-modeline-initialize): Add argument to specify buffer name
for mode-line vars.
(xscheme-process-sentinel): Make sure sentinel is run in the
process buffer so it sees its local vars.
(xscheme-process-filter-initialize, xscheme-set-runlight): More
elaborate logic to handle multiple-buffer mode lines.
(xscheme-enter-input-wait): Re-enable control-G handler upon
entering input wait.
(scheme-interaction-mode): Add arg to preserve local vars.
(xscheme-enter-interaction-mode)
(xscheme-enter-debugger-mode): Preserve local vars.
(xscheme-start-process): Clobber local vars.
(scheme-interaction-mode-commands): Allow end user to add commands
to scheme-interaction-mode keymap.
(scheme-interaction-mode-commands-alist): New variable.
(xscheme-send-string): Don't use insert-before-markers.
Implement a per-buffer kill ring:
(xscheme-insert-expression)
(xscheme-rotate-yank-pointer, xscheme-yank)
(xscheme-yank-pop, xscheme-yank-push): New functions.
(xscheme-expressions-ring)
(xscheme-expressions-ring-yank-pointer)
(xscheme-expressions-ring-max): New variables.
(xscheme-send-string-1): Call xscheme-insert-expression to save
expression in ring.
(xscheme-yank-previous-send): Now an alias for xscheme-yank.
(xscheme-previous-send): Deleted variable.
(xscheme-send-string-2, xscheme-send-char, xscheme-send-proceed,
xscheme-send-control-g-interrupt): Use process-send-string rather
than send-string.
(xscheme-send-region): Insert a newline after an expression that
is submitted in the interaction buffer, for consistency with
recent changes to Edwin.
(xscheme-delete-output): New function mimics comint-delete-output.
(xscheme-last-input-end): New internal variable.
(xscheme-process-filter-output): Update xscheme-last-input-end.
(xscheme-send-control-g-interrupt): Make sure that
xscheme-control-g-disabled-p is looked up in the right buffer.
(xscheme-enable-control-g): Clear C-g message if visible.
(xscheme-control-g-message-string): New internal var.
(xscheme-send-control-g-interrupt): Use new var.
(xscheme-send-control-g-interrupt, xscheme-send-interrupt): Delay
after sending interrupt in order to work around race condition.
(xscheme-send-control-g-interrupt, xscheme-send-interrupt)
(xscheme-send-char): Use xscheme-send-char rather than send-string
to send single char.
(xscheme-process-filter, xscheme-process-filter-alist): Add
support for evaluating expressions outside of the call-excursion.
(xscheme-process-filter:string-action-noexcursion): New func.
(xscheme-write-value): Change output string to match that used by Edwin.
(xscheme-coerce-prompt): Don't write a space after a command
prompt. The PROMPT-FOR-COMMAND- procedures will take care of this
for us.
(reset-scheme): Delete process after killing it.
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Wed, 02 Jan 2002 23:50:46 +0000 |
| parents | f9c5738cf0d1 |
| children | 0be46fec7fc2 |
| files | lisp/xscheme.el |
| diffstat | 1 files changed, 494 insertions(+), 153 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/xscheme.el Wed Jan 02 22:56:12 2002 +0000 +++ b/lisp/xscheme.el Wed Jan 02 23:50:46 2002 +0000 @@ -1,6 +1,6 @@ ;;; xscheme.el --- run MIT Scheme under Emacs -;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1987, 1989, 1990, 2001 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: languages, lisp @@ -24,10 +24,10 @@ ;;; Commentary: -;; A major mode for editing Scheme and interacting with MIT's C-Scheme. +;; A major mode for interacting with MIT Scheme. ;; -;; Requires C-Scheme release 5 or later -;; Changes to Control-G handler require runtime version 13.85 or later +;; Requires MIT Scheme release 5 or later. +;; Changes to Control-G handler require runtime version 13.85 or later. ;;; Code: @@ -71,6 +71,13 @@ :type 'boolean :group 'xscheme) +(defcustom xscheme-start-hook nil + "If non-nil, a procedure to call when the Scheme process is started. +When called, the current buffer will be the Scheme process-buffer." + :type 'hook + :group 'xscheme + :version 20.3) + (defun xscheme-evaluation-commands (keymap) (define-key keymap "\e\C-x" 'xscheme-send-definition) (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) @@ -93,28 +100,23 @@ "Run MIT Scheme in an inferior process. Output goes to the buffer `*scheme*'. With argument, asks for a command line." - (interactive - (list (let ((default - (or xscheme-process-command-line - (xscheme-default-command-line)))) - (if current-prefix-arg - (read-string "Run Scheme: " default) - default)))) - (setq xscheme-process-command-line command-line) - (pop-to-buffer (xscheme-start-process command-line))) + (interactive (list (xscheme-read-command-line current-prefix-arg))) + (xscheme-start command-line xscheme-process-name xscheme-buffer-name)) -(defun reset-scheme () - "Reset the Scheme process." - (interactive) - (let ((process (get-process "scheme"))) - (cond ((or (not process) - (not (eq (process-status process) 'run)) - (yes-or-no-p -"The Scheme process is running, are you SURE you want to reset it? ")) - (message "Resetting Scheme process...") - (if process (kill-process process t)) - (xscheme-start-process xscheme-process-command-line) - (message "Resetting Scheme process...done"))))) +(defun xscheme-start (command-line process-name buffer-name) + (setq-default xscheme-process-command-line command-line) + (switch-to-buffer + (xscheme-start-process command-line process-name buffer-name)) + (make-local-variable 'xscheme-process-command-line) + (setq xscheme-process-command-line command-line)) + +(defun xscheme-read-command-line (arg) + (let ((default + (or xscheme-process-command-line + (xscheme-default-command-line)))) + (if arg + (read-string "Run Scheme: " default) + default))) (defun xscheme-default-command-line () (concat scheme-program-name " -emacs" @@ -124,15 +126,122 @@ (if scheme-band-name (concat " -band " scheme-band-name) ""))) + +(defun reset-scheme () + "Reset the Scheme process." + (interactive) + (let ((process (get-process xscheme-process-name))) + (cond ((or (not process) + (not (eq (process-status process) 'run)) + (yes-or-no-p +"The Scheme process is running, are you SURE you want to reset it? ")) + (message "Resetting Scheme process...") + (if process + (progn + (kill-process process t) + (delete-process process))) + (xscheme-start-process xscheme-process-command-line + xscheme-process-name + xscheme-buffer-name) + (message "Resetting Scheme process...done"))))) + +;;;; Multiple Scheme buffer management commands + +(defun start-scheme (buffer-name &optional globally) + "Choose a scheme interaction buffer, or create a new one." + ;; (interactive "BScheme interaction buffer: \nP") + (interactive + (list (read-buffer "Scheme interaction buffer: " + xscheme-buffer-name + nil) + current-prefix-arg)) + (let ((buffer (get-buffer-create buffer-name))) + (let ((process (get-buffer-process buffer))) + (if process + (switch-to-buffer buffer) + (if (or (not (buffer-file-name buffer)) + (yes-or-no-p (concat "Buffer " + (buffer-name buffer) + " contains file " + (buffer-file-name buffer) + "; start scheme in it? "))) + (progn + (xscheme-start (xscheme-read-command-line t) + buffer-name + buffer-name) + (if globally + (global-set-scheme-interaction-buffer buffer-name))) + (message "start-scheme aborted")))))) + +(fset 'select-scheme 'start-scheme) + +(defun global-set-scheme-interaction-buffer (buffer-name) + "Set the default scheme interaction buffer." + (interactive + (list (read-buffer "Scheme interaction buffer: " + xscheme-buffer-name + t))) + (let ((process-name (verify-xscheme-buffer buffer-name nil))) + (setq-default xscheme-buffer-name buffer-name) + (setq-default xscheme-process-name process-name) + (setq-default xscheme-runlight-string + (save-excursion (set-buffer buffer-name) + xscheme-runlight-string)) + (setq-default xscheme-runlight + (if (eq (process-status process-name) 'run) + default-xscheme-runlight + "")))) + +(defun local-set-scheme-interaction-buffer (buffer-name) + "Set the scheme interaction buffer for the current buffer." + (interactive + (list (read-buffer "Scheme interaction buffer: " + xscheme-buffer-name + t))) + (let ((process-name (verify-xscheme-buffer buffer-name t))) + (make-local-variable 'xscheme-buffer-name) + (setq xscheme-buffer-name buffer-name) + (make-local-variable 'xscheme-process-name) + (setq xscheme-process-name process-name) + (make-local-variable 'xscheme-runlight) + (setq xscheme-runlight (save-excursion (set-buffer buffer-name) + xscheme-runlight)))) + +(defun local-clear-scheme-interaction-buffer () + "Make the current buffer use the default scheme interaction buffer." + (interactive) + (if (xscheme-process-buffer-current-p) + (error "Cannot change the interaction buffer of an interaction buffer")) + (kill-local-variable 'xscheme-buffer-name) + (kill-local-variable 'xscheme-process-name) + (kill-local-variable 'xscheme-runlight)) + +(defun verify-xscheme-buffer (buffer-name localp) + (if (and localp (xscheme-process-buffer-current-p)) + (error "Cannot change the interaction buffer of an interaction buffer")) + (let* ((buffer (get-buffer buffer-name)) + (process (and buffer (get-buffer-process buffer)))) + (cond ((not buffer) + (error "Buffer does not exist" buffer-name)) + ((not process) + (error "Buffer is not a scheme interaction buffer" buffer-name)) + (t + (save-excursion + (set-buffer buffer) + (if (not (xscheme-process-buffer-current-p)) + (error "Buffer is not a scheme interaction buffer" + buffer-name))) + (process-name process))))) ;;;; Interaction Mode -(defun scheme-interaction-mode () - "Major mode for interacting with the inferior Scheme process. +(defun scheme-interaction-mode (&optional preserve) + "Major mode for interacting with an inferior MIT Scheme process. Like scheme-mode except that: \\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input -\\[xscheme-yank-previous-send] yanks the expression most recently sent to Scheme +\\[xscheme-yank-pop] yanks an expression previously sent to Scheme +\\[xscheme-yank-push] yanks an expression more recently sent to Scheme All output from the Scheme process is written in the Scheme process buffer, which is initially named \"*scheme*\". The result of @@ -199,22 +308,74 @@ with no args, if that value is non-nil. Likewise with the value of scheme-mode-hook. scheme-interaction-mode-hook is called after scheme-mode-hook." - (interactive) - (kill-all-local-variables) + (interactive "P") + (if (not preserve) + (let ((previous-mode major-mode)) + (kill-all-local-variables) + (make-local-variable 'xscheme-previous-mode) + (make-local-variable 'xscheme-buffer-name) + (make-local-variable 'xscheme-process-name) + (make-local-variable 'xscheme-previous-process-state) + (make-local-variable 'xscheme-runlight-string) + (make-local-variable 'xscheme-runlight) + (make-local-variable 'xscheme-last-input-end) + (setq xscheme-previous-mode previous-mode) + (let ((buffer (current-buffer))) + (setq xscheme-buffer-name (buffer-name buffer)) + (setq xscheme-last-input-end (make-marker)) + (let ((process (get-buffer-process buffer))) + (if process + (progn + (setq xscheme-process-name (process-name process)) + (setq xscheme-previous-process-state + (cons (process-filter process) + (process-sentinel process))) + (xscheme-process-filter-initialize t) + (xscheme-modeline-initialize xscheme-buffer-name) + (set-process-sentinel process 'xscheme-process-sentinel) + (set-process-filter process 'xscheme-process-filter)) + (setq xscheme-previous-process-state (cons nil nil))))))) (scheme-interaction-mode-initialize) (scheme-mode-variables) - (make-local-variable 'xscheme-previous-send) (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) +(defun exit-scheme-interaction-mode () + "Take buffer out of scheme interaction mode" + (interactive) + (if (not (eq major-mode 'scheme-interaction-mode)) + (error "Buffer not in scheme interaction mode")) + (let ((previous-state xscheme-previous-process-state)) + (funcall xscheme-previous-mode) + (let ((process (get-buffer-process (current-buffer)))) + (if process + (progn + (if (eq (process-filter process) 'xscheme-process-filter) + (set-process-filter process (car previous-state))) + (if (eq (process-sentinel process) 'xscheme-process-sentinel) + (set-process-sentinel process (cdr previous-state)))))))) + (defun scheme-interaction-mode-initialize () (use-local-map scheme-interaction-mode-map) (setq major-mode 'scheme-interaction-mode) (setq mode-name "Scheme Interaction")) (defun scheme-interaction-mode-commands (keymap) - (define-key keymap "\C-c\C-m" 'xscheme-send-current-line) - (define-key keymap "\C-c\C-p" 'xscheme-send-proceed) - (define-key keymap "\C-c\C-y" 'xscheme-yank-previous-send)) + (let ((entries scheme-interaction-mode-commands-alist)) + (while entries + (define-key keymap + (car (car entries)) + (car (cdr (car entries)))) + (setq entries (cdr entries))))) + +(defvar scheme-interaction-mode-commands-alist nil) +(setq scheme-interaction-mode-commands-alist + (append scheme-interaction-mode-commands-alist + '(("\C-c\C-m" xscheme-send-current-line) + ("\C-c\C-o" xscheme-delete-output) + ("\C-c\C-p" xscheme-send-proceed) + ("\C-c\C-y" xscheme-yank) + ("\ep" xscheme-yank-pop) + ("\en" xscheme-yank-push)))) (defvar scheme-interaction-mode-map nil) (if (not scheme-interaction-mode-map) @@ -231,7 +392,7 @@ (if (not (eq major-mode 'scheme-interaction-mode)) (if (eq major-mode 'scheme-debugger-mode) (scheme-interaction-mode-initialize) - (scheme-interaction-mode))))) + (scheme-interaction-mode t))))) (fset 'advertised-xscheme-send-previous-expression 'xscheme-send-previous-expression) @@ -279,7 +440,7 @@ (if (not (eq major-mode 'scheme-debugger-mode)) (progn (if (not (eq major-mode 'scheme-interaction-mode)) - (scheme-interaction-mode)) + (scheme-interaction-mode t)) (scheme-debugger-mode-initialize))))) (defun xscheme-debugger-mode-p () @@ -299,8 +460,6 @@ (progn (reset-scheme) (xscheme-wait-for-process) - (goto-char (point-max)) - (apply 'insert-before-markers strings) (xscheme-send-string-1 strings)))) ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) ((and (not xscheme-allow-pipelined-evaluation) @@ -312,24 +471,20 @@ (let ((string (apply 'concat strings))) (xscheme-send-string-2 string) (if (eq major-mode 'scheme-interaction-mode) - (setq xscheme-previous-send string)))) + (xscheme-insert-expression string)))) (defun xscheme-send-string-2 (string) - (let ((process (get-process "scheme"))) - (send-string process (concat string "\n")) + (let ((process (get-process xscheme-process-name))) + (process-send-string process (concat string "\n")) (if (xscheme-process-buffer-current-p) (set-marker (process-mark process) (point))))) -(defun xscheme-yank-previous-send () - "Insert the most recent expression at point." - (interactive) - (push-mark) - (insert xscheme-previous-send)) - (defun xscheme-select-process-buffer () "Select the Scheme process buffer and move to its output point." (interactive) - (let ((process (or (get-process "scheme") (error "No scheme process")))) + (let ((process + (or (get-process xscheme-process-name) + (error "No scheme process")))) (let ((buffer (or (process-buffer process) (error "No process buffer")))) (let ((window (get-buffer-window buffer))) (if window @@ -337,13 +492,106 @@ (switch-to-buffer buffer)) (goto-char (process-mark process)))))) +;;;; Scheme expressions ring + +(defun xscheme-insert-expression (string) + (setq xscheme-expressions-ring (cons string xscheme-expressions-ring)) + (if (> (length xscheme-expressions-ring) xscheme-expressions-ring-max) + (setcdr (nthcdr (1- xscheme-expressions-ring-max) + xscheme-expressions-ring) + nil)) + (setq xscheme-expressions-ring-yank-pointer xscheme-expressions-ring)) + +(defun xscheme-rotate-yank-pointer (arg) + "Rotate the yanking point in the kill ring." + (interactive "p") + (let ((length (length xscheme-expressions-ring))) + (if (zerop length) + (error "Scheme expression ring is empty") + (setq xscheme-expressions-ring-yank-pointer + (let ((index + (% (+ arg + (- length + (length xscheme-expressions-ring-yank-pointer))) + length))) + (nthcdr (if (< index 0) + (+ index length) + index) + xscheme-expressions-ring)))))) + +(defun xscheme-yank (&optional arg) + "Insert the most recent expression at point. +With just C-U as argument, same but put point in front (and mark at end). +With argument n, reinsert the nth most recently sent expression. +See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]." + (interactive "*P") + (xscheme-rotate-yank-pointer (if (listp arg) 0 + (if (eq arg '-) -1 + (1- arg)))) + (push-mark (point)) + (insert (car xscheme-expressions-ring-yank-pointer)) + (if (consp arg) + (exchange-point-and-mark))) + +;; Old name, to avoid errors in users' init files. +(fset 'xscheme-yank-previous-send + 'xscheme-yank) + +(defun xscheme-yank-pop (arg) + "Insert or replace a just-yanked expression with an older expression. +If the previous command was not a yank, it yanks. +Otherwise, the region contains a stretch of reinserted +expression. yank-pop deletes that text and inserts in its +place a different expression. + +With no argument, the next older expression is inserted. +With argument n, the n'th older expression is inserted. +If n is negative, this is a more recent expression. + +The sequence of expressions wraps around, so that after the oldest one +comes the newest one." + (interactive "*p") + (setq this-command 'xscheme-yank) + (if (not (eq last-command 'xscheme-yank)) + (progn + (xscheme-yank) + (setq arg (- arg 1)))) + (if (not (= arg 0)) + (let ((before (< (point) (mark)))) + (delete-region (point) (mark)) + (xscheme-rotate-yank-pointer arg) + (set-mark (point)) + (insert (car xscheme-expressions-ring-yank-pointer)) + (if before (exchange-point-and-mark))))) + +(defun xscheme-yank-push (arg) + "Insert or replace a just-yanked expression with a more recent expression. +If the previous command was not a yank, it yanks. +Otherwise, the region contains a stretch of reinserted +expression. yank-pop deletes that text and inserts in its +place a different expression. + +With no argument, the next more recent expression is inserted. +With argument n, the n'th more recent expression is inserted. +If n is negative, a less recent expression is used. + +The sequence of expressions wraps around, so that after the oldest one +comes the newest one." + (interactive "*p") + (xscheme-yank-pop (- 0 arg))) + (defun xscheme-send-region (start end) "Send the current region to the Scheme process. The region is sent terminated by a newline." (interactive "r") (if (xscheme-process-buffer-current-p) - (progn (goto-char end) - (set-marker (process-mark (get-process "scheme")) end))) + (progn + (goto-char end) + (if (not (bolp)) + (insert-before-markers ?\n)) + (set-marker (process-mark (get-process xscheme-process-name)) + (point)) + (set-marker xscheme-last-input-end (point)))) (xscheme-send-string (buffer-substring start end))) (defun xscheme-send-definition () @@ -396,7 +644,23 @@ (defun xscheme-send-char (char) "Prompt for a character and send it to the Scheme process." (interactive "cCharacter to send: ") - (send-string "scheme" (char-to-string char))) + (process-send-string xscheme-process-name (char-to-string char))) + +(defun xscheme-delete-output () + "Delete all output from interpreter since last input." + (interactive) + (let ((proc (get-buffer-process (current-buffer)))) + (save-excursion + (goto-char (process-mark proc)) + (re-search-backward + "^;\\(Unspecified return value$\\|Value\\( [0-9]+\\)?: \\|\\(Abort\\|Up\\|Quit\\)!$\\)" + xscheme-last-input-end + t) + (forward-line 0) + (if (< (marker-position xscheme-last-input-end) (point)) + (progn + (delete-region xscheme-last-input-end (point)) + (insert-before-markers "*** output flushed ***\n")))))) ;;;; Interrupts @@ -408,7 +672,7 @@ (defun xscheme-send-proceed () "Cause the Scheme process to proceed from a breakpoint." (interactive) - (send-string "scheme" "(proceed)\n")) + (process-send-string xscheme-process-name "(proceed)\n")) (defun xscheme-send-control-g-interrupt () "Cause the Scheme processor to halt and flush input. @@ -416,14 +680,22 @@ (interactive) (let ((inhibit-quit t)) (cond ((not xscheme-control-g-synchronization-p) - (interrupt-process "scheme")) - (xscheme-control-g-disabled-p + (interrupt-process xscheme-process-name)) + ((save-excursion + (set-buffer xscheme-buffer-name) + xscheme-control-g-disabled-p) (message "Relax...")) (t - (setq xscheme-control-g-disabled-p t) - (message "Sending C-G interrupt to Scheme...") - (interrupt-process "scheme") - (send-string "scheme" (char-to-string 0)))))) + (save-excursion + (set-buffer xscheme-buffer-name) + (setq xscheme-control-g-disabled-p t)) + (message xscheme-control-g-message-string) + (interrupt-process xscheme-process-name) + (sleep-for 0.1) + (xscheme-send-char 0))))) + +(defconst xscheme-control-g-message-string + "Sending C-G interrupt to Scheme...") (defun xscheme-send-control-u-interrupt () "Cause the Scheme process to halt, returning to previous rep loop." @@ -443,18 +715,33 @@ (defun xscheme-send-interrupt (char mark-p) "Send a ^A type interrupt to the Scheme process." (interactive "cInterrupt character to send: ") - (quit-process "scheme") - (send-string "scheme" (char-to-string char)) + (quit-process xscheme-process-name) + (sleep-for 0.1) + (xscheme-send-char char) (if (and mark-p xscheme-control-g-synchronization-p) - (send-string "scheme" (char-to-string 0)))) + (xscheme-send-char 0))) ;;;; Internal Variables (defvar xscheme-process-command-line nil "Command used to start the most recent Scheme process.") -(defvar xscheme-previous-send "" - "Most recent expression transmitted to the Scheme process.") +(defvar xscheme-process-name "scheme" + "Name of xscheme process that we're currently interacting with.") + +(defvar xscheme-buffer-name "*scheme*" + "Name of xscheme buffer that we're currently interacting with.") + +(defvar xscheme-expressions-ring-max 30 + "*Maximum length of Scheme expressions ring.") + +(defvar xscheme-expressions-ring nil + "List of expressions recently transmitted to the Scheme process.") + +(defvar xscheme-expressions-ring-yank-pointer nil + "The tail of the Scheme expressions ring whose car is the last thing yanked.") + +(defvar xscheme-last-input-end) (defvar xscheme-process-filter-state 'idle "State of scheme process escape reader state machine: @@ -488,20 +775,32 @@ (defvar xscheme-string-receiver nil "Procedure to send the string argument from the scheme process.") -(defcustom xscheme-start-hook nil - "If non-nil, a procedure to call when the Scheme process is started. -When called, the current buffer will be the Scheme process-buffer." - :type 'hook - :group 'xscheme) +(defconst default-xscheme-runlight + '(": " xscheme-runlight-string) + "Default global (shared) xscheme-runlight modeline format.") +(defvar xscheme-runlight "") (defvar xscheme-runlight-string nil) (defvar xscheme-mode-string nil) -(defvar xscheme-filter-input nil) +(setq-default scheme-mode-line-process + '("" xscheme-runlight)) + +(mapcar 'make-variable-buffer-local + '(xscheme-expressions-ring + xscheme-expressions-ring-yank-pointer + xscheme-process-filter-state + xscheme-running-p + xscheme-control-g-disabled-p + xscheme-allow-output-p + xscheme-prompt + xscheme-string-accumulator + xscheme-mode-string + scheme-mode-line-process)) ;;;; Basic Process Control -(defun xscheme-start-process (command-line) - (let ((buffer (get-buffer-create "*scheme*"))) +(defun xscheme-start-process (command-line the-process the-buffer) + (let ((buffer (get-buffer-create the-buffer))) (let ((process (get-buffer-process buffer))) (save-excursion (set-buffer buffer) @@ -509,20 +808,28 @@ (set-marker (process-mark process) (point-max)) (progn (if process (delete-process process)) (goto-char (point-max)) - (scheme-interaction-mode) + (scheme-interaction-mode nil) + (setq xscheme-process-name the-process) (if (bobp) (insert-before-markers (substitute-command-keys xscheme-startup-message))) (setq process (let ((process-connection-type nil)) (apply 'start-process - (cons "scheme" + (cons the-process (cons buffer (xscheme-parse-command-line command-line)))))) + (if (not (equal (process-name process) the-process)) + (setq xscheme-process-name (process-name process))) + (if (not (equal (buffer-name buffer) the-buffer)) + (setq xscheme-buffer-name (buffer-name buffer))) + (message "Starting process %s in buffer %s" + xscheme-process-name + xscheme-buffer-name) (set-marker (process-mark process) (point-max)) (xscheme-process-filter-initialize t) - (xscheme-modeline-initialize) + (xscheme-modeline-initialize xscheme-buffer-name) (set-process-sentinel process 'xscheme-process-sentinel) (set-process-filter process 'xscheme-process-filter) (run-hooks 'xscheme-start-hook))))) @@ -556,12 +863,12 @@ (defun xscheme-process-running-p () "True iff there is a Scheme process whose status is `run'." - (let ((process (get-process "scheme"))) + (let ((process (get-process xscheme-process-name))) (and process (eq (process-status process) 'run)))) (defun xscheme-process-buffer () - (let ((process (get-process "scheme"))) + (let ((process (get-process xscheme-process-name))) (and process (process-buffer process)))) (defun xscheme-process-buffer-window () @@ -575,17 +882,23 @@ ;;;; Process Filter (defun xscheme-process-sentinel (proc reason) - (xscheme-process-filter-initialize (eq reason 'run)) - (if (eq reason 'run) - (xscheme-modeline-initialize) - (progn - (setq scheme-mode-line-process "") - (setq xscheme-mode-string "no process"))) - (if (and (not (memq reason '(run stop))) - xscheme-signal-death-message) - (progn (beep) - (message -"The Scheme process has died! Do M-x reset-scheme to restart it")))) + (let* ((buffer (process-buffer proc)) + (name (buffer-name buffer))) + (save-excursion + (set-buffer buffer) + (xscheme-process-filter-initialize (eq reason 'run)) + (if (not (eq reason 'run)) + (progn + (setq scheme-mode-line-process "") + (setq xscheme-mode-string "no process") + (if (equal name (default-value 'xscheme-buffer-name)) + (setq-default xscheme-runlight "")))) + (if (and (not (memq reason '(run stop))) + xscheme-signal-death-message) + (progn + (beep) + (message +"The Scheme process has died! Do M-x reset-scheme to restart it")))))) (defun xscheme-process-filter-initialize (running-p) (setq xscheme-process-filter-state 'idle) @@ -593,52 +906,73 @@ (setq xscheme-control-g-disabled-p nil) (setq xscheme-allow-output-p t) (setq xscheme-prompt "") - (setq scheme-mode-line-process '(": " xscheme-runlight-string))) + (if running-p + (let ((name (buffer-name (current-buffer)))) + (setq scheme-mode-line-process '(": " xscheme-runlight-string)) + (xscheme-modeline-initialize name) + (if (equal name (default-value 'xscheme-buffer-name)) + (setq-default xscheme-runlight default-xscheme-runlight)))) + (if (or (eq xscheme-runlight default-xscheme-runlight) + (equal xscheme-runlight "")) + (setq xscheme-runlight (list ": " 'xscheme-buffer-name ": " "?"))) + (rplaca (nthcdr 3 xscheme-runlight) + (if running-p "?" "no process"))) (defun xscheme-process-filter (proc string) - (let ((xscheme-filter-input string)) + (let ((xscheme-filter-input string) + (call-noexcursion nil)) (while xscheme-filter-input - (cond ((eq xscheme-process-filter-state 'idle) - (let ((start (string-match "\e" xscheme-filter-input))) - (if start - (progn - (xscheme-process-filter-output - (substring xscheme-filter-input 0 start)) - (setq xscheme-filter-input - (substring xscheme-filter-input (1+ start))) - (setq xscheme-process-filter-state 'reading-type)) + (setq call-noexcursion nil) + (save-excursion + (set-buffer (process-buffer proc)) + (cond ((eq xscheme-process-filter-state 'idle) + (let ((start (string-match "\e" xscheme-filter-input))) + (if start + (progn + (xscheme-process-filter-output + (substring xscheme-filter-input 0 start)) + (setq xscheme-filter-input + (substring xscheme-filter-input (1+ start))) + (setq xscheme-process-filter-state 'reading-type)) (let ((string xscheme-filter-input)) (setq xscheme-filter-input nil) (xscheme-process-filter-output string))))) - ((eq xscheme-process-filter-state 'reading-type) - (if (zerop (length xscheme-filter-input)) - (setq xscheme-filter-input nil) + ((eq xscheme-process-filter-state 'reading-type) + (if (zerop (length xscheme-filter-input)) + (setq xscheme-filter-input nil) (let ((char (aref xscheme-filter-input 0))) (setq xscheme-filter-input (substring xscheme-filter-input 1)) (let ((entry (assoc char xscheme-process-filter-alist))) (if entry (funcall (nth 2 entry) (nth 1 entry)) - (progn - (xscheme-process-filter-output ?\e char) - (setq xscheme-process-filter-state 'idle))))))) - ((eq xscheme-process-filter-state 'reading-string) - (let ((start (string-match "\e" xscheme-filter-input))) - (if start - (let ((string - (concat xscheme-string-accumulator - (substring xscheme-filter-input 0 start)))) - (setq xscheme-filter-input - (substring xscheme-filter-input (1+ start))) - (setq xscheme-process-filter-state 'idle) - (funcall xscheme-string-receiver string)) + (progn + (xscheme-process-filter-output ?\e char) + (setq xscheme-process-filter-state 'idle))))))) + ((eq xscheme-process-filter-state 'reading-string) + (let ((start (string-match "\e" xscheme-filter-input))) + (if start + (let ((string + (concat xscheme-string-accumulator + (substring xscheme-filter-input 0 start)))) + (setq xscheme-filter-input + (substring xscheme-filter-input (1+ start))) + (setq xscheme-process-filter-state 'idle) + (if (listp xscheme-string-receiver) + (progn + (setq xscheme-string-receiver + (car xscheme-string-receiver)) + (setq call-noexcursion string)) + (funcall xscheme-string-receiver string))) (progn (setq xscheme-string-accumulator (concat xscheme-string-accumulator xscheme-filter-input)) (setq xscheme-filter-input nil))))) - (t - (error "Scheme process filter -- bad state")))))) + (t + (error "Scheme process filter -- bad state")))) + (if call-noexcursion + (funcall xscheme-string-receiver call-noexcursion))))) ;;;; Process Filter Output @@ -647,18 +981,22 @@ (let ((string (apply 'concat args))) (save-excursion (xscheme-goto-output-point) - (while (string-match "\\(\007\\|\f\\)" string) - (let ((start (match-beginning 0)) - (end (match-end 0))) - (insert-before-markers (substring string 0 start)) - (if (= ?\f (aref string start)) - (progn - (if (not (bolp)) - (insert-before-markers ?\n)) - (insert-before-markers ?\f)) - (beep)) - (setq string (substring string (1+ start))))) - (insert-before-markers string))))) + (let ((old-point (point))) + (while (string-match "\\(\007\\|\f\\)" string) + (let ((start (match-beginning 0)) + (end (match-end 0))) + (insert-before-markers (substring string 0 start)) + (if (= ?\f (aref string start)) + (progn + (if (not (bolp)) + (insert-before-markers ?\n)) + (insert-before-markers ?\f)) + (beep)) + (setq string (substring string (1+ start))))) + (insert-before-markers string) + (if (and xscheme-last-input-end + (equal (marker-position xscheme-last-input-end) (point))) + (set-marker xscheme-last-input-end old-point))))))) (defun xscheme-guarantee-newlines (n) (if xscheme-allow-output-p @@ -677,23 +1015,33 @@ (setq n (1- n)))))) (defun xscheme-goto-output-point () - (let ((process (get-process "scheme"))) + (let ((process (get-process xscheme-process-name))) (set-buffer (process-buffer process)) (goto-char (process-mark process)))) -(defun xscheme-modeline-initialize () +(defun xscheme-modeline-initialize (name) (setq xscheme-runlight-string "") + (if (equal name (default-value 'xscheme-buffer-name)) + (setq-default xscheme-runlight-string "")) (setq xscheme-mode-string "") - (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string))) + (setq mode-line-buffer-identification + (list (concat name ": ") + 'xscheme-mode-string))) (defun xscheme-set-runlight (runlight) (setq xscheme-runlight-string runlight) + (if (equal (buffer-name (current-buffer)) + (default-value 'xscheme-buffer-name)) + (setq-default xscheme-runlight-string runlight)) + (rplaca (nthcdr 3 xscheme-runlight) runlight) (force-mode-line-update t)) ;;;; Process Filter Operations (defvar xscheme-process-filter-alist - '((?D xscheme-enter-debugger-mode + '((?A xscheme-eval + xscheme-process-filter:string-action-noexcursion) + (?D xscheme-enter-debugger-mode xscheme-process-filter:string-action) (?E xscheme-eval xscheme-process-filter:string-action) @@ -703,6 +1051,8 @@ xscheme-process-filter:simple-action) (?b xscheme-start-gc xscheme-process-filter:simple-action) + (?c xscheme-unsolicited-read-char + xscheme-process-filter:simple-action) (?e xscheme-finish-gc xscheme-process-filter:simple-action) (?f xscheme-exit-input-wait @@ -726,8 +1076,6 @@ (?w xscheme-cd xscheme-process-filter:string-action) (?z xscheme-display-process-buffer - xscheme-process-filter:simple-action) - (?c xscheme-unsolicited-read-char xscheme-process-filter:simple-action)) "Table used to decide how to handle process filter commands. Value is a list of entries, each entry is a list of three items. @@ -752,6 +1100,9 @@ (setq xscheme-string-accumulator "") (setq xscheme-process-filter-state 'reading-string)) +(defun xscheme-process-filter:string-action-noexcursion (action) + (xscheme-process-filter:string-action (cons action nil))) + (defconst xscheme-runlight:running "run" "The character displayed when the Scheme process is running.") @@ -770,6 +1121,7 @@ (defun xscheme-enter-input-wait () (xscheme-set-runlight xscheme-runlight:input) + (setq xscheme-control-g-disabled-p nil) (setq xscheme-running-p nil)) (defun xscheme-exit-input-wait () @@ -777,7 +1129,9 @@ (setq xscheme-running-p t)) (defun xscheme-enable-control-g () - (setq xscheme-control-g-disabled-p nil)) + (setq xscheme-control-g-disabled-p nil) + (if (string= (current-message) xscheme-control-g-message-string) + (message nil))) (defun xscheme-display-process-buffer () (let ((window (or (xscheme-process-buffer-window) @@ -800,11 +1154,11 @@ (defun xscheme-write-value (string) (if (zerop (length string)) - (xscheme-write-message-1 "(no value)" ";No value") + (xscheme-write-message-1 "(no value)" ";Unspecified return value") (xscheme-write-message-1 string (format ";Value: %s" string)))) (defun xscheme-write-message-1 (message-string output-string) - (let* ((process (get-process "scheme")) + (let* ((process (get-process xscheme-process-name)) (window (get-buffer-window (process-buffer process)))) (if (or (not window) (not (pos-visible-in-window-p (process-mark process) @@ -827,25 +1181,12 @@ (xscheme-guarantee-newlines 2)) (defun xscheme-coerce-prompt (string) - (if (string-match "^[0-9]+ " string) + (if (string-match "^[0-9]+ \\[[^]]+\\] " string) (let ((end (match-end 0))) - (concat (substring string 0 end) - (let ((prompt (substring string end))) - (let ((entry (assoc prompt xscheme-prompt-alist))) - (if entry - (cdr entry) - prompt))))) + (xscheme-process-filter-output (substring string end)) + (substring string 0 (- end 1))) string)) -(defvar xscheme-prompt-alist - '(("[Normal REPL]" . "[Evaluator]") - ("[Error REPL]" . "[Evaluator]") - ("[Breakpoint REPL]" . "[Evaluator]") - ("[Debugger REPL]" . "[Evaluator]") - ("[Visiting environment]" . "[Evaluator]") - ("[Environment Inspector]" . "[Where]")) - "An alist which maps the Scheme command interpreter type to a print string.") - (defun xscheme-cd (directory-string) (save-excursion (set-buffer (xscheme-process-buffer))