;;; xscheme.el --- run MIT Scheme under Emacs
-;; Copyright (C) 1986, 1987, 1989, 1990, 2001, 2002, 2003, 2004, 2005, 2006, 2007
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1989-1990, 2001-2014 Free Software
+;; Foundation, Inc.
-;; Maintainer: FSF
+;; 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
+;; 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, or (at your option)
-;; any later version.
+;; 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
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;; Internal Variables
(defvar xscheme-previous-mode)
-(defvar xscheme-previous-process-state)
(defvar xscheme-last-input-end)
(defvar xscheme-process-command-line nil
"Name of xscheme buffer that we're currently interacting with.")
(defvar xscheme-expressions-ring-max 30
- "*Maximum length of Scheme expressions ring.")
+ "Maximum length of Scheme expressions ring.")
(defvar xscheme-expressions-ring nil
"List of expressions recently transmitted to the Scheme process.")
(defconst default-xscheme-runlight
'(": " xscheme-runlight-string)
- "Default global (shared) xscheme-runlight modeline format.")
+ "Default global (shared) xscheme-runlight mode line format.")
(defvar xscheme-runlight "")
(defvar xscheme-runlight-string nil)
:group 'lisp)
(defcustom scheme-band-name nil
- "*Band loaded by the `run-scheme' command."
+ "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."
+ "Arguments passed to the Scheme program by the `run-scheme' command."
:type '(choice (const nil) string)
:group 'xscheme)
(defcustom xscheme-startup-message
"This is the Scheme process buffer.
-Type \\[advertised-xscheme-send-previous-expression] to evaluate the expression before point.
+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.
(defun xscheme-evaluation-commands (keymap)
(define-key keymap "\e\C-x" 'xscheme-send-definition)
- (define-key keymap "\C-x\C-e" 'advertised-xscheme-send-previous-expression)
+ (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)
(setq-default xscheme-process-command-line command-line)
(switch-to-buffer
(xscheme-start-process command-line process-name buffer-name))
- (make-local-variable 'xscheme-process-command-line)
- (setq xscheme-process-command-line command-line))
+ (set (make-local-variable 'xscheme-process-command-line) command-line))
(defun xscheme-read-command-line (arg)
(let ((default
(setq-default xscheme-buffer-name buffer-name)
(setq-default xscheme-process-name process-name)
(setq-default xscheme-runlight-string
- (save-excursion (set-buffer buffer-name)
- 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
xscheme-buffer-name
t)))
(let ((process-name (verify-xscheme-buffer buffer-name t)))
- (make-local-variable 'xscheme-buffer-name)
- (setq xscheme-buffer-name buffer-name)
- (make-local-variable 'xscheme-process-name)
- (setq xscheme-process-name process-name)
- (make-local-variable 'xscheme-runlight)
- (setq xscheme-runlight (save-excursion (set-buffer buffer-name)
- xscheme-runlight))))
+ (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."
((not process)
(error "Buffer `%s' is not a scheme interaction buffer" buffer-name))
(t
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(if (not (xscheme-process-buffer-current-p))
(error "Buffer `%s' is not a scheme interaction buffer"
buffer-name)))
"Major mode for interacting with an inferior MIT Scheme process.
Like scheme-mode except that:
-\\[advertised-xscheme-send-previous-expression] sends the expression before point to the Scheme process as input
+\\[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
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 modelines of all buffers in
+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:
run evaluating
gc garbage collecting
-The process buffer's modeline contains additional information where
+The process buffer's mode line contains additional information where
the buffer's name is normally displayed: the command interpreter level
and type.
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-previous-mode)
- (make-local-variable 'xscheme-buffer-name)
- (make-local-variable 'xscheme-process-name)
- (make-local-variable 'xscheme-previous-process-state)
(make-local-variable 'xscheme-runlight-string)
(make-local-variable 'xscheme-runlight)
- (make-local-variable 'xscheme-last-input-end)
- (setq xscheme-previous-mode previous-mode)
+ (set (make-local-variable 'xscheme-previous-mode) previous-mode)
(let ((buffer (current-buffer)))
- (setq xscheme-buffer-name (buffer-name buffer))
- (setq xscheme-last-input-end (make-marker))
+ (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)))
- (if process
- (progn
- (setq xscheme-process-name (process-name process))
- (setq xscheme-previous-process-state
- (cons (process-filter process)
- (process-sentinel process)))
- (xscheme-process-filter-initialize t)
- (xscheme-modeline-initialize xscheme-buffer-name)
- (set-process-sentinel process 'xscheme-process-sentinel)
- (set-process-filter process 'xscheme-process-filter))
- (setq xscheme-previous-process-state (cons nil nil)))))))
+ (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"
+ "Take buffer out of scheme interaction mode."
(interactive)
- (if (not (eq major-mode 'scheme-interaction-mode))
+ (if (not (derived-mode-p 'scheme-interaction-mode))
(error "Buffer not in scheme interaction mode"))
- (let ((previous-state xscheme-previous-process-state))
- (funcall xscheme-previous-mode)
- (let ((process (get-buffer-process (current-buffer))))
- (if process
- (progn
- (if (eq (process-filter process) 'xscheme-process-filter)
- (set-process-filter process (car previous-state)))
- (if (eq (process-sentinel process) 'xscheme-process-sentinel)
- (set-process-sentinel process (cdr previous-state))))))))
+ (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)
+ (setq major-mode 'scheme-interaction-mode) ;FIXME: Use define-derived-mode.
(setq mode-name "Scheme Interaction"))
(defun scheme-interaction-mode-commands (keymap)
(scheme-interaction-mode-commands scheme-interaction-mode-map)))
(defun xscheme-enter-interaction-mode ()
- (save-excursion
- (set-buffer (xscheme-process-buffer))
- (if (not (eq major-mode 'scheme-interaction-mode))
- (if (eq major-mode 'scheme-debugger-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)))))
-(fset 'advertised-xscheme-send-previous-expression
- 'xscheme-send-previous-expression)
+(define-obsolete-function-alias 'advertised-xscheme-send-previous-expression
+ 'xscheme-send-previous-expression "23.2")
\f
;;;; Debugger Mode
(defun scheme-debugger-mode-initialize ()
(use-local-map scheme-debugger-mode-map)
- (setq major-mode 'scheme-debugger-mode)
+ (setq major-mode 'scheme-debugger-mode) ;FIXME: Use define-derived-mode.
(setq mode-name "Scheme Debugger"))
(defun scheme-debugger-mode-commands (keymap)
(defun scheme-debugger-self-insert ()
"Transmit this character to the Scheme process."
(interactive)
- (xscheme-send-char last-command-char))
+ (xscheme-send-char last-command-event))
-(defun xscheme-enter-debugger-mode (prompt-string)
- (save-excursion
- (set-buffer (xscheme-process-buffer))
- (if (not (eq major-mode 'scheme-debugger-mode))
+(defun xscheme-enter-debugger-mode (_prompt-string)
+ (with-current-buffer (xscheme-process-buffer)
+ (if (not (derived-mode-p 'scheme-debugger-mode))
(progn
- (if (not (eq major-mode 'scheme-interaction-mode))
+ (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
- (save-excursion
- (set-buffer buffer)
- (eq major-mode 'scheme-debugger-mode)))))
+ (with-current-buffer buffer
+ (derived-mode-p 'scheme-debugger-mode)))))
\f
;;;; Evaluation Commands
(defun xscheme-send-string-1 (strings)
(let ((string (apply 'concat strings)))
(xscheme-send-string-2 string)
- (if (eq major-mode 'scheme-interaction-mode)
+ (if (derived-mode-p 'scheme-interaction-mode)
(xscheme-insert-expression string))))
(defun xscheme-send-string-2 (string)
"Send the current line to the Scheme process.
Useful for working with debugging Scheme under adb."
(interactive)
- (let ((line
- (save-excursion
- (beginning-of-line)
- (let ((start (point)))
- (end-of-line)
- (buffer-substring start (point))))))
+ (let ((line (buffer-substring (line-beginning-position) (line-end-position))))
(end-of-line)
(insert ?\n)
(xscheme-send-string-2 line)))
(let ((inhibit-quit t))
(cond ((not xscheme-control-g-synchronization-p)
(interrupt-process xscheme-process-name))
- ((save-excursion
- (set-buffer xscheme-buffer-name)
+ ((with-current-buffer xscheme-buffer-name
xscheme-control-g-disabled-p)
(message "Relax..."))
(t
- (save-excursion
- (set-buffer xscheme-buffer-name)
+ (with-current-buffer xscheme-buffer-name
(setq xscheme-control-g-disabled-p t))
(message xscheme-control-g-message-string)
(interrupt-process xscheme-process-name)
(defun xscheme-start-process (command-line the-process the-buffer)
(let ((buffer (get-buffer-create the-buffer)))
(let ((process (get-buffer-process buffer)))
- (save-excursion
- (set-buffer 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))
xscheme-buffer-name)
(set-marker (process-mark process) (point-max))
(xscheme-process-filter-initialize t)
- (xscheme-modeline-initialize xscheme-buffer-name)
+ (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)))))
(defun xscheme-process-sentinel (proc reason)
(let* ((buffer (process-buffer proc))
(name (buffer-name buffer)))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(xscheme-process-filter-initialize (eq reason 'run))
(if (not (eq reason 'run))
(progn
(if running-p
(let ((name (buffer-name (current-buffer))))
(setq scheme-mode-line-process '(": " xscheme-runlight-string))
- (xscheme-modeline-initialize name)
+ (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)
(call-noexcursion nil))
(while xscheme-filter-input
(setq call-noexcursion nil)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(cond ((eq xscheme-process-filter-state 'idle)
(let ((start (string-match "\e" xscheme-filter-input)))
(if start
(xscheme-goto-output-point)
(let ((old-point (point)))
(while (string-match "\\(\007\\|\f\\)" string)
- (let ((start (match-beginning 0))
- (end (match-end 0)))
+ (let ((start (match-beginning 0)))
(insert-before-markers (substring string 0 start))
(if (= ?\f (aref string start))
(progn
(set-buffer (process-buffer process))
(goto-char (process-mark process))))
-(defun xscheme-modeline-initialize (name)
+(defun xscheme-mode-line-initialize (name)
(setq xscheme-runlight-string "")
(if (equal name (default-value 'xscheme-buffer-name))
(setq-default xscheme-runlight-string ""))
string))
(defun xscheme-cd (directory-string)
- (save-excursion
- (set-buffer (xscheme-process-buffer))
+ (with-current-buffer (xscheme-process-buffer)
(cd directory-string)))
\f
(defun xscheme-prompt-for-confirmation (prompt-string)
(provide 'xscheme)
-;;; arch-tag: cfc14adc-2917-409e-ad16-432e8d0017de
;;; xscheme.el ends here
HCoop / bpt / emacs.git / blobdiff