Return to xscheme.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

Annotation of GNUtools/emacs/lisp/xscheme.el, revision 1.1

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