code.delx.au - gnu-emacs/blob - lisp/progmodes/xscheme.el

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