(#includes): Allow compilation with only Xaw.
[emacs.git] / lisp / xscheme.el
blob32b402103db51023daff76617bb1ea31df895096
1 ;;; xscheme.el --- run Scheme under Emacs
3 ;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc.
5 ;; Maintainer: FSF
6 ;; Keywords: languages, lisp
8 ;; This file is part of GNU Emacs.
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
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
25 ;;; Commentary:
27 ;; A major mode for editing Scheme and interacting with MIT's C-Scheme.
29 ;; Requires C-Scheme release 5 or later
30 ;; Changes to Control-G handler require runtime version 13.85 or later
32 ;;; Code:
34 (require 'scheme)
36 (defgroup xscheme nil
37 "Major mode for editing Scheme and interacting with MIT's C-Scheme."
38 :group 'lisp)
40 (defcustom scheme-program-name "scheme"
41 "*Program invoked by the `run-scheme' command."
42 :type 'string
43 :group 'xscheme)
45 (defcustom scheme-band-name nil
46 "*Band loaded by the `run-scheme' command."
47 :type '(choice (const nil) string)
48 :group 'xscheme)
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)
55 (defcustom xscheme-allow-pipelined-evaluation t
56 "If non-nil, an expression may be transmitted while another is evaluating.
57 Otherwise, attempting to evaluate an expression before the previous expression
58 has finished evaluating will signal an error."
59 :type 'boolean
60 :group 'xscheme)
62 (defcustom xscheme-startup-message
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.
69 "String to insert into Scheme process buffer first time it is started.
70 Is processed with `substitute-command-keys' first."
71 :type 'string
72 :group 'xscheme)
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)
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))
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))
94 (xscheme-evaluation-commands scheme-mode-map)
95 (xscheme-interrupt-commands scheme-mode-map)
97 (defun run-scheme (command-line)
98 "Run MIT Scheme in an inferior process.
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)
109 (pop-to-buffer (xscheme-start-process command-line)))
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")))))
124 (defun xscheme-default-command-line ()
125 (concat scheme-program-name " -emacs"
126 (if scheme-program-arguments
127 (concat " " scheme-program-arguments)
129 (if scheme-band-name
130 (concat " -band " scheme-band-name)
131 "")))
133 ;;;; Interaction Mode
135 (defun scheme-interaction-mode ()
136 "Major mode for interacting with the inferior Scheme process.
137 Like scheme-mode except that:
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
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.
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:
154 input waiting for input
155 run evaluating
156 gc garbage collecting
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.
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.
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:
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
181 Some possible command interpreter types and their meanings are:
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
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.
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.
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}
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))
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"))
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))
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)))
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)))))
241 (fset 'advertised-xscheme-send-previous-expression
242 'xscheme-send-previous-expression)
244 ;;;; Debugger Mode
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.
253 Commands:
254 \\{scheme-debugger-mode-map}"
255 (error "Illegal entry to scheme-debugger-mode"))
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"))
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)))))
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)))
276 (defun scheme-debugger-self-insert ()
277 "Transmit this character to the Scheme process."
278 (interactive)
279 (xscheme-send-char last-command-char))
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)))))
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)))))
297 ;;;; Evaluation Commands
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))))
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))))
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)))))
328 (defun xscheme-yank-previous-send ()
329 "Insert the most recent expression at point."
330 (interactive)
331 (push-mark)
332 (insert xscheme-previous-send))
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))))))
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)))
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)))
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)))))
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)))
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)))
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)))
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)))
406 ;;;; Interrupts
408 (defun xscheme-send-breakpoint-interrupt ()
409 "Cause the Scheme process to enter a breakpoint."
410 (interactive)
411 (xscheme-send-interrupt ?b nil))
413 (defun xscheme-send-proceed ()
414 "Cause the Scheme process to proceed from a breakpoint."
415 (interactive)
416 (send-string "scheme" "(proceed)\n"))
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..."))
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))))))
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))
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))
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.
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))))
456 ;;;; Internal Variables
458 (defvar xscheme-process-command-line nil
459 "Command used to start the most recent Scheme process.")
461 (defvar xscheme-previous-send ""
462 "Most recent expression transmitted to the Scheme process.")
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")
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.")
474 (defconst xscheme-control-g-synchronization-p t
475 "If non-nil, insert markers in the scheme input stream to indicate when
476 control-g interrupts were signaled. Do not allow more control-g's to be
477 signaled until the scheme process acknowledges receipt.")
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.")
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.")
487 (defvar xscheme-prompt ""
488 "The current scheme prompt string.")
490 (defvar xscheme-string-accumulator ""
491 "Accumulator for the string being received from the scheme process.")
493 (defvar xscheme-string-receiver nil
494 "Procedure to send the string argument from the scheme process.")
496 (defcustom xscheme-start-hook nil
497 "If non-nil, a procedure to call when the Scheme process is started.
498 When called, the current buffer will be the Scheme process-buffer."
499 :type 'hook
500 :group 'xscheme)
502 (defvar xscheme-runlight-string nil)
503 (defvar xscheme-mode-string nil)
504 (defvar xscheme-filter-input nil)
506 ;;;; Basic Process Control
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))
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))
551 (setq result
552 (cons (substring string start index)
553 result))
554 (1+ index))))))
555 (nreverse result)))
557 (defun xscheme-wait-for-process ()
558 (sleep-for 2)
559 (while xscheme-running-p
560 (sleep-for 1)))
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))))
568 (defun xscheme-process-buffer ()
569 (let ((process (get-process "scheme")))
570 (and process (process-buffer process))))
572 (defun xscheme-process-buffer-window ()
573 (let ((buffer (xscheme-process-buffer)))
574 (and buffer (get-buffer-window buffer))))
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)))
580 ;;;; Process Filter
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"))))
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)))
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)))))
646 (error "Scheme process filter -- bad state"))))))
648 ;;;; Process Filter Output
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)))))
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))))))
684 (defun xscheme-goto-output-point ()
685 (let ((process (get-process "scheme")))
686 (set-buffer (process-buffer process))
687 (goto-char (process-mark process))))
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)))
694 (defun xscheme-set-runlight (runlight)
695 (setq xscheme-runlight-string runlight)
696 (force-mode-line-update t))
698 ;;;; Process Filter Operations
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.
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.
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.")
751 (defun xscheme-process-filter:simple-action (action)
752 (setq xscheme-process-filter-state 'idle)
753 (funcall action))
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))
760 (defconst xscheme-runlight:running "run"
761 "The character displayed when the Scheme process is running.")
763 (defconst xscheme-runlight:input "input"
764 "The character displayed when the Scheme process is waiting for input.")
766 (defconst xscheme-runlight:gc "gc"
767 "The character displayed when the Scheme process is garbage collecting.")
769 (defun xscheme-start-gc ()
770 (xscheme-set-runlight xscheme-runlight:gc))
772 (defun xscheme-finish-gc ()
773 (xscheme-set-runlight
774 (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input)))
776 (defun xscheme-enter-input-wait ()
777 (xscheme-set-runlight xscheme-runlight:input)
778 (setq xscheme-running-p nil))
780 (defun xscheme-exit-input-wait ()
781 (xscheme-set-runlight xscheme-runlight:running)
782 (setq xscheme-running-p t))
784 (defun xscheme-enable-control-g ()
785 (setq xscheme-control-g-disabled-p nil))
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)))))
796 (defun xscheme-unsolicited-read-char ()
797 nil)
799 (defun xscheme-eval (string)
800 (eval (car (read-from-string string))))
802 (defun xscheme-message (string)
803 (if (not (zerop (length string)))
804 (xscheme-write-message-1 string (format ";%s" string))))
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))))
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))
821 (defun xscheme-set-prompt-variable (string)
822 (setq xscheme-prompt string))
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))
828 (force-mode-line-update t))
830 (defun xscheme-output-goto ()
831 (xscheme-goto-output-point)
832 (xscheme-guarantee-newlines 2))
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))
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.")
854 (defun xscheme-cd (directory-string)
855 (save-excursion
856 (set-buffer (xscheme-process-buffer))
857 (cd directory-string)))
859 (defun xscheme-prompt-for-confirmation (prompt-string)
860 (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n)))
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)))
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)))
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")))
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)))))
894 (provide 'xscheme)
896 ;;; xscheme.el ends here