xscheme.el

早期freebsd实现

      (cond ((eq xscheme-process-filter-state 'idle)
	     (let ((start (string-match "\e" xscheme-filter-input)))
	       (if start
		   (progn
		     (xscheme-process-filter-output
		      (substring xscheme-filter-input 0 start))
		     (setq xscheme-filter-input
			   (substring xscheme-filter-input (1+ start)))
		     (setq xscheme-process-filter-state 'reading-type))
		   (let ((string xscheme-filter-input))
		     (setq xscheme-filter-input nil)
		     (xscheme-process-filter-output string)))))
	    ((eq xscheme-process-filter-state 'reading-type)
	     (if (zerop (length xscheme-filter-input))
		 (setq xscheme-filter-input nil)
		 (let ((char (aref xscheme-filter-input 0)))
		   (setq xscheme-filter-input
			 (substring xscheme-filter-input 1))
		   (let ((entry (assoc char xscheme-process-filter-alist)))
		     (if entry
			 (funcall (nth 2 entry) (nth 1 entry))
			 (progn
			   (xscheme-process-filter-output ?\e char)
			   (setq xscheme-process-filter-state 'idle)))))))
	    ((eq xscheme-process-filter-state 'reading-string)
	     (let ((start (string-match "\e" xscheme-filter-input)))
	       (if start
		   (let ((string
			  (concat xscheme-string-accumulator
				  (substring xscheme-filter-input 0 start))))
		     (setq xscheme-filter-input
			   (substring xscheme-filter-input (1+ start)))
		     (setq xscheme-process-filter-state 'idle)
		     (funcall xscheme-string-receiver string))
		   (progn
		     (setq xscheme-string-accumulator
			   (concat xscheme-string-accumulator
				   xscheme-filter-input))
		     (setq xscheme-filter-input nil)))))
	    (t
	     (error "Scheme process filter -- bad state"))))))

;;;; Process Filter Output

(defun xscheme-process-filter-output (&rest args)
  (if xscheme-allow-output-p
      (let ((string (apply 'concat args)))
	(save-excursion
	  (xscheme-goto-output-point)
	  (while (string-match "\\(\007\\|\f\\)" string)
	    (let ((start (match-beginning 0))
		  (end (match-end 0)))
	      (insert-before-markers (substring string 0 start))
	      (if (= ?\f (aref string start))
		  (progn
		    (if (not (bolp))
			(insert-before-markers ?\n))
		    (insert-before-markers ?\f))
		  (beep))
	      (setq string (substring string (1+ start)))))
	  (insert-before-markers string)))))

(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-runlight-string "")
  (setq xscheme-mode-string "")
  (setq mode-line-buffer-identification '("Scheme: " xscheme-mode-string)))

(defun xscheme-set-runlight (runlight)
  (setq xscheme-runlight-string 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

(defvar xscheme-process-filter-alist
  '((?D xscheme-enter-debugger-mode
	xscheme-process-filter:string-action)
    (?P xscheme-set-prompt-variable
	xscheme-process-filter:string-action)
    (?R xscheme-enter-interaction-mode
	xscheme-process-filter:simple-action)
    (?b xscheme-start-gc
	xscheme-process-filter:simple-action)
    (?e xscheme-finish-gc
	xscheme-process-filter:simple-action)
    (?f xscheme-exit-input-wait
	xscheme-process-filter:simple-action)
    (?g xscheme-enable-control-g
	xscheme-process-filter:simple-action)
    (?i xscheme-prompt-for-expression
	xscheme-process-filter:string-action)
    (?m xscheme-message
	xscheme-process-filter:string-action)
    (?n xscheme-prompt-for-confirmation
	xscheme-process-filter:string-action)
    (?o xscheme-output-goto
	xscheme-process-filter:simple-action)
    (?p xscheme-set-prompt
	xscheme-process-filter:string-action)
    (?s xscheme-enter-input-wait
	xscheme-process-filter:simple-action)
    (?v xscheme-write-value
	xscheme-process-filter:string-action)
    (?w xscheme-cd
	xscheme-process-filter:string-action)
    (?z xscheme-display-process-buffer
	xscheme-process-filter:simple-action)
    (?c xscheme-unsolicited-read-char
	xscheme-process-filter:simple-action))
  "Table used to decide how to handle process filter commands.
Value is a list of entries, each entry is a list of three items.

The first item is the character that the process filter dispatches on.
The second item is the action to be taken, a function.
The third item is the handler for the entry, a function.

When the process filter sees a command whose character matches a
particular entry, it calls the handler with two arguments: the action
and the string containing the rest of the process filter's input
stream.  It is the responsibility of the handler to invoke the action
with the appropriate arguments, and to reenter the process filter with
the remaining input.")

(defun xscheme-process-filter:simple-action (action)
  (setq xscheme-process-filter-state 'idle)
  (funcall action))

(defun xscheme-process-filter:string-action (action)
  (setq xscheme-string-receiver action)
  (setq xscheme-string-accumulator "")
  (setq xscheme-process-filter-state 'reading-string))

(defconst xscheme-runlight:running "run"
  "The character displayed when the Scheme process is running.")

(defconst xscheme-runlight:input "input"
  "The character displayed when the Scheme process is waiting for input.")

(defconst xscheme-runlight:gc "gc"
  "The character displayed when the Scheme process is garbage collecting.")

(defun xscheme-start-gc ()
  (xscheme-set-runlight xscheme-runlight:gc))

(defun xscheme-finish-gc ()
  (xscheme-set-runlight
   (if xscheme-running-p xscheme-runlight:running xscheme-runlight:input)))

(defun xscheme-enter-input-wait ()
  (xscheme-set-runlight xscheme-runlight:input)
  (setq xscheme-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-display-process-buffer ()
  (let ((window (or (xscheme-process-buffer-window)
		    (display-buffer (xscheme-process-buffer)))))
    (save-window-excursion
      (select-window window)
      (xscheme-goto-output-point)
      (if (xscheme-debugger-mode-p)
	  (xscheme-enter-interaction-mode)))))

(defun xscheme-unsolicited-read-char ()
  nil)

(defun xscheme-message (string)
  (if (not (zerop (length string)))
      (xscheme-write-message-1 string (format ";%s" string))))

(defun xscheme-write-value (string)
  (if (zerop (length string))
      (xscheme-write-message-1 "(no value)" ";No value")
      (xscheme-write-message-1 string (format ";Value: %s" string))))

(defun xscheme-write-message-1 (message-string output-string)
  (let* ((process (get-process "scheme"))
	 (window (get-buffer-window (process-buffer process))))
    (if (or (not window)
	    (not (pos-visible-in-window-p (process-mark process)
					  window)))
	(message "%s" message-string)))
  (xscheme-guarantee-newlines 1)
  (xscheme-process-filter-output output-string))

(defun xscheme-set-prompt-variable (string)
  (setq xscheme-prompt string))

(defun xscheme-set-prompt (string)
  (setq xscheme-prompt string)
  (xscheme-guarantee-newlines 2)
  (setq xscheme-mode-string (xscheme-coerce-prompt string))
  (xscheme-modeline-redisplay))

(defun xscheme-output-goto ()
  (xscheme-goto-output-point)
  (xscheme-guarantee-newlines 2))

(defun xscheme-coerce-prompt (string)
  (if (string-match "^[0-9]+ " string)
      (let ((end (match-end 0)))
	(concat (substring string 0 end)
		(let ((prompt (substring string end)))
		  (let ((entry (assoc prompt xscheme-prompt-alist)))
		    (if entry
			(cdr entry)
			prompt)))))
      string))

(defvar xscheme-prompt-alist
  '(("[Normal REPL]" . "[Evaluator]")
    ("[Error REPL]" . "[Evaluator]")
    ("[Breakpoint REPL]" . "[Evaluator]")
    ("[Debugger REPL]" . "[Evaluator]")
    ("[Visiting environment]" . "[Evaluator]")
    ("[Environment Inspector]" . "[Where]"))
  "An alist which maps the Scheme command interpreter type to a print string.")

(defun xscheme-cd (directory-string)
  (save-excursion
    (set-buffer (xscheme-process-buffer))
    (cd directory-string)))

(defun xscheme-prompt-for-confirmation (prompt-string)
  (xscheme-send-char (if (y-or-n-p prompt-string) ?y ?n)))

(defun xscheme-prompt-for-expression (prompt-string)
  (xscheme-send-string-2
   (read-from-minibuffer prompt-string nil xscheme-prompt-for-expression-map)))

(defvar xscheme-prompt-for-expression-map nil)
(if (not xscheme-prompt-for-expression-map)
    (progn
      (setq xscheme-prompt-for-expression-map
	    (copy-keymap minibuffer-local-map))
      (substitute-key-definition 'exit-minibuffer
				 'xscheme-prompt-for-expression-exit
				 xscheme-prompt-for-expression-map)))

(defun xscheme-prompt-for-expression-exit ()
  (interactive)
  (if (eq (xscheme-region-expression-p (point-min) (point-max)) 'one)
      (exit-minibuffer)
      (error "input must be a single, complete expression")))

(defun xscheme-region-expression-p (start end)
  (save-excursion
    (let ((old-syntax-table (syntax-table)))
      (unwind-protect
	  (progn
	    (set-syntax-table scheme-mode-syntax-table)
	    (let ((state (parse-partial-sexp start end)))
	      (and (zerop (car state))	;depth = 0
		   (nth 2 state)	;last-sexp exists, i.e. >= 1 sexps
		   (let ((state (parse-partial-sexp start (nth 2 state))))
		     (if (nth 2 state) 'many 'one)))))
	(set-syntax-table old-syntax-table)))))