From e11f05d1f3df175aeb52933aa122da823a55a7bd Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Oct 1987 19:44:09 +0000
Subject: [PATCH] Initial revision
---
etc/scheme.el | 485 +++++++++++++++++++++++++++++++++++++
etc/xscheme.el | 646 +++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 1131 insertions(+)
create mode 100644 etc/scheme.el
create mode 100644 etc/xscheme.el
diff --git a/etc/scheme.el b/etc/scheme.el
new file mode 100644
index 000000000..5d0a35a59
--- /dev/null
+++ b/etc/scheme.el
@@ -0,0 +1,485 @@
+;; Scheme mode, and its idiosyncratic commands.
+;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
+;; Adapted from Lisp mode by Bill Rozas, jinx@prep.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+
+;; Initially a query replace of Lisp mode, except for the indentation
+;; of special forms. Probably the code should be merged at some point
+;; so that there is sharing between both libraries.
+
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/etc/scheme.el,v 1.1 1987/10/19 19:44:09 cph Exp $
+
+(provide 'scheme)
+
+(defvar scheme-mode-syntax-table nil "")
+(defvar scheme-mode-abbrev-table nil "")
+
+(if (not scheme-mode-syntax-table)
+ (let ((i 0))
+ (setq scheme-mode-syntax-table (make-syntax-table))
+ (set-syntax-table scheme-mode-syntax-table)
+
+ ;; Default is atom-constituent.
+ (while (< i 256)
+ (modify-syntax-entry i "_ ")
+ (setq i (1+ i)))
+
+ ;; Word components.
+ (setq i ?0)
+ (while (<= i ?9)
+ (modify-syntax-entry i "w ")
+ (setq i (1+ i)))
+ (setq i ?A)
+ (while (<= i ?Z)
+ (modify-syntax-entry i "w ")
+ (setq i (1+ i)))
+ (setq i ?a)
+ (while (<= i ?z)
+ (modify-syntax-entry i "w ")
+ (setq i (1+ i)))
+
+ ;; Whitespace
+ (modify-syntax-entry ?\t " ")
+ (modify-syntax-entry ?\n "> ")
+ (modify-syntax-entry ?\f " ")
+ (modify-syntax-entry ?\r " ")
+ (modify-syntax-entry ? " ")
+
+ ;; These characters are delimiters but otherwise undefined.
+ ;; Brackets and braces balance for editing convenience.
+ (modify-syntax-entry ?[ "(] ")
+ (modify-syntax-entry ?] ")[ ")
+ (modify-syntax-entry ?{ "(} ")
+ (modify-syntax-entry ?} "){ ")
+ (modify-syntax-entry ?\| " 23")
+
+ ;; Other atom delimiters
+ (modify-syntax-entry ?\( "() ")
+ (modify-syntax-entry ?\) ")( ")
+ (modify-syntax-entry ?\; "< ")
+ (modify-syntax-entry ?\" "\" ")
+ (modify-syntax-entry ?' "' ")
+ (modify-syntax-entry ?` "' ")
+
+ ;; Special characters
+ (modify-syntax-entry ?, "' ")
+ (modify-syntax-entry ?@ "' ")
+ (modify-syntax-entry ?# "' 14")
+ (modify-syntax-entry ?\\ "\\ ")))
+
+(define-abbrev-table 'scheme-mode-abbrev-table ())
+
+(defun scheme-mode-variables ()
+ (set-syntax-table scheme-mode-syntax-table)
+ (setq local-abbrev-table scheme-mode-abbrev-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'scheme-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start ";")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip ";+[ \t]*")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'scheme-comment-indent))
+
+(defun scheme-mode-commands (map)
+ (define-key map "\t" 'scheme-indent-line)
+ (define-key map "\177" 'backward-delete-char-untabify)
+ (define-key map "\e\C-q" 'scheme-indent-sexp))
+
+(defvar scheme-mode-map (make-sparse-keymap))
+(scheme-mode-commands scheme-mode-map)
+
+(defun scheme-mode ()
+ "Major mode for editing Scheme code.
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs. Semicolons start comments.
+\\{scheme-mode-map}
+Entry to this mode calls the value of scheme-mode-hook
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map scheme-mode-map)
+ (setq major-mode 'scheme-mode)
+ (setq mode-name "Scheme")
+ (scheme-mode-variables)
+ (run-hooks 'scheme-mode-hook))
+
+(autoload 'run-scheme "xscheme"
+ "Run an inferior Scheme process.
+Output goes to the buffer `*scheme*'.
+With argument, asks for a command line."
+ t)
+
+(defvar scheme-mit-dialect t
+ "If non-nil, scheme mode is specialized for MIT Scheme.
+Set this to nil if you normally use another dialect.")
+
+(defun scheme-comment-indent (&optional pos)
+ (save-excursion
+ (if pos (goto-char pos))
+ (cond ((looking-at ";;;") (current-column))
+ ((looking-at ";;")
+ (let ((tem (calculate-scheme-indent)))
+ (if (listp tem) (car tem) tem)))
+ (t
+ (skip-chars-backward " \t")
+ (max (if (bolp) 0 (1+ (current-column)))
+ comment-column)))))
+
+(defvar scheme-indent-offset nil "")
+(defvar scheme-indent-hook 'scheme-indent-hook "")
+
+(defun scheme-indent-line (&optional whole-exp)
+ "Indent current line as Scheme code.
+With argument, indent any additional lines of the same expression
+rigidly along with this one."
+ (interactive "P")
+ (let ((indent (calculate-scheme-indent)) shift-amt beg end
+ (pos (- (point-max) (point))))
+ (beginning-of-line)
+ (setq beg (point))
+ (skip-chars-forward " \t")
+ (if (looking-at "[ \t]*;;;")
+ ;; Don't alter indentation of a ;;; comment line.
+ nil
+ (if (listp indent) (setq indent (car indent)))
+ (setq shift-amt (- indent (current-column)))
+ (if (zerop shift-amt)
+ nil
+ (delete-region beg (point))
+ (indent-to indent))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ ;; If desired, shift remaining lines of expression the same amount.
+ (and whole-exp (not (zerop shift-amt))
+ (save-excursion
+ (goto-char beg)
+ (forward-sexp 1)
+ (setq end (point))
+ (goto-char beg)
+ (forward-line 1)
+ (setq beg (point))
+ (> end beg))
+ (indent-code-rigidly beg end shift-amt)))))
+
+(defun calculate-scheme-indent (&optional parse-start)
+ "Return appropriate indentation for current line as scheme code.
+In usual case returns an integer: the column to indent to.
+Can instead return a list, whose car is the column to indent to.
+This means that following lines at the same level of indentation
+should not necessarily be indented the same way.
+The second element of the list is the buffer position
+of the start of the containing expression."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point)) state paren-depth desired-indent (retry t)
+ last-sexp containing-sexp first-sexp-list-p)
+ (if parse-start
+ (goto-char parse-start)
+ (beginning-of-defun))
+ ;; Find outermost containing sexp
+ (while (< (point) indent-point)
+ (setq state (parse-partial-sexp (point) indent-point 0)))
+ ;; Find innermost containing sexp
+ (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
+ (setq retry nil)
+ (setq last-sexp (nth 2 state))
+ (setq containing-sexp (car (cdr state)))
+ ;; Position following last unclosed open.
+ (goto-char (1+ containing-sexp))
+ ;; Is there a complete sexp since then?
+ (if (and last-sexp (> last-sexp (point)))
+ ;; Yes, but is there a containing sexp after that?
+ (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
+ (if (setq retry (car (cdr peek))) (setq state peek))))
+ (if (not retry)
+ ;; Innermost containing sexp found
+ (progn
+ (goto-char (1+ containing-sexp))
+ (if (not last-sexp)
+ ;; indent-point immediately follows open paren.
+ ;; Don't call hook.
+ (setq desired-indent (current-column))
+ ;; Move to first sexp after containing open paren
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (setq first-sexp-list-p (looking-at "\\s("))
+ (cond
+ ((> (save-excursion (forward-line 1) (point))
+ last-sexp)
+ ;; Last sexp is on same line as containing sexp.
+ ;; It's almost certainly a function call.
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (if (/= (point) last-sexp)
+ ;; Indent beneath first argument or, if only one sexp
+ ;; on line, indent beneath that.
+ (progn (forward-sexp 1)
+ (parse-partial-sexp (point) last-sexp 0 t)))
+ (backward-prefix-chars))
+ (t
+ ;; Indent beneath first sexp on same line as last-sexp.
+ ;; Again, it's almost certainly a function call.
+ (goto-char last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point) last-sexp 0 t)
+ (backward-prefix-chars)))))))
+ ;; If looking at a list, don't call hook.
+ (if first-sexp-list-p
+ (setq desired-indent (current-column)))
+ ;; Point is at the point to indent under unless we are inside a string.
+ ;; Call indentation hook except when overriden by scheme-indent-offset
+ ;; or if the desired indentation has already been computed.
+ (cond ((car (nthcdr 3 state))
+ ;; Inside a string, don't change indentation.
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (setq desired-indent (current-column)))
+ ((and (integerp scheme-indent-offset) containing-sexp)
+ ;; Indent by constant offset
+ (goto-char containing-sexp)
+ (setq desired-indent (+ scheme-indent-offset (current-column))))
+ ((not (or desired-indent
+ (and (boundp 'scheme-indent-hook)
+ scheme-indent-hook
+ (not retry)
+ (setq desired-indent
+ (funcall scheme-indent-hook
+ indent-point state)))))
+ ;; Use default indentation if not computed yet
+ (setq desired-indent (current-column))))
+ desired-indent)))
+
+(defun scheme-indent-hook (indent-point state)
+ (let ((normal-indent (current-column)))
+ (save-excursion
+ (goto-char (1+ (car (cdr state))))
+ (re-search-forward "\\sw\\|\\s_")
+ (if (/= (point) (car (cdr state)))
+ (let ((function (buffer-substring (progn (forward-char -1) (point))
+ (progn (forward-sexp 1) (point))))
+ method)
+ ;; Who cares about this, really?
+ ;(if (not (string-match "\\\\\\||" function)))
+ (setq function (downcase function))
+ (setq method (get (intern-soft function) 'scheme-indent-hook))
+ (cond ((integerp method)
+ (scheme-indent-specform method state indent-point))
+ (method
+ (funcall method state indent-point))
+ ((and (> (length function) 3)
+ (string-equal (substring function 0 3) "def"))
+ (scheme-indent-defform state indent-point))))))))
+
+(defvar scheme-body-indent 2 "")
+
+(defun scheme-indent-specform (count state indent-point)
+ (let ((containing-form-start (car (cdr state))) (i count)
+ body-indent containing-form-column)
+ ;; Move to the start of containing form, calculate indentation
+ ;; to use for non-distinguished forms (> count), and move past the
+ ;; function symbol. scheme-indent-hook guarantees that there is at
+ ;; least one word or symbol character following open paren of containing
+ ;; form.
+ (goto-char containing-form-start)
+ (setq containing-form-column (current-column))
+ (setq body-indent (+ scheme-body-indent containing-form-column))
+ (forward-char 1)
+ (forward-sexp 1)
+ ;; Now find the start of the last form.
+ (parse-partial-sexp (point) indent-point 1 t)
+ (while (and (< (point) indent-point)
+ (condition-case nil
+ (progn
+ (setq count (1- count))
+ (forward-sexp 1)
+ (parse-partial-sexp (point) indent-point 1 t))
+ (error nil))))
+ ;; Point is sitting on first character of last (or count) sexp.
+ (cond ((> count 0)
+ ;; A distinguished form. Use double scheme-body-indent.
+ (list (+ containing-form-column (* 2 scheme-body-indent))
+ containing-form-start))
+ ;; A non-distinguished form. Use body-indent if there are no
+ ;; distinguished forms and this is the first undistinguished
+ ;; form, or if this is the first undistinguished form and
+ ;; the preceding distinguished form has indentation at least
+ ;; as great as body-indent.
+ ((and (= count 0)
+ (or (= i 0)
+ (<= body-indent normal-indent)))
+ body-indent)
+ (t
+ normal-indent))))
+
+(defun scheme-indent-defform (state indent-point)
+ (goto-char (car (cdr state)))
+ (forward-line 1)
+ (if (> (point) (car (cdr (cdr state))))
+ (progn
+ (goto-char (car (cdr state)))
+ (+ scheme-body-indent (current-column)))))
+
+;;; Let is different in Scheme
+
+(defun would-be-symbol (string)
+ (not (string-equal (substring string 0 1) "(")))
+
+(defun next-sexp-as-string ()
+ ;; Assumes that protected by a save-excursion
+ (forward-sexp 1)
+ (let ((the-end (point)))
+ (backward-sexp 1)
+ (buffer-substring (point) the-end)))
+
+;; This is correct but too slow.
+;; The one below works almost always.
+;;(defun scheme-let-indent (state indent-point)
+;; (if (would-be-symbol (next-sexp-as-string))
+;; (scheme-indent-specform 2 state indent-point)
+;; (scheme-indent-specform 1 state indent-point)))
+
+(defun scheme-let-indent (state indent-point)
+ (skip-chars-forward " \t")
+ (if (looking-at "[a-zA-Z0-9+-*/?!@$%^&_:~]")
+ (scheme-indent-specform 2 state indent-point)
+ (scheme-indent-specform 1 state indent-point)))
+
+;; (put 'begin 'scheme-indent-hook 0), say, causes begin to be indented
+;; like defun if the first form is placed on the next line, otherwise
+;; it is indented like any other form (i.e. forms line up under first).
+
+(put 'begin 'scheme-indent-hook 0)
+(put 'case 'scheme-indent-hook 1)
+(put 'do 'scheme-indent-hook 2)
+(put 'lambda 'scheme-indent-hook 1)
+(put 'let 'scheme-indent-hook 'scheme-let-indent)
+(put 'let* 'scheme-indent-hook 1)
+(put 'letrec 'scheme-indent-hook 1)
+(put 'sequence 'scheme-indent-hook 0)
+
+(put 'call-with-input-file 'scheme-indent-hook 1)
+(put 'with-input-from-file 'scheme-indent-hook 1)
+(put 'with-input-from-port 'scheme-indent-hook 1)
+(put 'call-with-output-file 'scheme-indent-hook 1)
+(put 'with-output-to-file 'scheme-indent-hook 1)
+(put 'with-output-to-port 'scheme-indent-hook 1)
+
+;;;; MIT Scheme specific indentation.
+
+(if scheme-mit-dialect
+ (progn
+ (put 'fluid-let 'scheme-indent-hook 1)
+ (put 'in-package 'scheme-indent-hook 1)
+ (put 'let-syntax 'scheme-indent-hook 1)
+ (put 'local-declare 'scheme-indent-hook 1)
+ (put 'macro 'scheme-indent-hook 1)
+ (put 'make-environment 'scheme-indent-hook 0)
+ (put 'named-lambda 'scheme-indent-hook 1)
+ (put 'using-syntax 'scheme-indent-hook 1)
+
+ (put 'with-input-from-string 'scheme-indent-hook 1)
+ (put 'with-output-to-string 'scheme-indent-hook 0)
+
+ (put 'syntax-table-define 'scheme-indent-hook 2)
+ (put 'list-transform-positive 'scheme-indent-hook 1)
+ (put 'list-transform-negative 'scheme-indent-hook 1)
+ (put 'list-search-positive 'scheme-indent-hook 1)
+ (put 'list-search-negative 'scheme-indent-hook 1)
+
+ (put 'access-components 'scheme-indent-hook 1)
+ (put 'assignment-components 'scheme-indent-hook 1)
+ (put 'combination-components 'scheme-indent-hook 1)
+ (put 'comment-components 'scheme-indent-hook 1)
+ (put 'conditional-components 'scheme-indent-hook 1)
+ (put 'disjunction-components 'scheme-indent-hook 1)
+ (put 'declaration-components 'scheme-indent-hook 1)
+ (put 'definition-components 'scheme-indent-hook 1)
+ (put 'delay-components 'scheme-indent-hook 1)
+ (put 'in-package-components 'scheme-indent-hook 1)
+ (put 'lambda-components 'scheme-indent-hook 1)
+ (put 'lambda-components* 'scheme-indent-hook 1)
+ (put 'lambda-components** 'scheme-indent-hook 1)
+ (put 'open-block-components 'scheme-indent-hook 1)
+ (put 'pathname-components 'scheme-indent-hook 1)
+ (put 'procedure-components 'scheme-indent-hook 1)
+ (put 'sequence-components 'scheme-indent-hook 1)
+ (put 'unassigned\?-components 'scheme-indent-hook 1)
+ (put 'unbound\?-components 'scheme-indent-hook 1)
+ (put 'variable-components 'scheme-indent-hook 1)))
+
+(defun scheme-indent-sexp ()
+ "Indent each line of the list starting just after point."
+ (interactive)
+ (let ((indent-stack (list nil)) (next-depth 0) bol
+ outer-loop-done inner-loop-done state this-indent)
+ (save-excursion (forward-sexp 1))
+ (save-excursion
+ (setq outer-loop-done nil)
+ (while (not outer-loop-done)
+ (setq last-depth next-depth
+ innerloop-done nil)
+ (while (and (not innerloop-done)
+ (not (setq outer-loop-done (eobp))))
+ (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
+ nil nil state))
+ (setq next-depth (car state))
+ (if (car (nthcdr 4 state))
+ (progn (indent-for-comment)
+ (end-of-line)
+ (setcar (nthcdr 4 state) nil)))
+ (if (car (nthcdr 3 state))
+ (progn
+ (forward-line 1)
+ (setcar (nthcdr 5 state) nil))
+ (setq innerloop-done t)))
+ (if (setq outer-loop-done (<= next-depth 0))
+ nil
+ (while (> last-depth next-depth)
+ (setq indent-stack (cdr indent-stack)
+ last-depth (1- last-depth)))
+ (while (< last-depth next-depth)
+ (setq indent-stack (cons nil indent-stack)
+ last-depth (1+ last-depth)))
+ (forward-line 1)
+ (setq bol (point))
+ (skip-chars-forward " \t")
+ (if (or (eobp) (looking-at "[;\n]"))
+ nil
+ (if (and (car indent-stack)
+ (>= (car indent-stack) 0))
+ (setq this-indent (car indent-stack))
+ (let ((val (calculate-scheme-indent
+ (if (car indent-stack) (- (car indent-stack))))))
+ (if (integerp val)
+ (setcar indent-stack
+ (setq this-indent val))
+ (setcar indent-stack (- (car (cdr val))))
+ (setq this-indent (car val)))))
+ (if (/= (current-column) this-indent)
+ (progn (delete-region bol (point))
+ (indent-to this-indent)))))))))
diff --git a/etc/xscheme.el b/etc/xscheme.el
new file mode 100644
index 000000000..944fd48a9
--- /dev/null
+++ b/etc/xscheme.el
@@ -0,0 +1,646 @@
+;; Run Scheme under Emacs
+;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+;;; Requires C-Scheme release 5 or later
+;;; Changes to Control-G handler require runtime version 13.85 or later
+
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/etc/xscheme.el,v 1.1 1987/10/19 19:42:39 cph Exp $
+
+(require 'scheme)
+
+(defvar scheme-program-name "scheme"
+ "*Program invoked by the `run-scheme' command.")
+
+(defvar scheme-band-name nil
+ "*Band loaded by the `run-scheme' command.")
+
+(defvar scheme-program-arguments nil
+ "*Arguments passed to the Scheme program by the `run-scheme' command.")
+
+(defun run-scheme (command-line)
+ "Run an inferior Scheme process.
+Output goes to the buffer `*scheme*'.
+With argument, asks for a command line."
+ (interactive
+ (list (let ((default
+ (or xscheme-process-command-line
+ (xscheme-default-command-line))))
+ (if current-prefix-arg
+ (read-string "Run Scheme: " default)
+ default))))
+ (setq xscheme-process-command-line command-line)
+ (switch-to-buffer (xscheme-start-process command-line)))
+
+(defun reset-scheme ()
+ "Reset the Scheme process."
+ (interactive)
+ (let ((process (get-process "scheme")))
+ (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 (kill-process process t))
+ (xscheme-start-process xscheme-process-command-line)
+ (message "Resetting Scheme process...done")))))
+
+(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)
+ "")))
+
+;;;; Internal Variables
+
+(defvar xscheme-process-command-line nil
+ "Command used to start the most recent Scheme process.")
+
+(defvar xscheme-previous-send ""
+ "Most recent expression transmitted to the Scheme process.")
+
+(defvar 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 xscheme-process-filter-queue '()
+ "Queue used to synchronize filter actions properly.")
+
+(defvar xscheme-running-p nil
+ "This variable, if nil, indicates that the scheme process is
+waiting for input. Otherwise, it is busy evaluating something.")
+
+(defvar 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-allow-output-p t
+ "This variable, if nil, prevents output from the scheme process
+from being inserted into the process-buffer.")
+
+(defvar xscheme-prompt ""
+ "The current scheme prompt string.")
+
+(defvar xscheme-string-accumulator ""
+ "Accumulator for the string being received from the scheme process.")
+
+(defvar xscheme-string-receiver nil
+ "Procedure to send the string argument from the scheme process.")
+
+(defvar 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.")
+
+(defvar xscheme-signal-death-message nil
+ "If non-nil, causes a message to be generated when the Scheme process dies.")
+
+(defvar xscheme-mode-string ""
+ "String displayed in the mode line when the Scheme process is running.")
+
+;;;; Evaluation Commands
+
+(define-key scheme-mode-map "\eo" 'xscheme-send-buffer)
+(define-key scheme-mode-map "\ez" 'xscheme-send-definition)
+(define-key scheme-mode-map "\e\C-m" 'xscheme-send-previous-expression)
+(define-key scheme-mode-map "\e\C-x" 'xscheme-send-definition)
+(define-key scheme-mode-map "\e\C-z" 'xscheme-send-region)
+(define-key scheme-mode-map "\C-cb" 'xscheme-send-breakpoint-interrupt)
+(define-key scheme-mode-map "\C-cg" 'xscheme-send-control-g-interrupt)
+(define-key scheme-mode-map "\C-cn" 'xscheme-send-next-expression)
+(define-key scheme-mode-map "\C-cp" 'xscheme-send-previous-expression)
+(define-key scheme-mode-map "\C-cu" 'xscheme-send-control-u-interrupt)
+(define-key scheme-mode-map "\C-cx" 'xscheme-send-control-x-interrupt)
+;(define-key scheme-mode-map "\C-c\C-m" 'xscheme-send-current-line)
+(define-key scheme-mode-map "\C-c\C-y" 'xscheme-yank-previous-send)
+(define-key scheme-mode-map "\C-x\C-e" 'xscheme-send-previous-expression)
+
+(defun xscheme-send-string (&rest strings)
+ "Send the string arguments to the Scheme process.
+The strings are concatenated and terminated by a newline."
+ (cond (xscheme-running-p
+ (error "No sends allowed while Scheme running"))
+ ((xscheme-process-running-p)
+ (xscheme-send-string-1 strings))
+ ((yes-or-no-p "The Scheme process has died. Reset it? ")
+ (reset-scheme)
+ (xscheme-wait-for-process)
+ (goto-char (point-max))
+ (apply 'insert-before-markers strings)
+ (xscheme-send-string-1 strings))))
+
+(defun xscheme-send-string-1 (strings)
+ (let ((string (apply 'concat strings)))
+ (xscheme-send-string-2 string)
+ (setq xscheme-previous-send string)))
+
+(defun xscheme-send-string-2 (string)
+ (let ((process (get-process "scheme")))
+ (send-string process (concat string "\n"))
+ (if (eq (current-buffer) (process-buffer process))
+ (set-marker (process-mark process) (point)))))
+
+(defun xscheme-yank-previous-send ()
+ "Insert the most recent expression at point."
+ (interactive)
+ (push-mark)
+ (insert xscheme-previous-send))
+
+(defun xscheme-send-region (start end)
+ "Send the current region to the Scheme process.
+The region is sent terminated by a newline."
+ (interactive "r")
+ (let ((process (get-process "scheme")))
+ (if (and process (eq (current-buffer) (process-buffer process)))
+ (progn (goto-char end)
+ (set-marker (process-mark process) end))))
+ (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 `adb'."
+ (interactive)
+ (let ((line
+ (save-excursion
+ (beginning-of-line)
+ (let ((start (point)))
+ (end-of-line)
+ (buffer-substring start (point))))))
+ (end-of-line)
+ (insert ?\n)
+ (xscheme-send-string-2 line)))
+
+(defun xscheme-send-buffer ()
+ "Send the current buffer to the Scheme process."
+ (interactive)
+ (if (eq (current-buffer) (xscheme-process-buffer))
+ (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: ")
+ (send-string "scheme" (char-to-string char)))
+
+(defun xscheme-send-breakpoint-interrupt ()
+ "Cause the Scheme process to enter a breakpoint."
+ (interactive)
+ (xscheme-send-interrupt ?b nil))
+
+(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))
+ (if xscheme-control-g-disabled-p
+ (message "Relax...")
+ (progn
+ (setq xscheme-control-g-disabled-p t)
+ (message "Sending C-G interrupt to Scheme...")
+ (interrupt-process "scheme" t)
+ (send-string "scheme" (char-to-string 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 "scheme" t)
+ (send-string "scheme" (char-to-string char))
+ (if mark-p
+ (send-string "scheme" (char-to-string 0))))
+
+;;;; Basic Process Control
+
+(defun xscheme-start-process (command-line)
+ (let ((buffer (get-buffer-create "*scheme*")))
+ (let ((process (get-buffer-process buffer)))
+ (save-excursion
+ (set-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-mode)
+ (setq mode-line-process '(": %s"))
+ (add-to-global-mode-string 'xscheme-mode-string)
+ (setq process
+ (apply 'start-process
+ (cons "scheme"
+ (cons buffer
+ (xscheme-parse-command-line
+ command-line)))))
+ (set-marker (process-mark process) (point-max))
+ (xscheme-process-filter-initialize t)
+ (xscheme-modeline-initialize)
+ (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 iff there is a Scheme process whose status is `run'."
+ (let ((process (get-process "scheme")))
+ (and process
+ (eq (process-status process) 'run))))
+
+(defun xscheme-process-buffer ()
+ (let ((process (get-process "scheme")))
+ (and process (process-buffer process))))
+
+(defun xscheme-process-buffer-window ()
+ (let ((buffer (xscheme-process-buffer)))
+ (and buffer (get-buffer-window buffer))))
+
+;;;; Process Filter
+
+(defun xscheme-process-sentinel (proc reason)
+ (let ((inhibit-quit t))
+ (xscheme-process-filter-initialize (eq reason 'run))
+ (if (eq reason 'run)
+ (xscheme-modeline-initialize)
+ (setq xscheme-mode-string "")))
+ (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-process-filter-queue (cons '() '()))
+ (setq xscheme-running-p running-p)
+ (setq xscheme-control-g-disabled-p nil)
+ (setq xscheme-allow-output-p t)
+ (setq xscheme-prompt "")
+ (setq xscheme-string-accumulator "")
+ (setq xscheme-string-receiver nil))
+
+(defun xscheme-process-filter (proc string)
+ (let ((inhibit-quit t))
+ (cond ((eq xscheme-process-filter-state 'idle)
+ (xscheme-process-filter:idle string))
+ ((eq xscheme-process-filter-state 'reading-type)
+ (xscheme-process-filter:reading-type string))
+ ((eq xscheme-process-filter-state 'reading-string)
+ (xscheme-process-filter:reading-string string))
+ (t (error "Scheme process filter -- bad state")))))
+
+(defun xscheme-process-filter:idle (string)
+ (setq xscheme-process-filter-state 'idle)
+ (let ((start (string-match "\e" string)))
+ (if start
+ (progn (xscheme-process-filter:idle-1 (substring string 0 start))
+ (xscheme-process-filter:reading-type
+ (substring string (1+ start))))
+ (progn (xscheme-process-filter:idle-1 string)
+ (xscheme-process-filter:finish)))))
+
+(defun xscheme-process-filter:idle-1 (string)
+ (while (string-match "\\(\007\\|\f\\)" string)
+ (let ((start (match-beginning 0))
+ (end (match-end 0)))
+ (xscheme-process-filter-output (substring string 0 start))
+ (if (= ?\f (aref string start))
+ (progn (xscheme-guarantee-newlines 1)
+ (xscheme-process-filter-output ?\f))
+ (beep))
+ (setq string (substring string (1+ start)))))
+ (xscheme-process-filter-output string))
+
+(defun xscheme-process-filter:reading-type (string)
+ (let ((len (length string)))
+ (if (= 0 len)
+ (progn (setq xscheme-process-filter-state 'reading-type)
+ (xscheme-process-filter:finish))
+ (xscheme-process-filter-dispatch (aref string 0)
+ (substring string 1 len)))))
+
+(defun xscheme-process-filter:reading-string (string)
+ (let ((start (string-match "\e" string)))
+ (if start
+ (progn (xscheme-process-filter:enqueue
+ (list xscheme-string-receiver
+ (concat xscheme-string-accumulator
+ (substring string 0 start))))
+ (setq xscheme-string-accumulator "")
+ (setq xscheme-string-receiver nil)
+ (xscheme-process-filter:idle
+ (substring string (1+ start) (length string))))
+ (progn (setq xscheme-string-accumulator
+ (concat xscheme-string-accumulator string))
+ (setq xscheme-process-filter-state 'reading-string)
+ (xscheme-process-filter:finish)))))
+
+(defun xscheme-process-filter:enqueue (action)
+ (let ((next (cons action '())))
+ (if (cdr xscheme-process-filter-queue)
+ (setcdr (cdr xscheme-process-filter-queue) next)
+ (setcar xscheme-process-filter-queue next))
+ (setcdr xscheme-process-filter-queue next)))
+
+(defun xscheme-process-filter:finish ()
+ (while (car xscheme-process-filter-queue)
+ (let ((next (car xscheme-process-filter-queue)))
+ (setcar xscheme-process-filter-queue (cdr next))
+ (if (not (cdr next))
+ (setcdr xscheme-process-filter-queue '()))
+ (apply (car (car next)) (cdr (car next))))))
+
+;;;; Process Filter Output
+
+(defun xscheme-process-filter-output (&rest args)
+ (if (not (and args
+ (null (cdr args))
+ (stringp (car args))
+ (string-equal "" (car args))))
+ (xscheme-process-filter:enqueue
+ (cons 'xscheme-process-filter-output-1 args))))
+
+(defun xscheme-process-filter-output-1 (&rest args)
+ (if xscheme-allow-output-p
+ (save-excursion
+ (xscheme-goto-output-point)
+ (apply 'insert-before-markers args))))
+
+(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 "scheme")))
+ (set-buffer (process-buffer process))
+ (goto-char (process-mark process))))
+
+(defun xscheme-modeline-initialize ()
+ (setq xscheme-mode-string " "))
+
+(defun xscheme-set-runlight (runlight)
+ (aset xscheme-mode-string 0 runlight)
+ (xscheme-modeline-redisplay))
+
+(defun xscheme-modeline-redisplay ()
+ (save-excursion (set-buffer (other-buffer)))
+ (set-buffer-modified-p (buffer-modified-p))
+ (sit-for 0))
+
+;;;; Process Filter Operations
+
+(defun xscheme-process-filter-dispatch (char string)
+ (cond ((= char ?b)
+ (xscheme-process-filter:simple-action
+ 'xscheme-start-gc
+ string))
+ ((= char ?e)
+ (xscheme-process-filter:simple-action
+ 'xscheme-finish-gc
+ string))
+ ((= char ?s)
+ (xscheme-process-filter:simple-action
+ 'xscheme-enter-input-wait
+ string))
+ ((= char ?f)
+ (xscheme-process-filter:simple-action
+ 'xscheme-exit-input-wait
+ string))
+ ((= char ?c)
+ (xscheme-process-filter:simple-action
+ 'xscheme-input-char-immediately
+ string))
+ ((= char ?z)
+ (xscheme-process-filter:simple-action
+ 'xscheme-select-process-buffer
+ string))
+ ((= char ?m)
+ (xscheme-process-filter:string-action 'xscheme-message string))
+ ((= char ?p)
+ (xscheme-process-filter:string-action 'xscheme-set-prompt string))
+ ((= char ?P)
+ (xscheme-process-filter:string-action 'xscheme-set-prompt-variable
+ string))
+ ((= char ?v)
+ (xscheme-process-filter:string-action 'xscheme-write-value string))
+ ((= char ?g)
+ (xscheme-process-filter:simple-action 'xscheme-enable-control-g
+ string))
+ (t
+ (xscheme-process-filter-output ?\e char)
+ (xscheme-process-filter:idle string))))
+
+(defun xscheme-process-filter:simple-action (action string)
+ (xscheme-process-filter:enqueue (list action))
+ (xscheme-process-filter:idle string))
+
+(defun xscheme-process-filter:string-action (action string)
+ (setq xscheme-string-receiver action)
+ (xscheme-process-filter:reading-string string))
+
+(defconst xscheme-runlight:running ?R
+ "The character displayed when the Scheme process is running.")
+
+(defconst xscheme-runlight:input ?I
+ "The character displayed when the Scheme process is waiting for input.")
+
+(defconst xscheme-runlight:gc ?G
+ "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-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))
+
+(defun xscheme-input-char-immediately ()
+ (xscheme-message xscheme-prompt)
+ (let ((char nil)
+ (aborted-p t)
+ (not-done t))
+ (unwind-protect
+ (while not-done
+ (setq char
+ (let ((cursor-in-echo-area t))
+ (read-char)))
+ (cond ((= char ?\C-g)
+ (setq char nil)
+ (setq not-done nil))
+ ((= char ?\n)
+ ;; Disallow newlines, as Scheme is explicitly
+ ;; ignoring them. This is necessary because
+ ;; otherwise Scheme will attempt to read another
+ ;; character.
+ (beep))
+ (t
+ (setq aborted-p nil)
+ (setq not-done nil))))
+ (if aborted-p
+ (xscheme-send-control-g-interrupt)))
+ (xscheme-message "")
+ (if char
+ (xscheme-send-char char))))
+
+(defun xscheme-select-process-buffer ()
+ (let ((window (or (xscheme-process-buffer-window)
+ (display-buffer (xscheme-process-buffer)))))
+ (save-window-excursion
+ (select-window window)
+ (xscheme-goto-output-point))))
+
+(defun xscheme-message (string)
+ (message "%s" string))
+
+(defun xscheme-write-value (string)
+ (if (not (zerop (length string)))
+ (progn (xscheme-guarantee-newlines 1)
+ (xscheme-process-filter-output-1 (concat ";Value: " string))
+ (if (not (xscheme-process-buffer-window))
+ (xscheme-message 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
+ (concat (substring xscheme-mode-string 0 2)
+ (xscheme-coerce-prompt string)))
+ (xscheme-modeline-redisplay))
+
+(defun xscheme-coerce-prompt (string)
+ (if (string-match "^[0-9]+ " string)
+ (let ((end (match-end 0)))
+ (concat (substring string 0 end)
+ (let ((prompt (substring string end)))
+ (cond ((or (string-equal prompt "]=>")
+ (string-equal prompt "==>")
+ (string-equal prompt "Eval-in-env-->"))
+ "[Normal REP]")
+ ((string-equal prompt "Bkpt->") "[Breakpoint REP]")
+ ((string-equal prompt "Error->") "[Error REP]")
+ ((string-equal prompt "Debug-->") "[Debugger]")
+ ((string-equal prompt "Debugger-->") "[Debugger REP]")
+ ((string-equal prompt "Where-->")
+ "[Environment Inspector]")
+ (t prompt)))))
+ string))
+
+(defun add-to-global-mode-string (x)
+ (cond ((null global-mode-string)
+ (setq global-mode-string (list "" x " ")))
+ ((not (memq x global-mode-string))
+ (setq global-mode-string
+ (cons ""
+ (cons x
+ (cons " "
+ (if (equal "" (car global-mode-string))
+ (cdr global-mode-string)
+ global-mode-string))))))))
--
2.25.1