1 ;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
3 ;;;; This program is free software; you can redistribute it and/or modify
4 ;;;; it under the terms of the GNU General Public License as published by
5 ;;;; the Free Software Foundation; either version 2, or (at your option)
6 ;;;; any later version.
8 ;;;; This program is distributed in the hope that it will be useful,
9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 ;;;; GNU General Public License for more details.
13 ;;;; You should have received a copy of the GNU General Public License
14 ;;;; along with this software; see the file COPYING. If not, write to
15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 ;;;; Boston, MA 02111-1307 USA
18 ;;;; The author can be reached at djurfeldt@nada.kth.se
19 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
20 ;;;; (I didn't write this!)
24 ;;; *********************************************************************
25 ;;; * This is the Guile side of the Emacs interface *
26 ;;; * Experimental hACK---the real version will be coming soon (almost) *
27 ;;; *********************************************************************
29 ;;; {Session support for Emacs}
32 (define-module (ice-9 emacs)
33 :use-module (ice-9 debug)
34 :use-module (ice-9 threads)
35 :use-module (ice-9 session)
38 (define emacs-escape-character #\sub)
40 (define emacs-output-port (current-output-port))
42 (define (make-emacs-command char)
43 (let ((cmd (list->string (list emacs-escape-character char))))
45 (display cmd emacs-output-port))))
47 (define enter-input-wait (make-emacs-command #\s))
48 (define exit-input-wait (make-emacs-command #\f))
49 (define enter-read-character #\r)
50 (define sending-error (make-emacs-command #\F))
51 (define sending-backtrace (make-emacs-command #\B))
52 (define sending-result (make-emacs-command #\x))
53 (define end-of-text (make-emacs-command #\.))
54 (define no-stack (make-emacs-command #\S))
55 (define no-source (make-emacs-command #\R))
60 (add-hook! before-backtrace-hook sending-backtrace)
61 (add-hook! after-backtrace-hook end-of-text)
62 (add-hook! before-error-hook sending-error)
63 (add-hook! after-error-hook end-of-text)
68 (set-current-error-port emacs-output-port)
70 (add-hook! before-read-hook
73 (force-output emacs-output-port)))
75 (add-hook! after-read-hook
78 (force-output emacs-output-port)))
82 (define (make-emacs-load-port orig-port)
83 (letrec ((read-char-fn (lambda args
84 (let ((c (read-char orig-port)))
92 (lambda () (close-port orig-port)))
95 (set-current-input-port (make-emacs-load-port (current-input-port)))
97 (define (result-to-emacs exp)
99 (write exp emacs-output-port)
101 (force-output emacs-output-port))
103 (define load-acknowledge (make-emacs-command #\l))
105 (define load-port (current-input-port))
107 (define (flush-line port)
108 (let loop ((c (read-char port)))
109 (if (not (eq? c #\nl))
110 (loop (read-char port)))))
112 (define whitespace-chars (list #\space #\tab #\nl #\np))
114 (define (flush-whitespace port)
117 (let loop ((c (read-char port)))
118 (cond ((eq? c the-eof-object)
119 (error "End of file while receiving Emacs data"))
120 ((memq c whitespace-chars) (loop (read-char port)))
121 ((eq? c #\;) (flush-line port) (loop (read-char port)))
122 (else (unread-char c port))))
125 (read-char port) ; Read final newline
128 (define (emacs-load filename linum colnum module interactivep)
129 (set-port-filename! %%load-port filename)
130 (set-port-line! %%load-port linum)
131 (set-port-column! %%load-port colnum)
134 (let loop ((endp (flush-whitespace %%load-port)))
137 (save-module-excursion
140 (set-current-module (resolve-module module #f)))
142 (start-stack read-and-eval!
143 (read-and-eval! %%load-port))))
145 (result-to-emacs result)))))
146 (loop (flush-whitespace %%load-port)))
149 (set-port-filename! %%load-port #f))) ;reset port filename
151 (set-port-filename! %%load-port #f)
152 (cond ((eq? key 'end-of-chunk)
153 (fluid-set! the-last-stack #f)
154 (set! stack-saved? #t)
155 (scm-error 'misc-error
157 "Incomplete expression"
166 (read-char %%load-port)
170 (apply throw key args))))))
172 (define (emacs-eval-request form)
173 (result-to-emacs (eval form (interaction-environment))))
175 ;;*fixme* Not necessary to use flags no-stack and no-source
176 (define (get-frame-source frame)
177 (if (or (not (fluid-ref the-last-stack))
178 (>= frame (stack-length (fluid-ref the-last-stack))))
182 (let* ((frame (stack-ref (fluid-ref the-last-stack)
183 (frame-number->index frame)))
184 (source (frame-source frame)))
189 (define (emacs-select-frame frame)
190 (let ((source (get-frame-source frame)))
192 (let ((fname (source-property source 'filename))
193 (line (source-property source 'line))
194 (column (source-property source 'column)))
195 (if (and fname line column)
196 (list fname line column)
201 (define (object->string x . method)
202 (with-output-to-string
209 (define (format template . rest)
210 (let loop ((chars (string->list template))
213 (cond ((null? chars) (list->string (reverse result)))
214 ((char=? (car chars) #\%)
219 ((#\S) (object->string (car rest)))
220 ((#\s) (object->string (car rest) display)))))
223 (else (loop (cdr chars) (cons (car chars) result) rest)))))
225 (define (error-args->string args)
226 (let ((msg (apply format (caddr args) (cadddr args))))
227 (if (symbol? (cadr args))
228 (string-append (symbol->string (cadr args))
233 (define (emacs-frame-eval frame form)
234 (let ((source (get-frame-source frame)))
240 (local-eval (with-input-from-string form read)
241 (memoized-environment source)))))
244 (error-args->string args))))
249 (define (emacs-symdoc symbol)
250 (if (or (not (module-bound? (current-module) symbol))
251 (not (procedure? (eval symbol (interaction-environment)))))
253 (procedure-documentation (eval symbol (interaction-environment)))))
255 ;;; A fix to get the emacs interface to work together with the module system.
257 (variable-set! (builtin-variable '%%load-port) load-port)
258 (variable-set! (builtin-variable '%%emacs-load) emacs-load)
259 (variable-set! (builtin-variable '%%emacs-eval-request) emacs-eval-request)
260 (variable-set! (builtin-variable '%%emacs-select-frame) emacs-select-frame)
261 (variable-set! (builtin-variable '%%emacs-frame-eval) emacs-frame-eval)
262 (variable-set! (builtin-variable '%%emacs-symdoc) emacs-symdoc)
263 (variable-set! (builtin-variable '%%apropos-internal) apropos-internal)