lisp/progmodes/xscheme.el

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