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