![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to xscheme.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to xscheme.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 ! root 1: ;; Run Scheme under Emacs ! 2: ;; Copyright (C) 1986, 1987, 1989 Free Software Foundation, Inc. ! 3: ! 4: ;; This file is part of GNU Emacs. ! 5: ! 6: ;; GNU Emacs is distributed in the hope that it will be useful, ! 7: ;; but WITHOUT ANY WARRANTY. No author or distributor ! 8: ;; accepts responsibility to anyone for the consequences of using it ! 9: ;; or for whether it serves any particular purpose or works at all, ! 10: ;; unless he says so in writing. Refer to the GNU Emacs General Public ! 11: ;; License for full details. ! 12: ! 13: ;; Everyone is granted permission to copy, modify and redistribute ! 14: ;; GNU Emacs, but only under the conditions described in the ! 15: ;; GNU Emacs General Public License. A copy of this license is ! 16: ;; supposed to have been given to you along with GNU Emacs so you ! 17: ;; can know your rights and responsibilities. It should be in a ! 18: ;; file named COPYING. Among other things, the copyright notice ! 19: ;; and this notice must be preserved on all copies. ! 20: ! 21: ;;; Requires C-Scheme release 5 or later ! 22: ;;; Changes to Control-G handler require runtime version 13.85 or later ! 23: ! 24: ;;; $Header: xscheme.el,v 1.23 89/04/28 22:59:40 GMT cph Rel $ ! 25: ! 26: (require 'scheme) ! 27: ! 28: (defvar scheme-program-name "scheme" ! 29: "*Program invoked by the `run-scheme' command.") ! 30: ! 31: (defvar scheme-band-name nil ! 32: "*Band loaded by the `run-scheme' command.") ! 33: ! 34: (defvar scheme-program-arguments nil ! 35: "*Arguments passed to the Scheme program by the `run-scheme' command.") ! 36: ! 37: (defvar xscheme-allow-pipelined-evaluation t ! 38: "If non-nil, an expression may be transmitted while another is evaluating. ! 39: Otherwise, attempting to evaluate an expression before the previous expression ! 40: has finished evaluating will signal an error.") ! 41: ! 42: (defvar xscheme-startup-message ! 43: "This is the Scheme process buffer. ! 44: Type \\[advertised-xscheme-send-previous-expression] to evaluate the expression before point. ! 45: Type \\[xscheme-send-control-g-interrupt] to abort evaluation. ! 46: Type \\[describe-mode] for more information. ! 47: ! 48: " ! 49: "String to insert into Scheme process buffer first time it is started. ! 50: Is processed with `substitute-command-keys' first.") ! 51: ! 52: (defvar xscheme-signal-death-message nil ! 53: "If non-nil, causes a message to be generated when the Scheme process dies.") ! 54: ! 55: (defun xscheme-evaluation-commands (keymap) ! 56: (define-key keymap "\e\C-x" 'xscheme-send-definition) ! 57: (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression) ! 58: (define-key keymap "\eo" 'xscheme-send-buffer) ! 59: (define-key keymap "\ez" 'xscheme-send-definition) ! 60: (define-key keymap "\e\C-m" 'xscheme-send-previous-expression) ! 61: (define-key keymap "\e\C-z" 'xscheme-send-region)) ! 62: ! 63: (defun xscheme-interrupt-commands (keymap) ! 64: (define-key keymap "\C-c\C-s" 'xscheme-select-process-buffer) ! 65: (define-key keymap "\C-c\C-b" 'xscheme-send-breakpoint-interrupt) ! 66: (define-key keymap "\C-c\C-c" 'xscheme-send-control-g-interrupt) ! 67: (define-key keymap "\C-c\C-u" 'xscheme-send-control-u-interrupt) ! 68: (define-key keymap "\C-c\C-x" 'xscheme-send-control-x-interrupt)) ! 69: ! 70: (xscheme-evaluation-commands scheme-mode-map) ! 71: (xscheme-interrupt-commands scheme-mode-map) ! 72: ! 73: (defun run-scheme (command-line) ! 74: "Run an inferior Scheme process. ! 75: Output goes to the buffer `*scheme*'. ! 76: With argument, asks for a command line." ! 77: (interactive ! 78: (list (let ((default ! 79: (or xscheme-process-command-line ! 80: (xscheme-default-command-line)))) ! 81: (if current-prefix-arg ! 82: (read-string "Run Scheme: " default) ! 83: default)))) ! 84: (setq xscheme-process-command-line command-line) ! 85: (switch-to-buffer (xscheme-start-process command-line))) ! 86: ! 87: (defun reset-scheme () ! 88: "Reset the Scheme process." ! 89: (interactive) ! 90: (let ((process (get-process "scheme"))) ! 91: (cond ((or (not process) ! 92: (not (eq (process-status process) 'run)) ! 93: (yes-or-no-p ! 94: "The Scheme process is running, are you SURE you want to reset it? ")) ! 95: (message "Resetting Scheme process...") ! 96: (if process (kill-process process t)) ! 97: (xscheme-start-process xscheme-process-command-line) ! 98: (message "Resetting Scheme process...done"))))) ! 99: ! 100: (defun xscheme-default-command-line () ! 101: (concat scheme-program-name " -emacs" ! 102: (if scheme-program-arguments ! 103: (concat " " scheme-program-arguments) ! 104: "") ! 105: (if scheme-band-name ! 106: (concat " -band " scheme-band-name) ! 107: ""))) ! 108: ! 109: ;;;; Interaction Mode ! 110: ! 111: (defun scheme-interaction-mode () ! 112: "Major mode for interacting with the inferior Scheme process. ! 113: Like scheme-mode except that: ! 114: ! 115: \\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input ! 116: \\[xscheme-yank-previous-send] yanks the expression most recently sent to Scheme ! 117: ! 118: All output from the Scheme process is written in the Scheme process ! 119: buffer, which is initially named \"*scheme*\". The result of ! 120: evaluating a Scheme expression is also printed in the process buffer, ! 121: preceded by the string \";Value: \" to highlight it. If the process ! 122: buffer is not visible at that time, the value will also be displayed ! 123: in the minibuffer. If an error occurs, the process buffer will ! 124: automatically pop up to show you the error message. ! 125: ! 126: While the Scheme process is running, the modelines of all buffers in ! 127: scheme-mode are modified to show the state of the process. The ! 128: possible states and their meanings are: ! 129: ! 130: input waiting for input ! 131: run evaluating ! 132: gc garbage collecting ! 133: ! 134: The process buffer's modeline contains additional information where ! 135: the buffer's name is normally displayed: the command interpreter level ! 136: and type. ! 137: ! 138: Scheme maintains a stack of command interpreters. Every time an error ! 139: or breakpoint occurs, the current command interpreter is pushed on the ! 140: command interpreter stack, and a new command interpreter is started. ! 141: One example of why this is done is so that an error that occurs while ! 142: you are debugging another error will not destroy the state of the ! 143: initial error, allowing you to return to it after the second error has ! 144: been fixed. ! 145: ! 146: The command interpreter level indicates how many interpreters are in ! 147: the command interpreter stack. It is initially set to one, and it is ! 148: incremented every time that stack is pushed, and decremented every ! 149: time it is popped. The following commands are useful for manipulating ! 150: the command interpreter stack: ! 151: ! 152: \\[xscheme-send-breakpoint-interrupt] pushes the stack once ! 153: \\[xscheme-send-control-u-interrupt] pops the stack once ! 154: \\[xscheme-send-control-g-interrupt] pops everything off ! 155: \\[xscheme-send-control-x-interrupt] aborts evaluation, doesn't affect stack ! 156: ! 157: Some possible command interpreter types and their meanings are: ! 158: ! 159: [Evaluator] read-eval-print loop for evaluating expressions ! 160: [Debugger] single character commands for debugging errors ! 161: [Where] single character commands for examining environments ! 162: ! 163: Starting with release 6.2 of Scheme, the latter two types of command ! 164: interpreters will change the major mode of the Scheme process buffer ! 165: to scheme-debugger-mode , in which the evaluation commands are ! 166: disabled, and the keys which normally self insert instead send ! 167: themselves to the Scheme process. The command character ? will list ! 168: the available commands. ! 169: ! 170: For older releases of Scheme, the major mode will be be ! 171: scheme-interaction-mode , and the command characters must be sent as ! 172: if they were expressions. ! 173: ! 174: Commands: ! 175: Delete converts tabs to spaces as it moves back. ! 176: Blank lines separate paragraphs. Semicolons start comments. ! 177: \\{scheme-interaction-mode-map} ! 178: ! 179: Entry to this mode calls the value of scheme-interaction-mode-hook ! 180: with no args, if that value is non-nil." ! 181: (interactive) ! 182: (kill-all-local-variables) ! 183: (scheme-interaction-mode-initialize) ! 184: (scheme-mode-variables) ! 185: (make-local-variable 'xscheme-previous-send) ! 186: (run-hooks 'scheme-interaction-mode-hook)) ! 187: ! 188: (defun scheme-interaction-mode-initialize () ! 189: (use-local-map scheme-interaction-mode-map) ! 190: (setq major-mode 'scheme-interaction-mode) ! 191: (setq mode-name "Scheme Interaction")) ! 192: ! 193: (defun scheme-interaction-mode-commands (keymap) ! 194: (define-key keymap "\C-c\C-m" 'xscheme-send-current-line) ! 195: (define-key keymap "\C-c\C-p" 'xscheme-send-proceed) ! 196: (define-key keymap "\C-c\C-y" 'xscheme-yank-previous-send)) ! 197: ! 198: (defvar scheme-interaction-mode-map nil) ! 199: (if (not scheme-interaction-mode-map) ! 200: (progn ! 201: (setq scheme-interaction-mode-map (make-keymap)) ! 202: (scheme-mode-commands scheme-interaction-mode-map) ! 203: (xscheme-interrupt-commands scheme-interaction-mode-map) ! 204: (xscheme-evaluation-commands scheme-interaction-mode-map) ! 205: (scheme-interaction-mode-commands scheme-interaction-mode-map))) ! 206: ! 207: (defun xscheme-enter-interaction-mode () ! 208: (save-excursion ! 209: (set-buffer (xscheme-process-buffer)) ! 210: (if (not (eq major-mode 'scheme-interaction-mode)) ! 211: (if (eq major-mode 'scheme-debugger-mode) ! 212: (scheme-interaction-mode-initialize) ! 213: (scheme-interaction-mode))))) ! 214: ! 215: (fset 'advertised-xscheme-send-previous-expression ! 216: 'xscheme-send-previous-expression) ! 217: ! 218: ;;;; Debugger Mode ! 219: ! 220: (defun scheme-debugger-mode () ! 221: "Major mode for executing the Scheme debugger. ! 222: Like scheme-mode except that the evaluation commands ! 223: are disabled, and characters that would normally be self inserting are ! 224: sent to the Scheme process instead. Typing ? will show you which ! 225: characters perform useful functions. ! 226: ! 227: Commands: ! 228: \\{scheme-debugger-mode-map}" ! 229: (error "Illegal entry to scheme-debugger-mode")) ! 230: ! 231: (defun scheme-debugger-mode-initialize () ! 232: (use-local-map scheme-debugger-mode-map) ! 233: (setq major-mode 'scheme-debugger-mode) ! 234: (setq mode-name "Scheme Debugger")) ! 235: ! 236: (defun scheme-debugger-mode-commands (keymap) ! 237: (let ((char ? )) ! 238: (while (< char 127) ! 239: (define-key keymap (char-to-string char) 'scheme-debugger-self-insert) ! 240: (setq char (1+ char))))) ! 241: ! 242: (defvar scheme-debugger-mode-map nil) ! 243: (if (not scheme-debugger-mode-map) ! 244: (progn ! 245: (setq scheme-debugger-mode-map (make-keymap)) ! 246: (scheme-mode-commands scheme-debugger-mode-map) ! 247: (xscheme-interrupt-commands scheme-debugger-mode-map) ! 248: (scheme-debugger-mode-commands scheme-debugger-mode-map))) ! 249: ! 250: (defun scheme-debugger-self-insert () ! 251: "Transmit this character to the Scheme process." ! 252: (interactive) ! 253: (xscheme-send-char last-command-char)) ! 254: ! 255: (defun xscheme-enter-debugger-mode (prompt-string) ! 256: (save-excursion ! 257: (set-buffer (xscheme-process-buffer)) ! 258: (if (not (eq major-mode 'scheme-debugger-mode)) ! 259: (progn ! 260: (if (not (eq major-mode 'scheme-interaction-mode)) ! 261: (scheme-interaction-mode)) ! 262: (scheme-debugger-mode-initialize))))) ! 263: ! 264: (defun xscheme-debugger-mode-p () ! 265: (let ((buffer (xscheme-process-buffer))) ! 266: (and buffer ! 267: (save-excursion ! 268: (set-buffer buffer) ! 269: (eq major-mode 'scheme-debugger-mode))))) ! 270: ! 271: ;;;; Evaluation Commands ! 272: ! 273: (defun xscheme-send-string (&rest strings) ! 274: "Send the string arguments to the Scheme process. ! 275: The strings are concatenated and terminated by a newline." ! 276: (cond ((not (xscheme-process-running-p)) ! 277: (if (yes-or-no-p "The Scheme process has died. Reset it? ") ! 278: (progn ! 279: (reset-scheme) ! 280: (xscheme-wait-for-process) ! 281: (goto-char (point-max)) ! 282: (apply 'insert-before-markers strings) ! 283: (xscheme-send-string-1 strings)))) ! 284: ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode")) ! 285: ((and (not xscheme-allow-pipelined-evaluation) ! 286: xscheme-running-p) ! 287: (error "No sends allowed while Scheme running")) ! 288: (t (xscheme-send-string-1 strings)))) ! 289: ! 290: (defun xscheme-send-string-1 (strings) ! 291: (let ((string (apply 'concat strings))) ! 292: (xscheme-send-string-2 string) ! 293: (if (eq major-mode 'scheme-interaction-mode) ! 294: (setq xscheme-previous-send string)))) ! 295: ! 296: (defun xscheme-send-string-2 (string) ! 297: (let ((process (get-process "scheme"))) ! 298: (send-string process (concat string "\n")) ! 299: (if (xscheme-process-buffer-current-p) ! 300: (set-marker (process-mark process) (point))))) ! 301: ! 302: (defun xscheme-yank-previous-send () ! 303: "Insert the most recent expression at point." ! 304: (interactive) ! 305: (push-mark) ! 306: (insert xscheme-previous-send)) ! 307: ! 308: (defun xscheme-select-process-buffer () ! 309: "Select the Scheme process buffer and move to its output point." ! 310: (interactive) ! 311: (let ((process (or (get-process "scheme") (error "No scheme process")))) ! 312: (let ((buffer (or (process-buffer process) (error "No process buffer")))) ! 313: (let ((window (get-buffer-window buffer))) ! 314: (if window ! 315: (select-window window) ! 316: (switch-to-buffer buffer)) ! 317: (goto-char (process-mark process)))))) ! 318: ! 319: (defun xscheme-send-region (start end) ! 320: "Send the current region to the Scheme process. ! 321: The region is sent terminated by a newline." ! 322: (interactive "r") ! 323: (if (xscheme-process-buffer-current-p) ! 324: (progn (goto-char end) ! 325: (set-marker (process-mark (get-process "scheme")) end))) ! 326: (xscheme-send-string (buffer-substring start end))) ! 327: ! 328: (defun xscheme-send-definition () ! 329: "Send the current definition to the Scheme process. ! 330: If the current line begins with a non-whitespace character, ! 331: parse an expression from the beginning of the line and send that instead." ! 332: (interactive) ! 333: (let ((start nil) (end nil)) ! 334: (save-excursion ! 335: (end-of-defun) ! 336: (setq end (point)) ! 337: (if (re-search-backward "^\\s(" nil t) ! 338: (setq start (point)) ! 339: (error "Can't find definition"))) ! 340: (xscheme-send-region start end))) ! 341: ! 342: (defun xscheme-send-next-expression () ! 343: "Send the expression to the right of `point' to the Scheme process." ! 344: (interactive) ! 345: (let ((start (point))) ! 346: (xscheme-send-region start (save-excursion (forward-sexp) (point))))) ! 347: ! 348: (defun xscheme-send-previous-expression () ! 349: "Send the expression to the left of `point' to the Scheme process." ! 350: (interactive) ! 351: (let ((end (point))) ! 352: (xscheme-send-region (save-excursion (backward-sexp) (point)) end))) ! 353: ! 354: (defun xscheme-send-current-line () ! 355: "Send the current line to the Scheme process. ! 356: Useful for working with debugging Scheme under adb." ! 357: (interactive) ! 358: (let ((line ! 359: (save-excursion ! 360: (beginning-of-line) ! 361: (let ((start (point))) ! 362: (end-of-line) ! 363: (buffer-substring start (point)))))) ! 364: (end-of-line) ! 365: (insert ?\n) ! 366: (xscheme-send-string-2 line))) ! 367: ! 368: (defun xscheme-send-buffer () ! 369: "Send the current buffer to the Scheme process." ! 370: (interactive) ! 371: (if (xscheme-process-buffer-current-p) ! 372: (error "Not allowed to send this buffer's contents to Scheme")) ! 373: (xscheme-send-region (point-min) (point-max))) ! 374: ! 375: (defun xscheme-send-char (char) ! 376: "Prompt for a character and send it to the Scheme process." ! 377: (interactive "cCharacter to send: ") ! 378: (send-string "scheme" (char-to-string char))) ! 379: ! 380: ;;;; Interrupts ! 381: ! 382: (defun xscheme-send-breakpoint-interrupt () ! 383: "Cause the Scheme process to enter a breakpoint." ! 384: (interactive) ! 385: (xscheme-send-interrupt ?b nil)) ! 386: ! 387: (defun xscheme-send-proceed () ! 388: "Cause the Scheme process to proceed from a breakpoint." ! 389: (interactive) ! 390: (send-string "scheme" "(proceed)\n")) ! 391: ! 392: (defun xscheme-send-control-g-interrupt () ! 393: "Cause the Scheme processor to halt and flush input. ! 394: Control returns to the top level rep loop." ! 395: (interactive) ! 396: (let ((inhibit-quit t)) ! 397: (cond ((not xscheme-control-g-synchronization-p) ! 398: (interrupt-process "scheme")) ! 399: (xscheme-control-g-disabled-p ! 400: (message "Relax...")) ! 401: (t ! 402: (setq xscheme-control-g-disabled-p t) ! 403: (message "Sending C-G interrupt to Scheme...") ! 404: (interrupt-process "scheme") ! 405: (send-string "scheme" (char-to-string 0)))))) ! 406: ! 407: (defun xscheme-send-control-u-interrupt () ! 408: "Cause the Scheme process to halt, returning to previous rep loop." ! 409: (interactive) ! 410: (xscheme-send-interrupt ?u t)) ! 411: ! 412: (defun xscheme-send-control-x-interrupt () ! 413: "Cause the Scheme process to halt, returning to current rep loop." ! 414: (interactive) ! 415: (xscheme-send-interrupt ?x t)) ! 416: ! 417: ;;; This doesn't really work right -- Scheme just gobbles the first ! 418: ;;; character in the input. There is no way for us to guarantee that ! 419: ;;; the argument to this procedure is the first char unless we put ! 420: ;;; some kind of marker in the input stream. ! 421: ! 422: (defun xscheme-send-interrupt (char mark-p) ! 423: "Send a ^A type interrupt to the Scheme process." ! 424: (interactive "cInterrupt character to send: ") ! 425: (quit-process "scheme") ! 426: (send-string "scheme" (char-to-string char)) ! 427: (if (and mark-p xscheme-control-g-synchronization-p) ! 428: (send-string "scheme" (char-to-string 0)))) ! 429: ! 430: ;;;; Internal Variables ! 431: ! 432: (defvar xscheme-process-command-line nil ! 433: "Command used to start the most recent Scheme process.") ! 434: ! 435: (defvar xscheme-previous-send "" ! 436: "Most recent expression transmitted to the Scheme process.") ! 437: ! 438: (defvar xscheme-process-filter-state 'idle ! 439: "State of scheme process escape reader state machine: ! 440: idle waiting for an escape sequence ! 441: reading-type received an altmode but nothing else ! 442: reading-string reading prompt string") ! 443: ! 444: (defvar xscheme-running-p nil ! 445: "This variable, if nil, indicates that the scheme process is ! 446: waiting for input. Otherwise, it is busy evaluating something.") ! 447: ! 448: (defconst xscheme-control-g-synchronization-p t ! 449: "If non-nil, insert markers in the scheme input stream to indicate when ! 450: control-g interrupts were signalled. Do not allow more control-g's to be ! 451: signalled until the scheme process acknowledges receipt.") ! 452: ! 453: (defvar xscheme-control-g-disabled-p nil ! 454: "This variable, if non-nil, indicates that a control-g is being processed ! 455: by the scheme process, so additional control-g's are to be ignored.") ! 456: ! 457: (defvar xscheme-allow-output-p t ! 458: "This variable, if nil, prevents output from the scheme process ! 459: from being inserted into the process-buffer.") ! 460: ! 461: (defvar xscheme-prompt "" ! 462: "The current scheme prompt string.") ! 463: ! 464: (defvar xscheme-string-accumulator "" ! 465: "Accumulator for the string being received from the scheme process.") ! 466: ! 467: (defvar xscheme-string-receiver nil ! 468: "Procedure to send the string argument from the scheme process.") ! 469: ! 470: (defvar xscheme-start-hook nil ! 471: "If non-nil, a procedure to call when the Scheme process is started. ! 472: When called, the current buffer will be the Scheme process-buffer.") ! 473: ! 474: (defvar xscheme-runlight-string nil) ! 475: (defvar xscheme-mode-string nil) ! 476: (defvar xscheme-filter-input nil) ! 477: ! 478: ;;;; Basic Process Control ! 479: ! 480: (defun xscheme-start-process (command-line) ! 481: (let ((buffer (get-buffer-create "*scheme*"))) ! 482: (let ((process (get-buffer-process buffer))) ! 483: (save-excursion ! 484: (set-buffer buffer) ! 485: (if (and process (memq (process-status process) '(run stop))) ! 486: (set-marker (process-mark process) (point-max)) ! 487: (progn (if process (delete-process process)) ! 488: (goto-char (point-max)) ! 489: (scheme-interaction-mode) ! 490: (if (bobp) ! 491: (insert-before-markers ! 492: (substitute-command-keys xscheme-startup-message))) ! 493: (setq process ! 494: (let ((process-connection-type nil)) ! 495: (apply 'start-process ! 496: (cons "scheme" ! 497: (cons buffer ! 498: (xscheme-parse-command-line ! 499: command-line)))))) ! 500: (set-marker (process-mark process) (point-max)) ! 501: (xscheme-process-filter-initialize t) ! 502: (xscheme-modeline-initialize) ! 503: (set-process-sentinel process 'xscheme-process-sentinel) ! 504: (set-process-filter process 'xscheme-process-filter) ! 505: (run-hooks 'xscheme-start-hook))))) ! 506: buffer)) ! 507: ! 508: (defun xscheme-parse-command-line (string) ! 509: (setq string (substitute-in-file-name string)) ! 510: (let ((start 0) ! 511: (result '())) ! 512: (while start ! 513: (let ((index (string-match "[ \t]" string start))) ! 514: (setq start ! 515: (cond ((not index) ! 516: (setq result ! 517: (cons (substring string start) ! 518: result)) ! 519: nil) ! 520: ((= index start) ! 521: (string-match "[^ \t]" string start)) ! 522: (t ! 523: (setq result ! 524: (cons (substring string start index) ! 525: result)) ! 526: (1+ index)))))) ! 527: (nreverse result))) ! 528: ! 529: (defun xscheme-wait-for-process () ! 530: (sleep-for 2) ! 531: (while xscheme-running-p ! 532: (sleep-for 1))) ! 533: ! 534: (defun xscheme-process-running-p () ! 535: "True iff there is a Scheme process whose status is `run'." ! 536: (let ((process (get-process "scheme"))) ! 537: (and process ! 538: (eq (process-status process) 'run)))) ! 539: ! 540: (defun xscheme-process-buffer () ! 541: (let ((process (get-process "scheme"))) ! 542: (and process (process-buffer process)))) ! 543: ! 544: (defun xscheme-process-buffer-window () ! 545: (let ((buffer (xscheme-process-buffer))) ! 546: (and buffer (get-buffer-window buffer)))) ! 547: ! 548: (defun xscheme-process-buffer-current-p () ! 549: "True iff the current buffer is the Scheme process buffer." ! 550: (eq (xscheme-process-buffer) (current-buffer))) ! 551: ! 552: ;;;; Process Filter ! 553: ! 554: (defun xscheme-process-sentinel (proc reason) ! 555: (xscheme-process-filter-initialize (eq reason 'run)) ! 556: (if (eq reason 'run) ! 557: (xscheme-modeline-initialize) ! 558: (progn ! 559: (setq scheme-mode-line-process "") ! 560: (setq xscheme-mode-string "no process"))) ! 561: (if (and (not (memq reason '(run stop))) ! 562: xscheme-signal-death-message) ! 563: (progn (beep) ! 564: (message ! 565: "The Scheme process has died! Do M-x reset-scheme to restart it")))) ! 566: ! 567: (defun xscheme-process-filter-initialize (running-p) ! 568: (setq xscheme-process-filter-state 'idle) ! 569: (setq xscheme-running-p running-p) ! 570: (setq xscheme-control-g-disabled-p nil) ! 571: (setq xscheme-allow-output-p t) ! 572: (setq xscheme-prompt "") ! 573: (setq scheme-mode-line-process '(": " xscheme-runlight-string))) ! 574: ! 575: (defun xscheme-process-filter (proc string) ! 576: (let ((xscheme-filter-input string)) ! 577: (while xscheme-filter-input ! 578: (cond ((eq xscheme-process-filter-state 'idle) ! 579: (let ((start (string-match "\e" xscheme-filter-input))) ! 580: (if start ! 581: (progn ! 582: (xscheme-process-filter-output ! 583: (substring xscheme-filter-input 0 start)) ! 584: (setq xscheme-filter-input ! 585: (substring xscheme-filter-input (1+ start))) ! 586: (setq xscheme-process-filter-state 'reading-type)) ! 587: (let ((string xscheme-filter-input)) ! 588: (setq xscheme-filter-input nil) ! 589: (xscheme-process-filter-output string))))) ! 590: ((eq xscheme-process-filter-state 'reading-type) ! 591: (if (zerop (length xscheme-filter-input)) ! 592: (setq xscheme-filter-input nil) ! 593: (let ((char (aref xscheme-filter-input 0))) ! 594: (setq xscheme-filter-input ! 595: (substring xscheme-filter-input 1)) ! 596: (let ((entry (assoc char xscheme-process-filter-alist))) ! 597: (if entry ! 598: (funcall (nth 2 entry) (nth 1 entry)) ! 599: (progn ! 600: (xscheme-process-filter-output ?\e char) ! 601: (setq xscheme-process-filter-state 'idle))))))) ! 602: ((eq xscheme-process-filter-state 'reading-string) ! 603: (let ((start (string-match "\e" xscheme-filter-input))) ! 604: (if start ! 605: (let ((string ! 606: (concat xscheme-string-accumulator ! 607: (substring xscheme-filter-input 0 start)))) ! 608: (setq xscheme-filter-input ! 609: (substring xscheme-filter-input (1+ start))) ! 610: (setq xscheme-process-filter-state 'idle) ! 611: (funcall xscheme-string-receiver string)) ! 612: (progn ! 613: (setq xscheme-string-accumulator ! 614: (concat xscheme-string-accumulator ! 615: xscheme-filter-input)) ! 616: (setq xscheme-filter-input nil))))) ! 617: (t ! 618: (error "Scheme process filter -- bad state")))))) ! 619: ! 620: ;;;; Process Filter Output ! 621: ! 622: (defun xscheme-process-filter-output (&rest args) ! 623: (if xscheme-allow-output-p ! 624: (let ((string (apply 'concat args))) ! 625: (save-excursion ! 626: (xscheme-goto-output-point) ! 627: (while (string-match "\\(\007\\|\f\\)" string) ! 628: (let ((start (match-beginning 0)) ! 629: (end (match-end 0))) ! 630: (insert-before-markers (substring string 0 start)) ! 631: (if (= ?\f (aref string start)) ! 632: (progn ! 633: (if (not (bolp)) ! 634: (insert-before-markers ?\n)) ! 635: (insert-before-markers ?\f)) ! 636: (beep)) ! 637: (setq string (substring string (1+ start))))) ! 638: (insert-before-markers string))))) ! 639: ! 640: (defun xscheme-guarantee-newlines (n) ! 641: (if xscheme-allow-output-p ! 642: (save-excursion ! 643: (xscheme-goto-output-point) ! 644: (let ((stop nil)) ! 645: (while (and (not stop) ! 646: (bolp)) ! 647: (setq n (1- n)) ! 648: (if (bobp) ! 649: (setq stop t) ! 650: (backward-char)))) ! 651: (xscheme-goto-output-point) ! 652: (while (> n 0) ! 653: (insert-before-markers ?\n) ! 654: (setq n (1- n)))))) ! 655: ! 656: (defun xscheme-goto-output-point () ! 657: (let ((process (get-process "scheme"))) ! 658: (set-buffer (process-buffer process)) ! 659: (goto-char (process-mark process)))) ! 660: ! 661: (defun xscheme-modeline-initialize () ! 662: (setq xscheme-runlight-string "") ! 663: (setq xscheme-mode-string "") ! 664: (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string))) ! 665: ! 666: (defun xscheme-set-runlight (runlight) ! 667: (setq xscheme-runlight-string runlight) ! 668: (xscheme-modeline-redisplay)) ! 669: ! 670: (defun xscheme-modeline-redisplay () ! 671: (save-excursion (set-buffer (other-buffer))) ! 672: (set-buffer-modified-p (buffer-modified-p)) ! 673: (sit-for 0)) ! 674: ! 675: ;;;; Process Filter Operations ! 676: ! 677: (defvar xscheme-process-filter-alist ! 678: '((?D xscheme-enter-debugger-mode ! 679: xscheme-process-filter:string-action) ! 680: (?P xscheme-set-prompt-variable ! 681: xscheme-process-filter:string-action) ! 682: (?R xscheme-enter-interaction-mode ! 683: xscheme-process-filter:simple-action) ! 684: (?b xscheme-start-gc ! 685: xscheme-process-filter:simple-action) ! 686: (?e xscheme-finish-gc ! 687: xscheme-process-filter:simple-action) ! 688: (?f xscheme-exit-input-wait ! 689: xscheme-process-filter:simple-action) ! 690: (?g xscheme-enable-control-g ! 691: xscheme-process-filter:simple-action) ! 692: (?i xscheme-prompt-for-expression ! 693: xscheme-process-filter:string-action) ! 694: (?m xscheme-message ! 695: xscheme-process-filter:string-action) ! 696: (?n xscheme-prompt-for-confirmation ! 697: xscheme-process-filter:string-action) ! 698: (?o xscheme-output-goto ! 699: xscheme-process-filter:simple-action) ! 700: (?p xscheme-set-prompt ! 701: xscheme-process-filter:string-action) ! 702: (?s xscheme-enter-input-wait ! 703: xscheme-process-filter:simple-action) ! 704: (?v xscheme-write-value ! 705: xscheme-process-filter:string-action) ! 706: (?w xscheme-cd ! 707: xscheme-process-filter:string-action) ! 708: (?z xscheme-display-process-buffer ! 709: xscheme-process-filter:simple-action) ! 710: (?c xscheme-unsolicited-read-char ! 711: xscheme-process-filter:simple-action)) ! 712: "Table used to decide how to handle process filter commands. ! 713: Value is a list of entries, each entry is a list of three items. ! 714: ! 715: The first item is the character that the process filter dispatches on. ! 716: The second item is the action to be taken, a function. ! 717: The third item is the handler for the entry, a function. ! 718: ! 719: When the process filter sees a command whose character matches a ! 720: particular entry, it calls the handler with two arguments: the action ! 721: and the string containing the rest of the process filter's input ! 722: stream. It is the responsibility of the handler to invoke the action ! 723: with the appropriate arguments, and to reenter the process filter with ! 724: the remaining input.") ! 725: ! 726: (defun xscheme-process-filter:simple-action (action) ! 727: (setq xscheme-process-filter-state 'idle) ! 728: (funcall action)) ! 729: ! 730: (defun xscheme-process-filter:string-action (action) ! 731: (setq xscheme-string-receiver action) ! 732: (setq xscheme-string-accumulator "") ! 733: (setq xscheme-process-filter-state 'reading-string)) ! 734: ! 735: (defconst xscheme-runlight:running "run" ! 736: "The character displayed when the Scheme process is running.") ! 737: ! 738: (defconst xscheme-runlight:input "input" ! 739: "The character displayed when the Scheme process is waiting for input.") ! 740: ! 741: (defconst xscheme-runlight:gc "gc" ! 742: "The character displayed when the Scheme process is garbage collecting.") ! 743: ! 744: (defun xscheme-start-gc () ! 745: (xscheme-set-runlight xscheme-runlight:gc)) ! 746: ! 747: (defun xscheme-finish-gc () ! 748: (xscheme-set-runlight ! 749: (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input))) ! 750: ! 751: (defun xscheme-enter-input-wait () ! 752: (xscheme-set-runlight xscheme-runlight:input) ! 753: (setq xscheme-running-p nil)) ! 754: ! 755: (defun xscheme-exit-input-wait () ! 756: (xscheme-set-runlight xscheme-runlight:running) ! 757: (setq xscheme-running-p t)) ! 758: ! 759: (defun xscheme-enable-control-g () ! 760: (setq xscheme-control-g-disabled-p nil)) ! 761: ! 762: (defun xscheme-display-process-buffer () ! 763: (let ((window (or (xscheme-process-buffer-window) ! 764: (display-buffer (xscheme-process-buffer))))) ! 765: (save-window-excursion ! 766: (select-window window) ! 767: (xscheme-goto-output-point) ! 768: (if (xscheme-debugger-mode-p) ! 769: (xscheme-enter-interaction-mode))))) ! 770: ! 771: (defun xscheme-unsolicited-read-char () ! 772: nil) ! 773: ! 774: (defun xscheme-message (string) ! 775: (if (not (zerop (length string))) ! 776: (xscheme-write-message-1 string (format ";%s" string)))) ! 777: ! 778: (defun xscheme-write-value (string) ! 779: (if (zerop (length string)) ! 780: (xscheme-write-message-1 "(no value)" ";No value") ! 781: (xscheme-write-message-1 string (format ";Value: %s" string)))) ! 782: ! 783: (defun xscheme-write-message-1 (message-string output-string) ! 784: (let* ((process (get-process "scheme")) ! 785: (window (get-buffer-window (process-buffer process)))) ! 786: (if (or (not window) ! 787: (not (pos-visible-in-window-p (process-mark process) ! 788: window))) ! 789: (message "%s" message-string))) ! 790: (xscheme-guarantee-newlines 1) ! 791: (xscheme-process-filter-output output-string)) ! 792: ! 793: (defun xscheme-set-prompt-variable (string) ! 794: (setq xscheme-prompt string)) ! 795: ! 796: (defun xscheme-set-prompt (string) ! 797: (setq xscheme-prompt string) ! 798: (xscheme-guarantee-newlines 2) ! 799: (setq xscheme-mode-string (xscheme-coerce-prompt string)) ! 800: (xscheme-modeline-redisplay)) ! 801: ! 802: (defun xscheme-output-goto () ! 803: (xscheme-goto-output-point) ! 804: (xscheme-guarantee-newlines 2)) ! 805: ! 806: (defun xscheme-coerce-prompt (string) ! 807: (if (string-match "^[0-9]+ " string) ! 808: (let ((end (match-end 0))) ! 809: (concat (substring string 0 end) ! 810: (let ((prompt (substring string end))) ! 811: (let ((entry (assoc prompt xscheme-prompt-alist))) ! 812: (if entry ! 813: (cdr entry) ! 814: prompt))))) ! 815: string)) ! 816: ! 817: (defvar xscheme-prompt-alist ! 818: '(("[Normal REPL]" . "[Evaluator]") ! 819: ("[Error REPL]" . "[Evaluator]") ! 820: ("[Breakpoint REPL]" . "[Evaluator]") ! 821: ("[Debugger REPL]" . "[Evaluator]") ! 822: ("[Visiting environment]" . "[Evaluator]") ! 823: ("[Environment Inspector]" . "[Where]")) ! 824: "An alist which maps the Scheme command interpreter type to a print string.") ! 825: ! 826: (defun xscheme-cd (directory-string) ! 827: (save-excursion ! 828: (set-buffer (xscheme-process-buffer)) ! 829: (cd directory-string))) ! 830: ! 831: (defun xscheme-prompt-for-confirmation (prompt-string) ! 832: (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n))) ! 833: ! 834: (defun xscheme-prompt-for-expression (prompt-string) ! 835: (xscheme-send-string-2 ! 836: (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map))) ! 837: ! 838: (defvar xscheme-prompt-for-expression-map nil) ! 839: (if (not xscheme-prompt-for-expression-map) ! 840: (progn ! 841: (setq xscheme-prompt-for-expression-map ! 842: (copy-keymap minibuffer-local-map)) ! 843: (substitute-key-definition 'exit-minibuffer ! 844: 'xscheme-prompt-for-expression-exit ! 845: xscheme-prompt-for-expression-map))) ! 846: ! 847: (defun xscheme-prompt-for-expression-exit () ! 848: (interactive) ! 849: (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one) ! 850: (exit-minibuffer) ! 851: (error "input must be a single, complete expression"))) ! 852: ! 853: (defun xscheme-region-expression-p (start end) ! 854: (save-excursion ! 855: (let ((old-syntax-table (syntax-table))) ! 856: (unwind-protect ! 857: (progn ! 858: (set-syntax-table scheme-mode-syntax-table) ! 859: (let ((state (parse-partial-sexp start end))) ! 860: (and (zerop (car state)) ;depth = 0 ! 861: (nth 2 state) ;last-sexp exists, i.e. >= 1 sexps ! 862: (let ((state (parse-partial-sexp start (nth 2 state)))) ! 863: (if (nth 2 state) 'many 'one))))) ! 864: (set-syntax-table old-syntax-table)))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.