lisp/progmodes/xscheme.el

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