|
656
|
1 ;;; xscheme.el --- run Scheme under Emacs
|
|
|
2
|
|
840
|
3 ;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc.
|
|
|
4
|
|
773
|
5 ;; Maintainer: FSF
|
|
5140
|
6 ;; Keywords: languages, lisp
|
|
772
|
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
|
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
|
|
14169
|
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.
|
|
91
|
24
|
|
772
|
25 ;;; Commentary:
|
|
|
26
|
|
2319
|
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
|
|
91
|
31
|
|
772
|
32 ;;; Code:
|
|
|
33
|
|
91
|
34 (require 'scheme)
|
|
|
35
|
|
21088
|
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)
|
|
91
|
44
|
|
21088
|
45 (defcustom scheme-band-name nil
|
|
|
46 "*Band loaded by the `run-scheme' command."
|
|
|
47 :type '(choice (const nil) string)
|
|
|
48 :group 'xscheme)
|
|
91
|
49
|
|
21088
|
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)
|
|
91
|
54
|
|
21088
|
55 (defcustom xscheme-allow-pipelined-evaluation t
|
|
91
|
56 "If non-nil, an expression may be transmitted while another is evaluating.
|
|
|
57 Otherwise, attempting to evaluate an expression before the previous expression
|
|
21088
|
58 has finished evaluating will signal an error."
|
|
|
59 :type 'boolean
|
|
|
60 :group 'xscheme)
|
|
91
|
61
|
|
21088
|
62 (defcustom xscheme-startup-message
|
|
91
|
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.
|
|
21088
|
70 Is processed with `substitute-command-keys' first."
|
|
|
71 :type 'string
|
|
|
72 :group 'xscheme)
|
|
91
|
73
|
|
21088
|
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)
|
|
91
|
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
|
|
|
97 (defun run-scheme (command-line)
|
|
9590
|
98 "Run MIT Scheme in an inferior process.
|
|
91
|
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)
|
|
12866
|
109 (pop-to-buffer (xscheme-start-process command-line)))
|
|
91
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
14016
|
476 control-g interrupts were signaled. Do not allow more control-g's to be
|
|
|
477 signaled until the scheme process acknowledges receipt.")
|
|
91
|
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
|
|
21088
|
496 (defcustom xscheme-start-hook nil
|
|
91
|
497 "If non-nil, a procedure to call when the Scheme process is started.
|
|
21088
|
498 When called, the current buffer will be the Scheme process-buffer."
|
|
|
499 :type 'hook
|
|
|
500 :group 'xscheme)
|
|
91
|
501
|
|
|
502 (defvar xscheme-runlight-string nil)
|
|
|
503 (defvar xscheme-mode-string nil)
|
|
|
504 (defvar xscheme-filter-input nil)
|
|
|
505
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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)
|
11565
61cdc55737fb
(xscheme-set-runlight, xscheme-set-prompt): Use force-mode-line-update.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
696 (force-mode-line-update t))
|
|
91
|
697
|
|
|
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
|
|
|
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
|
|
|
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))
|
11565
61cdc55737fb
(xscheme-set-runlight, xscheme-set-prompt): Use force-mode-line-update.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
828 (force-mode-line-update t))
|
|
91
|
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
|
|
|
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)))))
|
|
656
|
893
|
|
5000
|
894 (provide 'xscheme)
|
|
|
895
|
|
656
|
896 ;;; xscheme.el ends here
|
