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