lisp/progmodes/xscheme.el

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