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