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