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