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