123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197 |
- ;;; xscheme.el --- run MIT Scheme under Emacs -*- lexical-binding: t; -*-
- ;; Copyright (C) 1986-1987, 1989-1990, 2001-2015 Free Software
- ;; Foundation, Inc.
- ;; Maintainer: emacs-devel@gnu.org
- ;; Keywords: languages, lisp
- ;; This file is part of GNU Emacs.
- ;; GNU Emacs is free software: you can redistribute it and/or modify
- ;; it under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation, either version 3 of the License, or
- ;; (at your option) any later version.
- ;; GNU Emacs is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
- ;; You should have received a copy of the GNU General Public License
- ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
- ;;; Commentary:
- ;; A major mode for interacting with MIT Scheme.
- ;;
- ;; Requires MIT Scheme release 5 or later.
- ;; Changes to Control-G handler require runtime version 13.85 or later.
- ;;; Code:
- (require 'scheme)
- ;;;; Internal Variables
- (defvar xscheme-previous-mode)
- (defvar xscheme-last-input-end)
- (defvar xscheme-process-command-line nil
- "Command used to start the most recent Scheme process.")
- (defvar xscheme-process-name "scheme"
- "Name of xscheme process that we're currently interacting with.")
- (defvar xscheme-buffer-name "*scheme*"
- "Name of xscheme buffer that we're currently interacting with.")
- (defvar xscheme-expressions-ring-max 30
- "Maximum length of Scheme expressions ring.")
- (defvar-local xscheme-expressions-ring nil
- "List of expressions recently transmitted to the Scheme process.")
- (defvar-local xscheme-expressions-ring-yank-pointer nil
- "The tail of the Scheme expressions ring whose car is the last thing yanked.")
- (defvar-local xscheme-running-p nil
- "This variable, if nil, indicates that the scheme process is
- waiting for input. Otherwise, it is busy evaluating something.")
- (defconst xscheme-control-g-synchronization-p t
- "If non-nil, insert markers in the scheme input stream to indicate when
- control-g interrupts were signaled. Do not allow more control-g's to be
- signaled until the scheme process acknowledges receipt.")
- (defvar-local xscheme-control-g-disabled-p nil
- "This variable, if non-nil, indicates that a control-g is being processed
- by the scheme process, so additional control-g's are to be ignored.")
- (defvar xscheme-string-receiver nil
- "Procedure to send the string argument from the scheme process.")
- (defconst default-xscheme-runlight
- '(": " xscheme-runlight-string)
- "Default global (shared) xscheme-runlight mode line format.")
- (defvar xscheme-runlight "")
- (defvar xscheme-runlight-string nil)
- (defvar-local xscheme-process-filter-state 'idle
- "State of scheme process escape reader state machine:
- idle waiting for an escape sequence
- reading-type received an altmode but nothing else
- reading-string reading prompt string")
- (defvar-local xscheme-allow-output-p t
- "This variable, if nil, prevents output from the scheme process
- from being inserted into the process-buffer.")
- (defvar-local xscheme-prompt ""
- "The current scheme prompt string.")
- (defvar-local xscheme-string-accumulator ""
- "Accumulator for the string being received from the scheme process.")
- (defvar-local xscheme-mode-string nil)
- (setq-default scheme-mode-line-process '("" xscheme-runlight))
- (make-variable-buffer-local 'scheme-mode-line-process)
- (defgroup xscheme nil
- "Major mode for editing Scheme and interacting with MIT's C-Scheme."
- :group 'lisp)
- (defcustom scheme-band-name nil
- "Band loaded by the `run-scheme' command."
- :type '(choice (const nil) string)
- :group 'xscheme)
- (defcustom scheme-program-arguments nil
- "Arguments passed to the Scheme program by the `run-scheme' command."
- :type '(choice (const nil) string)
- :group 'xscheme)
- (defcustom xscheme-allow-pipelined-evaluation t
- "If non-nil, an expression may be transmitted while another is evaluating.
- Otherwise, attempting to evaluate an expression before the previous expression
- has finished evaluating will signal an error."
- :type 'boolean
- :group 'xscheme)
- (defcustom xscheme-startup-message
- "This is the Scheme process buffer.
- Type \\[xscheme-send-previous-expression] to evaluate the expression before point.
- Type \\[xscheme-send-control-g-interrupt] to abort evaluation.
- Type \\[describe-mode] for more information.
- "
- "String to insert into Scheme process buffer first time it is started.
- Is processed with `substitute-command-keys' first."
- :type 'string
- :group 'xscheme)
- (defcustom xscheme-signal-death-message nil
- "If non-nil, causes a message to be generated when the Scheme process dies."
- :type 'boolean
- :group 'xscheme)
- (defcustom xscheme-start-hook nil
- "If non-nil, a procedure to call when the Scheme process is started.
- When called, the current buffer will be the Scheme process-buffer."
- :type 'hook
- :group 'xscheme
- :version "20.3")
- (defun xscheme-evaluation-commands (keymap)
- (define-key keymap "\e\C-x" 'xscheme-send-definition)
- (define-key keymap "\C-x\C-e" 'xscheme-send-previous-expression)
- (put 'xscheme-send-previous-expression :advertised-binding "\C-x\C-e")
- (define-key keymap "\eo" 'xscheme-send-buffer)
- (define-key keymap "\ez" 'xscheme-send-definition)
- (define-key keymap "\e\C-m" 'xscheme-send-previous-expression)
- (define-key keymap "\e\C-z" 'xscheme-send-region))
- (defun xscheme-interrupt-commands (keymap)
- (define-key keymap "\C-c\C-s" 'xscheme-select-process-buffer)
- (define-key keymap "\C-c\C-b" 'xscheme-send-breakpoint-interrupt)
- (define-key keymap "\C-c\C-c" 'xscheme-send-control-g-interrupt)
- (define-key keymap "\C-c\C-u" 'xscheme-send-control-u-interrupt)
- (define-key keymap "\C-c\C-x" 'xscheme-send-control-x-interrupt))
- (xscheme-evaluation-commands scheme-mode-map)
- (xscheme-interrupt-commands scheme-mode-map)
- (defun run-scheme (command-line)
- "Run MIT Scheme in an inferior process.
- Output goes to the buffer `*scheme*'.
- With argument, asks for a command line."
- (interactive (list (xscheme-read-command-line current-prefix-arg)))
- (xscheme-start command-line xscheme-process-name xscheme-buffer-name))
- (defun xscheme-start (command-line process-name buffer-name)
- (setq-default xscheme-process-command-line command-line)
- (switch-to-buffer
- (xscheme-start-process command-line process-name buffer-name))
- (set (make-local-variable 'xscheme-process-command-line) command-line))
- (defun xscheme-read-command-line (arg)
- (let ((default
- (or xscheme-process-command-line
- (xscheme-default-command-line))))
- (if arg
- (read-string "Run Scheme: " default)
- default)))
- (defun xscheme-default-command-line ()
- (concat scheme-program-name " -emacs"
- (if scheme-program-arguments
- (concat " " scheme-program-arguments)
- "")
- (if scheme-band-name
- (concat " -band " scheme-band-name)
- "")))
- (defun reset-scheme ()
- "Reset the Scheme process."
- (interactive)
- (let ((process (get-process xscheme-process-name)))
- (cond ((or (not process)
- (not (eq (process-status process) 'run))
- (yes-or-no-p
- "The Scheme process is running, are you SURE you want to reset it? "))
- (message "Resetting Scheme process...")
- (if process
- (progn
- (kill-process process t)
- (delete-process process)))
- (xscheme-start-process xscheme-process-command-line
- xscheme-process-name
- xscheme-buffer-name)
- (message "Resetting Scheme process...done")))))
- ;;;; Multiple Scheme buffer management commands
- (defun start-scheme (buffer-name &optional globally)
- "Choose a scheme interaction buffer, or create a new one."
- ;; (interactive "BScheme interaction buffer: \nP")
- (interactive
- (list (read-buffer "Scheme interaction buffer: "
- xscheme-buffer-name
- nil)
- current-prefix-arg))
- (let ((buffer (get-buffer-create buffer-name)))
- (let ((process (get-buffer-process buffer)))
- (if process
- (switch-to-buffer buffer)
- (if (or (not (buffer-file-name buffer))
- (yes-or-no-p (concat "Buffer "
- (buffer-name buffer)
- " contains file "
- (buffer-file-name buffer)
- "; start scheme in it? ")))
- (progn
- (xscheme-start (xscheme-read-command-line t)
- buffer-name
- buffer-name)
- (if globally
- (global-set-scheme-interaction-buffer buffer-name)))
- (message "start-scheme aborted"))))))
- (fset 'select-scheme 'start-scheme)
- (defun global-set-scheme-interaction-buffer (buffer-name)
- "Set the default scheme interaction buffer."
- (interactive
- (list (read-buffer "Scheme interaction buffer: "
- xscheme-buffer-name
- t)))
- (let ((process-name (verify-xscheme-buffer buffer-name nil)))
- (setq-default xscheme-buffer-name buffer-name)
- (setq-default xscheme-process-name process-name)
- (setq-default xscheme-runlight-string
- (with-current-buffer buffer-name
- xscheme-runlight-string))
- (setq-default xscheme-runlight
- (if (eq (process-status process-name) 'run)
- default-xscheme-runlight
- ""))))
- (defun local-set-scheme-interaction-buffer (buffer-name)
- "Set the scheme interaction buffer for the current buffer."
- (interactive
- (list (read-buffer "Scheme interaction buffer: "
- xscheme-buffer-name
- t)))
- (let ((process-name (verify-xscheme-buffer buffer-name t)))
- (set (make-local-variable 'xscheme-buffer-name) buffer-name)
- (set (make-local-variable 'xscheme-process-name) process-name)
- (set (make-local-variable 'xscheme-runlight)
- (with-current-buffer buffer-name
- xscheme-runlight))))
- (defun local-clear-scheme-interaction-buffer ()
- "Make the current buffer use the default scheme interaction buffer."
- (interactive)
- (if (xscheme-process-buffer-current-p)
- (error "Cannot change the interaction buffer of an interaction buffer"))
- (kill-local-variable 'xscheme-buffer-name)
- (kill-local-variable 'xscheme-process-name)
- (kill-local-variable 'xscheme-runlight))
- (defun verify-xscheme-buffer (buffer-name localp)
- (if (and localp (xscheme-process-buffer-current-p))
- (error "Cannot change the interaction buffer of an interaction buffer"))
- (let* ((buffer (get-buffer buffer-name))
- (process (and buffer (get-buffer-process buffer))))
- (cond ((not buffer)
- (error "Buffer `%s' does not exist" buffer-name))
- ((not process)
- (error "Buffer `%s' is not a scheme interaction buffer" buffer-name))
- (t
- (with-current-buffer buffer
- (if (not (xscheme-process-buffer-current-p))
- (error "Buffer `%s' is not a scheme interaction buffer"
- buffer-name)))
- (process-name process)))))
- ;;;; Interaction Mode
- (defun scheme-interaction-mode (&optional preserve)
- "Major mode for interacting with an inferior MIT Scheme process.
- Like scheme-mode except that:
- \\[xscheme-send-previous-expression] sends the expression before point to the Scheme process as input
- \\[xscheme-yank-pop] yanks an expression previously sent to Scheme
- \\[xscheme-yank-push] yanks an expression more recently sent to Scheme
- All output from the Scheme process is written in the Scheme process
- buffer, which is initially named \"*scheme*\". The result of
- evaluating a Scheme expression is also printed in the process buffer,
- preceded by the string \";Value: \" to highlight it. If the process
- buffer is not visible at that time, the value will also be displayed
- in the minibuffer. If an error occurs, the process buffer will
- automatically pop up to show you the error message.
- While the Scheme process is running, the mode lines of all buffers in
- scheme-mode are modified to show the state of the process. The
- possible states and their meanings are:
- input waiting for input
- run evaluating
- gc garbage collecting
- The process buffer's mode line contains additional information where
- the buffer's name is normally displayed: the command interpreter level
- and type.
- Scheme maintains a stack of command interpreters. Every time an error
- or breakpoint occurs, the current command interpreter is pushed on the
- command interpreter stack, and a new command interpreter is started.
- One example of why this is done is so that an error that occurs while
- you are debugging another error will not destroy the state of the
- initial error, allowing you to return to it after the second error has
- been fixed.
- The command interpreter level indicates how many interpreters are in
- the command interpreter stack. It is initially set to one, and it is
- incremented every time that stack is pushed, and decremented every
- time it is popped. The following commands are useful for manipulating
- the command interpreter stack:
- \\[xscheme-send-breakpoint-interrupt] pushes the stack once
- \\[xscheme-send-control-u-interrupt] pops the stack once
- \\[xscheme-send-control-g-interrupt] pops everything off
- \\[xscheme-send-control-x-interrupt] aborts evaluation, doesn't affect stack
- Some possible command interpreter types and their meanings are:
- \[Evaluator] read-eval-print loop for evaluating expressions
- \[Debugger] single character commands for debugging errors
- \[Where] single character commands for examining environments
- Starting with release 6.2 of Scheme, the latter two types of command
- interpreters will change the major mode of the Scheme process buffer
- to scheme-debugger-mode , in which the evaluation commands are
- disabled, and the keys which normally self insert instead send
- themselves to the Scheme process. The command character ? will list
- the available commands.
- For older releases of Scheme, the major mode will be be
- scheme-interaction-mode , and the command characters must be sent as
- if they were expressions.
- Commands:
- Delete converts tabs to spaces as it moves back.
- Blank lines separate paragraphs. Semicolons start comments.
- \\{scheme-interaction-mode-map}
- Entry to this mode calls the value of scheme-interaction-mode-hook
- with no args, if that value is non-nil.
- Likewise with the value of scheme-mode-hook.
- scheme-interaction-mode-hook is called after scheme-mode-hook."
- ;; FIXME: Use define-derived-mode.
- (interactive "P")
- (if (not preserve)
- (let ((previous-mode major-mode))
- (kill-all-local-variables)
- (make-local-variable 'xscheme-runlight-string)
- (make-local-variable 'xscheme-runlight)
- (set (make-local-variable 'xscheme-previous-mode) previous-mode)
- (let ((buffer (current-buffer)))
- (set (make-local-variable 'xscheme-buffer-name) (buffer-name buffer))
- (set (make-local-variable 'xscheme-last-input-end) (make-marker))
- (let ((process (get-buffer-process buffer)))
- (when process
- (setq-local xscheme-process-name (process-name process))
- ;; FIXME: Use add-function!
- (xscheme-process-filter-initialize t)
- (xscheme-mode-line-initialize xscheme-buffer-name)
- (add-function :override (process-sentinel process)
- #'xscheme-process-sentinel)
- (add-function :override (process-filter process)
- #'xscheme-process-filter))))))
- (scheme-interaction-mode-initialize)
- (scheme-mode-variables)
- (run-mode-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook))
- (defun exit-scheme-interaction-mode ()
- "Take buffer out of scheme interaction mode."
- (interactive)
- (if (not (derived-mode-p 'scheme-interaction-mode))
- (error "Buffer not in scheme interaction mode"))
- (funcall xscheme-previous-mode)
- (let ((process (get-buffer-process (current-buffer))))
- (when process
- (remove-function (process-sentinel process) #'xscheme-process-sentinel)
- (remove-function (process-filter process) #'xscheme-process-filter))))
- (defvar scheme-interaction-mode-commands-alist nil)
- (defvar scheme-interaction-mode-map nil)
- (defun scheme-interaction-mode-initialize ()
- (use-local-map scheme-interaction-mode-map)
- (setq major-mode 'scheme-interaction-mode) ;FIXME: Use define-derived-mode.
- (setq mode-name "Scheme Interaction"))
- (defun scheme-interaction-mode-commands (keymap)
- (let ((entries scheme-interaction-mode-commands-alist))
- (while entries
- (define-key keymap
- (car (car entries))
- (car (cdr (car entries))))
- (setq entries (cdr entries)))))
- ;; Initialize the command alist
- (setq scheme-interaction-mode-commands-alist
- (append scheme-interaction-mode-commands-alist
- '(("\C-c\C-m" xscheme-send-current-line)
- ("\C-c\C-o" xscheme-delete-output)
- ("\C-c\C-p" xscheme-send-proceed)
- ("\C-c\C-y" xscheme-yank)
- ("\ep" xscheme-yank-pop)
- ("\en" xscheme-yank-push))))
- ;; Initialize the mode map
- (if (not scheme-interaction-mode-map)
- (progn
- (setq scheme-interaction-mode-map (make-keymap))
- (scheme-mode-commands scheme-interaction-mode-map)
- (xscheme-interrupt-commands scheme-interaction-mode-map)
- (xscheme-evaluation-commands scheme-interaction-mode-map)
- (scheme-interaction-mode-commands scheme-interaction-mode-map)))
- (defun xscheme-enter-interaction-mode ()
- (with-current-buffer (xscheme-process-buffer)
- (if (not (derived-mode-p 'scheme-interaction-mode))
- (if (derived-mode-p 'scheme-debugger-mode)
- (scheme-interaction-mode-initialize)
- (scheme-interaction-mode t)))))
- (define-obsolete-function-alias 'advertised-xscheme-send-previous-expression
- 'xscheme-send-previous-expression "23.2")
- ;;;; Debugger Mode
- (defun scheme-debugger-mode ()
- "Major mode for executing the Scheme debugger.
- Like scheme-mode except that the evaluation commands
- are disabled, and characters that would normally be self inserting are
- sent to the Scheme process instead. Typing ? will show you which
- characters perform useful functions.
- Commands:
- \\{scheme-debugger-mode-map}"
- (error "Invalid entry to scheme-debugger-mode"))
- (defvar scheme-debugger-mode-map nil)
- (defun scheme-debugger-mode-initialize ()
- (use-local-map scheme-debugger-mode-map)
- (setq major-mode 'scheme-debugger-mode) ;FIXME: Use define-derived-mode.
- (setq mode-name "Scheme Debugger"))
- (defun scheme-debugger-mode-commands (keymap)
- (let ((char ?\s))
- (while (< char 127)
- (define-key keymap (char-to-string char) 'scheme-debugger-self-insert)
- (setq char (1+ char)))))
- ;; Initialize the debugger mode map
- (if (not scheme-debugger-mode-map)
- (progn
- (setq scheme-debugger-mode-map (make-keymap))
- (scheme-mode-commands scheme-debugger-mode-map)
- (xscheme-interrupt-commands scheme-debugger-mode-map)
- (scheme-debugger-mode-commands scheme-debugger-mode-map)))
- (defun scheme-debugger-self-insert ()
- "Transmit this character to the Scheme process."
- (interactive)
- (xscheme-send-char last-command-event))
- (defun xscheme-enter-debugger-mode (_prompt-string)
- (with-current-buffer (xscheme-process-buffer)
- (if (not (derived-mode-p 'scheme-debugger-mode))
- (progn
- (if (not (derived-mode-p 'scheme-interaction-mode))
- (scheme-interaction-mode t))
- (scheme-debugger-mode-initialize)))))
- (defun xscheme-debugger-mode-p ()
- (let ((buffer (xscheme-process-buffer)))
- (and buffer
- (with-current-buffer buffer
- (derived-mode-p 'scheme-debugger-mode)))))
- ;;;; Evaluation Commands
- (defun xscheme-send-string (&rest strings)
- "Send the string arguments to the Scheme process.
- The strings are concatenated and terminated by a newline."
- (cond ((not (xscheme-process-running-p))
- (if (yes-or-no-p "The Scheme process has died. Reset it? ")
- (progn
- (reset-scheme)
- (xscheme-wait-for-process)
- (xscheme-send-string-1 strings))))
- ((xscheme-debugger-mode-p) (error "No sends allowed in debugger mode"))
- ((and (not xscheme-allow-pipelined-evaluation)
- xscheme-running-p)
- (error "No sends allowed while Scheme running"))
- (t (xscheme-send-string-1 strings))))
- (defun xscheme-send-string-1 (strings)
- (let ((string (apply 'concat strings)))
- (xscheme-send-string-2 string)
- (if (derived-mode-p 'scheme-interaction-mode)
- (xscheme-insert-expression string))))
- (defun xscheme-send-string-2 (string)
- (let ((process (get-process xscheme-process-name)))
- (process-send-string process (concat string "\n"))
- (if (xscheme-process-buffer-current-p)
- (set-marker (process-mark process) (point)))))
- (defun xscheme-select-process-buffer ()
- "Select the Scheme process buffer and move to its output point."
- (interactive)
- (let ((process
- (or (get-process xscheme-process-name)
- (error "No scheme process"))))
- (let ((buffer (or (process-buffer process) (error "No process buffer"))))
- (let ((window (get-buffer-window buffer)))
- (if window
- (select-window window)
- (switch-to-buffer buffer))
- (goto-char (process-mark process))))))
- ;;;; Scheme expressions ring
- (defun xscheme-insert-expression (string)
- (setq xscheme-expressions-ring-yank-pointer
- (add-to-history 'xscheme-expressions-ring string
- xscheme-expressions-ring-max)))
- (defun xscheme-rotate-yank-pointer (arg)
- "Rotate the yanking point in the kill ring."
- (interactive "p")
- (let ((length (length xscheme-expressions-ring)))
- (if (zerop length)
- (error "Scheme expression ring is empty")
- (setq xscheme-expressions-ring-yank-pointer
- (let ((index
- (% (+ arg
- (- length
- (length xscheme-expressions-ring-yank-pointer)))
- length)))
- (nthcdr (if (< index 0)
- (+ index length)
- index)
- xscheme-expressions-ring))))))
- (defun xscheme-yank (&optional arg)
- "Insert the most recent expression at point.
- With just C-U as argument, same but put point in front (and mark at end).
- With argument n, reinsert the nth most recently sent expression.
- See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]."
- (interactive "*P")
- (xscheme-rotate-yank-pointer (if (listp arg) 0
- (if (eq arg '-) -1
- (1- arg))))
- (push-mark (point))
- (insert (car xscheme-expressions-ring-yank-pointer))
- (if (consp arg)
- (exchange-point-and-mark)))
- ;; Old name, to avoid errors in users' init files.
- (fset 'xscheme-yank-previous-send
- 'xscheme-yank)
- (defun xscheme-yank-pop (arg)
- "Insert or replace a just-yanked expression with an older expression.
- If the previous command was not a yank, it yanks.
- Otherwise, the region contains a stretch of reinserted
- expression. yank-pop deletes that text and inserts in its
- place a different expression.
- With no argument, the next older expression is inserted.
- With argument n, the n'th older expression is inserted.
- If n is negative, this is a more recent expression.
- The sequence of expressions wraps around, so that after the oldest one
- comes the newest one."
- (interactive "*p")
- (setq this-command 'xscheme-yank)
- (if (not (eq last-command 'xscheme-yank))
- (progn
- (xscheme-yank)
- (setq arg (- arg 1))))
- (if (not (= arg 0))
- (let ((before (< (point) (mark))))
- (delete-region (point) (mark))
- (xscheme-rotate-yank-pointer arg)
- (set-mark (point))
- (insert (car xscheme-expressions-ring-yank-pointer))
- (if before (exchange-point-and-mark)))))
- (defun xscheme-yank-push (arg)
- "Insert or replace a just-yanked expression with a more recent expression.
- If the previous command was not a yank, it yanks.
- Otherwise, the region contains a stretch of reinserted
- expression. yank-pop deletes that text and inserts in its
- place a different expression.
- With no argument, the next more recent expression is inserted.
- With argument n, the n'th more recent expression is inserted.
- If n is negative, a less recent expression is used.
- The sequence of expressions wraps around, so that after the oldest one
- comes the newest one."
- (interactive "*p")
- (xscheme-yank-pop (- 0 arg)))
- (defun xscheme-send-region (start end)
- "Send the current region to the Scheme process.
- The region is sent terminated by a newline."
- (interactive "r")
- (if (xscheme-process-buffer-current-p)
- (progn
- (goto-char end)
- (if (not (bolp))
- (insert-before-markers ?\n))
- (set-marker (process-mark (get-process xscheme-process-name))
- (point))
- (set-marker xscheme-last-input-end (point))))
- (xscheme-send-string (buffer-substring start end)))
- (defun xscheme-send-definition ()
- "Send the current definition to the Scheme process.
- If the current line begins with a non-whitespace character,
- parse an expression from the beginning of the line and send that instead."
- (interactive)
- (let ((start nil) (end nil))
- (save-excursion
- (end-of-defun)
- (setq end (point))
- (if (re-search-backward "^\\s(" nil t)
- (setq start (point))
- (error "Can't find definition")))
- (xscheme-send-region start end)))
- (defun xscheme-send-next-expression ()
- "Send the expression to the right of `point' to the Scheme process."
- (interactive)
- (let ((start (point)))
- (xscheme-send-region start (save-excursion (forward-sexp) (point)))))
- (defun xscheme-send-previous-expression ()
- "Send the expression to the left of `point' to the Scheme process."
- (interactive)
- (let ((end (point)))
- (xscheme-send-region (save-excursion (backward-sexp) (point)) end)))
- (defun xscheme-send-current-line ()
- "Send the current line to the Scheme process.
- Useful for working with debugging Scheme under adb."
- (interactive)
- (let ((line (buffer-substring (line-beginning-position) (line-end-position))))
- (end-of-line)
- (insert ?\n)
- (xscheme-send-string-2 line)))
- (defun xscheme-send-buffer ()
- "Send the current buffer to the Scheme process."
- (interactive)
- (if (xscheme-process-buffer-current-p)
- (error "Not allowed to send this buffer's contents to Scheme"))
- (xscheme-send-region (point-min) (point-max)))
- (defun xscheme-send-char (char)
- "Prompt for a character and send it to the Scheme process."
- (interactive "cCharacter to send: ")
- (process-send-string xscheme-process-name (char-to-string char)))
- (defun xscheme-delete-output ()
- "Delete all output from interpreter since last input."
- (interactive)
- (let ((proc (get-buffer-process (current-buffer))))
- (save-excursion
- (goto-char (process-mark proc))
- (re-search-backward
- "^;\\(Unspecified return value$\\|Value\\( [0-9]+\\)?: \\|\\(Abort\\|Up\\|Quit\\)!$\\)"
- xscheme-last-input-end
- t)
- (forward-line 0)
- (if (< (marker-position xscheme-last-input-end) (point))
- (progn
- (delete-region xscheme-last-input-end (point))
- (insert-before-markers "*** output flushed ***\n"))))))
- ;;;; Interrupts
- (defun xscheme-send-breakpoint-interrupt ()
- "Cause the Scheme process to enter a breakpoint."
- (interactive)
- (xscheme-send-interrupt ?b nil))
- (defun xscheme-send-proceed ()
- "Cause the Scheme process to proceed from a breakpoint."
- (interactive)
- (process-send-string xscheme-process-name "(proceed)\n"))
- (defconst xscheme-control-g-message-string
- "Sending C-G interrupt to Scheme...")
- (defun xscheme-send-control-g-interrupt ()
- "Cause the Scheme processor to halt and flush input.
- Control returns to the top level rep loop."
- (interactive)
- (let ((inhibit-quit t))
- (cond ((not xscheme-control-g-synchronization-p)
- (interrupt-process xscheme-process-name))
- ((with-current-buffer xscheme-buffer-name
- xscheme-control-g-disabled-p)
- (message "Relax..."))
- (t
- (with-current-buffer xscheme-buffer-name
- (setq xscheme-control-g-disabled-p t))
- (message xscheme-control-g-message-string)
- (interrupt-process xscheme-process-name)
- (sleep-for 0.1)
- (xscheme-send-char 0)))))
- (defun xscheme-send-control-u-interrupt ()
- "Cause the Scheme process to halt, returning to previous rep loop."
- (interactive)
- (xscheme-send-interrupt ?u t))
- (defun xscheme-send-control-x-interrupt ()
- "Cause the Scheme process to halt, returning to current rep loop."
- (interactive)
- (xscheme-send-interrupt ?x t))
- ;;; This doesn't really work right -- Scheme just gobbles the first
- ;;; character in the input. There is no way for us to guarantee that
- ;;; the argument to this procedure is the first char unless we put
- ;;; some kind of marker in the input stream.
- (defun xscheme-send-interrupt (char mark-p)
- "Send a ^A type interrupt to the Scheme process."
- (interactive "cInterrupt character to send: ")
- (quit-process xscheme-process-name)
- (sleep-for 0.1)
- (xscheme-send-char char)
- (if (and mark-p xscheme-control-g-synchronization-p)
- (xscheme-send-char 0)))
- ;;;; Basic Process Control
- (defun xscheme-start-process (command-line the-process the-buffer)
- (let ((buffer (get-buffer-create the-buffer)))
- (let ((process (get-buffer-process buffer)))
- (with-current-buffer buffer
- (if (and process (memq (process-status process) '(run stop)))
- (set-marker (process-mark process) (point-max))
- (progn (if process (delete-process process))
- (goto-char (point-max))
- (scheme-interaction-mode nil)
- (setq xscheme-process-name the-process)
- (if (bobp)
- (insert-before-markers
- (substitute-command-keys xscheme-startup-message)))
- (setq process
- (let ((process-connection-type nil))
- (apply 'start-process
- (cons the-process
- (cons buffer
- (xscheme-parse-command-line
- command-line))))))
- (if (not (equal (process-name process) the-process))
- (setq xscheme-process-name (process-name process)))
- (if (not (equal (buffer-name buffer) the-buffer))
- (setq xscheme-buffer-name (buffer-name buffer)))
- (message "Starting process %s in buffer %s"
- xscheme-process-name
- xscheme-buffer-name)
- (set-marker (process-mark process) (point-max))
- (xscheme-process-filter-initialize t)
- (xscheme-mode-line-initialize xscheme-buffer-name)
- (set-process-sentinel process 'xscheme-process-sentinel)
- (set-process-filter process 'xscheme-process-filter)
- (run-hooks 'xscheme-start-hook)))))
- buffer))
- (defun xscheme-parse-command-line (string)
- (setq string (substitute-in-file-name string))
- (let ((start 0)
- (result '()))
- (while start
- (let ((index (string-match "[ \t]" string start)))
- (setq start
- (cond ((not index)
- (setq result
- (cons (substring string start)
- result))
- nil)
- ((= index start)
- (string-match "[^ \t]" string start))
- (t
- (setq result
- (cons (substring string start index)
- result))
- (1+ index))))))
- (nreverse result)))
- (defun xscheme-wait-for-process ()
- (sleep-for 2)
- (while xscheme-running-p
- (sleep-for 1)))
- (defun xscheme-process-running-p ()
- "True if there is a Scheme process whose status is `run'."
- (let ((process (get-process xscheme-process-name)))
- (and process
- (eq (process-status process) 'run))))
- (defun xscheme-process-buffer ()
- (let ((process (get-process xscheme-process-name)))
- (and process (process-buffer process))))
- (defun xscheme-process-buffer-window ()
- (let ((buffer (xscheme-process-buffer)))
- (and buffer (get-buffer-window buffer))))
- (defun xscheme-process-buffer-current-p ()
- "True if the current buffer is the Scheme process buffer."
- (eq (xscheme-process-buffer) (current-buffer)))
- ;;;; Process Filter Operations
- (defvar xscheme-process-filter-alist
- '((?A xscheme-eval
- xscheme-process-filter:string-action-noexcursion)
- (?D xscheme-enter-debugger-mode
- xscheme-process-filter:string-action)
- (?E xscheme-eval
- xscheme-process-filter:string-action)
- (?P xscheme-set-prompt-variable
- xscheme-process-filter:string-action)
- (?R xscheme-enter-interaction-mode
- xscheme-process-filter:simple-action)
- (?b xscheme-start-gc
- xscheme-process-filter:simple-action)
- (?c xscheme-unsolicited-read-char
- xscheme-process-filter:simple-action)
- (?e xscheme-finish-gc
- xscheme-process-filter:simple-action)
- (?f xscheme-exit-input-wait
- xscheme-process-filter:simple-action)
- (?g xscheme-enable-control-g
- xscheme-process-filter:simple-action)
- (?i xscheme-prompt-for-expression
- xscheme-process-filter:string-action)
- (?m xscheme-message
- xscheme-process-filter:string-action)
- (?n xscheme-prompt-for-confirmation
- xscheme-process-filter:string-action)
- (?o xscheme-output-goto
- xscheme-process-filter:simple-action)
- (?p xscheme-set-prompt
- xscheme-process-filter:string-action)
- (?s xscheme-enter-input-wait
- xscheme-process-filter:simple-action)
- (?v xscheme-write-value
- xscheme-process-filter:string-action)
- (?w xscheme-cd
- xscheme-process-filter:string-action)
- (?z xscheme-display-process-buffer
- xscheme-process-filter:simple-action))
- "Table used to decide how to handle process filter commands.
- Value is a list of entries, each entry is a list of three items.
- The first item is the character that the process filter dispatches on.
- The second item is the action to be taken, a function.
- The third item is the handler for the entry, a function.
- When the process filter sees a command whose character matches a
- particular entry, it calls the handler with two arguments: the action
- and the string containing the rest of the process filter's input
- stream. It is the responsibility of the handler to invoke the action
- with the appropriate arguments, and to reenter the process filter with
- the remaining input.")
- ;;;; Process Filter
- (defun xscheme-process-sentinel (proc reason)
- (let* ((buffer (process-buffer proc))
- (name (buffer-name buffer)))
- (with-current-buffer buffer
- (xscheme-process-filter-initialize (eq reason 'run))
- (if (not (eq reason 'run))
- (progn
- (setq scheme-mode-line-process "")
- (setq xscheme-mode-string "no process")
- (if (equal name (default-value 'xscheme-buffer-name))
- (setq-default xscheme-runlight ""))))
- (if (and (not (memq reason '(run stop)))
- xscheme-signal-death-message)
- (progn
- (beep)
- (message
- "The Scheme process has died! Do M-x reset-scheme to restart it"))))))
- (defun xscheme-process-filter-initialize (running-p)
- (setq xscheme-process-filter-state 'idle)
- (setq xscheme-running-p running-p)
- (setq xscheme-control-g-disabled-p nil)
- (setq xscheme-allow-output-p t)
- (setq xscheme-prompt "")
- (if running-p
- (let ((name (buffer-name (current-buffer))))
- (setq scheme-mode-line-process '(": " xscheme-runlight-string))
- (xscheme-mode-line-initialize name)
- (if (equal name (default-value 'xscheme-buffer-name))
- (setq-default xscheme-runlight default-xscheme-runlight))))
- (if (or (eq xscheme-runlight default-xscheme-runlight)
- (equal xscheme-runlight ""))
- (setq xscheme-runlight (list ": " 'xscheme-buffer-name ": " "?")))
- (rplaca (nthcdr 3 xscheme-runlight)
- (if running-p "?" "no process")))
- (defun xscheme-process-filter (proc string)
- (let ((xscheme-filter-input string)
- (call-noexcursion nil))
- (while xscheme-filter-input
- (setq call-noexcursion nil)
- (with-current-buffer (process-buffer proc)
- (cond ((eq xscheme-process-filter-state 'idle)
- (let ((start (string-match "\e" xscheme-filter-input)))
- (if start
- (progn
- (xscheme-process-filter-output
- (substring xscheme-filter-input 0 start))
- (setq xscheme-filter-input
- (substring xscheme-filter-input (1+ start)))
- (setq xscheme-process-filter-state 'reading-type))
- (let ((string xscheme-filter-input))
- (setq xscheme-filter-input nil)
- (xscheme-process-filter-output string)))))
- ((eq xscheme-process-filter-state 'reading-type)
- (if (zerop (length xscheme-filter-input))
- (setq xscheme-filter-input nil)
- (let ((char (aref xscheme-filter-input 0)))
- (setq xscheme-filter-input
- (substring xscheme-filter-input 1))
- (let ((entry (assoc char xscheme-process-filter-alist)))
- (if entry
- (funcall (nth 2 entry) (nth 1 entry))
- (progn
- (xscheme-process-filter-output ?\e char)
- (setq xscheme-process-filter-state 'idle)))))))
- ((eq xscheme-process-filter-state 'reading-string)
- (let ((start (string-match "\e" xscheme-filter-input)))
- (if start
- (let ((string
- (concat xscheme-string-accumulator
- (substring xscheme-filter-input 0 start))))
- (setq xscheme-filter-input
- (substring xscheme-filter-input (1+ start)))
- (setq xscheme-process-filter-state 'idle)
- (if (listp xscheme-string-receiver)
- (progn
- (setq xscheme-string-receiver
- (car xscheme-string-receiver))
- (setq call-noexcursion string))
- (funcall xscheme-string-receiver string)))
- (progn
- (setq xscheme-string-accumulator
- (concat xscheme-string-accumulator
- xscheme-filter-input))
- (setq xscheme-filter-input nil)))))
- (t
- (error "Scheme process filter -- bad state"))))
- (if call-noexcursion
- (funcall xscheme-string-receiver call-noexcursion)))))
- ;;;; Process Filter Output
- (defun xscheme-process-filter-output (&rest args)
- (if xscheme-allow-output-p
- (let ((string (apply 'concat args)))
- (save-excursion
- (xscheme-goto-output-point)
- (let ((old-point (point)))
- (while (string-match "\\(\007\\|\f\\)" string)
- (let ((start (match-beginning 0)))
- (insert-before-markers (substring string 0 start))
- (if (= ?\f (aref string start))
- (progn
- (if (not (bolp))
- (insert-before-markers ?\n))
- (insert-before-markers ?\f))
- (beep))
- (setq string (substring string (1+ start)))))
- (insert-before-markers string)
- (if (and xscheme-last-input-end
- (equal (marker-position xscheme-last-input-end) (point)))
- (set-marker xscheme-last-input-end old-point)))))))
- (defun xscheme-guarantee-newlines (n)
- (if xscheme-allow-output-p
- (save-excursion
- (xscheme-goto-output-point)
- (let ((stop nil))
- (while (and (not stop)
- (bolp))
- (setq n (1- n))
- (if (bobp)
- (setq stop t)
- (backward-char))))
- (xscheme-goto-output-point)
- (while (> n 0)
- (insert-before-markers ?\n)
- (setq n (1- n))))))
- (defun xscheme-goto-output-point ()
- (let ((process (get-process xscheme-process-name)))
- (set-buffer (process-buffer process))
- (goto-char (process-mark process))))
- (defun xscheme-mode-line-initialize (name)
- (setq xscheme-runlight-string "")
- (if (equal name (default-value 'xscheme-buffer-name))
- (setq-default xscheme-runlight-string ""))
- (setq xscheme-mode-string "")
- (setq mode-line-buffer-identification
- (list (concat name ": ")
- 'xscheme-mode-string)))
- (defun xscheme-set-runlight (runlight)
- (setq xscheme-runlight-string runlight)
- (if (equal (buffer-name (current-buffer))
- (default-value 'xscheme-buffer-name))
- (setq-default xscheme-runlight-string runlight))
- (rplaca (nthcdr 3 xscheme-runlight) runlight)
- (force-mode-line-update t))
- (defun xscheme-process-filter:simple-action (action)
- (setq xscheme-process-filter-state 'idle)
- (funcall action))
- (defun xscheme-process-filter:string-action (action)
- (setq xscheme-string-receiver action)
- (setq xscheme-string-accumulator "")
- (setq xscheme-process-filter-state 'reading-string))
- (defun xscheme-process-filter:string-action-noexcursion (action)
- (xscheme-process-filter:string-action (cons action nil)))
- (defconst xscheme-runlight:running "run"
- "The character displayed when the Scheme process is running.")
- (defconst xscheme-runlight:input "input"
- "The character displayed when the Scheme process is waiting for input.")
- (defconst xscheme-runlight:gc "gc"
- "The character displayed when the Scheme process is garbage collecting.")
- (defun xscheme-start-gc ()
- (xscheme-set-runlight xscheme-runlight:gc))
- (defun xscheme-finish-gc ()
- (xscheme-set-runlight
- (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input)))
- (defun xscheme-enter-input-wait ()
- (xscheme-set-runlight xscheme-runlight:input)
- (setq xscheme-control-g-disabled-p nil)
- (setq xscheme-running-p nil))
- (defun xscheme-exit-input-wait ()
- (xscheme-set-runlight xscheme-runlight:running)
- (setq xscheme-running-p t))
- (defun xscheme-enable-control-g ()
- (setq xscheme-control-g-disabled-p nil)
- (if (string= (current-message) xscheme-control-g-message-string)
- (message nil)))
- (defun xscheme-display-process-buffer ()
- (let ((window (or (xscheme-process-buffer-window)
- (display-buffer (xscheme-process-buffer)))))
- (save-window-excursion
- (select-window window)
- (xscheme-goto-output-point)
- (if (xscheme-debugger-mode-p)
- (xscheme-enter-interaction-mode)))))
- (defun xscheme-unsolicited-read-char ()
- nil)
- (defun xscheme-eval (string)
- (eval (car (read-from-string string))))
- (defun xscheme-message (string)
- (if (not (zerop (length string)))
- (xscheme-write-message-1 string (format ";%s" string))))
- (defun xscheme-write-value (string)
- (if (zerop (length string))
- (xscheme-write-message-1 "(no value)" ";Unspecified return value")
- (xscheme-write-message-1 string (format ";Value: %s" string))))
- (defun xscheme-write-message-1 (message-string output-string)
- (let* ((process (get-process xscheme-process-name))
- (window (get-buffer-window (process-buffer process))))
- (if (or (not window)
- (not (pos-visible-in-window-p (process-mark process)
- window)))
- (message "%s" message-string)))
- (xscheme-guarantee-newlines 1)
- (xscheme-process-filter-output output-string))
- (defun xscheme-set-prompt-variable (string)
- (setq xscheme-prompt string))
- (defun xscheme-set-prompt (string)
- (setq xscheme-prompt string)
- (xscheme-guarantee-newlines 2)
- (setq xscheme-mode-string (xscheme-coerce-prompt string))
- (force-mode-line-update t))
- (defun xscheme-output-goto ()
- (xscheme-goto-output-point)
- (xscheme-guarantee-newlines 2))
- (defun xscheme-coerce-prompt (string)
- (if (string-match "^[0-9]+ \\[[^]]+\\] " string)
- (let ((end (match-end 0)))
- (xscheme-process-filter-output (substring string end))
- (substring string 0 (- end 1)))
- string))
- (defun xscheme-cd (directory-string)
- (with-current-buffer (xscheme-process-buffer)
- (cd directory-string)))
- (defun xscheme-prompt-for-confirmation (prompt-string)
- (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n)))
- (defvar xscheme-prompt-for-expression-map nil)
- (if (not xscheme-prompt-for-expression-map)
- (progn
- (setq xscheme-prompt-for-expression-map
- (copy-keymap minibuffer-local-map))
- (substitute-key-definition 'exit-minibuffer
- 'xscheme-prompt-for-expression-exit
- xscheme-prompt-for-expression-map)))
- (defun xscheme-prompt-for-expression (prompt-string)
- (xscheme-send-string-2
- (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map)))
- (defun xscheme-prompt-for-expression-exit ()
- (interactive)
- (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one)
- (exit-minibuffer)
- (error "input must be a single, complete expression")))
- (defun xscheme-region-expression-p (start end)
- (save-excursion
- (let ((old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table scheme-mode-syntax-table)
- (let ((state (parse-partial-sexp start end)))
- (and (zerop (car state)) ;depth = 0
- (nth 2 state) ;last-sexp exists, i.e. >= 1 sexps
- (let ((state (parse-partial-sexp start (nth 2 state))))
- (if (nth 2 state) 'many 'one)))))
- (set-syntax-table old-syntax-table)))))
- (provide 'xscheme)
- ;;; xscheme.el ends here
|