diff options
Diffstat (limited to 'ice-9/emacs.scm')
-rw-r--r-- | ice-9/emacs.scm | 296 |
1 files changed, 0 insertions, 296 deletions
diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm deleted file mode 100644 index 7673d52e5..000000000 --- a/ice-9/emacs.scm +++ /dev/null @@ -1,296 +0,0 @@ -;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. -;;;; -;;;; The author can be reached at djurfeldt@nada.kth.se -;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN -;;;; (I didn't write this!) -;;;; - - -;;; ********************************************************************* -;;; * This is the Guile side of the Emacs interface * -;;; * Experimental hACK---the real version will be coming soon (almost) * -;;; ********************************************************************* - -;;; {Session support for Emacs} -;;; - -(define-module (ice-9 emacs) - :use-module (ice-9 debug) - :use-module (ice-9 threads) - :use-module (ice-9 session) - :no-backtrace) - -(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 #\.)) -(define no-stack (make-emacs-command #\S)) -(define no-source (make-emacs-command #\R)) - -;; {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-current-input-port (make-emacs-load-port (current-input-port))) - -(define (result-to-emacs exp) - (sending-result) - (write exp emacs-output-port) - (end-of-text) - (force-output emacs-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 #\np)) - -(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 receiving 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 colnum module interactivep) - (set-port-filename! %%load-port filename) - (set-port-line! %%load-port linum) - (set-port-column! %%load-port colnum) - (lazy-catch #t - (lambda () - (let loop ((endp (flush-whitespace %%load-port))) - (if (not endp) - (begin - (save-module-excursion - (lambda () - (if module - (set-current-module (resolve-module module #f))) - (let ((result - (start-stack read-and-eval! - (read-and-eval! %%load-port)))) - (if interactivep - (result-to-emacs result))))) - (loop (flush-whitespace %%load-port))) - (begin - (load-acknowledge))) - (set-port-filename! %%load-port #f))) ;reset port filename - (lambda (key . args) - (set-port-filename! %%load-port #f) - (cond ((eq? key 'end-of-chunk) - (fluid-set! the-last-stack #f) - (set! stack-saved? #t) - (scm-error 'misc-error - #f - "Incomplete expression" - '() - '())) - ((eq? key 'exit)) - (else - (save-stack 2) - (catch 'end-of-chunk - (lambda () - (let loop () - (read-char %%load-port) - (loop))) - (lambda args - #f)) - (apply throw key args)))))) - -(define (emacs-eval-request form) - (result-to-emacs (eval form (interaction-environment)))) - -;;*fixme* Not necessary to use flags no-stack and no-source -(define (get-frame-source frame) - (if (or (not (fluid-ref the-last-stack)) - (>= frame (stack-length (fluid-ref the-last-stack)))) - (begin - (no-stack) - #f) - (let* ((frame (stack-ref (fluid-ref the-last-stack) - (frame-number->index frame))) - (source (frame-source frame))) - (or source - (begin (no-source) - #f))))) - -(define (emacs-select-frame frame) - (let ((source (get-frame-source frame))) - (if source - (let ((fname (source-property source 'filename)) - (line (source-property source 'line)) - (column (source-property source 'column))) - (if (and fname line column) - (list fname line column) - (begin (no-source) - '()))) - '()))) - -(define (object->string x . method) - (with-output-to-string - (lambda () - ((if (null? method) - write - (car method)) - x)))) - -(define (format template . rest) - (let loop ((chars (string->list template)) - (result '()) - (rest rest)) - (cond ((null? chars) (list->string (reverse result))) - ((char=? (car chars) #\%) - (loop (cddr chars) - (append (reverse - (string->list - (case (cadr chars) - ((#\S) (object->string (car rest))) - ((#\s) (object->string (car rest) display))))) - result) - (cdr rest))) - (else (loop (cdr chars) (cons (car chars) result) rest))))) - -(define (error-args->string args) - (let ((msg (apply format (caddr args) (cadddr args)))) - (if (symbol? (cadr args)) - (string-append (symbol->string (cadr args)) - ": " - msg) - msg))) - -(define (emacs-frame-eval frame form) - (let ((source (get-frame-source frame))) - (if source - (catch #t - (lambda () - (list 'result - (object->string - (local-eval (with-input-from-string form read) - (memoized-environment source))))) - (lambda args - (list (car args) - (error-args->string args)))) - (begin - (no-source) - '())))) - -(define (emacs-symdoc symbol) - (if (or (not (module-bound? (current-module) symbol)) - (not (procedure? (eval symbol (interaction-environment))))) - 'nil - (procedure-documentation (eval symbol (interaction-environment))))) - -;;; A fix to get the emacs interface to work together with the module system. -;;; -(for-each (lambda (name value) - (module-define! the-root-module name value)) - '(%%load-port - %%emacs-load - %%emacs-eval-request - %%emacs-select-frame - %%emacs-frame-eval - %%emacs-symdoc - %%apropos-internal) - (list load-port - emacs-load - emacs-eval-request - emacs-select-frame - emacs-frame-eval - emacs-symdoc - apropos-internal)) |