1 ;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
3 ;;;; This library is free software; you can redistribute it and/or
4 ;;;; modify it under the terms of the GNU Lesser General Public
5 ;;;; License as published by the Free Software Foundation; either
6 ;;;; version 2.1 of the License, or (at your option) any later version.
8 ;;;; This library 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 GNU
11 ;;;; Lesser General Public License for more details.
13 ;;;; You should have received a copy of the GNU Lesser General Public
14 ;;;; License along with this library; if not, write to the Free Software
15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17 ;;;; The author can be reached at djurfeldt@nada.kth.se
18 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
19 ;;;; (I didn't write this!)
23 ;;; *********************************************************************
24 ;;; * This is the Guile side of the Emacs interface *
25 ;;; * Experimental hACK---the real version will be coming soon (almost) *
26 ;;; *********************************************************************
28 ;;; {Session support for Emacs}
31 (define-module (ice-9 emacs)
32 :use-module (ice-9 debug)
33 :use-module (ice-9 threads)
34 :use-module (ice-9 session)
37 (define emacs-escape-character #\sub)
39 (define emacs-output-port (current-output-port))
41 (define (make-emacs-command char)
42 (let ((cmd (list->string (list emacs-escape-character char))))
44 (display cmd emacs-output-port))))
46 (define enter-input-wait (make-emacs-command #\s))
47 (define exit-input-wait (make-emacs-command #\f))
48 (define enter-read-character #\r)
49 (define sending-error (make-emacs-command #\F))
50 (define sending-backtrace (make-emacs-command #\B))
51 (define sending-result (make-emacs-command #\x))
52 (define end-of-text (make-emacs-command #\.))
53 (define no-stack (make-emacs-command #\S))
54 (define no-source (make-emacs-command #\R))
59 (add-hook! before-backtrace-hook sending-backtrace)
60 (add-hook! after-backtrace-hook end-of-text)
61 (add-hook! before-error-hook sending-error)
62 (add-hook! after-error-hook end-of-text)
67 (set-current-error-port emacs-output-port)
69 (add-hook! before-read-hook
72 (force-output emacs-output-port)))
74 (add-hook! after-read-hook
77 (force-output emacs-output-port)))
81 (define (make-emacs-load-port orig-port)
82 (letrec ((read-char-fn (lambda args
83 (let ((c (read-char orig-port)))
91 (lambda () (close-port orig-port)))
94 (set-current-input-port (make-emacs-load-port (current-input-port)))
96 (define (result-to-emacs exp)
98 (write exp emacs-output-port)
100 (force-output emacs-output-port))
102 (define load-acknowledge (make-emacs-command #\l))
104 (define load-port (current-input-port))
106 (define (flush-line port)
107 (let loop ((c (read-char port)))
108 (if (not (eq? c #\nl))
109 (loop (read-char port)))))
111 (define whitespace-chars (list #\space #\tab #\nl #\np))
113 (define (flush-whitespace port)
116 (let loop ((c (read-char port)))
117 (cond ((eq? c the-eof-object)
118 (error "End of file while receiving Emacs data"))
119 ((memq c whitespace-chars) (loop (read-char port)))
120 ((eq? c #\;) (flush-line port) (loop (read-char port)))
121 (else (unread-char c port))))
124 (read-char port) ; Read final newline
127 (define (emacs-load filename linum colnum module interactivep)
128 (define (read-and-eval! port)
129 (let ((x (read port)))
132 (primitive-eval x))))
133 (set-port-filename! %%load-port filename)
134 (set-port-line! %%load-port linum)
135 (set-port-column! %%load-port colnum)
138 (let loop ((endp (flush-whitespace %%load-port)))
141 (save-module-excursion
144 (set-current-module (resolve-module module #f)))
146 (start-stack read-and-eval!
147 (read-and-eval! %%load-port))))
149 (result-to-emacs result)))))
150 (loop (flush-whitespace %%load-port)))
153 (set-port-filename! %%load-port #f))) ;reset port filename
155 (set-port-filename! %%load-port #f)
156 (cond ((eq? key 'end-of-chunk)
157 (fluid-set! the-last-stack #f)
158 (set! stack-saved? #t)
159 (scm-error 'misc-error
161 "Incomplete expression"
170 (read-char %%load-port)
174 (apply throw key args))))))
176 (define (emacs-eval-request form)
177 (result-to-emacs (eval form (interaction-environment))))
179 ;;*fixme* Not necessary to use flags no-stack and no-source
180 (define (get-frame-source frame)
181 (if (or (not (fluid-ref the-last-stack))
182 (>= frame (stack-length (fluid-ref the-last-stack))))
186 (let* ((frame (stack-ref (fluid-ref the-last-stack)
187 (frame-number->index frame)))
188 (source (frame-source frame)))
193 (define (emacs-select-frame frame)
194 (let ((source (get-frame-source frame)))
196 (let ((fname (source-property source 'filename))
197 (line (source-property source 'line))
198 (column (source-property source 'column)))
199 (if (and fname line column)
200 (list fname line column)
205 (define (object->string x . method)
206 (with-output-to-string
213 (define (format template . rest)
214 (let loop ((chars (string->list template))
217 (cond ((null? chars) (list->string (reverse result)))
218 ((char=? (car chars) #\%)
223 ((#\S) (object->string (car rest)))
224 ((#\s) (object->string (car rest) display)))))
227 (else (loop (cdr chars) (cons (car chars) result) rest)))))
229 (define (error-args->string args)
230 (let ((msg (apply format (caddr args) (cadddr args))))
231 (if (symbol? (cadr args))
232 (string-append (symbol->string (cadr args))
237 (define (emacs-frame-eval frame form)
238 (let ((source (get-frame-source frame)))
244 (local-eval (with-input-from-string form read)
245 (memoized-environment source)))))
248 (error-args->string args))))
253 (define (emacs-symdoc symbol)
254 (if (or (not (module-bound? (current-module) symbol))
255 (not (procedure? (eval symbol (interaction-environment)))))
257 (procedure-documentation (eval symbol (interaction-environment)))))
259 ;;; A fix to get the emacs interface to work together with the module system.
261 (for-each (lambda (name value)
262 (module-define! the-root-module name value))