Commit | Line | Data |
---|---|---|
d5031a2a | 1 | ;;; xscheme.el --- run MIT Scheme under Emacs -*- lexical-binding: t; -*- |
c5c3d778 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1986-1987, 1989-1990, 2001-2014 Free Software |
ab422c4d | 4 | ;; Foundation, Inc. |
c5c3d778 | 5 | |
34dc21db | 6 | ;; Maintainer: emacs-devel@gnu.org |
c5c3d778 DL |
7 | ;; Keywords: languages, lisp |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
b1fc2b50 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
c5c3d778 | 12 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
c5c3d778 DL |
15 | |
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
c5c3d778 DL |
23 | |
24 | ;;; Commentary: | |
25 | ||
26 | ;; A major mode for interacting with MIT Scheme. | |
27 | ;; | |
28 | ;; Requires MIT Scheme release 5 or later. | |
29 | ;; Changes to Control-G handler require runtime version 13.85 or later. | |
30 | ||
31 | ;;; Code: | |
32 | ||
33 | (require 'scheme) | |
f28d4b0f JB |
34 | |
35 | ;;;; Internal Variables | |
36 | ||
37 | (defvar xscheme-previous-mode) | |
f28d4b0f JB |
38 | (defvar xscheme-last-input-end) |
39 | ||
40 | (defvar xscheme-process-command-line nil | |
41 | "Command used to start the most recent Scheme process.") | |
42 | ||
43 | (defvar xscheme-process-name "scheme" | |
44 | "Name of xscheme process that we're currently interacting with.") | |
45 | ||
46 | (defvar xscheme-buffer-name "*scheme*" | |
47 | "Name of xscheme buffer that we're currently interacting with.") | |
48 | ||
49 | (defvar xscheme-expressions-ring-max 30 | |
fb7ada5f | 50 | "Maximum length of Scheme expressions ring.") |
f28d4b0f | 51 | |
d5031a2a | 52 | (defvar-local xscheme-expressions-ring nil |
f28d4b0f JB |
53 | "List of expressions recently transmitted to the Scheme process.") |
54 | ||
d5031a2a | 55 | (defvar-local xscheme-expressions-ring-yank-pointer nil |
f28d4b0f JB |
56 | "The tail of the Scheme expressions ring whose car is the last thing yanked.") |
57 | ||
d5031a2a | 58 | (defvar-local xscheme-running-p nil |
f28d4b0f JB |
59 | "This variable, if nil, indicates that the scheme process is |
60 | waiting for input. Otherwise, it is busy evaluating something.") | |
61 | ||
62 | (defconst xscheme-control-g-synchronization-p t | |
63 | "If non-nil, insert markers in the scheme input stream to indicate when | |
64 | control-g interrupts were signaled. Do not allow more control-g's to be | |
65 | signaled until the scheme process acknowledges receipt.") | |
66 | ||
d5031a2a | 67 | (defvar-local xscheme-control-g-disabled-p nil |
f28d4b0f JB |
68 | "This variable, if non-nil, indicates that a control-g is being processed |
69 | by the scheme process, so additional control-g's are to be ignored.") | |
70 | ||
71 | (defvar xscheme-string-receiver nil | |
72 | "Procedure to send the string argument from the scheme process.") | |
73 | ||
74 | (defconst default-xscheme-runlight | |
75 | '(": " xscheme-runlight-string) | |
37269466 | 76 | "Default global (shared) xscheme-runlight mode line format.") |
f28d4b0f JB |
77 | |
78 | (defvar xscheme-runlight "") | |
79 | (defvar xscheme-runlight-string nil) | |
80 | ||
d5031a2a | 81 | (defvar-local xscheme-process-filter-state 'idle |
f28d4b0f JB |
82 | "State of scheme process escape reader state machine: |
83 | idle waiting for an escape sequence | |
84 | reading-type received an altmode but nothing else | |
85 | reading-string reading prompt string") | |
86 | ||
d5031a2a | 87 | (defvar-local xscheme-allow-output-p t |
f28d4b0f JB |
88 | "This variable, if nil, prevents output from the scheme process |
89 | from being inserted into the process-buffer.") | |
90 | ||
d5031a2a | 91 | (defvar-local xscheme-prompt "" |
f28d4b0f JB |
92 | "The current scheme prompt string.") |
93 | ||
d5031a2a | 94 | (defvar-local xscheme-string-accumulator "" |
f28d4b0f JB |
95 | "Accumulator for the string being received from the scheme process.") |
96 | ||
d5031a2a LL |
97 | (defvar-local xscheme-mode-string nil) |
98 | (setq-default scheme-mode-line-process '("" xscheme-runlight)) | |
99 | (make-variable-buffer-local 'scheme-mode-line-process) | |
100 | ||
c5c3d778 DL |
101 | \f |
102 | (defgroup xscheme nil | |
103 | "Major mode for editing Scheme and interacting with MIT's C-Scheme." | |
104 | :group 'lisp) | |
105 | ||
106 | (defcustom scheme-band-name nil | |
fb7ada5f | 107 | "Band loaded by the `run-scheme' command." |
c5c3d778 DL |
108 | :type '(choice (const nil) string) |
109 | :group 'xscheme) | |
110 | ||
111 | (defcustom scheme-program-arguments nil | |
fb7ada5f | 112 | "Arguments passed to the Scheme program by the `run-scheme' command." |
c5c3d778 DL |
113 | :type '(choice (const nil) string) |
114 | :group 'xscheme) | |
115 | ||
116 | (defcustom xscheme-allow-pipelined-evaluation t | |
117 | "If non-nil, an expression may be transmitted while another is evaluating. | |
118 | Otherwise, attempting to evaluate an expression before the previous expression | |
119 | has finished evaluating will signal an error." | |
120 | :type 'boolean | |
121 | :group 'xscheme) | |
122 | ||
123 | (defcustom xscheme-startup-message | |
124 | "This is the Scheme process buffer. | |
8cb95edf | 125 | Type \\[xscheme-send-previous-expression] to evaluate the expression before point. |
c5c3d778 DL |
126 | Type \\[xscheme-send-control-g-interrupt] to abort evaluation. |
127 | Type \\[describe-mode] for more information. | |
128 | ||
129 | " | |
130 | "String to insert into Scheme process buffer first time it is started. | |
131 | Is processed with `substitute-command-keys' first." | |
132 | :type 'string | |
133 | :group 'xscheme) | |
134 | ||
135 | (defcustom xscheme-signal-death-message nil | |
136 | "If non-nil, causes a message to be generated when the Scheme process dies." | |
137 | :type 'boolean | |
138 | :group 'xscheme) | |
139 | ||
140 | (defcustom xscheme-start-hook nil | |
141 | "If non-nil, a procedure to call when the Scheme process is started. | |
142 | When called, the current buffer will be the Scheme process-buffer." | |
143 | :type 'hook | |
144 | :group 'xscheme | |
145 | :version "20.3") | |
146 | ||
147 | (defun xscheme-evaluation-commands (keymap) | |
148 | (define-key keymap "\e\C-x" 'xscheme-send-definition) | |
8cb95edf SM |
149 | (define-key keymap "\C-x\C-e" 'xscheme-send-previous-expression) |
150 | (put 'xscheme-send-previous-expression :advertised-binding "\C-x\C-e") | |
c5c3d778 DL |
151 | (define-key keymap "\eo" 'xscheme-send-buffer) |
152 | (define-key keymap "\ez" 'xscheme-send-definition) | |
153 | (define-key keymap "\e\C-m" 'xscheme-send-previous-expression) | |
154 | (define-key keymap "\e\C-z" 'xscheme-send-region)) | |
155 | ||
156 | (defun xscheme-interrupt-commands (keymap) | |
157 | (define-key keymap "\C-c\C-s" 'xscheme-select-process-buffer) | |
158 | (define-key keymap "\C-c\C-b" 'xscheme-send-breakpoint-interrupt) | |
159 | (define-key keymap "\C-c\C-c" 'xscheme-send-control-g-interrupt) | |
160 | (define-key keymap "\C-c\C-u" 'xscheme-send-control-u-interrupt) | |
161 | (define-key keymap "\C-c\C-x" 'xscheme-send-control-x-interrupt)) | |
162 | ||
163 | (xscheme-evaluation-commands scheme-mode-map) | |
164 | (xscheme-interrupt-commands scheme-mode-map) | |
165 | \f | |
166 | (defun run-scheme (command-line) | |
167 | "Run MIT Scheme in an inferior process. | |
168 | Output goes to the buffer `*scheme*'. | |
169 | With argument, asks for a command line." | |
170 | (interactive (list (xscheme-read-command-line current-prefix-arg))) | |
171 | (xscheme-start command-line xscheme-process-name xscheme-buffer-name)) | |
172 | ||
173 | (defun xscheme-start (command-line process-name buffer-name) | |
174 | (setq-default xscheme-process-command-line command-line) | |
175 | (switch-to-buffer | |
176 | (xscheme-start-process command-line process-name buffer-name)) | |
175069ef | 177 | (set (make-local-variable 'xscheme-process-command-line) command-line)) |
c5c3d778 DL |
178 | |
179 | (defun xscheme-read-command-line (arg) | |
180 | (let ((default | |
181 | (or xscheme-process-command-line | |
182 | (xscheme-default-command-line)))) | |
183 | (if arg | |
184 | (read-string "Run Scheme: " default) | |
185 | default))) | |
186 | ||
187 | (defun xscheme-default-command-line () | |
188 | (concat scheme-program-name " -emacs" | |
189 | (if scheme-program-arguments | |
190 | (concat " " scheme-program-arguments) | |
191 | "") | |
192 | (if scheme-band-name | |
193 | (concat " -band " scheme-band-name) | |
194 | ""))) | |
195 | ||
196 | (defun reset-scheme () | |
197 | "Reset the Scheme process." | |
198 | (interactive) | |
199 | (let ((process (get-process xscheme-process-name))) | |
200 | (cond ((or (not process) | |
201 | (not (eq (process-status process) 'run)) | |
202 | (yes-or-no-p | |
203 | "The Scheme process is running, are you SURE you want to reset it? ")) | |
204 | (message "Resetting Scheme process...") | |
205 | (if process | |
206 | (progn | |
207 | (kill-process process t) | |
208 | (delete-process process))) | |
209 | (xscheme-start-process xscheme-process-command-line | |
210 | xscheme-process-name | |
211 | xscheme-buffer-name) | |
212 | (message "Resetting Scheme process...done"))))) | |
213 | \f | |
214 | ;;;; Multiple Scheme buffer management commands | |
215 | ||
216 | (defun start-scheme (buffer-name &optional globally) | |
217 | "Choose a scheme interaction buffer, or create a new one." | |
218 | ;; (interactive "BScheme interaction buffer: \nP") | |
219 | (interactive | |
220 | (list (read-buffer "Scheme interaction buffer: " | |
221 | xscheme-buffer-name | |
222 | nil) | |
223 | current-prefix-arg)) | |
224 | (let ((buffer (get-buffer-create buffer-name))) | |
225 | (let ((process (get-buffer-process buffer))) | |
226 | (if process | |
227 | (switch-to-buffer buffer) | |
228 | (if (or (not (buffer-file-name buffer)) | |
229 | (yes-or-no-p (concat "Buffer " | |
230 | (buffer-name buffer) | |
231 | " contains file " | |
232 | (buffer-file-name buffer) | |
233 | "; start scheme in it? "))) | |
234 | (progn | |
235 | (xscheme-start (xscheme-read-command-line t) | |
236 | buffer-name | |
237 | buffer-name) | |
238 | (if globally | |
239 | (global-set-scheme-interaction-buffer buffer-name))) | |
240 | (message "start-scheme aborted")))))) | |
241 | ||
242 | (fset 'select-scheme 'start-scheme) | |
243 | ||
244 | (defun global-set-scheme-interaction-buffer (buffer-name) | |
245 | "Set the default scheme interaction buffer." | |
246 | (interactive | |
247 | (list (read-buffer "Scheme interaction buffer: " | |
248 | xscheme-buffer-name | |
249 | t))) | |
250 | (let ((process-name (verify-xscheme-buffer buffer-name nil))) | |
251 | (setq-default xscheme-buffer-name buffer-name) | |
252 | (setq-default xscheme-process-name process-name) | |
253 | (setq-default xscheme-runlight-string | |
9a529312 SM |
254 | (with-current-buffer buffer-name |
255 | xscheme-runlight-string)) | |
c5c3d778 DL |
256 | (setq-default xscheme-runlight |
257 | (if (eq (process-status process-name) 'run) | |
258 | default-xscheme-runlight | |
259 | "")))) | |
260 | ||
261 | (defun local-set-scheme-interaction-buffer (buffer-name) | |
262 | "Set the scheme interaction buffer for the current buffer." | |
263 | (interactive | |
264 | (list (read-buffer "Scheme interaction buffer: " | |
265 | xscheme-buffer-name | |
266 | t))) | |
267 | (let ((process-name (verify-xscheme-buffer buffer-name t))) | |
175069ef SM |
268 | (set (make-local-variable 'xscheme-buffer-name) buffer-name) |
269 | (set (make-local-variable 'xscheme-process-name) process-name) | |
270 | (set (make-local-variable 'xscheme-runlight) | |
271 | (with-current-buffer buffer-name | |
272 | xscheme-runlight)))) | |
c5c3d778 DL |
273 | |
274 | (defun local-clear-scheme-interaction-buffer () | |
275 | "Make the current buffer use the default scheme interaction buffer." | |
276 | (interactive) | |
277 | (if (xscheme-process-buffer-current-p) | |
278 | (error "Cannot change the interaction buffer of an interaction buffer")) | |
279 | (kill-local-variable 'xscheme-buffer-name) | |
280 | (kill-local-variable 'xscheme-process-name) | |
281 | (kill-local-variable 'xscheme-runlight)) | |
282 | ||
283 | (defun verify-xscheme-buffer (buffer-name localp) | |
284 | (if (and localp (xscheme-process-buffer-current-p)) | |
285 | (error "Cannot change the interaction buffer of an interaction buffer")) | |
286 | (let* ((buffer (get-buffer buffer-name)) | |
287 | (process (and buffer (get-buffer-process buffer)))) | |
288 | (cond ((not buffer) | |
ac72d80b | 289 | (error "Buffer `%s' does not exist" buffer-name)) |
c5c3d778 | 290 | ((not process) |
ac72d80b | 291 | (error "Buffer `%s' is not a scheme interaction buffer" buffer-name)) |
c5c3d778 | 292 | (t |
9a529312 | 293 | (with-current-buffer buffer |
c5c3d778 | 294 | (if (not (xscheme-process-buffer-current-p)) |
ac72d80b | 295 | (error "Buffer `%s' is not a scheme interaction buffer" |
c5c3d778 DL |
296 | buffer-name))) |
297 | (process-name process))))) | |
298 | \f | |
299 | ;;;; Interaction Mode | |
300 | ||
301 | (defun scheme-interaction-mode (&optional preserve) | |
302 | "Major mode for interacting with an inferior MIT Scheme process. | |
303 | Like scheme-mode except that: | |
304 | ||
8cb95edf | 305 | \\[xscheme-send-previous-expression] sends the expression before point to the Scheme process as input |
c5c3d778 DL |
306 | \\[xscheme-yank-pop] yanks an expression previously sent to Scheme |
307 | \\[xscheme-yank-push] yanks an expression more recently sent to Scheme | |
308 | ||
309 | All output from the Scheme process is written in the Scheme process | |
310 | buffer, which is initially named \"*scheme*\". The result of | |
311 | evaluating a Scheme expression is also printed in the process buffer, | |
312 | preceded by the string \";Value: \" to highlight it. If the process | |
313 | buffer is not visible at that time, the value will also be displayed | |
314 | in the minibuffer. If an error occurs, the process buffer will | |
315 | automatically pop up to show you the error message. | |
316 | ||
37269466 | 317 | While the Scheme process is running, the mode lines of all buffers in |
c5c3d778 DL |
318 | scheme-mode are modified to show the state of the process. The |
319 | possible states and their meanings are: | |
320 | ||
321 | input waiting for input | |
322 | run evaluating | |
323 | gc garbage collecting | |
324 | ||
37269466 | 325 | The process buffer's mode line contains additional information where |
c5c3d778 DL |
326 | the buffer's name is normally displayed: the command interpreter level |
327 | and type. | |
328 | ||
329 | Scheme maintains a stack of command interpreters. Every time an error | |
330 | or breakpoint occurs, the current command interpreter is pushed on the | |
331 | command interpreter stack, and a new command interpreter is started. | |
332 | One example of why this is done is so that an error that occurs while | |
333 | you are debugging another error will not destroy the state of the | |
334 | initial error, allowing you to return to it after the second error has | |
335 | been fixed. | |
336 | ||
337 | The command interpreter level indicates how many interpreters are in | |
338 | the command interpreter stack. It is initially set to one, and it is | |
339 | incremented every time that stack is pushed, and decremented every | |
340 | time it is popped. The following commands are useful for manipulating | |
341 | the command interpreter stack: | |
342 | ||
343 | \\[xscheme-send-breakpoint-interrupt] pushes the stack once | |
344 | \\[xscheme-send-control-u-interrupt] pops the stack once | |
345 | \\[xscheme-send-control-g-interrupt] pops everything off | |
346 | \\[xscheme-send-control-x-interrupt] aborts evaluation, doesn't affect stack | |
347 | ||
348 | Some possible command interpreter types and their meanings are: | |
349 | ||
350 | \[Evaluator] read-eval-print loop for evaluating expressions | |
351 | \[Debugger] single character commands for debugging errors | |
352 | \[Where] single character commands for examining environments | |
353 | ||
354 | Starting with release 6.2 of Scheme, the latter two types of command | |
355 | interpreters will change the major mode of the Scheme process buffer | |
356 | to scheme-debugger-mode , in which the evaluation commands are | |
357 | disabled, and the keys which normally self insert instead send | |
358 | themselves to the Scheme process. The command character ? will list | |
359 | the available commands. | |
360 | ||
361 | For older releases of Scheme, the major mode will be be | |
362 | scheme-interaction-mode , and the command characters must be sent as | |
363 | if they were expressions. | |
364 | ||
365 | Commands: | |
366 | Delete converts tabs to spaces as it moves back. | |
367 | Blank lines separate paragraphs. Semicolons start comments. | |
368 | \\{scheme-interaction-mode-map} | |
369 | ||
370 | Entry to this mode calls the value of scheme-interaction-mode-hook | |
371 | with no args, if that value is non-nil. | |
372 | Likewise with the value of scheme-mode-hook. | |
373 | scheme-interaction-mode-hook is called after scheme-mode-hook." | |
175069ef | 374 | ;; FIXME: Use define-derived-mode. |
c5c3d778 DL |
375 | (interactive "P") |
376 | (if (not preserve) | |
377 | (let ((previous-mode major-mode)) | |
378 | (kill-all-local-variables) | |
c5c3d778 DL |
379 | (make-local-variable 'xscheme-runlight-string) |
380 | (make-local-variable 'xscheme-runlight) | |
175069ef | 381 | (set (make-local-variable 'xscheme-previous-mode) previous-mode) |
c5c3d778 | 382 | (let ((buffer (current-buffer))) |
175069ef SM |
383 | (set (make-local-variable 'xscheme-buffer-name) (buffer-name buffer)) |
384 | (set (make-local-variable 'xscheme-last-input-end) (make-marker)) | |
c5c3d778 | 385 | (let ((process (get-buffer-process buffer))) |
bcd7a0a4 SM |
386 | (when process |
387 | (setq-local xscheme-process-name (process-name process)) | |
388 | ;; FIXME: Use add-function! | |
389 | (xscheme-process-filter-initialize t) | |
390 | (xscheme-mode-line-initialize xscheme-buffer-name) | |
391 | (add-function :override (process-sentinel process) | |
392 | #'xscheme-process-sentinel) | |
393 | (add-function :override (process-filter process) | |
394 | #'xscheme-process-filter)))))) | |
c5c3d778 DL |
395 | (scheme-interaction-mode-initialize) |
396 | (scheme-mode-variables) | |
9a969196 | 397 | (run-mode-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook)) |
c5c3d778 DL |
398 | |
399 | (defun exit-scheme-interaction-mode () | |
bcd7a0a4 | 400 | "Take buffer out of scheme interaction mode." |
c5c3d778 | 401 | (interactive) |
175069ef | 402 | (if (not (derived-mode-p 'scheme-interaction-mode)) |
c5c3d778 | 403 | (error "Buffer not in scheme interaction mode")) |
bcd7a0a4 SM |
404 | (funcall xscheme-previous-mode) |
405 | (let ((process (get-buffer-process (current-buffer)))) | |
406 | (when process | |
407 | (remove-function (process-sentinel process) #'xscheme-process-sentinel) | |
408 | (remove-function (process-filter process) #'xscheme-process-filter)))) | |
c5c3d778 | 409 | |
f28d4b0f JB |
410 | (defvar scheme-interaction-mode-commands-alist nil) |
411 | (defvar scheme-interaction-mode-map nil) | |
412 | ||
c5c3d778 DL |
413 | (defun scheme-interaction-mode-initialize () |
414 | (use-local-map scheme-interaction-mode-map) | |
175069ef | 415 | (setq major-mode 'scheme-interaction-mode) ;FIXME: Use define-derived-mode. |
c5c3d778 DL |
416 | (setq mode-name "Scheme Interaction")) |
417 | ||
418 | (defun scheme-interaction-mode-commands (keymap) | |
419 | (let ((entries scheme-interaction-mode-commands-alist)) | |
420 | (while entries | |
421 | (define-key keymap | |
422 | (car (car entries)) | |
423 | (car (cdr (car entries)))) | |
424 | (setq entries (cdr entries))))) | |
425 | ||
f28d4b0f | 426 | ;; Initialize the command alist |
c5c3d778 DL |
427 | (setq scheme-interaction-mode-commands-alist |
428 | (append scheme-interaction-mode-commands-alist | |
429 | '(("\C-c\C-m" xscheme-send-current-line) | |
430 | ("\C-c\C-o" xscheme-delete-output) | |
431 | ("\C-c\C-p" xscheme-send-proceed) | |
432 | ("\C-c\C-y" xscheme-yank) | |
433 | ("\ep" xscheme-yank-pop) | |
434 | ("\en" xscheme-yank-push)))) | |
435 | ||
f28d4b0f | 436 | ;; Initialize the mode map |
c5c3d778 DL |
437 | (if (not scheme-interaction-mode-map) |
438 | (progn | |
439 | (setq scheme-interaction-mode-map (make-keymap)) | |
440 | (scheme-mode-commands scheme-interaction-mode-map) | |
441 | (xscheme-interrupt-commands scheme-interaction-mode-map) | |
442 | (xscheme-evaluation-commands scheme-interaction-mode-map) | |
443 | (scheme-interaction-mode-commands scheme-interaction-mode-map))) | |
444 | ||
445 | (defun xscheme-enter-interaction-mode () | |
9a529312 | 446 | (with-current-buffer (xscheme-process-buffer) |
175069ef SM |
447 | (if (not (derived-mode-p 'scheme-interaction-mode)) |
448 | (if (derived-mode-p 'scheme-debugger-mode) | |
c5c3d778 DL |
449 | (scheme-interaction-mode-initialize) |
450 | (scheme-interaction-mode t))))) | |
451 | ||
8cb95edf SM |
452 | (define-obsolete-function-alias 'advertised-xscheme-send-previous-expression |
453 | 'xscheme-send-previous-expression "23.2") | |
c5c3d778 DL |
454 | \f |
455 | ;;;; Debugger Mode | |
456 | ||
457 | (defun scheme-debugger-mode () | |
458 | "Major mode for executing the Scheme debugger. | |
459 | Like scheme-mode except that the evaluation commands | |
460 | are disabled, and characters that would normally be self inserting are | |
461 | sent to the Scheme process instead. Typing ? will show you which | |
462 | characters perform useful functions. | |
463 | ||
464 | Commands: | |
465 | \\{scheme-debugger-mode-map}" | |
eac9c0ef | 466 | (error "Invalid entry to scheme-debugger-mode")) |
c5c3d778 | 467 | |
f28d4b0f JB |
468 | (defvar scheme-debugger-mode-map nil) |
469 | ||
c5c3d778 DL |
470 | (defun scheme-debugger-mode-initialize () |
471 | (use-local-map scheme-debugger-mode-map) | |
175069ef | 472 | (setq major-mode 'scheme-debugger-mode) ;FIXME: Use define-derived-mode. |
c5c3d778 DL |
473 | (setq mode-name "Scheme Debugger")) |
474 | ||
475 | (defun scheme-debugger-mode-commands (keymap) | |
f28d4b0f | 476 | (let ((char ?\s)) |
c5c3d778 DL |
477 | (while (< char 127) |
478 | (define-key keymap (char-to-string char) 'scheme-debugger-self-insert) | |
479 | (setq char (1+ char))))) | |
480 | ||
f28d4b0f | 481 | ;; Initialize the debugger mode map |
c5c3d778 DL |
482 | (if (not scheme-debugger-mode-map) |
483 | (progn | |
484 | (setq scheme-debugger-mode-map (make-keymap)) | |
485 | (scheme-mode-commands scheme-debugger-mode-map) | |
486 | (xscheme-interrupt-commands scheme-debugger-mode-map) | |
487 | (scheme-debugger-mode-commands scheme-debugger-mode-map))) | |
488 | ||
489 | (defun scheme-debugger-self-insert () | |
490 | "Transmit this character to the Scheme process." | |
491 | (interactive) | |
1ba983e8 | 492 | (xscheme-send-char last-command-event)) |
c5c3d778 | 493 | |
e02f48d7 | 494 | (defun xscheme-enter-debugger-mode (_prompt-string) |
9a529312 | 495 | (with-current-buffer (xscheme-process-buffer) |
175069ef | 496 | (if (not (derived-mode-p 'scheme-debugger-mode)) |
c5c3d778 | 497 | (progn |
175069ef | 498 | (if (not (derived-mode-p 'scheme-interaction-mode)) |
c5c3d778 DL |
499 | (scheme-interaction-mode t)) |
500 | (scheme-debugger-mode-initialize))))) | |
501 | ||
502 | (defun xscheme-debugger-mode-p () | |
503 | (let ((buffer (xscheme-process-buffer))) | |
504 | (and buffer | |
9a529312 | 505 | (with-current-buffer buffer |
175069ef | 506 | (derived-mode-p 'scheme-debugger-mode))))) |
c5c3d778 DL |
507 | \f |
508 | ;;;; Evaluation Commands | |
509 | ||
510 | (defun xscheme-send-string (&rest strings) | |
511 | "Send the string arguments to the Scheme process. | |
512 | The strings are concatenated and terminated by a newline." | |
513 | (cond ((not (xscheme-process-running-p)) | |
514 | (if (yes-or-no-p "The Scheme process has died. Reset it? ") | |
515 | (progn | |
516 | (reset-scheme) | |
517 | (xscheme-wait-for-process) | |
518 | (xscheme-send-string-1 strings)))) | |
519 | ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) | |
520 | ((and (not xscheme-allow-pipelined-evaluation) | |
521 | xscheme-running-p) | |
522 | (error "No sends allowed while Scheme running")) | |
523 | (t (xscheme-send-string-1 strings)))) | |
524 | ||
525 | (defun xscheme-send-string-1 (strings) | |
526 | (let ((string (apply 'concat strings))) | |
527 | (xscheme-send-string-2 string) | |
175069ef | 528 | (if (derived-mode-p 'scheme-interaction-mode) |
c5c3d778 DL |
529 | (xscheme-insert-expression string)))) |
530 | ||
531 | (defun xscheme-send-string-2 (string) | |
532 | (let ((process (get-process xscheme-process-name))) | |
533 | (process-send-string process (concat string "\n")) | |
534 | (if (xscheme-process-buffer-current-p) | |
535 | (set-marker (process-mark process) (point))))) | |
536 | ||
537 | (defun xscheme-select-process-buffer () | |
538 | "Select the Scheme process buffer and move to its output point." | |
539 | (interactive) | |
540 | (let ((process | |
541 | (or (get-process xscheme-process-name) | |
542 | (error "No scheme process")))) | |
543 | (let ((buffer (or (process-buffer process) (error "No process buffer")))) | |
544 | (let ((window (get-buffer-window buffer))) | |
545 | (if window | |
546 | (select-window window) | |
547 | (switch-to-buffer buffer)) | |
548 | (goto-char (process-mark process)))))) | |
549 | \f | |
550 | ;;;; Scheme expressions ring | |
551 | ||
552 | (defun xscheme-insert-expression (string) | |
662705b1 KS |
553 | (setq xscheme-expressions-ring-yank-pointer |
554 | (add-to-history 'xscheme-expressions-ring string | |
555 | xscheme-expressions-ring-max))) | |
c5c3d778 DL |
556 | |
557 | (defun xscheme-rotate-yank-pointer (arg) | |
558 | "Rotate the yanking point in the kill ring." | |
559 | (interactive "p") | |
560 | (let ((length (length xscheme-expressions-ring))) | |
561 | (if (zerop length) | |
562 | (error "Scheme expression ring is empty") | |
563 | (setq xscheme-expressions-ring-yank-pointer | |
564 | (let ((index | |
565 | (% (+ arg | |
566 | (- length | |
567 | (length xscheme-expressions-ring-yank-pointer))) | |
568 | length))) | |
569 | (nthcdr (if (< index 0) | |
570 | (+ index length) | |
571 | index) | |
572 | xscheme-expressions-ring)))))) | |
573 | ||
574 | (defun xscheme-yank (&optional arg) | |
575 | "Insert the most recent expression at point. | |
576 | With just C-U as argument, same but put point in front (and mark at end). | |
577 | With argument n, reinsert the nth most recently sent expression. | |
578 | See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]." | |
579 | (interactive "*P") | |
580 | (xscheme-rotate-yank-pointer (if (listp arg) 0 | |
581 | (if (eq arg '-) -1 | |
582 | (1- arg)))) | |
583 | (push-mark (point)) | |
584 | (insert (car xscheme-expressions-ring-yank-pointer)) | |
585 | (if (consp arg) | |
586 | (exchange-point-and-mark))) | |
587 | ||
588 | ;; Old name, to avoid errors in users' init files. | |
589 | (fset 'xscheme-yank-previous-send | |
590 | 'xscheme-yank) | |
591 | ||
592 | (defun xscheme-yank-pop (arg) | |
593 | "Insert or replace a just-yanked expression with an older expression. | |
594 | If the previous command was not a yank, it yanks. | |
595 | Otherwise, the region contains a stretch of reinserted | |
596 | expression. yank-pop deletes that text and inserts in its | |
597 | place a different expression. | |
598 | ||
599 | With no argument, the next older expression is inserted. | |
600 | With argument n, the n'th older expression is inserted. | |
601 | If n is negative, this is a more recent expression. | |
602 | ||
603 | The sequence of expressions wraps around, so that after the oldest one | |
604 | comes the newest one." | |
605 | (interactive "*p") | |
606 | (setq this-command 'xscheme-yank) | |
607 | (if (not (eq last-command 'xscheme-yank)) | |
608 | (progn | |
609 | (xscheme-yank) | |
610 | (setq arg (- arg 1)))) | |
611 | (if (not (= arg 0)) | |
612 | (let ((before (< (point) (mark)))) | |
613 | (delete-region (point) (mark)) | |
614 | (xscheme-rotate-yank-pointer arg) | |
615 | (set-mark (point)) | |
616 | (insert (car xscheme-expressions-ring-yank-pointer)) | |
617 | (if before (exchange-point-and-mark))))) | |
618 | ||
619 | (defun xscheme-yank-push (arg) | |
620 | "Insert or replace a just-yanked expression with a more recent expression. | |
621 | If the previous command was not a yank, it yanks. | |
622 | Otherwise, the region contains a stretch of reinserted | |
623 | expression. yank-pop deletes that text and inserts in its | |
624 | place a different expression. | |
625 | ||
626 | With no argument, the next more recent expression is inserted. | |
627 | With argument n, the n'th more recent expression is inserted. | |
628 | If n is negative, a less recent expression is used. | |
629 | ||
630 | The sequence of expressions wraps around, so that after the oldest one | |
631 | comes the newest one." | |
632 | (interactive "*p") | |
633 | (xscheme-yank-pop (- 0 arg))) | |
634 | \f | |
635 | (defun xscheme-send-region (start end) | |
636 | "Send the current region to the Scheme process. | |
637 | The region is sent terminated by a newline." | |
638 | (interactive "r") | |
639 | (if (xscheme-process-buffer-current-p) | |
640 | (progn | |
641 | (goto-char end) | |
642 | (if (not (bolp)) | |
643 | (insert-before-markers ?\n)) | |
644 | (set-marker (process-mark (get-process xscheme-process-name)) | |
645 | (point)) | |
646 | (set-marker xscheme-last-input-end (point)))) | |
647 | (xscheme-send-string (buffer-substring start end))) | |
648 | ||
649 | (defun xscheme-send-definition () | |
650 | "Send the current definition to the Scheme process. | |
651 | If the current line begins with a non-whitespace character, | |
652 | parse an expression from the beginning of the line and send that instead." | |
653 | (interactive) | |
654 | (let ((start nil) (end nil)) | |
655 | (save-excursion | |
656 | (end-of-defun) | |
657 | (setq end (point)) | |
658 | (if (re-search-backward "^\\s(" nil t) | |
659 | (setq start (point)) | |
660 | (error "Can't find definition"))) | |
661 | (xscheme-send-region start end))) | |
662 | ||
663 | (defun xscheme-send-next-expression () | |
664 | "Send the expression to the right of `point' to the Scheme process." | |
665 | (interactive) | |
666 | (let ((start (point))) | |
667 | (xscheme-send-region start (save-excursion (forward-sexp) (point))))) | |
668 | ||
669 | (defun xscheme-send-previous-expression () | |
670 | "Send the expression to the left of `point' to the Scheme process." | |
671 | (interactive) | |
672 | (let ((end (point))) | |
673 | (xscheme-send-region (save-excursion (backward-sexp) (point)) end))) | |
674 | \f | |
675 | (defun xscheme-send-current-line () | |
676 | "Send the current line to the Scheme process. | |
677 | Useful for working with debugging Scheme under adb." | |
678 | (interactive) | |
9b026d9f | 679 | (let ((line (buffer-substring (line-beginning-position) (line-end-position)))) |
c5c3d778 DL |
680 | (end-of-line) |
681 | (insert ?\n) | |
682 | (xscheme-send-string-2 line))) | |
683 | ||
684 | (defun xscheme-send-buffer () | |
685 | "Send the current buffer to the Scheme process." | |
686 | (interactive) | |
687 | (if (xscheme-process-buffer-current-p) | |
688 | (error "Not allowed to send this buffer's contents to Scheme")) | |
689 | (xscheme-send-region (point-min) (point-max))) | |
690 | ||
691 | (defun xscheme-send-char (char) | |
692 | "Prompt for a character and send it to the Scheme process." | |
693 | (interactive "cCharacter to send: ") | |
694 | (process-send-string xscheme-process-name (char-to-string char))) | |
695 | ||
696 | (defun xscheme-delete-output () | |
697 | "Delete all output from interpreter since last input." | |
698 | (interactive) | |
699 | (let ((proc (get-buffer-process (current-buffer)))) | |
700 | (save-excursion | |
701 | (goto-char (process-mark proc)) | |
702 | (re-search-backward | |
703 | "^;\\(Unspecified return value$\\|Value\\( [0-9]+\\)?: \\|\\(Abort\\|Up\\|Quit\\)!$\\)" | |
704 | xscheme-last-input-end | |
705 | t) | |
706 | (forward-line 0) | |
707 | (if (< (marker-position xscheme-last-input-end) (point)) | |
708 | (progn | |
709 | (delete-region xscheme-last-input-end (point)) | |
710 | (insert-before-markers "*** output flushed ***\n")))))) | |
711 | \f | |
712 | ;;;; Interrupts | |
713 | ||
714 | (defun xscheme-send-breakpoint-interrupt () | |
715 | "Cause the Scheme process to enter a breakpoint." | |
716 | (interactive) | |
717 | (xscheme-send-interrupt ?b nil)) | |
718 | ||
719 | (defun xscheme-send-proceed () | |
720 | "Cause the Scheme process to proceed from a breakpoint." | |
721 | (interactive) | |
722 | (process-send-string xscheme-process-name "(proceed)\n")) | |
723 | ||
f28d4b0f JB |
724 | (defconst xscheme-control-g-message-string |
725 | "Sending C-G interrupt to Scheme...") | |
726 | ||
c5c3d778 DL |
727 | (defun xscheme-send-control-g-interrupt () |
728 | "Cause the Scheme processor to halt and flush input. | |
729 | Control returns to the top level rep loop." | |
730 | (interactive) | |
731 | (let ((inhibit-quit t)) | |
732 | (cond ((not xscheme-control-g-synchronization-p) | |
733 | (interrupt-process xscheme-process-name)) | |
9a529312 | 734 | ((with-current-buffer xscheme-buffer-name |
c5c3d778 DL |
735 | xscheme-control-g-disabled-p) |
736 | (message "Relax...")) | |
737 | (t | |
9a529312 | 738 | (with-current-buffer xscheme-buffer-name |
c5c3d778 DL |
739 | (setq xscheme-control-g-disabled-p t)) |
740 | (message xscheme-control-g-message-string) | |
741 | (interrupt-process xscheme-process-name) | |
742 | (sleep-for 0.1) | |
743 | (xscheme-send-char 0))))) | |
744 | ||
c5c3d778 DL |
745 | (defun xscheme-send-control-u-interrupt () |
746 | "Cause the Scheme process to halt, returning to previous rep loop." | |
747 | (interactive) | |
748 | (xscheme-send-interrupt ?u t)) | |
749 | ||
750 | (defun xscheme-send-control-x-interrupt () | |
751 | "Cause the Scheme process to halt, returning to current rep loop." | |
752 | (interactive) | |
753 | (xscheme-send-interrupt ?x t)) | |
754 | ||
755 | ;;; This doesn't really work right -- Scheme just gobbles the first | |
756 | ;;; character in the input. There is no way for us to guarantee that | |
757 | ;;; the argument to this procedure is the first char unless we put | |
758 | ;;; some kind of marker in the input stream. | |
759 | ||
760 | (defun xscheme-send-interrupt (char mark-p) | |
761 | "Send a ^A type interrupt to the Scheme process." | |
762 | (interactive "cInterrupt character to send: ") | |
763 | (quit-process xscheme-process-name) | |
764 | (sleep-for 0.1) | |
765 | (xscheme-send-char char) | |
766 | (if (and mark-p xscheme-control-g-synchronization-p) | |
767 | (xscheme-send-char 0))) | |
768 | \f | |
c5c3d778 DL |
769 | ;;;; Basic Process Control |
770 | ||
771 | (defun xscheme-start-process (command-line the-process the-buffer) | |
772 | (let ((buffer (get-buffer-create the-buffer))) | |
773 | (let ((process (get-buffer-process buffer))) | |
9a529312 | 774 | (with-current-buffer buffer |
c5c3d778 DL |
775 | (if (and process (memq (process-status process) '(run stop))) |
776 | (set-marker (process-mark process) (point-max)) | |
777 | (progn (if process (delete-process process)) | |
778 | (goto-char (point-max)) | |
779 | (scheme-interaction-mode nil) | |
780 | (setq xscheme-process-name the-process) | |
781 | (if (bobp) | |
782 | (insert-before-markers | |
783 | (substitute-command-keys xscheme-startup-message))) | |
784 | (setq process | |
785 | (let ((process-connection-type nil)) | |
786 | (apply 'start-process | |
787 | (cons the-process | |
788 | (cons buffer | |
789 | (xscheme-parse-command-line | |
790 | command-line)))))) | |
791 | (if (not (equal (process-name process) the-process)) | |
792 | (setq xscheme-process-name (process-name process))) | |
793 | (if (not (equal (buffer-name buffer) the-buffer)) | |
794 | (setq xscheme-buffer-name (buffer-name buffer))) | |
795 | (message "Starting process %s in buffer %s" | |
796 | xscheme-process-name | |
797 | xscheme-buffer-name) | |
798 | (set-marker (process-mark process) (point-max)) | |
799 | (xscheme-process-filter-initialize t) | |
37269466 | 800 | (xscheme-mode-line-initialize xscheme-buffer-name) |
c5c3d778 DL |
801 | (set-process-sentinel process 'xscheme-process-sentinel) |
802 | (set-process-filter process 'xscheme-process-filter) | |
803 | (run-hooks 'xscheme-start-hook))))) | |
804 | buffer)) | |
805 | ||
806 | (defun xscheme-parse-command-line (string) | |
807 | (setq string (substitute-in-file-name string)) | |
808 | (let ((start 0) | |
809 | (result '())) | |
810 | (while start | |
811 | (let ((index (string-match "[ \t]" string start))) | |
812 | (setq start | |
813 | (cond ((not index) | |
814 | (setq result | |
815 | (cons (substring string start) | |
816 | result)) | |
817 | nil) | |
818 | ((= index start) | |
819 | (string-match "[^ \t]" string start)) | |
820 | (t | |
821 | (setq result | |
822 | (cons (substring string start index) | |
823 | result)) | |
824 | (1+ index)))))) | |
825 | (nreverse result))) | |
826 | \f | |
827 | (defun xscheme-wait-for-process () | |
828 | (sleep-for 2) | |
829 | (while xscheme-running-p | |
830 | (sleep-for 1))) | |
831 | ||
832 | (defun xscheme-process-running-p () | |
e7f767c2 | 833 | "True if there is a Scheme process whose status is `run'." |
c5c3d778 DL |
834 | (let ((process (get-process xscheme-process-name))) |
835 | (and process | |
836 | (eq (process-status process) 'run)))) | |
837 | ||
838 | (defun xscheme-process-buffer () | |
839 | (let ((process (get-process xscheme-process-name))) | |
840 | (and process (process-buffer process)))) | |
841 | ||
842 | (defun xscheme-process-buffer-window () | |
843 | (let ((buffer (xscheme-process-buffer))) | |
844 | (and buffer (get-buffer-window buffer)))) | |
845 | ||
846 | (defun xscheme-process-buffer-current-p () | |
e7f767c2 | 847 | "True if the current buffer is the Scheme process buffer." |
c5c3d778 DL |
848 | (eq (xscheme-process-buffer) (current-buffer))) |
849 | \f | |
f28d4b0f JB |
850 | ;;;; Process Filter Operations |
851 | ||
852 | (defvar xscheme-process-filter-alist | |
853 | '((?A xscheme-eval | |
854 | xscheme-process-filter:string-action-noexcursion) | |
855 | (?D xscheme-enter-debugger-mode | |
856 | xscheme-process-filter:string-action) | |
857 | (?E xscheme-eval | |
858 | xscheme-process-filter:string-action) | |
859 | (?P xscheme-set-prompt-variable | |
860 | xscheme-process-filter:string-action) | |
861 | (?R xscheme-enter-interaction-mode | |
862 | xscheme-process-filter:simple-action) | |
863 | (?b xscheme-start-gc | |
864 | xscheme-process-filter:simple-action) | |
865 | (?c xscheme-unsolicited-read-char | |
866 | xscheme-process-filter:simple-action) | |
867 | (?e xscheme-finish-gc | |
868 | xscheme-process-filter:simple-action) | |
869 | (?f xscheme-exit-input-wait | |
870 | xscheme-process-filter:simple-action) | |
871 | (?g xscheme-enable-control-g | |
872 | xscheme-process-filter:simple-action) | |
873 | (?i xscheme-prompt-for-expression | |
874 | xscheme-process-filter:string-action) | |
875 | (?m xscheme-message | |
876 | xscheme-process-filter:string-action) | |
877 | (?n xscheme-prompt-for-confirmation | |
878 | xscheme-process-filter:string-action) | |
879 | (?o xscheme-output-goto | |
880 | xscheme-process-filter:simple-action) | |
881 | (?p xscheme-set-prompt | |
882 | xscheme-process-filter:string-action) | |
883 | (?s xscheme-enter-input-wait | |
884 | xscheme-process-filter:simple-action) | |
885 | (?v xscheme-write-value | |
886 | xscheme-process-filter:string-action) | |
887 | (?w xscheme-cd | |
888 | xscheme-process-filter:string-action) | |
889 | (?z xscheme-display-process-buffer | |
890 | xscheme-process-filter:simple-action)) | |
891 | "Table used to decide how to handle process filter commands. | |
892 | Value is a list of entries, each entry is a list of three items. | |
893 | ||
894 | The first item is the character that the process filter dispatches on. | |
895 | The second item is the action to be taken, a function. | |
896 | The third item is the handler for the entry, a function. | |
897 | ||
898 | When the process filter sees a command whose character matches a | |
899 | particular entry, it calls the handler with two arguments: the action | |
900 | and the string containing the rest of the process filter's input | |
901 | stream. It is the responsibility of the handler to invoke the action | |
902 | with the appropriate arguments, and to reenter the process filter with | |
903 | the remaining input.") | |
904 | \f | |
c5c3d778 DL |
905 | ;;;; Process Filter |
906 | ||
907 | (defun xscheme-process-sentinel (proc reason) | |
908 | (let* ((buffer (process-buffer proc)) | |
909 | (name (buffer-name buffer))) | |
9a529312 | 910 | (with-current-buffer buffer |
c5c3d778 DL |
911 | (xscheme-process-filter-initialize (eq reason 'run)) |
912 | (if (not (eq reason 'run)) | |
913 | (progn | |
914 | (setq scheme-mode-line-process "") | |
915 | (setq xscheme-mode-string "no process") | |
916 | (if (equal name (default-value 'xscheme-buffer-name)) | |
917 | (setq-default xscheme-runlight "")))) | |
918 | (if (and (not (memq reason '(run stop))) | |
919 | xscheme-signal-death-message) | |
920 | (progn | |
921 | (beep) | |
922 | (message | |
923 | "The Scheme process has died! Do M-x reset-scheme to restart it")))))) | |
924 | ||
925 | (defun xscheme-process-filter-initialize (running-p) | |
926 | (setq xscheme-process-filter-state 'idle) | |
927 | (setq xscheme-running-p running-p) | |
928 | (setq xscheme-control-g-disabled-p nil) | |
929 | (setq xscheme-allow-output-p t) | |
930 | (setq xscheme-prompt "") | |
931 | (if running-p | |
932 | (let ((name (buffer-name (current-buffer)))) | |
933 | (setq scheme-mode-line-process '(": " xscheme-runlight-string)) | |
37269466 | 934 | (xscheme-mode-line-initialize name) |
c5c3d778 DL |
935 | (if (equal name (default-value 'xscheme-buffer-name)) |
936 | (setq-default xscheme-runlight default-xscheme-runlight)))) | |
937 | (if (or (eq xscheme-runlight default-xscheme-runlight) | |
938 | (equal xscheme-runlight "")) | |
939 | (setq xscheme-runlight (list ": " 'xscheme-buffer-name ": " "?"))) | |
940 | (rplaca (nthcdr 3 xscheme-runlight) | |
941 | (if running-p "?" "no process"))) | |
942 | ||
943 | (defun xscheme-process-filter (proc string) | |
944 | (let ((xscheme-filter-input string) | |
945 | (call-noexcursion nil)) | |
946 | (while xscheme-filter-input | |
947 | (setq call-noexcursion nil) | |
9a529312 | 948 | (with-current-buffer (process-buffer proc) |
c5c3d778 DL |
949 | (cond ((eq xscheme-process-filter-state 'idle) |
950 | (let ((start (string-match "\e" xscheme-filter-input))) | |
951 | (if start | |
952 | (progn | |
953 | (xscheme-process-filter-output | |
954 | (substring xscheme-filter-input 0 start)) | |
955 | (setq xscheme-filter-input | |
956 | (substring xscheme-filter-input (1+ start))) | |
957 | (setq xscheme-process-filter-state 'reading-type)) | |
958 | (let ((string xscheme-filter-input)) | |
959 | (setq xscheme-filter-input nil) | |
960 | (xscheme-process-filter-output string))))) | |
961 | ((eq xscheme-process-filter-state 'reading-type) | |
962 | (if (zerop (length xscheme-filter-input)) | |
963 | (setq xscheme-filter-input nil) | |
964 | (let ((char (aref xscheme-filter-input 0))) | |
965 | (setq xscheme-filter-input | |
966 | (substring xscheme-filter-input 1)) | |
967 | (let ((entry (assoc char xscheme-process-filter-alist))) | |
968 | (if entry | |
969 | (funcall (nth 2 entry) (nth 1 entry)) | |
970 | (progn | |
971 | (xscheme-process-filter-output ?\e char) | |
972 | (setq xscheme-process-filter-state 'idle))))))) | |
973 | ((eq xscheme-process-filter-state 'reading-string) | |
974 | (let ((start (string-match "\e" xscheme-filter-input))) | |
975 | (if start | |
976 | (let ((string | |
977 | (concat xscheme-string-accumulator | |
978 | (substring xscheme-filter-input 0 start)))) | |
979 | (setq xscheme-filter-input | |
980 | (substring xscheme-filter-input (1+ start))) | |
981 | (setq xscheme-process-filter-state 'idle) | |
982 | (if (listp xscheme-string-receiver) | |
983 | (progn | |
984 | (setq xscheme-string-receiver | |
985 | (car xscheme-string-receiver)) | |
986 | (setq call-noexcursion string)) | |
987 | (funcall xscheme-string-receiver string))) | |
988 | (progn | |
989 | (setq xscheme-string-accumulator | |
990 | (concat xscheme-string-accumulator | |
991 | xscheme-filter-input)) | |
992 | (setq xscheme-filter-input nil))))) | |
993 | (t | |
994 | (error "Scheme process filter -- bad state")))) | |
995 | (if call-noexcursion | |
996 | (funcall xscheme-string-receiver call-noexcursion))))) | |
997 | \f | |
998 | ;;;; Process Filter Output | |
999 | ||
1000 | (defun xscheme-process-filter-output (&rest args) | |
1001 | (if xscheme-allow-output-p | |
1002 | (let ((string (apply 'concat args))) | |
1003 | (save-excursion | |
1004 | (xscheme-goto-output-point) | |
1005 | (let ((old-point (point))) | |
1006 | (while (string-match "\\(\007\\|\f\\)" string) | |
e02f48d7 | 1007 | (let ((start (match-beginning 0))) |
c5c3d778 DL |
1008 | (insert-before-markers (substring string 0 start)) |
1009 | (if (= ?\f (aref string start)) | |
1010 | (progn | |
1011 | (if (not (bolp)) | |
1012 | (insert-before-markers ?\n)) | |
1013 | (insert-before-markers ?\f)) | |
1014 | (beep)) | |
1015 | (setq string (substring string (1+ start))))) | |
1016 | (insert-before-markers string) | |
1017 | (if (and xscheme-last-input-end | |
1018 | (equal (marker-position xscheme-last-input-end) (point))) | |
1019 | (set-marker xscheme-last-input-end old-point))))))) | |
1020 | ||
1021 | (defun xscheme-guarantee-newlines (n) | |
1022 | (if xscheme-allow-output-p | |
1023 | (save-excursion | |
1024 | (xscheme-goto-output-point) | |
1025 | (let ((stop nil)) | |
1026 | (while (and (not stop) | |
1027 | (bolp)) | |
1028 | (setq n (1- n)) | |
1029 | (if (bobp) | |
1030 | (setq stop t) | |
1031 | (backward-char)))) | |
1032 | (xscheme-goto-output-point) | |
1033 | (while (> n 0) | |
1034 | (insert-before-markers ?\n) | |
1035 | (setq n (1- n)))))) | |
1036 | ||
1037 | (defun xscheme-goto-output-point () | |
1038 | (let ((process (get-process xscheme-process-name))) | |
1039 | (set-buffer (process-buffer process)) | |
1040 | (goto-char (process-mark process)))) | |
1041 | ||
37269466 | 1042 | (defun xscheme-mode-line-initialize (name) |
c5c3d778 DL |
1043 | (setq xscheme-runlight-string "") |
1044 | (if (equal name (default-value 'xscheme-buffer-name)) | |
1045 | (setq-default xscheme-runlight-string "")) | |
1046 | (setq xscheme-mode-string "") | |
1047 | (setq mode-line-buffer-identification | |
1048 | (list (concat name ": ") | |
1049 | 'xscheme-mode-string))) | |
1050 | ||
1051 | (defun xscheme-set-runlight (runlight) | |
1052 | (setq xscheme-runlight-string runlight) | |
1053 | (if (equal (buffer-name (current-buffer)) | |
1054 | (default-value 'xscheme-buffer-name)) | |
1055 | (setq-default xscheme-runlight-string runlight)) | |
1056 | (rplaca (nthcdr 3 xscheme-runlight) runlight) | |
1057 | (force-mode-line-update t)) | |
1058 | \f | |
c5c3d778 DL |
1059 | (defun xscheme-process-filter:simple-action (action) |
1060 | (setq xscheme-process-filter-state 'idle) | |
1061 | (funcall action)) | |
1062 | ||
1063 | (defun xscheme-process-filter:string-action (action) | |
1064 | (setq xscheme-string-receiver action) | |
1065 | (setq xscheme-string-accumulator "") | |
1066 | (setq xscheme-process-filter-state 'reading-string)) | |
1067 | ||
1068 | (defun xscheme-process-filter:string-action-noexcursion (action) | |
1069 | (xscheme-process-filter:string-action (cons action nil))) | |
1070 | ||
1071 | (defconst xscheme-runlight:running "run" | |
1072 | "The character displayed when the Scheme process is running.") | |
1073 | ||
1074 | (defconst xscheme-runlight:input "input" | |
1075 | "The character displayed when the Scheme process is waiting for input.") | |
1076 | ||
1077 | (defconst xscheme-runlight:gc "gc" | |
1078 | "The character displayed when the Scheme process is garbage collecting.") | |
1079 | ||
1080 | (defun xscheme-start-gc () | |
1081 | (xscheme-set-runlight xscheme-runlight:gc)) | |
1082 | ||
1083 | (defun xscheme-finish-gc () | |
1084 | (xscheme-set-runlight | |
1085 | (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) | |
1086 | ||
1087 | (defun xscheme-enter-input-wait () | |
1088 | (xscheme-set-runlight xscheme-runlight:input) | |
1089 | (setq xscheme-control-g-disabled-p nil) | |
1090 | (setq xscheme-running-p nil)) | |
1091 | ||
1092 | (defun xscheme-exit-input-wait () | |
1093 | (xscheme-set-runlight xscheme-runlight:running) | |
1094 | (setq xscheme-running-p t)) | |
1095 | ||
1096 | (defun xscheme-enable-control-g () | |
1097 | (setq xscheme-control-g-disabled-p nil) | |
1098 | (if (string= (current-message) xscheme-control-g-message-string) | |
1099 | (message nil))) | |
1100 | ||
1101 | (defun xscheme-display-process-buffer () | |
1102 | (let ((window (or (xscheme-process-buffer-window) | |
1103 | (display-buffer (xscheme-process-buffer))))) | |
1104 | (save-window-excursion | |
1105 | (select-window window) | |
1106 | (xscheme-goto-output-point) | |
1107 | (if (xscheme-debugger-mode-p) | |
1108 | (xscheme-enter-interaction-mode))))) | |
1109 | ||
1110 | (defun xscheme-unsolicited-read-char () | |
1111 | nil) | |
1112 | \f | |
1113 | (defun xscheme-eval (string) | |
1114 | (eval (car (read-from-string string)))) | |
1115 | ||
1116 | (defun xscheme-message (string) | |
1117 | (if (not (zerop (length string))) | |
1118 | (xscheme-write-message-1 string (format ";%s" string)))) | |
1119 | ||
1120 | (defun xscheme-write-value (string) | |
1121 | (if (zerop (length string)) | |
1122 | (xscheme-write-message-1 "(no value)" ";Unspecified return value") | |
1123 | (xscheme-write-message-1 string (format ";Value: %s" string)))) | |
1124 | ||
1125 | (defun xscheme-write-message-1 (message-string output-string) | |
1126 | (let* ((process (get-process xscheme-process-name)) | |
1127 | (window (get-buffer-window (process-buffer process)))) | |
1128 | (if (or (not window) | |
1129 | (not (pos-visible-in-window-p (process-mark process) | |
1130 | window))) | |
1131 | (message "%s" message-string))) | |
1132 | (xscheme-guarantee-newlines 1) | |
1133 | (xscheme-process-filter-output output-string)) | |
1134 | ||
1135 | (defun xscheme-set-prompt-variable (string) | |
1136 | (setq xscheme-prompt string)) | |
1137 | ||
1138 | (defun xscheme-set-prompt (string) | |
1139 | (setq xscheme-prompt string) | |
1140 | (xscheme-guarantee-newlines 2) | |
1141 | (setq xscheme-mode-string (xscheme-coerce-prompt string)) | |
1142 | (force-mode-line-update t)) | |
1143 | ||
1144 | (defun xscheme-output-goto () | |
1145 | (xscheme-goto-output-point) | |
1146 | (xscheme-guarantee-newlines 2)) | |
1147 | ||
1148 | (defun xscheme-coerce-prompt (string) | |
1149 | (if (string-match "^[0-9]+ \\[[^]]+\\] " string) | |
1150 | (let ((end (match-end 0))) | |
1151 | (xscheme-process-filter-output (substring string end)) | |
1152 | (substring string 0 (- end 1))) | |
1153 | string)) | |
1154 | ||
1155 | (defun xscheme-cd (directory-string) | |
9a529312 | 1156 | (with-current-buffer (xscheme-process-buffer) |
c5c3d778 DL |
1157 | (cd directory-string))) |
1158 | \f | |
1159 | (defun xscheme-prompt-for-confirmation (prompt-string) | |
1160 | (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n))) | |
1161 | ||
c5c3d778 DL |
1162 | (defvar xscheme-prompt-for-expression-map nil) |
1163 | (if (not xscheme-prompt-for-expression-map) | |
1164 | (progn | |
1165 | (setq xscheme-prompt-for-expression-map | |
1166 | (copy-keymap minibuffer-local-map)) | |
1167 | (substitute-key-definition 'exit-minibuffer | |
1168 | 'xscheme-prompt-for-expression-exit | |
1169 | xscheme-prompt-for-expression-map))) | |
1170 | ||
f28d4b0f JB |
1171 | (defun xscheme-prompt-for-expression (prompt-string) |
1172 | (xscheme-send-string-2 | |
1173 | (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map))) | |
1174 | ||
c5c3d778 DL |
1175 | (defun xscheme-prompt-for-expression-exit () |
1176 | (interactive) | |
1177 | (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one) | |
1178 | (exit-minibuffer) | |
1179 | (error "input must be a single, complete expression"))) | |
1180 | ||
1181 | (defun xscheme-region-expression-p (start end) | |
1182 | (save-excursion | |
1183 | (let ((old-syntax-table (syntax-table))) | |
1184 | (unwind-protect | |
1185 | (progn | |
1186 | (set-syntax-table scheme-mode-syntax-table) | |
1187 | (let ((state (parse-partial-sexp start end))) | |
1188 | (and (zerop (car state)) ;depth = 0 | |
1189 | (nth 2 state) ;last-sexp exists, i.e. >= 1 sexps | |
1190 | (let ((state (parse-partial-sexp start (nth 2 state)))) | |
1191 | (if (nth 2 state) 'many 'one))))) | |
1192 | (set-syntax-table old-syntax-table))))) | |
1193 | ||
1194 | (provide 'xscheme) | |
1195 | ||
1196 | ;;; xscheme.el ends here |