lisp/xscheme.el

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