lisp/progmodes/xscheme.el

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