xscheme.el

早期freebsd实现

(defun xscheme-send-string-1 (strings)
  (let ((string (apply 'concat strings)))
    (xscheme-send-string-2 string)
    (if (eq major-mode 'scheme-interaction-mode)
	(setq xscheme-previous-send string))))

(defun xscheme-send-string-2 (string)
  (let ((process (get-process "scheme")))
    (send-string process (concat string "\n"))
    (if (xscheme-process-buffer-current-p)
	(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-select-process-buffer ()
  "Select the Scheme process buffer and move to its output point."
  (interactive)
  (let ((process (or (get-process "scheme") (error "No scheme process"))))
    (let ((buffer (or (process-buffer process) (error "No process buffer"))))
      (let ((window (get-buffer-window buffer)))
	(if window
	    (select-window window)
	    (switch-to-buffer buffer))
	(goto-char (process-mark process))))))

(defun xscheme-send-region (start end)
  "Send the current region to the Scheme process.
The region is sent terminated by a newline."
  (interactive "r")
  (if (xscheme-process-buffer-current-p)
      (progn (goto-char end)
	     (set-marker (process-mark (get-process "scheme")) 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 debugging Scheme under 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 (xscheme-process-buffer-current-p)
      (error "Not allowed to send this buffer's contents to Scheme"))
  (xscheme-send-region (point-min) (point-max)))

(defun xscheme-send-char (char)
  "Prompt for a character and send it to the Scheme process."
  (interactive "cCharacter to send: ")
  (send-string "scheme" (char-to-string char)))

;;;; Interrupts

(defun xscheme-send-breakpoint-interrupt ()
  "Cause the Scheme process to enter a breakpoint."
  (interactive)
  (xscheme-send-interrupt ?b nil))

(defun xscheme-send-proceed ()
  "Cause the Scheme process to proceed from a breakpoint."
  (interactive)
  (send-string "scheme" "(proceed)\n"))

(defun xscheme-send-control-g-interrupt ()
  "Cause the Scheme processor to halt and flush input.
Control returns to the top level rep loop."
  (interactive)
  (let ((inhibit-quit t))
    (cond ((not xscheme-control-g-synchronization-p)
	   (interrupt-process "scheme"))
	  (xscheme-control-g-disabled-p
	   (message "Relax..."))
	  (t
	   (setq xscheme-control-g-disabled-p t)
	   (message "Sending C-G interrupt to Scheme...")
	   (interrupt-process "scheme")
	   (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")
  (send-string "scheme" (char-to-string char))
  (if (and mark-p xscheme-control-g-synchronization-p)
      (send-string "scheme" (char-to-string 0))))

;;;; 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-running-p nil
  "This variable, if nil, indicates that the scheme process is
waiting for input.  Otherwise, it is busy evaluating something.")

(defconst xscheme-control-g-synchronization-p t
  "If non-nil, insert markers in the scheme input stream to indicate when
control-g interrupts were signalled.  Do not allow more control-g's to be
signalled until the scheme process acknowledges receipt.")

(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-runlight-string nil)
(defvar xscheme-mode-string nil)
(defvar xscheme-filter-input nil)

;;;; 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-interaction-mode)
		   (if (bobp)
		       (insert-before-markers
			(substitute-command-keys xscheme-startup-message)))
		   (setq process
			 (let ((process-connection-type nil))
			   (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))))

(defun xscheme-process-buffer-current-p ()
  "True iff the current buffer is the Scheme process buffer."
  (eq (xscheme-process-buffer) (current-buffer)))

;;;; Process Filter

(defun xscheme-process-sentinel (proc reason)
  (xscheme-process-filter-initialize (eq reason 'run))
  (if (eq reason 'run)
      (xscheme-modeline-initialize)
      (progn
       (setq scheme-mode-line-process "")
       (setq xscheme-mode-string "no process")))
  (if (and (not (memq reason '(run stop)))
	   xscheme-signal-death-message)
      (progn (beep)
	     (message
"The Scheme process has died!  Do M-x reset-scheme to restart it"))))

(defun xscheme-process-filter-initialize (running-p)
  (setq xscheme-process-filter-state 'idle)
  (setq xscheme-running-p running-p)
  (setq xscheme-control-g-disabled-p nil)
  (setq xscheme-allow-output-p t)
  (setq xscheme-prompt "")
  (setq scheme-mode-line-process '(": " xscheme-runlight-string)))

(defun xscheme-process-filter (proc string)
  (let ((xscheme-filter-input string))
    (while xscheme-filter-input