diff options
Diffstat (limited to 'ice-9/emacs.scm')
-rw-r--r-- | ice-9/emacs.scm | 163 |
1 files changed, 163 insertions, 0 deletions
diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm new file mode 100644 index 000000000..c563200cc --- /dev/null +++ b/ice-9/emacs.scm @@ -0,0 +1,163 @@ +;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;;; +;;;; The author can be reached at djurfeldt@nada.kth.se +;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN +;;;; + + +;;; ******************************* +;;; * Experimental hack * +;;; * Shouldn't go into snapshots * +;;; * Don't distribute! * +;;; ******************************* + +;;; {Session support for Emacs} +;;; + +(define-module (ice-9 emacs) + :use-module (ice-9 threads) + :use-module (ice-9 nonblocking)) + +(define emacs-escape-character #\sub) + +(define emacs-output-port (current-output-port)) + +(define (make-emacs-command char) + (let ((cmd (list->string (list emacs-escape-character char)))) + (lambda () + (display cmd emacs-output-port)))) + +(define enter-input-wait (make-emacs-command #\s)) +(define exit-input-wait (make-emacs-command #\f)) +(define enter-read-character #\r) +(define sending-error (make-emacs-command #\F)) +(define sending-backtrace (make-emacs-command #\B)) +(define sending-result (make-emacs-command #\x)) +(define end-of-text (make-emacs-command #\.)) + +;; {Error handling} +;; + +(add-hook! before-backtrace-hook sending-backtrace) +(add-hook! after-backtrace-hook end-of-text) +(add-hook! before-error-hook sending-error) +(add-hook! after-error-hook end-of-text) + +;; {Repl} +;; + +(set-current-error-port emacs-output-port) + +(add-hook! before-read-hook + (lambda () + (enter-input-wait) + (force-output emacs-output-port))) + +(add-hook! after-read-hook + (lambda () + (exit-input-wait) + (force-output emacs-output-port))) + +;;; {Misc.} + +(define (make-emacs-load-port orig-port) + (letrec ((read-char-fn (lambda args + (let ((c (read-char orig-port))) + (if (eq? c #\soh) + (throw 'end-of-chunk) + c))))) + + (make-soft-port + (vector #f #f #f + read-char-fn + (lambda () (close-port orig-port))) + "r"))) + +(set! repl-input-port (make-emacs-load-port (current-input-port))) +(set-current-input-port repl-input-port) + +(define (emacs-eval-request form) + (let ((port (current-output-port))) + (sending-result port) + (write (eval form) port) + (end-of-text port) + (force-output port))) + +(define load-acknowledge (make-emacs-command #\l)) + +(define load-port (current-input-port)) + +(define (flush-line port) + (let loop ((c (read-char port))) + (if (not (eq? c #\nl)) + (loop (read-char port))))) + +(define whitespace-chars (list #\space #\tab #\nl)) + +(define (flush-whitespace port) + (catch 'end-of-chunk + (lambda () + (let loop ((c (read-char port))) + (cond ((eq? c the-eof-object) + (error "End of file while recieving Emacs data")) + ((memq c whitespace-chars) (loop (read-char port))) + ((eq? c #\;) (flush-line port) (loop (read-char port))) + (else (unread-char c port)))) + #f) + (lambda args + (read-char port) ; Read final newline + #t))) + +(define (emacs-load filename linum) + (set-port-filename! %%load-port filename) + (set-port-line! %%load-port (- linum 1)) + (set-port-column! %%load-port 0) + (lazy-catch #t + (lambda () + (let loop ((endp (flush-whitespace %%load-port))) + (if (not endp) + (begin + (start-stack read-and-eval! (read-and-eval! %%load-port)) + (loop (flush-whitespace %%load-port))) + (begin + (load-acknowledge)))) + ) + (lambda (key . args) + (cond ((eq? key 'end-of-chunk) + (set! the-last-stack #f) + (set! stack-saved? #t) + (scm-error 'misc-error + 'emacs-load + "Incomplete expression" + '() + '())) + ((eq? key 'exit)) + (else + (save-stack) + (catch 'end-of-chunk + (lambda () + (let loop () + (read-char %%load-port) + (loop))) + (lambda args + #f)) + (apply throw key args)))))) + +;;; A fix to get the emacs interface to work together with the module system. +;;; +(variable-set! (builtin-variable '%%load-port) load-port) +(variable-set! (builtin-variable '%%emacs-load) emacs-load) |