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