Mercurial > emacs
comparison lisp/xscheme.el @ 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 | 8af1f6c81e70 |
| children | d1cd5d1c6e77 |
comparison
equal
deleted
inserted
replaced
| 42489:f9c5738cf0d1 | 42490:0715d86d229c |
|---|---|
| 1 ;;; xscheme.el --- run MIT Scheme under Emacs | 1 ;;; xscheme.el --- run MIT Scheme under Emacs |
| 2 | 2 |
| 3 ;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1986, 1987, 1989, 1990, 2001 Free Software Foundation, Inc. |
| 4 | 4 |
| 5 ;; Maintainer: FSF | 5 ;; Maintainer: FSF |
| 6 ;; Keywords: languages, lisp | 6 ;; Keywords: languages, lisp |
| 7 | 7 |
| 8 ;; This file is part of GNU Emacs. | 8 ;; This file is part of GNU Emacs. |
| 22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 23 ;; Boston, MA 02111-1307, USA. | 23 ;; Boston, MA 02111-1307, USA. |
| 24 | 24 |
| 25 ;;; Commentary: | 25 ;;; Commentary: |
| 26 | 26 |
| 27 ;; A major mode for editing Scheme and interacting with MIT's C-Scheme. | 27 ;; A major mode for interacting with MIT Scheme. |
| 28 ;; | 28 ;; |
| 29 ;; Requires C-Scheme release 5 or later | 29 ;; Requires MIT Scheme release 5 or later. |
| 30 ;; Changes to Control-G handler require runtime version 13.85 or later | 30 ;; Changes to Control-G handler require runtime version 13.85 or later. |
| 31 | 31 |
| 32 ;;; Code: | 32 ;;; Code: |
| 33 | 33 |
| 34 (require 'scheme) | 34 (require 'scheme) |
| 35 | 35 |
| 68 | 68 |
| 69 (defcustom xscheme-signal-death-message nil | 69 (defcustom xscheme-signal-death-message nil |
| 70 "If non-nil, causes a message to be generated when the Scheme process dies." | 70 "If non-nil, causes a message to be generated when the Scheme process dies." |
| 71 :type 'boolean | 71 :type 'boolean |
| 72 :group 'xscheme) | 72 :group 'xscheme) |
| 73 | |
| 74 (defcustom xscheme-start-hook nil | |
| 75 "If non-nil, a procedure to call when the Scheme process is started. | |
| 76 When called, the current buffer will be the Scheme process-buffer." | |
| 77 :type 'hook | |
| 78 :group 'xscheme | |
| 79 :version 20.3) | |
| 73 | 80 |
| 74 (defun xscheme-evaluation-commands (keymap) | 81 (defun xscheme-evaluation-commands (keymap) |
| 75 (define-key keymap "\e\C-x" 'xscheme-send-definition) | 82 (define-key keymap "\e\C-x" 'xscheme-send-definition) |
| 76 (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) | 83 (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) |
| 77 (define-key keymap "\eo" 'xscheme-send-buffer) | 84 (define-key keymap "\eo" 'xscheme-send-buffer) |
| 91 | 98 |
| 92 (defun run-scheme (command-line) | 99 (defun run-scheme (command-line) |
| 93 "Run MIT Scheme in an inferior process. | 100 "Run MIT Scheme in an inferior process. |
| 94 Output goes to the buffer `*scheme*'. | 101 Output goes to the buffer `*scheme*'. |
| 95 With argument, asks for a command line." | 102 With argument, asks for a command line." |
| 96 (interactive | 103 (interactive (list (xscheme-read-command-line current-prefix-arg))) |
| 97 (list (let ((default | 104 (xscheme-start command-line xscheme-process-name xscheme-buffer-name)) |
| 98 (or xscheme-process-command-line | 105 |
| 99 (xscheme-default-command-line)))) | 106 (defun xscheme-start (command-line process-name buffer-name) |
| 100 (if current-prefix-arg | 107 (setq-default xscheme-process-command-line command-line) |
| 101 (read-string "Run Scheme: " default) | 108 (switch-to-buffer |
| 102 default)))) | 109 (xscheme-start-process command-line process-name buffer-name)) |
| 103 (setq xscheme-process-command-line command-line) | 110 (make-local-variable 'xscheme-process-command-line) |
| 104 (pop-to-buffer (xscheme-start-process command-line))) | 111 (setq xscheme-process-command-line command-line)) |
| 105 | 112 |
| 106 (defun reset-scheme () | 113 (defun xscheme-read-command-line (arg) |
| 107 "Reset the Scheme process." | 114 (let ((default |
| 108 (interactive) | 115 (or xscheme-process-command-line |
| 109 (let ((process (get-process "scheme"))) | 116 (xscheme-default-command-line)))) |
| 110 (cond ((or (not process) | 117 (if arg |
| 111 (not (eq (process-status process) 'run)) | 118 (read-string "Run Scheme: " default) |
| 112 (yes-or-no-p | 119 default))) |
| 113 "The Scheme process is running, are you SURE you want to reset it? ")) | |
| 114 (message "Resetting Scheme process...") | |
| 115 (if process (kill-process process t)) | |
| 116 (xscheme-start-process xscheme-process-command-line) | |
| 117 (message "Resetting Scheme process...done"))))) | |
| 118 | 120 |
| 119 (defun xscheme-default-command-line () | 121 (defun xscheme-default-command-line () |
| 120 (concat scheme-program-name " -emacs" | 122 (concat scheme-program-name " -emacs" |
| 121 (if scheme-program-arguments | 123 (if scheme-program-arguments |
| 122 (concat " " scheme-program-arguments) | 124 (concat " " scheme-program-arguments) |
| 123 "") | 125 "") |
| 124 (if scheme-band-name | 126 (if scheme-band-name |
| 125 (concat " -band " scheme-band-name) | 127 (concat " -band " scheme-band-name) |
| 126 ""))) | 128 ""))) |
| 129 | |
| 130 (defun reset-scheme () | |
| 131 "Reset the Scheme process." | |
| 132 (interactive) | |
| 133 (let ((process (get-process xscheme-process-name))) | |
| 134 (cond ((or (not process) | |
| 135 (not (eq (process-status process) 'run)) | |
| 136 (yes-or-no-p | |
| 137 "The Scheme process is running, are you SURE you want to reset it? ")) | |
| 138 (message "Resetting Scheme process...") | |
| 139 (if process | |
| 140 (progn | |
| 141 (kill-process process t) | |
| 142 (delete-process process))) | |
| 143 (xscheme-start-process xscheme-process-command-line | |
| 144 xscheme-process-name | |
| 145 xscheme-buffer-name) | |
| 146 (message "Resetting Scheme process...done"))))) | |
| 147 | |
| 148 ;;;; Multiple Scheme buffer management commands | |
| 149 | |
| 150 (defun start-scheme (buffer-name &optional globally) | |
| 151 "Choose a scheme interaction buffer, or create a new one." | |
| 152 ;; (interactive "BScheme interaction buffer: \nP") | |
| 153 (interactive | |
| 154 (list (read-buffer "Scheme interaction buffer: " | |
| 155 xscheme-buffer-name | |
| 156 nil) | |
| 157 current-prefix-arg)) | |
| 158 (let ((buffer (get-buffer-create buffer-name))) | |
| 159 (let ((process (get-buffer-process buffer))) | |
| 160 (if process | |
| 161 (switch-to-buffer buffer) | |
| 162 (if (or (not (buffer-file-name buffer)) | |
| 163 (yes-or-no-p (concat "Buffer " | |
| 164 (buffer-name buffer) | |
| 165 " contains file " | |
| 166 (buffer-file-name buffer) | |
| 167 "; start scheme in it? "))) | |
| 168 (progn | |
| 169 (xscheme-start (xscheme-read-command-line t) | |
| 170 buffer-name | |
| 171 buffer-name) | |
| 172 (if globally | |
| 173 (global-set-scheme-interaction-buffer buffer-name))) | |
| 174 (message "start-scheme aborted")))))) | |
| 175 | |
| 176 (fset 'select-scheme 'start-scheme) | |
| 177 | |
| 178 (defun global-set-scheme-interaction-buffer (buffer-name) | |
| 179 "Set the default scheme interaction buffer." | |
| 180 (interactive | |
| 181 (list (read-buffer "Scheme interaction buffer: " | |
| 182 xscheme-buffer-name | |
| 183 t))) | |
| 184 (let ((process-name (verify-xscheme-buffer buffer-name nil))) | |
| 185 (setq-default xscheme-buffer-name buffer-name) | |
| 186 (setq-default xscheme-process-name process-name) | |
| 187 (setq-default xscheme-runlight-string | |
| 188 (save-excursion (set-buffer buffer-name) | |
| 189 xscheme-runlight-string)) | |
| 190 (setq-default xscheme-runlight | |
| 191 (if (eq (process-status process-name) 'run) | |
| 192 default-xscheme-runlight | |
| 193 "")))) | |
| 194 | |
| 195 (defun local-set-scheme-interaction-buffer (buffer-name) | |
| 196 "Set the scheme interaction buffer for the current buffer." | |
| 197 (interactive | |
| 198 (list (read-buffer "Scheme interaction buffer: " | |
| 199 xscheme-buffer-name | |
| 200 t))) | |
| 201 (let ((process-name (verify-xscheme-buffer buffer-name t))) | |
| 202 (make-local-variable 'xscheme-buffer-name) | |
| 203 (setq xscheme-buffer-name buffer-name) | |
| 204 (make-local-variable 'xscheme-process-name) | |
| 205 (setq xscheme-process-name process-name) | |
| 206 (make-local-variable 'xscheme-runlight) | |
| 207 (setq xscheme-runlight (save-excursion (set-buffer buffer-name) | |
| 208 xscheme-runlight)))) | |
| 209 | |
| 210 (defun local-clear-scheme-interaction-buffer () | |
| 211 "Make the current buffer use the default scheme interaction buffer." | |
| 212 (interactive) | |
| 213 (if (xscheme-process-buffer-current-p) | |
| 214 (error "Cannot change the interaction buffer of an interaction buffer")) | |
| 215 (kill-local-variable 'xscheme-buffer-name) | |
| 216 (kill-local-variable 'xscheme-process-name) | |
| 217 (kill-local-variable 'xscheme-runlight)) | |
| 218 | |
| 219 (defun verify-xscheme-buffer (buffer-name localp) | |
| 220 (if (and localp (xscheme-process-buffer-current-p)) | |
| 221 (error "Cannot change the interaction buffer of an interaction buffer")) | |
| 222 (let* ((buffer (get-buffer buffer-name)) | |
| 223 (process (and buffer (get-buffer-process buffer)))) | |
| 224 (cond ((not buffer) | |
| 225 (error "Buffer does not exist" buffer-name)) | |
| 226 ((not process) | |
| 227 (error "Buffer is not a scheme interaction buffer" buffer-name)) | |
| 228 (t | |
| 229 (save-excursion | |
| 230 (set-buffer buffer) | |
| 231 (if (not (xscheme-process-buffer-current-p)) | |
| 232 (error "Buffer is not a scheme interaction buffer" | |
| 233 buffer-name))) | |
| 234 (process-name process))))) | |
| 127 | 235 |
| 128 ;;;; Interaction Mode | 236 ;;;; Interaction Mode |
| 129 | 237 |
| 130 (defun scheme-interaction-mode () | 238 (defun scheme-interaction-mode (&optional preserve) |
| 131 "Major mode for interacting with the inferior Scheme process. | 239 "Major mode for interacting with an inferior MIT Scheme process. |
| 132 Like scheme-mode except that: | 240 Like scheme-mode except that: |
| 133 | 241 |
| 134 \\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input | 242 \\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input |
| 135 \\[xscheme-yank-previous-send] yanks the expression most recently sent to Scheme | 243 \\[xscheme-yank-pop] yanks an expression previously sent to Scheme |
| 244 \\[xscheme-yank-push] yanks an expression more recently sent to Scheme | |
| 136 | 245 |
| 137 All output from the Scheme process is written in the Scheme process | 246 All output from the Scheme process is written in the Scheme process |
| 138 buffer, which is initially named \"*scheme*\". The result of | 247 buffer, which is initially named \"*scheme*\". The result of |
| 139 evaluating a Scheme expression is also printed in the process buffer, | 248 evaluating a Scheme expression is also printed in the process buffer, |
| 140 preceded by the string \";Value: \" to highlight it. If the process | 249 preceded by the string \";Value: \" to highlight it. If the process |
| 197 | 306 |
| 198 Entry to this mode calls the value of scheme-interaction-mode-hook | 307 Entry to this mode calls the value of scheme-interaction-mode-hook |
| 199 with no args, if that value is non-nil. | 308 with no args, if that value is non-nil. |
| 200 Likewise with the value of scheme-mode-hook. | 309 Likewise with the value of scheme-mode-hook. |
| 201 scheme-interaction-mode-hook is called after scheme-mode-hook." | 310 scheme-interaction-mode-hook is called after scheme-mode-hook." |
| 202 (interactive) | 311 (interactive "P") |
| 203 (kill-all-local-variables) | 312 (if (not preserve) |
| 313 (let ((previous-mode major-mode)) | |
| 314 (kill-all-local-variables) | |
| 315 (make-local-variable 'xscheme-previous-mode) | |
| 316 (make-local-variable 'xscheme-buffer-name) | |
| 317 (make-local-variable 'xscheme-process-name) | |
| 318 (make-local-variable 'xscheme-previous-process-state) | |
| 319 (make-local-variable 'xscheme-runlight-string) | |
| 320 (make-local-variable 'xscheme-runlight) | |
| 321 (make-local-variable 'xscheme-last-input-end) | |
| 322 (setq xscheme-previous-mode previous-mode) | |
| 323 (let ((buffer (current-buffer))) | |
| 324 (setq xscheme-buffer-name (buffer-name buffer)) | |
| 325 (setq xscheme-last-input-end (make-marker)) | |
| 326 (let ((process (get-buffer-process buffer))) | |
| 327 (if process | |
| 328 (progn | |
| 329 (setq xscheme-process-name (process-name process)) | |
| 330 (setq xscheme-previous-process-state | |
| 331 (cons (process-filter process) | |
| 332 (process-sentinel process))) | |
| 333 (xscheme-process-filter-initialize t) | |
| 334 (xscheme-modeline-initialize xscheme-buffer-name) | |
| 335 (set-process-sentinel process 'xscheme-process-sentinel) | |
| 336 (set-process-filter process 'xscheme-process-filter)) | |
| 337 (setq xscheme-previous-process-state (cons nil nil))))))) | |
| 204 (scheme-interaction-mode-initialize) | 338 (scheme-interaction-mode-initialize) |
| 205 (scheme-mode-variables) | 339 (scheme-mode-variables) |
| 206 (make-local-variable 'xscheme-previous-send) | |
| 207 (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) | 340 (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) |
| 341 | |
| 342 (defun exit-scheme-interaction-mode () | |
| 343 "Take buffer out of scheme interaction mode" | |
| 344 (interactive) | |
| 345 (if (not (eq major-mode 'scheme-interaction-mode)) | |
| 346 (error "Buffer not in scheme interaction mode")) | |
| 347 (let ((previous-state xscheme-previous-process-state)) | |
| 348 (funcall xscheme-previous-mode) | |
| 349 (let ((process (get-buffer-process (current-buffer)))) | |
| 350 (if process | |
| 351 (progn | |
| 352 (if (eq (process-filter process) 'xscheme-process-filter) | |
| 353 (set-process-filter process (car previous-state))) | |
| 354 (if (eq (process-sentinel process) 'xscheme-process-sentinel) | |
| 355 (set-process-sentinel process (cdr previous-state)))))))) | |
| 208 | 356 |
| 209 (defun scheme-interaction-mode-initialize () | 357 (defun scheme-interaction-mode-initialize () |
| 210 (use-local-map scheme-interaction-mode-map) | 358 (use-local-map scheme-interaction-mode-map) |
| 211 (setq major-mode 'scheme-interaction-mode) | 359 (setq major-mode 'scheme-interaction-mode) |
| 212 (setq mode-name "Scheme Interaction")) | 360 (setq mode-name "Scheme Interaction")) |
| 213 | 361 |
| 214 (defun scheme-interaction-mode-commands (keymap) | 362 (defun scheme-interaction-mode-commands (keymap) |
| 215 (define-key keymap "\C-c\C-m" 'xscheme-send-current-line) | 363 (let ((entries scheme-interaction-mode-commands-alist)) |
| 216 (define-key keymap "\C-c\C-p" 'xscheme-send-proceed) | 364 (while entries |
| 217 (define-key keymap "\C-c\C-y" 'xscheme-yank-previous-send)) | 365 (define-key keymap |
| 366 (car (car entries)) | |
| 367 (car (cdr (car entries)))) | |
| 368 (setq entries (cdr entries))))) | |
| 369 | |
| 370 (defvar scheme-interaction-mode-commands-alist nil) | |
| 371 (setq scheme-interaction-mode-commands-alist | |
| 372 (append scheme-interaction-mode-commands-alist | |
| 373 '(("\C-c\C-m" xscheme-send-current-line) | |
| 374 ("\C-c\C-o" xscheme-delete-output) | |
| 375 ("\C-c\C-p" xscheme-send-proceed) | |
| 376 ("\C-c\C-y" xscheme-yank) | |
| 377 ("\ep" xscheme-yank-pop) | |
| 378 ("\en" xscheme-yank-push)))) | |
| 218 | 379 |
| 219 (defvar scheme-interaction-mode-map nil) | 380 (defvar scheme-interaction-mode-map nil) |
| 220 (if (not scheme-interaction-mode-map) | 381 (if (not scheme-interaction-mode-map) |
| 221 (progn | 382 (progn |
| 222 (setq scheme-interaction-mode-map (make-keymap)) | 383 (setq scheme-interaction-mode-map (make-keymap)) |
| 229 (save-excursion | 390 (save-excursion |
| 230 (set-buffer (xscheme-process-buffer)) | 391 (set-buffer (xscheme-process-buffer)) |
| 231 (if (not (eq major-mode 'scheme-interaction-mode)) | 392 (if (not (eq major-mode 'scheme-interaction-mode)) |
| 232 (if (eq major-mode 'scheme-debugger-mode) | 393 (if (eq major-mode 'scheme-debugger-mode) |
| 233 (scheme-interaction-mode-initialize) | 394 (scheme-interaction-mode-initialize) |
| 234 (scheme-interaction-mode))))) | 395 (scheme-interaction-mode t))))) |
| 235 | 396 |
| 236 (fset 'advertised-xscheme-send-previous-expression | 397 (fset 'advertised-xscheme-send-previous-expression |
| 237 'xscheme-send-previous-expression) | 398 'xscheme-send-previous-expression) |
| 238 | 399 |
| 239 ;;;; Debugger Mode | 400 ;;;; Debugger Mode |
| 277 (save-excursion | 438 (save-excursion |
| 278 (set-buffer (xscheme-process-buffer)) | 439 (set-buffer (xscheme-process-buffer)) |
| 279 (if (not (eq major-mode 'scheme-debugger-mode)) | 440 (if (not (eq major-mode 'scheme-debugger-mode)) |
| 280 (progn | 441 (progn |
| 281 (if (not (eq major-mode 'scheme-interaction-mode)) | 442 (if (not (eq major-mode 'scheme-interaction-mode)) |
| 282 (scheme-interaction-mode)) | 443 (scheme-interaction-mode t)) |
| 283 (scheme-debugger-mode-initialize))))) | 444 (scheme-debugger-mode-initialize))))) |
| 284 | 445 |
| 285 (defun xscheme-debugger-mode-p () | 446 (defun xscheme-debugger-mode-p () |
| 286 (let ((buffer (xscheme-process-buffer))) | 447 (let ((buffer (xscheme-process-buffer))) |
| 287 (and buffer | 448 (and buffer |
| 297 (cond ((not (xscheme-process-running-p)) | 458 (cond ((not (xscheme-process-running-p)) |
| 298 (if (yes-or-no-p "The Scheme process has died. Reset it? ") | 459 (if (yes-or-no-p "The Scheme process has died. Reset it? ") |
| 299 (progn | 460 (progn |
| 300 (reset-scheme) | 461 (reset-scheme) |
| 301 (xscheme-wait-for-process) | 462 (xscheme-wait-for-process) |
| 302 (goto-char (point-max)) | |
| 303 (apply 'insert-before-markers strings) | |
| 304 (xscheme-send-string-1 strings)))) | 463 (xscheme-send-string-1 strings)))) |
| 305 ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) | 464 ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) |
| 306 ((and (not xscheme-allow-pipelined-evaluation) | 465 ((and (not xscheme-allow-pipelined-evaluation) |
| 307 xscheme-running-p) | 466 xscheme-running-p) |
| 308 (error "No sends allowed while Scheme running")) | 467 (error "No sends allowed while Scheme running")) |
| 310 | 469 |
| 311 (defun xscheme-send-string-1 (strings) | 470 (defun xscheme-send-string-1 (strings) |
| 312 (let ((string (apply 'concat strings))) | 471 (let ((string (apply 'concat strings))) |
| 313 (xscheme-send-string-2 string) | 472 (xscheme-send-string-2 string) |
| 314 (if (eq major-mode 'scheme-interaction-mode) | 473 (if (eq major-mode 'scheme-interaction-mode) |
| 315 (setq xscheme-previous-send string)))) | 474 (xscheme-insert-expression string)))) |
| 316 | 475 |
| 317 (defun xscheme-send-string-2 (string) | 476 (defun xscheme-send-string-2 (string) |
| 318 (let ((process (get-process "scheme"))) | 477 (let ((process (get-process xscheme-process-name))) |
| 319 (send-string process (concat string "\n")) | 478 (process-send-string process (concat string "\n")) |
| 320 (if (xscheme-process-buffer-current-p) | 479 (if (xscheme-process-buffer-current-p) |
| 321 (set-marker (process-mark process) (point))))) | 480 (set-marker (process-mark process) (point))))) |
| 322 | 481 |
| 323 (defun xscheme-yank-previous-send () | |
| 324 "Insert the most recent expression at point." | |
| 325 (interactive) | |
| 326 (push-mark) | |
| 327 (insert xscheme-previous-send)) | |
| 328 | |
| 329 (defun xscheme-select-process-buffer () | 482 (defun xscheme-select-process-buffer () |
| 330 "Select the Scheme process buffer and move to its output point." | 483 "Select the Scheme process buffer and move to its output point." |
| 331 (interactive) | 484 (interactive) |
| 332 (let ((process (or (get-process "scheme") (error "No scheme process")))) | 485 (let ((process |
| 486 (or (get-process xscheme-process-name) | |
| 487 (error "No scheme process")))) | |
| 333 (let ((buffer (or (process-buffer process) (error "No process buffer")))) | 488 (let ((buffer (or (process-buffer process) (error "No process buffer")))) |
| 334 (let ((window (get-buffer-window buffer))) | 489 (let ((window (get-buffer-window buffer))) |
| 335 (if window | 490 (if window |
| 336 (select-window window) | 491 (select-window window) |
| 337 (switch-to-buffer buffer)) | 492 (switch-to-buffer buffer)) |
| 338 (goto-char (process-mark process)))))) | 493 (goto-char (process-mark process)))))) |
| 339 | 494 |
| 495 ;;;; Scheme expressions ring | |
| 496 | |
| 497 (defun xscheme-insert-expression (string) | |
| 498 (setq xscheme-expressions-ring (cons string xscheme-expressions-ring)) | |
| 499 (if (> (length xscheme-expressions-ring) xscheme-expressions-ring-max) | |
| 500 (setcdr (nthcdr (1- xscheme-expressions-ring-max) | |
| 501 xscheme-expressions-ring) | |
| 502 nil)) | |
| 503 (setq xscheme-expressions-ring-yank-pointer xscheme-expressions-ring)) | |
| 504 | |
| 505 (defun xscheme-rotate-yank-pointer (arg) | |
| 506 "Rotate the yanking point in the kill ring." | |
| 507 (interactive "p") | |
| 508 (let ((length (length xscheme-expressions-ring))) | |
| 509 (if (zerop length) | |
| 510 (error "Scheme expression ring is empty") | |
| 511 (setq xscheme-expressions-ring-yank-pointer | |
| 512 (let ((index | |
| 513 (% (+ arg | |
| 514 (- length | |
| 515 (length xscheme-expressions-ring-yank-pointer))) | |
| 516 length))) | |
| 517 (nthcdr (if (< index 0) | |
| 518 (+ index length) | |
| 519 index) | |
| 520 xscheme-expressions-ring)))))) | |
| 521 | |
| 522 (defun xscheme-yank (&optional arg) | |
| 523 "Insert the most recent expression at point. | |
| 524 With just C-U as argument, same but put point in front (and mark at end). | |
| 525 With argument n, reinsert the nth most recently sent expression. | |
| 526 See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]." | |
| 527 (interactive "*P") | |
| 528 (xscheme-rotate-yank-pointer (if (listp arg) 0 | |
| 529 (if (eq arg '-) -1 | |
| 530 (1- arg)))) | |
| 531 (push-mark (point)) | |
| 532 (insert (car xscheme-expressions-ring-yank-pointer)) | |
| 533 (if (consp arg) | |
| 534 (exchange-point-and-mark))) | |
| 535 | |
| 536 ;; Old name, to avoid errors in users' init files. | |
| 537 (fset 'xscheme-yank-previous-send | |
| 538 'xscheme-yank) | |
| 539 | |
| 540 (defun xscheme-yank-pop (arg) | |
| 541 "Insert or replace a just-yanked expression with an older expression. | |
| 542 If the previous command was not a yank, it yanks. | |
| 543 Otherwise, the region contains a stretch of reinserted | |
| 544 expression. yank-pop deletes that text and inserts in its | |
| 545 place a different expression. | |
| 546 | |
| 547 With no argument, the next older expression is inserted. | |
| 548 With argument n, the n'th older expression is inserted. | |
| 549 If n is negative, this is a more recent expression. | |
| 550 | |
| 551 The sequence of expressions wraps around, so that after the oldest one | |
| 552 comes the newest one." | |
| 553 (interactive "*p") | |
| 554 (setq this-command 'xscheme-yank) | |
| 555 (if (not (eq last-command 'xscheme-yank)) | |
| 556 (progn | |
| 557 (xscheme-yank) | |
| 558 (setq arg (- arg 1)))) | |
| 559 (if (not (= arg 0)) | |
| 560 (let ((before (< (point) (mark)))) | |
| 561 (delete-region (point) (mark)) | |
| 562 (xscheme-rotate-yank-pointer arg) | |
| 563 (set-mark (point)) | |
| 564 (insert (car xscheme-expressions-ring-yank-pointer)) | |
| 565 (if before (exchange-point-and-mark))))) | |
| 566 | |
| 567 (defun xscheme-yank-push (arg) | |
| 568 "Insert or replace a just-yanked expression with a more recent expression. | |
| 569 If the previous command was not a yank, it yanks. | |
| 570 Otherwise, the region contains a stretch of reinserted | |
| 571 expression. yank-pop deletes that text and inserts in its | |
| 572 place a different expression. | |
| 573 | |
| 574 With no argument, the next more recent expression is inserted. | |
| 575 With argument n, the n'th more recent expression is inserted. | |
| 576 If n is negative, a less recent expression is used. | |
| 577 | |
| 578 The sequence of expressions wraps around, so that after the oldest one | |
| 579 comes the newest one." | |
| 580 (interactive "*p") | |
| 581 (xscheme-yank-pop (- 0 arg))) | |
| 582 | |
| 340 (defun xscheme-send-region (start end) | 583 (defun xscheme-send-region (start end) |
| 341 "Send the current region to the Scheme process. | 584 "Send the current region to the Scheme process. |
| 342 The region is sent terminated by a newline." | 585 The region is sent terminated by a newline." |
| 343 (interactive "r") | 586 (interactive "r") |
| 344 (if (xscheme-process-buffer-current-p) | 587 (if (xscheme-process-buffer-current-p) |
| 345 (progn (goto-char end) | 588 (progn |
| 346 (set-marker (process-mark (get-process "scheme")) end))) | 589 (goto-char end) |
| 590 (if (not (bolp)) | |
| 591 (insert-before-markers ?\n)) | |
| 592 (set-marker (process-mark (get-process xscheme-process-name)) | |
| 593 (point)) | |
| 594 (set-marker xscheme-last-input-end (point)))) | |
| 347 (xscheme-send-string (buffer-substring start end))) | 595 (xscheme-send-string (buffer-substring start end))) |
| 348 | 596 |
| 349 (defun xscheme-send-definition () | 597 (defun xscheme-send-definition () |
| 350 "Send the current definition to the Scheme process. | 598 "Send the current definition to the Scheme process. |
| 351 If the current line begins with a non-whitespace character, | 599 If the current line begins with a non-whitespace character, |
| 394 (xscheme-send-region (point-min) (point-max))) | 642 (xscheme-send-region (point-min) (point-max))) |
| 395 | 643 |
| 396 (defun xscheme-send-char (char) | 644 (defun xscheme-send-char (char) |
| 397 "Prompt for a character and send it to the Scheme process." | 645 "Prompt for a character and send it to the Scheme process." |
| 398 (interactive "cCharacter to send: ") | 646 (interactive "cCharacter to send: ") |
| 399 (send-string "scheme" (char-to-string char))) | 647 (process-send-string xscheme-process-name (char-to-string char))) |
| 648 | |
| 649 (defun xscheme-delete-output () | |
| 650 "Delete all output from interpreter since last input." | |
| 651 (interactive) | |
| 652 (let ((proc (get-buffer-process (current-buffer)))) | |
| 653 (save-excursion | |
| 654 (goto-char (process-mark proc)) | |
| 655 (re-search-backward | |
| 656 "^;\\(Unspecified return value$\\|Value\\( [0-9]+\\)?: \\|\\(Abort\\|Up\\|Quit\\)!$\\)" | |
| 657 xscheme-last-input-end | |
| 658 t) | |
| 659 (forward-line 0) | |
| 660 (if (< (marker-position xscheme-last-input-end) (point)) | |
| 661 (progn | |
| 662 (delete-region xscheme-last-input-end (point)) | |
| 663 (insert-before-markers "*** output flushed ***\n")))))) | |
| 400 | 664 |
| 401 ;;;; Interrupts | 665 ;;;; Interrupts |
| 402 | 666 |
| 403 (defun xscheme-send-breakpoint-interrupt () | 667 (defun xscheme-send-breakpoint-interrupt () |
| 404 "Cause the Scheme process to enter a breakpoint." | 668 "Cause the Scheme process to enter a breakpoint." |
| 406 (xscheme-send-interrupt ?b nil)) | 670 (xscheme-send-interrupt ?b nil)) |
| 407 | 671 |
| 408 (defun xscheme-send-proceed () | 672 (defun xscheme-send-proceed () |
| 409 "Cause the Scheme process to proceed from a breakpoint." | 673 "Cause the Scheme process to proceed from a breakpoint." |
| 410 (interactive) | 674 (interactive) |
| 411 (send-string "scheme" "(proceed)\n")) | 675 (process-send-string xscheme-process-name "(proceed)\n")) |
| 412 | 676 |
| 413 (defun xscheme-send-control-g-interrupt () | 677 (defun xscheme-send-control-g-interrupt () |
| 414 "Cause the Scheme processor to halt and flush input. | 678 "Cause the Scheme processor to halt and flush input. |
| 415 Control returns to the top level rep loop." | 679 Control returns to the top level rep loop." |
| 416 (interactive) | 680 (interactive) |
| 417 (let ((inhibit-quit t)) | 681 (let ((inhibit-quit t)) |
| 418 (cond ((not xscheme-control-g-synchronization-p) | 682 (cond ((not xscheme-control-g-synchronization-p) |
| 419 (interrupt-process "scheme")) | 683 (interrupt-process xscheme-process-name)) |
| 420 (xscheme-control-g-disabled-p | 684 ((save-excursion |
| 685 (set-buffer xscheme-buffer-name) | |
| 686 xscheme-control-g-disabled-p) | |
| 421 (message "Relax...")) | 687 (message "Relax...")) |
| 422 (t | 688 (t |
| 423 (setq xscheme-control-g-disabled-p t) | 689 (save-excursion |
| 424 (message "Sending C-G interrupt to Scheme...") | 690 (set-buffer xscheme-buffer-name) |
| 425 (interrupt-process "scheme") | 691 (setq xscheme-control-g-disabled-p t)) |
| 426 (send-string "scheme" (char-to-string 0)))))) | 692 (message xscheme-control-g-message-string) |
| 693 (interrupt-process xscheme-process-name) | |
| 694 (sleep-for 0.1) | |
| 695 (xscheme-send-char 0))))) | |
| 696 | |
| 697 (defconst xscheme-control-g-message-string | |
| 698 "Sending C-G interrupt to Scheme...") | |
| 427 | 699 |
| 428 (defun xscheme-send-control-u-interrupt () | 700 (defun xscheme-send-control-u-interrupt () |
| 429 "Cause the Scheme process to halt, returning to previous rep loop." | 701 "Cause the Scheme process to halt, returning to previous rep loop." |
| 430 (interactive) | 702 (interactive) |
| 431 (xscheme-send-interrupt ?u t)) | 703 (xscheme-send-interrupt ?u t)) |
| 441 ;;; some kind of marker in the input stream. | 713 ;;; some kind of marker in the input stream. |
| 442 | 714 |
| 443 (defun xscheme-send-interrupt (char mark-p) | 715 (defun xscheme-send-interrupt (char mark-p) |
| 444 "Send a ^A type interrupt to the Scheme process." | 716 "Send a ^A type interrupt to the Scheme process." |
| 445 (interactive "cInterrupt character to send: ") | 717 (interactive "cInterrupt character to send: ") |
| 446 (quit-process "scheme") | 718 (quit-process xscheme-process-name) |
| 447 (send-string "scheme" (char-to-string char)) | 719 (sleep-for 0.1) |
| 720 (xscheme-send-char char) | |
| 448 (if (and mark-p xscheme-control-g-synchronization-p) | 721 (if (and mark-p xscheme-control-g-synchronization-p) |
| 449 (send-string "scheme" (char-to-string 0)))) | 722 (xscheme-send-char 0))) |
| 450 | 723 |
| 451 ;;;; Internal Variables | 724 ;;;; Internal Variables |
| 452 | 725 |
| 453 (defvar xscheme-process-command-line nil | 726 (defvar xscheme-process-command-line nil |
| 454 "Command used to start the most recent Scheme process.") | 727 "Command used to start the most recent Scheme process.") |
| 455 | 728 |
| 456 (defvar xscheme-previous-send "" | 729 (defvar xscheme-process-name "scheme" |
| 457 "Most recent expression transmitted to the Scheme process.") | 730 "Name of xscheme process that we're currently interacting with.") |
| 731 | |
| 732 (defvar xscheme-buffer-name "*scheme*" | |
| 733 "Name of xscheme buffer that we're currently interacting with.") | |
| 734 | |
| 735 (defvar xscheme-expressions-ring-max 30 | |
| 736 "*Maximum length of Scheme expressions ring.") | |
| 737 | |
| 738 (defvar xscheme-expressions-ring nil | |
| 739 "List of expressions recently transmitted to the Scheme process.") | |
| 740 | |
| 741 (defvar xscheme-expressions-ring-yank-pointer nil | |
| 742 "The tail of the Scheme expressions ring whose car is the last thing yanked.") | |
| 743 | |
| 744 (defvar xscheme-last-input-end) | |
| 458 | 745 |
| 459 (defvar xscheme-process-filter-state 'idle | 746 (defvar xscheme-process-filter-state 'idle |
| 460 "State of scheme process escape reader state machine: | 747 "State of scheme process escape reader state machine: |
| 461 idle waiting for an escape sequence | 748 idle waiting for an escape sequence |
| 462 reading-type received an altmode but nothing else | 749 reading-type received an altmode but nothing else |
| 486 "Accumulator for the string being received from the scheme process.") | 773 "Accumulator for the string being received from the scheme process.") |
| 487 | 774 |
| 488 (defvar xscheme-string-receiver nil | 775 (defvar xscheme-string-receiver nil |
| 489 "Procedure to send the string argument from the scheme process.") | 776 "Procedure to send the string argument from the scheme process.") |
| 490 | 777 |
| 491 (defcustom xscheme-start-hook nil | 778 (defconst default-xscheme-runlight |
| 492 "If non-nil, a procedure to call when the Scheme process is started. | 779 '(": " xscheme-runlight-string) |
| 493 When called, the current buffer will be the Scheme process-buffer." | 780 "Default global (shared) xscheme-runlight modeline format.") |
| 494 :type 'hook | 781 |
| 495 :group 'xscheme) | 782 (defvar xscheme-runlight "") |
| 496 | |
| 497 (defvar xscheme-runlight-string nil) | 783 (defvar xscheme-runlight-string nil) |
| 498 (defvar xscheme-mode-string nil) | 784 (defvar xscheme-mode-string nil) |
| 499 (defvar xscheme-filter-input nil) | 785 (setq-default scheme-mode-line-process |
| 786 '("" xscheme-runlight)) | |
| 787 | |
| 788 (mapcar 'make-variable-buffer-local | |
| 789 '(xscheme-expressions-ring | |
| 790 xscheme-expressions-ring-yank-pointer | |
| 791 xscheme-process-filter-state | |
| 792 xscheme-running-p | |
| 793 xscheme-control-g-disabled-p | |
| 794 xscheme-allow-output-p | |
| 795 xscheme-prompt | |
| 796 xscheme-string-accumulator | |
| 797 xscheme-mode-string | |
| 798 scheme-mode-line-process)) | |
| 500 | 799 |
| 501 ;;;; Basic Process Control | 800 ;;;; Basic Process Control |
| 502 | 801 |
| 503 (defun xscheme-start-process (command-line) | 802 (defun xscheme-start-process (command-line the-process the-buffer) |
| 504 (let ((buffer (get-buffer-create "*scheme*"))) | 803 (let ((buffer (get-buffer-create the-buffer))) |
| 505 (let ((process (get-buffer-process buffer))) | 804 (let ((process (get-buffer-process buffer))) |
| 506 (save-excursion | 805 (save-excursion |
| 507 (set-buffer buffer) | 806 (set-buffer buffer) |
| 508 (if (and process (memq (process-status process) '(run stop))) | 807 (if (and process (memq (process-status process) '(run stop))) |
| 509 (set-marker (process-mark process) (point-max)) | 808 (set-marker (process-mark process) (point-max)) |
| 510 (progn (if process (delete-process process)) | 809 (progn (if process (delete-process process)) |
| 511 (goto-char (point-max)) | 810 (goto-char (point-max)) |
| 512 (scheme-interaction-mode) | 811 (scheme-interaction-mode nil) |
| 812 (setq xscheme-process-name the-process) | |
| 513 (if (bobp) | 813 (if (bobp) |
| 514 (insert-before-markers | 814 (insert-before-markers |
| 515 (substitute-command-keys xscheme-startup-message))) | 815 (substitute-command-keys xscheme-startup-message))) |
| 516 (setq process | 816 (setq process |
| 517 (let ((process-connection-type nil)) | 817 (let ((process-connection-type nil)) |
| 518 (apply 'start-process | 818 (apply 'start-process |
| 519 (cons "scheme" | 819 (cons the-process |
| 520 (cons buffer | 820 (cons buffer |
| 521 (xscheme-parse-command-line | 821 (xscheme-parse-command-line |
| 522 command-line)))))) | 822 command-line)))))) |
| 823 (if (not (equal (process-name process) the-process)) | |
| 824 (setq xscheme-process-name (process-name process))) | |
| 825 (if (not (equal (buffer-name buffer) the-buffer)) | |
| 826 (setq xscheme-buffer-name (buffer-name buffer))) | |
| 827 (message "Starting process %s in buffer %s" | |
| 828 xscheme-process-name | |
| 829 xscheme-buffer-name) | |
| 523 (set-marker (process-mark process) (point-max)) | 830 (set-marker (process-mark process) (point-max)) |
| 524 (xscheme-process-filter-initialize t) | 831 (xscheme-process-filter-initialize t) |
| 525 (xscheme-modeline-initialize) | 832 (xscheme-modeline-initialize xscheme-buffer-name) |
| 526 (set-process-sentinel process 'xscheme-process-sentinel) | 833 (set-process-sentinel process 'xscheme-process-sentinel) |
| 527 (set-process-filter process 'xscheme-process-filter) | 834 (set-process-filter process 'xscheme-process-filter) |
| 528 (run-hooks 'xscheme-start-hook))))) | 835 (run-hooks 'xscheme-start-hook))))) |
| 529 buffer)) | 836 buffer)) |
| 530 | 837 |
| 554 (while xscheme-running-p | 861 (while xscheme-running-p |
| 555 (sleep-for 1))) | 862 (sleep-for 1))) |
| 556 | 863 |
| 557 (defun xscheme-process-running-p () | 864 (defun xscheme-process-running-p () |
| 558 "True iff there is a Scheme process whose status is `run'." | 865 "True iff there is a Scheme process whose status is `run'." |
| 559 (let ((process (get-process "scheme"))) | 866 (let ((process (get-process xscheme-process-name))) |
| 560 (and process | 867 (and process |
| 561 (eq (process-status process) 'run)))) | 868 (eq (process-status process) 'run)))) |
| 562 | 869 |
| 563 (defun xscheme-process-buffer () | 870 (defun xscheme-process-buffer () |
| 564 (let ((process (get-process "scheme"))) | 871 (let ((process (get-process xscheme-process-name))) |
| 565 (and process (process-buffer process)))) | 872 (and process (process-buffer process)))) |
| 566 | 873 |
| 567 (defun xscheme-process-buffer-window () | 874 (defun xscheme-process-buffer-window () |
| 568 (let ((buffer (xscheme-process-buffer))) | 875 (let ((buffer (xscheme-process-buffer))) |
| 569 (and buffer (get-buffer-window buffer)))) | 876 (and buffer (get-buffer-window buffer)))) |
| 573 (eq (xscheme-process-buffer) (current-buffer))) | 880 (eq (xscheme-process-buffer) (current-buffer))) |
| 574 | 881 |
| 575 ;;;; Process Filter | 882 ;;;; Process Filter |
| 576 | 883 |
| 577 (defun xscheme-process-sentinel (proc reason) | 884 (defun xscheme-process-sentinel (proc reason) |
| 578 (xscheme-process-filter-initialize (eq reason 'run)) | 885 (let* ((buffer (process-buffer proc)) |
| 579 (if (eq reason 'run) | 886 (name (buffer-name buffer))) |
| 580 (xscheme-modeline-initialize) | 887 (save-excursion |
| 581 (progn | 888 (set-buffer buffer) |
| 582 (setq scheme-mode-line-process "") | 889 (xscheme-process-filter-initialize (eq reason 'run)) |
| 583 (setq xscheme-mode-string "no process"))) | 890 (if (not (eq reason 'run)) |
| 584 (if (and (not (memq reason '(run stop))) | 891 (progn |
| 585 xscheme-signal-death-message) | 892 (setq scheme-mode-line-process "") |
| 586 (progn (beep) | 893 (setq xscheme-mode-string "no process") |
| 587 (message | 894 (if (equal name (default-value 'xscheme-buffer-name)) |
| 588 "The Scheme process has died! Do M-x reset-scheme to restart it")))) | 895 (setq-default xscheme-runlight "")))) |
| 896 (if (and (not (memq reason '(run stop))) | |
| 897 xscheme-signal-death-message) | |
| 898 (progn | |
| 899 (beep) | |
| 900 (message | |
| 901 "The Scheme process has died! Do M-x reset-scheme to restart it")))))) | |
| 589 | 902 |
| 590 (defun xscheme-process-filter-initialize (running-p) | 903 (defun xscheme-process-filter-initialize (running-p) |
| 591 (setq xscheme-process-filter-state 'idle) | 904 (setq xscheme-process-filter-state 'idle) |
| 592 (setq xscheme-running-p running-p) | 905 (setq xscheme-running-p running-p) |
| 593 (setq xscheme-control-g-disabled-p nil) | 906 (setq xscheme-control-g-disabled-p nil) |
| 594 (setq xscheme-allow-output-p t) | 907 (setq xscheme-allow-output-p t) |
| 595 (setq xscheme-prompt "") | 908 (setq xscheme-prompt "") |
| 596 (setq scheme-mode-line-process '(": " xscheme-runlight-string))) | 909 (if running-p |
| 910 (let ((name (buffer-name (current-buffer)))) | |
| 911 (setq scheme-mode-line-process '(": " xscheme-runlight-string)) | |
| 912 (xscheme-modeline-initialize name) | |
| 913 (if (equal name (default-value 'xscheme-buffer-name)) | |
| 914 (setq-default xscheme-runlight default-xscheme-runlight)))) | |
| 915 (if (or (eq xscheme-runlight default-xscheme-runlight) | |
| 916 (equal xscheme-runlight "")) | |
| 917 (setq xscheme-runlight (list ": " 'xscheme-buffer-name ": " "?"))) | |
| 918 (rplaca (nthcdr 3 xscheme-runlight) | |
| 919 (if running-p "?" "no process"))) | |
| 597 | 920 |
| 598 (defun xscheme-process-filter (proc string) | 921 (defun xscheme-process-filter (proc string) |
| 599 (let ((xscheme-filter-input string)) | 922 (let ((xscheme-filter-input string) |
| 923 (call-noexcursion nil)) | |
| 600 (while xscheme-filter-input | 924 (while xscheme-filter-input |
| 601 (cond ((eq xscheme-process-filter-state 'idle) | 925 (setq call-noexcursion nil) |
| 602 (let ((start (string-match "\e" xscheme-filter-input))) | 926 (save-excursion |
| 603 (if start | 927 (set-buffer (process-buffer proc)) |
| 604 (progn | 928 (cond ((eq xscheme-process-filter-state 'idle) |
| 605 (xscheme-process-filter-output | 929 (let ((start (string-match "\e" xscheme-filter-input))) |
| 606 (substring xscheme-filter-input 0 start)) | 930 (if start |
| 607 (setq xscheme-filter-input | 931 (progn |
| 608 (substring xscheme-filter-input (1+ start))) | 932 (xscheme-process-filter-output |
| 609 (setq xscheme-process-filter-state 'reading-type)) | 933 (substring xscheme-filter-input 0 start)) |
| 934 (setq xscheme-filter-input | |
| 935 (substring xscheme-filter-input (1+ start))) | |
| 936 (setq xscheme-process-filter-state 'reading-type)) | |
| 610 (let ((string xscheme-filter-input)) | 937 (let ((string xscheme-filter-input)) |
| 611 (setq xscheme-filter-input nil) | 938 (setq xscheme-filter-input nil) |
| 612 (xscheme-process-filter-output string))))) | 939 (xscheme-process-filter-output string))))) |
| 613 ((eq xscheme-process-filter-state 'reading-type) | 940 ((eq xscheme-process-filter-state 'reading-type) |
| 614 (if (zerop (length xscheme-filter-input)) | 941 (if (zerop (length xscheme-filter-input)) |
| 615 (setq xscheme-filter-input nil) | 942 (setq xscheme-filter-input nil) |
| 616 (let ((char (aref xscheme-filter-input 0))) | 943 (let ((char (aref xscheme-filter-input 0))) |
| 617 (setq xscheme-filter-input | 944 (setq xscheme-filter-input |
| 618 (substring xscheme-filter-input 1)) | 945 (substring xscheme-filter-input 1)) |
| 619 (let ((entry (assoc char xscheme-process-filter-alist))) | 946 (let ((entry (assoc char xscheme-process-filter-alist))) |
| 620 (if entry | 947 (if entry |
| 621 (funcall (nth 2 entry) (nth 1 entry)) | 948 (funcall (nth 2 entry) (nth 1 entry)) |
| 622 (progn | 949 (progn |
| 623 (xscheme-process-filter-output ?\e char) | 950 (xscheme-process-filter-output ?\e char) |
| 624 (setq xscheme-process-filter-state 'idle))))))) | 951 (setq xscheme-process-filter-state 'idle))))))) |
| 625 ((eq xscheme-process-filter-state 'reading-string) | 952 ((eq xscheme-process-filter-state 'reading-string) |
| 626 (let ((start (string-match "\e" xscheme-filter-input))) | 953 (let ((start (string-match "\e" xscheme-filter-input))) |
| 627 (if start | 954 (if start |
| 628 (let ((string | 955 (let ((string |
| 629 (concat xscheme-string-accumulator | 956 (concat xscheme-string-accumulator |
| 630 (substring xscheme-filter-input 0 start)))) | 957 (substring xscheme-filter-input 0 start)))) |
| 631 (setq xscheme-filter-input | 958 (setq xscheme-filter-input |
| 632 (substring xscheme-filter-input (1+ start))) | 959 (substring xscheme-filter-input (1+ start))) |
| 633 (setq xscheme-process-filter-state 'idle) | 960 (setq xscheme-process-filter-state 'idle) |
| 634 (funcall xscheme-string-receiver string)) | 961 (if (listp xscheme-string-receiver) |
| 962 (progn | |
| 963 (setq xscheme-string-receiver | |
| 964 (car xscheme-string-receiver)) | |
| 965 (setq call-noexcursion string)) | |
| 966 (funcall xscheme-string-receiver string))) | |
| 635 (progn | 967 (progn |
| 636 (setq xscheme-string-accumulator | 968 (setq xscheme-string-accumulator |
| 637 (concat xscheme-string-accumulator | 969 (concat xscheme-string-accumulator |
| 638 xscheme-filter-input)) | 970 xscheme-filter-input)) |
| 639 (setq xscheme-filter-input nil))))) | 971 (setq xscheme-filter-input nil))))) |
| 640 (t | 972 (t |
| 641 (error "Scheme process filter -- bad state")))))) | 973 (error "Scheme process filter -- bad state")))) |
| 974 (if call-noexcursion | |
| 975 (funcall xscheme-string-receiver call-noexcursion))))) | |
| 642 | 976 |
| 643 ;;;; Process Filter Output | 977 ;;;; Process Filter Output |
| 644 | 978 |
| 645 (defun xscheme-process-filter-output (&rest args) | 979 (defun xscheme-process-filter-output (&rest args) |
| 646 (if xscheme-allow-output-p | 980 (if xscheme-allow-output-p |
| 647 (let ((string (apply 'concat args))) | 981 (let ((string (apply 'concat args))) |
| 648 (save-excursion | 982 (save-excursion |
| 649 (xscheme-goto-output-point) | 983 (xscheme-goto-output-point) |
| 650 (while (string-match "\\(\007\\|\f\\)" string) | 984 (let ((old-point (point))) |
| 651 (let ((start (match-beginning 0)) | 985 (while (string-match "\\(\007\\|\f\\)" string) |
| 652 (end (match-end 0))) | 986 (let ((start (match-beginning 0)) |
| 653 (insert-before-markers (substring string 0 start)) | 987 (end (match-end 0))) |
| 654 (if (= ?\f (aref string start)) | 988 (insert-before-markers (substring string 0 start)) |
| 655 (progn | 989 (if (= ?\f (aref string start)) |
| 656 (if (not (bolp)) | 990 (progn |
| 657 (insert-before-markers ?\n)) | 991 (if (not (bolp)) |
| 658 (insert-before-markers ?\f)) | 992 (insert-before-markers ?\n)) |
| 659 (beep)) | 993 (insert-before-markers ?\f)) |
| 660 (setq string (substring string (1+ start))))) | 994 (beep)) |
| 661 (insert-before-markers string))))) | 995 (setq string (substring string (1+ start))))) |
| 996 (insert-before-markers string) | |
| 997 (if (and xscheme-last-input-end | |
| 998 (equal (marker-position xscheme-last-input-end) (point))) | |
| 999 (set-marker xscheme-last-input-end old-point))))))) | |
| 662 | 1000 |
| 663 (defun xscheme-guarantee-newlines (n) | 1001 (defun xscheme-guarantee-newlines (n) |
| 664 (if xscheme-allow-output-p | 1002 (if xscheme-allow-output-p |
| 665 (save-excursion | 1003 (save-excursion |
| 666 (xscheme-goto-output-point) | 1004 (xscheme-goto-output-point) |
| 675 (while (> n 0) | 1013 (while (> n 0) |
| 676 (insert-before-markers ?\n) | 1014 (insert-before-markers ?\n) |
| 677 (setq n (1- n)))))) | 1015 (setq n (1- n)))))) |
| 678 | 1016 |
| 679 (defun xscheme-goto-output-point () | 1017 (defun xscheme-goto-output-point () |
| 680 (let ((process (get-process "scheme"))) | 1018 (let ((process (get-process xscheme-process-name))) |
| 681 (set-buffer (process-buffer process)) | 1019 (set-buffer (process-buffer process)) |
| 682 (goto-char (process-mark process)))) | 1020 (goto-char (process-mark process)))) |
| 683 | 1021 |
| 684 (defun xscheme-modeline-initialize () | 1022 (defun xscheme-modeline-initialize (name) |
| 685 (setq xscheme-runlight-string "") | 1023 (setq xscheme-runlight-string "") |
| 1024 (if (equal name (default-value 'xscheme-buffer-name)) | |
| 1025 (setq-default xscheme-runlight-string "")) | |
| 686 (setq xscheme-mode-string "") | 1026 (setq xscheme-mode-string "") |
| 687 (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string))) | 1027 (setq mode-line-buffer-identification |
| 1028 (list (concat name ": ") | |
| 1029 'xscheme-mode-string))) | |
| 688 | 1030 |
| 689 (defun xscheme-set-runlight (runlight) | 1031 (defun xscheme-set-runlight (runlight) |
| 690 (setq xscheme-runlight-string runlight) | 1032 (setq xscheme-runlight-string runlight) |
| 1033 (if (equal (buffer-name (current-buffer)) | |
| 1034 (default-value 'xscheme-buffer-name)) | |
| 1035 (setq-default xscheme-runlight-string runlight)) | |
| 1036 (rplaca (nthcdr 3 xscheme-runlight) runlight) | |
| 691 (force-mode-line-update t)) | 1037 (force-mode-line-update t)) |
| 692 | 1038 |
| 693 ;;;; Process Filter Operations | 1039 ;;;; Process Filter Operations |
| 694 | 1040 |
| 695 (defvar xscheme-process-filter-alist | 1041 (defvar xscheme-process-filter-alist |
| 696 '((?D xscheme-enter-debugger-mode | 1042 '((?A xscheme-eval |
| 1043 xscheme-process-filter:string-action-noexcursion) | |
| 1044 (?D xscheme-enter-debugger-mode | |
| 697 xscheme-process-filter:string-action) | 1045 xscheme-process-filter:string-action) |
| 698 (?E xscheme-eval | 1046 (?E xscheme-eval |
| 699 xscheme-process-filter:string-action) | 1047 xscheme-process-filter:string-action) |
| 700 (?P xscheme-set-prompt-variable | 1048 (?P xscheme-set-prompt-variable |
| 701 xscheme-process-filter:string-action) | 1049 xscheme-process-filter:string-action) |
| 702 (?R xscheme-enter-interaction-mode | 1050 (?R xscheme-enter-interaction-mode |
| 703 xscheme-process-filter:simple-action) | 1051 xscheme-process-filter:simple-action) |
| 704 (?b xscheme-start-gc | 1052 (?b xscheme-start-gc |
| 1053 xscheme-process-filter:simple-action) | |
| 1054 (?c xscheme-unsolicited-read-char | |
| 705 xscheme-process-filter:simple-action) | 1055 xscheme-process-filter:simple-action) |
| 706 (?e xscheme-finish-gc | 1056 (?e xscheme-finish-gc |
| 707 xscheme-process-filter:simple-action) | 1057 xscheme-process-filter:simple-action) |
| 708 (?f xscheme-exit-input-wait | 1058 (?f xscheme-exit-input-wait |
| 709 xscheme-process-filter:simple-action) | 1059 xscheme-process-filter:simple-action) |
| 724 (?v xscheme-write-value | 1074 (?v xscheme-write-value |
| 725 xscheme-process-filter:string-action) | 1075 xscheme-process-filter:string-action) |
| 726 (?w xscheme-cd | 1076 (?w xscheme-cd |
| 727 xscheme-process-filter:string-action) | 1077 xscheme-process-filter:string-action) |
| 728 (?z xscheme-display-process-buffer | 1078 (?z xscheme-display-process-buffer |
| 729 xscheme-process-filter:simple-action) | |
| 730 (?c xscheme-unsolicited-read-char | |
| 731 xscheme-process-filter:simple-action)) | 1079 xscheme-process-filter:simple-action)) |
| 732 "Table used to decide how to handle process filter commands. | 1080 "Table used to decide how to handle process filter commands. |
| 733 Value is a list of entries, each entry is a list of three items. | 1081 Value is a list of entries, each entry is a list of three items. |
| 734 | 1082 |
| 735 The first item is the character that the process filter dispatches on. | 1083 The first item is the character that the process filter dispatches on. |
| 750 (defun xscheme-process-filter:string-action (action) | 1098 (defun xscheme-process-filter:string-action (action) |
| 751 (setq xscheme-string-receiver action) | 1099 (setq xscheme-string-receiver action) |
| 752 (setq xscheme-string-accumulator "") | 1100 (setq xscheme-string-accumulator "") |
| 753 (setq xscheme-process-filter-state 'reading-string)) | 1101 (setq xscheme-process-filter-state 'reading-string)) |
| 754 | 1102 |
| 1103 (defun xscheme-process-filter:string-action-noexcursion (action) | |
| 1104 (xscheme-process-filter:string-action (cons action nil))) | |
| 1105 | |
| 755 (defconst xscheme-runlight:running "run" | 1106 (defconst xscheme-runlight:running "run" |
| 756 "The character displayed when the Scheme process is running.") | 1107 "The character displayed when the Scheme process is running.") |
| 757 | 1108 |
| 758 (defconst xscheme-runlight:input "input" | 1109 (defconst xscheme-runlight:input "input" |
| 759 "The character displayed when the Scheme process is waiting for input.") | 1110 "The character displayed when the Scheme process is waiting for input.") |
| 768 (xscheme-set-runlight | 1119 (xscheme-set-runlight |
| 769 (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) | 1120 (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) |
| 770 | 1121 |
| 771 (defun xscheme-enter-input-wait () | 1122 (defun xscheme-enter-input-wait () |
| 772 (xscheme-set-runlight xscheme-runlight:input) | 1123 (xscheme-set-runlight xscheme-runlight:input) |
| 1124 (setq xscheme-control-g-disabled-p nil) | |
| 773 (setq xscheme-running-p nil)) | 1125 (setq xscheme-running-p nil)) |
| 774 | 1126 |
| 775 (defun xscheme-exit-input-wait () | 1127 (defun xscheme-exit-input-wait () |
| 776 (xscheme-set-runlight xscheme-runlight:running) | 1128 (xscheme-set-runlight xscheme-runlight:running) |
| 777 (setq xscheme-running-p t)) | 1129 (setq xscheme-running-p t)) |
| 778 | 1130 |
| 779 (defun xscheme-enable-control-g () | 1131 (defun xscheme-enable-control-g () |
| 780 (setq xscheme-control-g-disabled-p nil)) | 1132 (setq xscheme-control-g-disabled-p nil) |
| 1133 (if (string= (current-message) xscheme-control-g-message-string) | |
| 1134 (message nil))) | |
| 781 | 1135 |
| 782 (defun xscheme-display-process-buffer () | 1136 (defun xscheme-display-process-buffer () |
| 783 (let ((window (or (xscheme-process-buffer-window) | 1137 (let ((window (or (xscheme-process-buffer-window) |
| 784 (display-buffer (xscheme-process-buffer))))) | 1138 (display-buffer (xscheme-process-buffer))))) |
| 785 (save-window-excursion | 1139 (save-window-excursion |
| 798 (if (not (zerop (length string))) | 1152 (if (not (zerop (length string))) |
| 799 (xscheme-write-message-1 string (format ";%s" string)))) | 1153 (xscheme-write-message-1 string (format ";%s" string)))) |
| 800 | 1154 |
| 801 (defun xscheme-write-value (string) | 1155 (defun xscheme-write-value (string) |
| 802 (if (zerop (length string)) | 1156 (if (zerop (length string)) |
| 803 (xscheme-write-message-1 "(no value)" ";No value") | 1157 (xscheme-write-message-1 "(no value)" ";Unspecified return value") |
| 804 (xscheme-write-message-1 string (format ";Value: %s" string)))) | 1158 (xscheme-write-message-1 string (format ";Value: %s" string)))) |
| 805 | 1159 |
| 806 (defun xscheme-write-message-1 (message-string output-string) | 1160 (defun xscheme-write-message-1 (message-string output-string) |
| 807 (let* ((process (get-process "scheme")) | 1161 (let* ((process (get-process xscheme-process-name)) |
| 808 (window (get-buffer-window (process-buffer process)))) | 1162 (window (get-buffer-window (process-buffer process)))) |
| 809 (if (or (not window) | 1163 (if (or (not window) |
| 810 (not (pos-visible-in-window-p (process-mark process) | 1164 (not (pos-visible-in-window-p (process-mark process) |
| 811 window))) | 1165 window))) |
| 812 (message "%s" message-string))) | 1166 (message "%s" message-string))) |
| 825 (defun xscheme-output-goto () | 1179 (defun xscheme-output-goto () |
| 826 (xscheme-goto-output-point) | 1180 (xscheme-goto-output-point) |
| 827 (xscheme-guarantee-newlines 2)) | 1181 (xscheme-guarantee-newlines 2)) |
| 828 | 1182 |
| 829 (defun xscheme-coerce-prompt (string) | 1183 (defun xscheme-coerce-prompt (string) |
| 830 (if (string-match "^[0-9]+ " string) | 1184 (if (string-match "^[0-9]+ \\[[^]]+\\] " string) |
| 831 (let ((end (match-end 0))) | 1185 (let ((end (match-end 0))) |
| 832 (concat (substring string 0 end) | 1186 (xscheme-process-filter-output (substring string end)) |
| 833 (let ((prompt (substring string end))) | 1187 (substring string 0 (- end 1))) |
| 834 (let ((entry (assoc prompt xscheme-prompt-alist))) | |
| 835 (if entry | |
| 836 (cdr entry) | |
| 837 prompt))))) | |
| 838 string)) | 1188 string)) |
| 839 | |
| 840 (defvar xscheme-prompt-alist | |
| 841 '(("[Normal REPL]" . "[Evaluator]") | |
| 842 ("[Error REPL]" . "[Evaluator]") | |
| 843 ("[Breakpoint REPL]" . "[Evaluator]") | |
| 844 ("[Debugger REPL]" . "[Evaluator]") | |
| 845 ("[Visiting environment]" . "[Evaluator]") | |
| 846 ("[Environment Inspector]" . "[Where]")) | |
| 847 "An alist which maps the Scheme command interpreter type to a print string.") | |
| 848 | 1189 |
| 849 (defun xscheme-cd (directory-string) | 1190 (defun xscheme-cd (directory-string) |
| 850 (save-excursion | 1191 (save-excursion |
| 851 (set-buffer (xscheme-process-buffer)) | 1192 (set-buffer (xscheme-process-buffer)) |
| 852 (cd directory-string))) | 1193 (cd directory-string))) |