Commit | Line | Data |
---|---|---|
76d7458e ER |
1 | ;;; xscheme.el --- run Scheme under Emacs |
2 | ||
eea8d4ef ER |
3 | ;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc. |
4 | ||
d46bac56 | 5 | ;; Maintainer: FSF |
b7f66977 | 6 | ;; Keywords: languages, lisp |
6cf0d154 | 7 | |
a1ad21ca CH |
8 | ;; This file is part of GNU Emacs. |
9 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
e5167999 | 12 | ;; the Free Software Foundation; either version 2, or (at your option) |
a1ad21ca CH |
13 | ;; any later version. |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
b578f267 EN |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;; Boston, MA 02111-1307, USA. | |
a1ad21ca | 24 | |
6cf0d154 ER |
25 | ;;; Commentary: |
26 | ||
c91c4e6d ER |
27 | ;; A major mode for editing Scheme and interacting with MIT's C-Scheme. |
28 | ;; | |
29 | ;; Requires C-Scheme release 5 or later | |
30 | ;; Changes to Control-G handler require runtime version 13.85 or later | |
a1ad21ca | 31 | |
6cf0d154 ER |
32 | ;;; Code: |
33 | ||
a1ad21ca CH |
34 | (require 'scheme) |
35 | \f | |
4bef9110 SE |
36 | (defgroup xscheme nil |
37 | "Major mode for editing Scheme and interacting with MIT's C-Scheme." | |
38 | :group 'lisp) | |
39 | ||
40 | (defcustom scheme-program-name "scheme" | |
41 | "*Program invoked by the `run-scheme' command." | |
42 | :type 'string | |
43 | :group 'xscheme) | |
44 | ||
45 | (defcustom scheme-band-name nil | |
46 | "*Band loaded by the `run-scheme' command." | |
47 | :type '(choice (const nil) string) | |
48 | :group 'xscheme) | |
49 | ||
50 | (defcustom scheme-program-arguments nil | |
51 | "*Arguments passed to the Scheme program by the `run-scheme' command." | |
52 | :type '(choice (const nil) string) | |
53 | :group 'xscheme) | |
54 | ||
55 | (defcustom xscheme-allow-pipelined-evaluation t | |
a1ad21ca CH |
56 | "If non-nil, an expression may be transmitted while another is evaluating. |
57 | Otherwise, attempting to evaluate an expression before the previous expression | |
4bef9110 SE |
58 | has finished evaluating will signal an error." |
59 | :type 'boolean | |
60 | :group 'xscheme) | |
a1ad21ca | 61 | |
4bef9110 | 62 | (defcustom xscheme-startup-message |
a1ad21ca CH |
63 | "This is the Scheme process buffer. |
64 | Type \\[advertised-xscheme-send-previous-expression] to evaluate the expression before point. | |
65 | Type \\[xscheme-send-control-g-interrupt] to abort evaluation. | |
66 | Type \\[describe-mode] for more information. | |
67 | ||
68 | " | |
69 | "String to insert into Scheme process buffer first time it is started. | |
4bef9110 SE |
70 | Is processed with `substitute-command-keys' first." |
71 | :type 'string | |
72 | :group 'xscheme) | |
a1ad21ca | 73 | |
4bef9110 SE |
74 | (defcustom xscheme-signal-death-message nil |
75 | "If non-nil, causes a message to be generated when the Scheme process dies." | |
76 | :type 'boolean | |
77 | :group 'xscheme) | |
a1ad21ca CH |
78 | |
79 | (defun xscheme-evaluation-commands (keymap) | |
80 | (define-key keymap "\e\C-x" 'xscheme-send-definition) | |
81 | (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) | |
82 | (define-key keymap "\eo" 'xscheme-send-buffer) | |
83 | (define-key keymap "\ez" 'xscheme-send-definition) | |
84 | (define-key keymap "\e\C-m" 'xscheme-send-previous-expression) | |
85 | (define-key keymap "\e\C-z" 'xscheme-send-region)) | |
86 | ||
87 | (defun xscheme-interrupt-commands (keymap) | |
88 | (define-key keymap "\C-c\C-s" 'xscheme-select-process-buffer) | |
89 | (define-key keymap "\C-c\C-b" 'xscheme-send-breakpoint-interrupt) | |
90 | (define-key keymap "\C-c\C-c" 'xscheme-send-control-g-interrupt) | |
91 | (define-key keymap "\C-c\C-u" 'xscheme-send-control-u-interrupt) | |
92 | (define-key keymap "\C-c\C-x" 'xscheme-send-control-x-interrupt)) | |
93 | ||
94 | (xscheme-evaluation-commands scheme-mode-map) | |
95 | (xscheme-interrupt-commands scheme-mode-map) | |
96 | \f | |
97 | (defun run-scheme (command-line) | |
0178cafa | 98 | "Run MIT Scheme in an inferior process. |
a1ad21ca CH |
99 | Output goes to the buffer `*scheme*'. |
100 | With argument, asks for a command line." | |
101 | (interactive | |
102 | (list (let ((default | |
103 | (or xscheme-process-command-line | |
104 | (xscheme-default-command-line)))) | |
105 | (if current-prefix-arg | |
106 | (read-string "Run Scheme: " default) | |
107 | default)))) | |
108 | (setq xscheme-process-command-line command-line) | |
f0e30fe8 | 109 | (pop-to-buffer (xscheme-start-process command-line))) |
a1ad21ca CH |
110 | |
111 | (defun reset-scheme () | |
112 | "Reset the Scheme process." | |
113 | (interactive) | |
114 | (let ((process (get-process "scheme"))) | |
115 | (cond ((or (not process) | |
116 | (not (eq (process-status process) 'run)) | |
117 | (yes-or-no-p | |
118 | "The Scheme process is running, are you SURE you want to reset it? ")) | |
119 | (message "Resetting Scheme process...") | |
120 | (if process (kill-process process t)) | |
121 | (xscheme-start-process xscheme-process-command-line) | |
122 | (message "Resetting Scheme process...done"))))) | |
123 | ||
124 | (defun xscheme-default-command-line () | |
125 | (concat scheme-program-name " -emacs" | |
126 | (if scheme-program-arguments | |
127 | (concat " " scheme-program-arguments) | |
128 | "") | |
129 | (if scheme-band-name | |
130 | (concat " -band " scheme-band-name) | |
131 | ""))) | |
132 | \f | |
133 | ;;;; Interaction Mode | |
134 | ||
135 | (defun scheme-interaction-mode () | |
136 | "Major mode for interacting with the inferior Scheme process. | |
137 | Like scheme-mode except that: | |
138 | ||
139 | \\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input | |
140 | \\[xscheme-yank-previous-send] yanks the expression most recently sent to Scheme | |
141 | ||
142 | All output from the Scheme process is written in the Scheme process | |
143 | buffer, which is initially named \"*scheme*\". The result of | |
144 | evaluating a Scheme expression is also printed in the process buffer, | |
145 | preceded by the string \";Value: \" to highlight it. If the process | |
146 | buffer is not visible at that time, the value will also be displayed | |
147 | in the minibuffer. If an error occurs, the process buffer will | |
148 | automatically pop up to show you the error message. | |
149 | ||
150 | While the Scheme process is running, the modelines of all buffers in | |
151 | scheme-mode are modified to show the state of the process. The | |
152 | possible states and their meanings are: | |
153 | ||
154 | input waiting for input | |
155 | run evaluating | |
156 | gc garbage collecting | |
157 | ||
158 | The process buffer's modeline contains additional information where | |
159 | the buffer's name is normally displayed: the command interpreter level | |
160 | and type. | |
161 | ||
162 | Scheme maintains a stack of command interpreters. Every time an error | |
163 | or breakpoint occurs, the current command interpreter is pushed on the | |
164 | command interpreter stack, and a new command interpreter is started. | |
165 | One example of why this is done is so that an error that occurs while | |
166 | you are debugging another error will not destroy the state of the | |
167 | initial error, allowing you to return to it after the second error has | |
168 | been fixed. | |
169 | ||
170 | The command interpreter level indicates how many interpreters are in | |
171 | the command interpreter stack. It is initially set to one, and it is | |
172 | incremented every time that stack is pushed, and decremented every | |
173 | time it is popped. The following commands are useful for manipulating | |
174 | the command interpreter stack: | |
175 | ||
176 | \\[xscheme-send-breakpoint-interrupt] pushes the stack once | |
177 | \\[xscheme-send-control-u-interrupt] pops the stack once | |
178 | \\[xscheme-send-control-g-interrupt] pops everything off | |
179 | \\[xscheme-send-control-x-interrupt] aborts evaluation, doesn't affect stack | |
180 | ||
181 | Some possible command interpreter types and their meanings are: | |
182 | ||
183 | [Evaluator] read-eval-print loop for evaluating expressions | |
184 | [Debugger] single character commands for debugging errors | |
185 | [Where] single character commands for examining environments | |
186 | ||
187 | Starting with release 6.2 of Scheme, the latter two types of command | |
188 | interpreters will change the major mode of the Scheme process buffer | |
189 | to scheme-debugger-mode , in which the evaluation commands are | |
190 | disabled, and the keys which normally self insert instead send | |
191 | themselves to the Scheme process. The command character ? will list | |
192 | the available commands. | |
193 | ||
194 | For older releases of Scheme, the major mode will be be | |
195 | scheme-interaction-mode , and the command characters must be sent as | |
196 | if they were expressions. | |
197 | ||
198 | Commands: | |
199 | Delete converts tabs to spaces as it moves back. | |
200 | Blank lines separate paragraphs. Semicolons start comments. | |
201 | \\{scheme-interaction-mode-map} | |
202 | ||
203 | Entry to this mode calls the value of scheme-interaction-mode-hook | |
204 | with no args, if that value is non-nil. | |
205 | Likewise with the value of scheme-mode-hook. | |
206 | scheme-interaction-mode-hook is called after scheme-mode-hook." | |
207 | (interactive) | |
208 | (kill-all-local-variables) | |
209 | (scheme-interaction-mode-initialize) | |
210 | (scheme-mode-variables) | |
211 | (make-local-variable 'xscheme-previous-send) | |
212 | (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) | |
213 | ||
214 | (defun scheme-interaction-mode-initialize () | |
215 | (use-local-map scheme-interaction-mode-map) | |
216 | (setq major-mode 'scheme-interaction-mode) | |
217 | (setq mode-name "Scheme Interaction")) | |
218 | ||
219 | (defun scheme-interaction-mode-commands (keymap) | |
220 | (define-key keymap "\C-c\C-m" 'xscheme-send-current-line) | |
221 | (define-key keymap "\C-c\C-p" 'xscheme-send-proceed) | |
222 | (define-key keymap "\C-c\C-y" 'xscheme-yank-previous-send)) | |
223 | ||
224 | (defvar scheme-interaction-mode-map nil) | |
225 | (if (not scheme-interaction-mode-map) | |
226 | (progn | |
227 | (setq scheme-interaction-mode-map (make-keymap)) | |
228 | (scheme-mode-commands scheme-interaction-mode-map) | |
229 | (xscheme-interrupt-commands scheme-interaction-mode-map) | |
230 | (xscheme-evaluation-commands scheme-interaction-mode-map) | |
231 | (scheme-interaction-mode-commands scheme-interaction-mode-map))) | |
232 | ||
233 | (defun xscheme-enter-interaction-mode () | |
234 | (save-excursion | |
235 | (set-buffer (xscheme-process-buffer)) | |
236 | (if (not (eq major-mode 'scheme-interaction-mode)) | |
237 | (if (eq major-mode 'scheme-debugger-mode) | |
238 | (scheme-interaction-mode-initialize) | |
239 | (scheme-interaction-mode))))) | |
240 | ||
241 | (fset 'advertised-xscheme-send-previous-expression | |
242 | 'xscheme-send-previous-expression) | |
243 | \f | |
244 | ;;;; Debugger Mode | |
245 | ||
246 | (defun scheme-debugger-mode () | |
247 | "Major mode for executing the Scheme debugger. | |
248 | Like scheme-mode except that the evaluation commands | |
249 | are disabled, and characters that would normally be self inserting are | |
250 | sent to the Scheme process instead. Typing ? will show you which | |
251 | characters perform useful functions. | |
252 | ||
253 | Commands: | |
254 | \\{scheme-debugger-mode-map}" | |
255 | (error "Illegal entry to scheme-debugger-mode")) | |
256 | ||
257 | (defun scheme-debugger-mode-initialize () | |
258 | (use-local-map scheme-debugger-mode-map) | |
259 | (setq major-mode 'scheme-debugger-mode) | |
260 | (setq mode-name "Scheme Debugger")) | |
261 | ||
262 | (defun scheme-debugger-mode-commands (keymap) | |
263 | (let ((char ? )) | |
264 | (while (< char 127) | |
265 | (define-key keymap (char-to-string char) 'scheme-debugger-self-insert) | |
266 | (setq char (1+ char))))) | |
267 | ||
268 | (defvar scheme-debugger-mode-map nil) | |
269 | (if (not scheme-debugger-mode-map) | |
270 | (progn | |
271 | (setq scheme-debugger-mode-map (make-keymap)) | |
272 | (scheme-mode-commands scheme-debugger-mode-map) | |
273 | (xscheme-interrupt-commands scheme-debugger-mode-map) | |
274 | (scheme-debugger-mode-commands scheme-debugger-mode-map))) | |
275 | ||
276 | (defun scheme-debugger-self-insert () | |
277 | "Transmit this character to the Scheme process." | |
278 | (interactive) | |
279 | (xscheme-send-char last-command-char)) | |
280 | ||
281 | (defun xscheme-enter-debugger-mode (prompt-string) | |
282 | (save-excursion | |
283 | (set-buffer (xscheme-process-buffer)) | |
284 | (if (not (eq major-mode 'scheme-debugger-mode)) | |
285 | (progn | |
286 | (if (not (eq major-mode 'scheme-interaction-mode)) | |
287 | (scheme-interaction-mode)) | |
288 | (scheme-debugger-mode-initialize))))) | |
289 | ||
290 | (defun xscheme-debugger-mode-p () | |
291 | (let ((buffer (xscheme-process-buffer))) | |
292 | (and buffer | |
293 | (save-excursion | |
294 | (set-buffer buffer) | |
295 | (eq major-mode 'scheme-debugger-mode))))) | |
296 | \f | |
297 | ;;;; Evaluation Commands | |
298 | ||
299 | (defun xscheme-send-string (&rest strings) | |
300 | "Send the string arguments to the Scheme process. | |
301 | The strings are concatenated and terminated by a newline." | |
302 | (cond ((not (xscheme-process-running-p)) | |
303 | (if (yes-or-no-p "The Scheme process has died. Reset it? ") | |
304 | (progn | |
305 | (reset-scheme) | |
306 | (xscheme-wait-for-process) | |
307 | (goto-char (point-max)) | |
308 | (apply 'insert-before-markers strings) | |
309 | (xscheme-send-string-1 strings)))) | |
310 | ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) | |
311 | ((and (not xscheme-allow-pipelined-evaluation) | |
312 | xscheme-running-p) | |
313 | (error "No sends allowed while Scheme running")) | |
314 | (t (xscheme-send-string-1 strings)))) | |
315 | ||
316 | (defun xscheme-send-string-1 (strings) | |
317 | (let ((string (apply 'concat strings))) | |
318 | (xscheme-send-string-2 string) | |
319 | (if (eq major-mode 'scheme-interaction-mode) | |
320 | (setq xscheme-previous-send string)))) | |
321 | ||
322 | (defun xscheme-send-string-2 (string) | |
323 | (let ((process (get-process "scheme"))) | |
324 | (send-string process (concat string "\n")) | |
325 | (if (xscheme-process-buffer-current-p) | |
326 | (set-marker (process-mark process) (point))))) | |
327 | ||
328 | (defun xscheme-yank-previous-send () | |
329 | "Insert the most recent expression at point." | |
330 | (interactive) | |
331 | (push-mark) | |
332 | (insert xscheme-previous-send)) | |
333 | ||
334 | (defun xscheme-select-process-buffer () | |
335 | "Select the Scheme process buffer and move to its output point." | |
336 | (interactive) | |
337 | (let ((process (or (get-process "scheme") (error "No scheme process")))) | |
338 | (let ((buffer (or (process-buffer process) (error "No process buffer")))) | |
339 | (let ((window (get-buffer-window buffer))) | |
340 | (if window | |
341 | (select-window window) | |
342 | (switch-to-buffer buffer)) | |
343 | (goto-char (process-mark process)))))) | |
344 | \f | |
345 | (defun xscheme-send-region (start end) | |
346 | "Send the current region to the Scheme process. | |
347 | The region is sent terminated by a newline." | |
348 | (interactive "r") | |
349 | (if (xscheme-process-buffer-current-p) | |
350 | (progn (goto-char end) | |
351 | (set-marker (process-mark (get-process "scheme")) end))) | |
352 | (xscheme-send-string (buffer-substring start end))) | |
353 | ||
354 | (defun xscheme-send-definition () | |
355 | "Send the current definition to the Scheme process. | |
356 | If the current line begins with a non-whitespace character, | |
357 | parse an expression from the beginning of the line and send that instead." | |
358 | (interactive) | |
359 | (let ((start nil) (end nil)) | |
360 | (save-excursion | |
361 | (end-of-defun) | |
362 | (setq end (point)) | |
363 | (if (re-search-backward "^\\s(" nil t) | |
364 | (setq start (point)) | |
365 | (error "Can't find definition"))) | |
366 | (xscheme-send-region start end))) | |
367 | ||
368 | (defun xscheme-send-next-expression () | |
369 | "Send the expression to the right of `point' to the Scheme process." | |
370 | (interactive) | |
371 | (let ((start (point))) | |
372 | (xscheme-send-region start (save-excursion (forward-sexp) (point))))) | |
373 | ||
374 | (defun xscheme-send-previous-expression () | |
375 | "Send the expression to the left of `point' to the Scheme process." | |
376 | (interactive) | |
377 | (let ((end (point))) | |
378 | (xscheme-send-region (save-excursion (backward-sexp) (point)) end))) | |
379 | \f | |
380 | (defun xscheme-send-current-line () | |
381 | "Send the current line to the Scheme process. | |
382 | Useful for working with debugging Scheme under adb." | |
383 | (interactive) | |
384 | (let ((line | |
385 | (save-excursion | |
386 | (beginning-of-line) | |
387 | (let ((start (point))) | |
388 | (end-of-line) | |
389 | (buffer-substring start (point)))))) | |
390 | (end-of-line) | |
391 | (insert ?\n) | |
392 | (xscheme-send-string-2 line))) | |
393 | ||
394 | (defun xscheme-send-buffer () | |
395 | "Send the current buffer to the Scheme process." | |
396 | (interactive) | |
397 | (if (xscheme-process-buffer-current-p) | |
398 | (error "Not allowed to send this buffer's contents to Scheme")) | |
399 | (xscheme-send-region (point-min) (point-max))) | |
400 | ||
401 | (defun xscheme-send-char (char) | |
402 | "Prompt for a character and send it to the Scheme process." | |
403 | (interactive "cCharacter to send: ") | |
404 | (send-string "scheme" (char-to-string char))) | |
405 | \f | |
406 | ;;;; Interrupts | |
407 | ||
408 | (defun xscheme-send-breakpoint-interrupt () | |
409 | "Cause the Scheme process to enter a breakpoint." | |
410 | (interactive) | |
411 | (xscheme-send-interrupt ?b nil)) | |
412 | ||
413 | (defun xscheme-send-proceed () | |
414 | "Cause the Scheme process to proceed from a breakpoint." | |
415 | (interactive) | |
416 | (send-string "scheme" "(proceed)\n")) | |
417 | ||
418 | (defun xscheme-send-control-g-interrupt () | |
419 | "Cause the Scheme processor to halt and flush input. | |
420 | Control returns to the top level rep loop." | |
421 | (interactive) | |
422 | (let ((inhibit-quit t)) | |
423 | (cond ((not xscheme-control-g-synchronization-p) | |
424 | (interrupt-process "scheme")) | |
425 | (xscheme-control-g-disabled-p | |
426 | (message "Relax...")) | |
427 | (t | |
428 | (setq xscheme-control-g-disabled-p t) | |
429 | (message "Sending C-G interrupt to Scheme...") | |
430 | (interrupt-process "scheme") | |
431 | (send-string "scheme" (char-to-string 0)))))) | |
432 | ||
433 | (defun xscheme-send-control-u-interrupt () | |
434 | "Cause the Scheme process to halt, returning to previous rep loop." | |
435 | (interactive) | |
436 | (xscheme-send-interrupt ?u t)) | |
437 | ||
438 | (defun xscheme-send-control-x-interrupt () | |
439 | "Cause the Scheme process to halt, returning to current rep loop." | |
440 | (interactive) | |
441 | (xscheme-send-interrupt ?x t)) | |
442 | ||
443 | ;;; This doesn't really work right -- Scheme just gobbles the first | |
444 | ;;; character in the input. There is no way for us to guarantee that | |
445 | ;;; the argument to this procedure is the first char unless we put | |
446 | ;;; some kind of marker in the input stream. | |
447 | ||
448 | (defun xscheme-send-interrupt (char mark-p) | |
449 | "Send a ^A type interrupt to the Scheme process." | |
450 | (interactive "cInterrupt character to send: ") | |
451 | (quit-process "scheme") | |
452 | (send-string "scheme" (char-to-string char)) | |
453 | (if (and mark-p xscheme-control-g-synchronization-p) | |
454 | (send-string "scheme" (char-to-string 0)))) | |
455 | \f | |
456 | ;;;; Internal Variables | |
457 | ||
458 | (defvar xscheme-process-command-line nil | |
459 | "Command used to start the most recent Scheme process.") | |
460 | ||
461 | (defvar xscheme-previous-send "" | |
462 | "Most recent expression transmitted to the Scheme process.") | |
463 | ||
464 | (defvar xscheme-process-filter-state 'idle | |
465 | "State of scheme process escape reader state machine: | |
466 | idle waiting for an escape sequence | |
467 | reading-type received an altmode but nothing else | |
468 | reading-string reading prompt string") | |
469 | ||
470 | (defvar xscheme-running-p nil | |
471 | "This variable, if nil, indicates that the scheme process is | |
472 | waiting for input. Otherwise, it is busy evaluating something.") | |
473 | ||
474 | (defconst xscheme-control-g-synchronization-p t | |
475 | "If non-nil, insert markers in the scheme input stream to indicate when | |
0a40ffd2 KH |
476 | control-g interrupts were signaled. Do not allow more control-g's to be |
477 | signaled until the scheme process acknowledges receipt.") | |
a1ad21ca CH |
478 | |
479 | (defvar xscheme-control-g-disabled-p nil | |
480 | "This variable, if non-nil, indicates that a control-g is being processed | |
481 | by the scheme process, so additional control-g's are to be ignored.") | |
482 | ||
483 | (defvar xscheme-allow-output-p t | |
484 | "This variable, if nil, prevents output from the scheme process | |
485 | from being inserted into the process-buffer.") | |
486 | ||
487 | (defvar xscheme-prompt "" | |
488 | "The current scheme prompt string.") | |
489 | ||
490 | (defvar xscheme-string-accumulator "" | |
491 | "Accumulator for the string being received from the scheme process.") | |
492 | ||
493 | (defvar xscheme-string-receiver nil | |
494 | "Procedure to send the string argument from the scheme process.") | |
495 | ||
4bef9110 | 496 | (defcustom xscheme-start-hook nil |
a1ad21ca | 497 | "If non-nil, a procedure to call when the Scheme process is started. |
4bef9110 SE |
498 | When called, the current buffer will be the Scheme process-buffer." |
499 | :type 'hook | |
500 | :group 'xscheme) | |
a1ad21ca CH |
501 | |
502 | (defvar xscheme-runlight-string nil) | |
503 | (defvar xscheme-mode-string nil) | |
504 | (defvar xscheme-filter-input nil) | |
505 | \f | |
506 | ;;;; Basic Process Control | |
507 | ||
508 | (defun xscheme-start-process (command-line) | |
509 | (let ((buffer (get-buffer-create "*scheme*"))) | |
510 | (let ((process (get-buffer-process buffer))) | |
511 | (save-excursion | |
512 | (set-buffer buffer) | |
513 | (if (and process (memq (process-status process) '(run stop))) | |
514 | (set-marker (process-mark process) (point-max)) | |
515 | (progn (if process (delete-process process)) | |
516 | (goto-char (point-max)) | |
517 | (scheme-interaction-mode) | |
518 | (if (bobp) | |
519 | (insert-before-markers | |
520 | (substitute-command-keys xscheme-startup-message))) | |
521 | (setq process | |
522 | (let ((process-connection-type nil)) | |
523 | (apply 'start-process | |
524 | (cons "scheme" | |
525 | (cons buffer | |
526 | (xscheme-parse-command-line | |
527 | command-line)))))) | |
528 | (set-marker (process-mark process) (point-max)) | |
529 | (xscheme-process-filter-initialize t) | |
530 | (xscheme-modeline-initialize) | |
531 | (set-process-sentinel process 'xscheme-process-sentinel) | |
532 | (set-process-filter process 'xscheme-process-filter) | |
533 | (run-hooks 'xscheme-start-hook))))) | |
534 | buffer)) | |
535 | ||
536 | (defun xscheme-parse-command-line (string) | |
537 | (setq string (substitute-in-file-name string)) | |
538 | (let ((start 0) | |
539 | (result '())) | |
540 | (while start | |
541 | (let ((index (string-match "[ \t]" string start))) | |
542 | (setq start | |
543 | (cond ((not index) | |
544 | (setq result | |
545 | (cons (substring string start) | |
546 | result)) | |
547 | nil) | |
548 | ((= index start) | |
549 | (string-match "[^ \t]" string start)) | |
550 | (t | |
551 | (setq result | |
552 | (cons (substring string start index) | |
553 | result)) | |
554 | (1+ index)))))) | |
555 | (nreverse result))) | |
556 | \f | |
557 | (defun xscheme-wait-for-process () | |
558 | (sleep-for 2) | |
559 | (while xscheme-running-p | |
560 | (sleep-for 1))) | |
561 | ||
562 | (defun xscheme-process-running-p () | |
563 | "True iff there is a Scheme process whose status is `run'." | |
564 | (let ((process (get-process "scheme"))) | |
565 | (and process | |
566 | (eq (process-status process) 'run)))) | |
567 | ||
568 | (defun xscheme-process-buffer () | |
569 | (let ((process (get-process "scheme"))) | |
570 | (and process (process-buffer process)))) | |
571 | ||
572 | (defun xscheme-process-buffer-window () | |
573 | (let ((buffer (xscheme-process-buffer))) | |
574 | (and buffer (get-buffer-window buffer)))) | |
575 | ||
576 | (defun xscheme-process-buffer-current-p () | |
577 | "True iff the current buffer is the Scheme process buffer." | |
578 | (eq (xscheme-process-buffer) (current-buffer))) | |
579 | \f | |
580 | ;;;; Process Filter | |
581 | ||
582 | (defun xscheme-process-sentinel (proc reason) | |
583 | (xscheme-process-filter-initialize (eq reason 'run)) | |
584 | (if (eq reason 'run) | |
585 | (xscheme-modeline-initialize) | |
586 | (progn | |
587 | (setq scheme-mode-line-process "") | |
588 | (setq xscheme-mode-string "no process"))) | |
589 | (if (and (not (memq reason '(run stop))) | |
590 | xscheme-signal-death-message) | |
591 | (progn (beep) | |
592 | (message | |
593 | "The Scheme process has died! Do M-x reset-scheme to restart it")))) | |
594 | ||
595 | (defun xscheme-process-filter-initialize (running-p) | |
596 | (setq xscheme-process-filter-state 'idle) | |
597 | (setq xscheme-running-p running-p) | |
598 | (setq xscheme-control-g-disabled-p nil) | |
599 | (setq xscheme-allow-output-p t) | |
600 | (setq xscheme-prompt "") | |
601 | (setq scheme-mode-line-process '(": " xscheme-runlight-string))) | |
602 | ||
603 | (defun xscheme-process-filter (proc string) | |
604 | (let ((xscheme-filter-input string)) | |
605 | (while xscheme-filter-input | |
606 | (cond ((eq xscheme-process-filter-state 'idle) | |
607 | (let ((start (string-match "\e" xscheme-filter-input))) | |
608 | (if start | |
609 | (progn | |
610 | (xscheme-process-filter-output | |
611 | (substring xscheme-filter-input 0 start)) | |
612 | (setq xscheme-filter-input | |
613 | (substring xscheme-filter-input (1+ start))) | |
614 | (setq xscheme-process-filter-state 'reading-type)) | |
615 | (let ((string xscheme-filter-input)) | |
616 | (setq xscheme-filter-input nil) | |
617 | (xscheme-process-filter-output string))))) | |
618 | ((eq xscheme-process-filter-state 'reading-type) | |
619 | (if (zerop (length xscheme-filter-input)) | |
620 | (setq xscheme-filter-input nil) | |
621 | (let ((char (aref xscheme-filter-input 0))) | |
622 | (setq xscheme-filter-input | |
623 | (substring xscheme-filter-input 1)) | |
624 | (let ((entry (assoc char xscheme-process-filter-alist))) | |
625 | (if entry | |
626 | (funcall (nth 2 entry) (nth 1 entry)) | |
627 | (progn | |
628 | (xscheme-process-filter-output ?\e char) | |
629 | (setq xscheme-process-filter-state 'idle))))))) | |
630 | ((eq xscheme-process-filter-state 'reading-string) | |
631 | (let ((start (string-match "\e" xscheme-filter-input))) | |
632 | (if start | |
633 | (let ((string | |
634 | (concat xscheme-string-accumulator | |
635 | (substring xscheme-filter-input 0 start)))) | |
636 | (setq xscheme-filter-input | |
637 | (substring xscheme-filter-input (1+ start))) | |
638 | (setq xscheme-process-filter-state 'idle) | |
639 | (funcall xscheme-string-receiver string)) | |
640 | (progn | |
641 | (setq xscheme-string-accumulator | |
642 | (concat xscheme-string-accumulator | |
643 | xscheme-filter-input)) | |
644 | (setq xscheme-filter-input nil))))) | |
645 | (t | |
646 | (error "Scheme process filter -- bad state")))))) | |
647 | \f | |
648 | ;;;; Process Filter Output | |
649 | ||
650 | (defun xscheme-process-filter-output (&rest args) | |
651 | (if xscheme-allow-output-p | |
652 | (let ((string (apply 'concat args))) | |
653 | (save-excursion | |
654 | (xscheme-goto-output-point) | |
655 | (while (string-match "\\(\007\\|\f\\)" string) | |
656 | (let ((start (match-beginning 0)) | |
657 | (end (match-end 0))) | |
658 | (insert-before-markers (substring string 0 start)) | |
659 | (if (= ?\f (aref string start)) | |
660 | (progn | |
661 | (if (not (bolp)) | |
662 | (insert-before-markers ?\n)) | |
663 | (insert-before-markers ?\f)) | |
664 | (beep)) | |
665 | (setq string (substring string (1+ start))))) | |
666 | (insert-before-markers string))))) | |
667 | ||
668 | (defun xscheme-guarantee-newlines (n) | |
669 | (if xscheme-allow-output-p | |
670 | (save-excursion | |
671 | (xscheme-goto-output-point) | |
672 | (let ((stop nil)) | |
673 | (while (and (not stop) | |
674 | (bolp)) | |
675 | (setq n (1- n)) | |
676 | (if (bobp) | |
677 | (setq stop t) | |
678 | (backward-char)))) | |
679 | (xscheme-goto-output-point) | |
680 | (while (> n 0) | |
681 | (insert-before-markers ?\n) | |
682 | (setq n (1- n)))))) | |
683 | ||
684 | (defun xscheme-goto-output-point () | |
685 | (let ((process (get-process "scheme"))) | |
686 | (set-buffer (process-buffer process)) | |
687 | (goto-char (process-mark process)))) | |
688 | ||
689 | (defun xscheme-modeline-initialize () | |
690 | (setq xscheme-runlight-string "") | |
691 | (setq xscheme-mode-string "") | |
692 | (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string))) | |
693 | ||
694 | (defun xscheme-set-runlight (runlight) | |
695 | (setq xscheme-runlight-string runlight) | |
390d1087 | 696 | (force-mode-line-update t)) |
a1ad21ca CH |
697 | \f |
698 | ;;;; Process Filter Operations | |
699 | ||
700 | (defvar xscheme-process-filter-alist | |
701 | '((?D xscheme-enter-debugger-mode | |
702 | xscheme-process-filter:string-action) | |
703 | (?E xscheme-eval | |
704 | xscheme-process-filter:string-action) | |
705 | (?P xscheme-set-prompt-variable | |
706 | xscheme-process-filter:string-action) | |
707 | (?R xscheme-enter-interaction-mode | |
708 | xscheme-process-filter:simple-action) | |
709 | (?b xscheme-start-gc | |
710 | xscheme-process-filter:simple-action) | |
711 | (?e xscheme-finish-gc | |
712 | xscheme-process-filter:simple-action) | |
713 | (?f xscheme-exit-input-wait | |
714 | xscheme-process-filter:simple-action) | |
715 | (?g xscheme-enable-control-g | |
716 | xscheme-process-filter:simple-action) | |
717 | (?i xscheme-prompt-for-expression | |
718 | xscheme-process-filter:string-action) | |
719 | (?m xscheme-message | |
720 | xscheme-process-filter:string-action) | |
721 | (?n xscheme-prompt-for-confirmation | |
722 | xscheme-process-filter:string-action) | |
723 | (?o xscheme-output-goto | |
724 | xscheme-process-filter:simple-action) | |
725 | (?p xscheme-set-prompt | |
726 | xscheme-process-filter:string-action) | |
727 | (?s xscheme-enter-input-wait | |
728 | xscheme-process-filter:simple-action) | |
729 | (?v xscheme-write-value | |
730 | xscheme-process-filter:string-action) | |
731 | (?w xscheme-cd | |
732 | xscheme-process-filter:string-action) | |
733 | (?z xscheme-display-process-buffer | |
734 | xscheme-process-filter:simple-action) | |
735 | (?c xscheme-unsolicited-read-char | |
736 | xscheme-process-filter:simple-action)) | |
737 | "Table used to decide how to handle process filter commands. | |
738 | Value is a list of entries, each entry is a list of three items. | |
739 | ||
740 | The first item is the character that the process filter dispatches on. | |
741 | The second item is the action to be taken, a function. | |
742 | The third item is the handler for the entry, a function. | |
743 | ||
744 | When the process filter sees a command whose character matches a | |
745 | particular entry, it calls the handler with two arguments: the action | |
746 | and the string containing the rest of the process filter's input | |
747 | stream. It is the responsibility of the handler to invoke the action | |
748 | with the appropriate arguments, and to reenter the process filter with | |
749 | the remaining input.") | |
750 | \f | |
751 | (defun xscheme-process-filter:simple-action (action) | |
752 | (setq xscheme-process-filter-state 'idle) | |
753 | (funcall action)) | |
754 | ||
755 | (defun xscheme-process-filter:string-action (action) | |
756 | (setq xscheme-string-receiver action) | |
757 | (setq xscheme-string-accumulator "") | |
758 | (setq xscheme-process-filter-state 'reading-string)) | |
759 | ||
760 | (defconst xscheme-runlight:running "run" | |
761 | "The character displayed when the Scheme process is running.") | |
762 | ||
763 | (defconst xscheme-runlight:input "input" | |
764 | "The character displayed when the Scheme process is waiting for input.") | |
765 | ||
766 | (defconst xscheme-runlight:gc "gc" | |
767 | "The character displayed when the Scheme process is garbage collecting.") | |
768 | ||
769 | (defun xscheme-start-gc () | |
770 | (xscheme-set-runlight xscheme-runlight:gc)) | |
771 | ||
772 | (defun xscheme-finish-gc () | |
773 | (xscheme-set-runlight | |
774 | (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) | |
775 | ||
776 | (defun xscheme-enter-input-wait () | |
777 | (xscheme-set-runlight xscheme-runlight:input) | |
778 | (setq xscheme-running-p nil)) | |
779 | ||
780 | (defun xscheme-exit-input-wait () | |
781 | (xscheme-set-runlight xscheme-runlight:running) | |
782 | (setq xscheme-running-p t)) | |
783 | ||
784 | (defun xscheme-enable-control-g () | |
785 | (setq xscheme-control-g-disabled-p nil)) | |
786 | ||
787 | (defun xscheme-display-process-buffer () | |
788 | (let ((window (or (xscheme-process-buffer-window) | |
789 | (display-buffer (xscheme-process-buffer))))) | |
790 | (save-window-excursion | |
791 | (select-window window) | |
792 | (xscheme-goto-output-point) | |
793 | (if (xscheme-debugger-mode-p) | |
794 | (xscheme-enter-interaction-mode))))) | |
795 | ||
796 | (defun xscheme-unsolicited-read-char () | |
797 | nil) | |
798 | \f | |
799 | (defun xscheme-eval (string) | |
800 | (eval (car (read-from-string string)))) | |
801 | ||
802 | (defun xscheme-message (string) | |
803 | (if (not (zerop (length string))) | |
804 | (xscheme-write-message-1 string (format ";%s" string)))) | |
805 | ||
806 | (defun xscheme-write-value (string) | |
807 | (if (zerop (length string)) | |
808 | (xscheme-write-message-1 "(no value)" ";No value") | |
809 | (xscheme-write-message-1 string (format ";Value: %s" string)))) | |
810 | ||
811 | (defun xscheme-write-message-1 (message-string output-string) | |
812 | (let* ((process (get-process "scheme")) | |
813 | (window (get-buffer-window (process-buffer process)))) | |
814 | (if (or (not window) | |
815 | (not (pos-visible-in-window-p (process-mark process) | |
816 | window))) | |
817 | (message "%s" message-string))) | |
818 | (xscheme-guarantee-newlines 1) | |
819 | (xscheme-process-filter-output output-string)) | |
820 | ||
821 | (defun xscheme-set-prompt-variable (string) | |
822 | (setq xscheme-prompt string)) | |
823 | ||
824 | (defun xscheme-set-prompt (string) | |
825 | (setq xscheme-prompt string) | |
826 | (xscheme-guarantee-newlines 2) | |
827 | (setq xscheme-mode-string (xscheme-coerce-prompt string)) | |
390d1087 | 828 | (force-mode-line-update t)) |
a1ad21ca CH |
829 | |
830 | (defun xscheme-output-goto () | |
831 | (xscheme-goto-output-point) | |
832 | (xscheme-guarantee-newlines 2)) | |
833 | ||
834 | (defun xscheme-coerce-prompt (string) | |
835 | (if (string-match "^[0-9]+ " string) | |
836 | (let ((end (match-end 0))) | |
837 | (concat (substring string 0 end) | |
838 | (let ((prompt (substring string end))) | |
839 | (let ((entry (assoc prompt xscheme-prompt-alist))) | |
840 | (if entry | |
841 | (cdr entry) | |
842 | prompt))))) | |
843 | string)) | |
844 | ||
845 | (defvar xscheme-prompt-alist | |
846 | '(("[Normal REPL]" . "[Evaluator]") | |
847 | ("[Error REPL]" . "[Evaluator]") | |
848 | ("[Breakpoint REPL]" . "[Evaluator]") | |
849 | ("[Debugger REPL]" . "[Evaluator]") | |
850 | ("[Visiting environment]" . "[Evaluator]") | |
851 | ("[Environment Inspector]" . "[Where]")) | |
852 | "An alist which maps the Scheme command interpreter type to a print string.") | |
853 | ||
854 | (defun xscheme-cd (directory-string) | |
855 | (save-excursion | |
856 | (set-buffer (xscheme-process-buffer)) | |
857 | (cd directory-string))) | |
858 | \f | |
859 | (defun xscheme-prompt-for-confirmation (prompt-string) | |
860 | (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n))) | |
861 | ||
862 | (defun xscheme-prompt-for-expression (prompt-string) | |
863 | (xscheme-send-string-2 | |
864 | (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map))) | |
865 | ||
866 | (defvar xscheme-prompt-for-expression-map nil) | |
867 | (if (not xscheme-prompt-for-expression-map) | |
868 | (progn | |
869 | (setq xscheme-prompt-for-expression-map | |
870 | (copy-keymap minibuffer-local-map)) | |
871 | (substitute-key-definition 'exit-minibuffer | |
872 | 'xscheme-prompt-for-expression-exit | |
873 | xscheme-prompt-for-expression-map))) | |
874 | ||
875 | (defun xscheme-prompt-for-expression-exit () | |
876 | (interactive) | |
877 | (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one) | |
878 | (exit-minibuffer) | |
879 | (error "input must be a single, complete expression"))) | |
880 | ||
881 | (defun xscheme-region-expression-p (start end) | |
882 | (save-excursion | |
883 | (let ((old-syntax-table (syntax-table))) | |
884 | (unwind-protect | |
885 | (progn | |
886 | (set-syntax-table scheme-mode-syntax-table) | |
887 | (let ((state (parse-partial-sexp start end))) | |
888 | (and (zerop (car state)) ;depth = 0 | |
889 | (nth 2 state) ;last-sexp exists, i.e. >= 1 sexps | |
890 | (let ((state (parse-partial-sexp start (nth 2 state)))) | |
891 | (if (nth 2 state) 'many 'one))))) | |
892 | (set-syntax-table old-syntax-table))))) | |
76d7458e | 893 | |
ff383ac0 RS |
894 | (provide 'xscheme) |
895 | ||
76d7458e | 896 | ;;; xscheme.el ends here |