From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Oct 1987 19:44:09 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~13077
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e11f05d1f3df175aeb52933aa122da823a55a7bd;p=mit-scheme.git

Initial revision
---

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))))))))