Commit | Line | Data |
---|---|---|
8397a3a6 | 1 | ;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006, 2009 Free Software Foundation, Inc. |
7dd98e0b | 2 | ;;;; |
73be1d9e MV |
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 | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
7dd98e0b | 7 | ;;;; |
73be1d9e | 8 | ;;;; This library is distributed in the hope that it will be useful, |
7dd98e0b | 9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. | |
7dd98e0b | 12 | ;;;; |
73be1d9e MV |
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 | |
92205699 | 15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 16 | ;;;; |
7dd98e0b MD |
17 | ;;;; The author can be reached at djurfeldt@nada.kth.se |
18 | ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN | |
67da6c57 | 19 | ;;;; (I didn't write this!) |
7dd98e0b MD |
20 | ;;;; |
21 | \f | |
22 | ||
67da6c57 MD |
23 | ;;; ********************************************************************* |
24 | ;;; * This is the Guile side of the Emacs interface * | |
25 | ;;; * Experimental hACK---the real version will be coming soon (almost) * | |
26 | ;;; ********************************************************************* | |
7dd98e0b MD |
27 | |
28 | ;;; {Session support for Emacs} | |
29 | ;;; | |
30 | ||
31 | (define-module (ice-9 emacs) | |
1c215029 | 32 | :use-module (ice-9 debug) |
7dd98e0b | 33 | :use-module (ice-9 threads) |
3267d4a1 MD |
34 | :use-module (ice-9 session) |
35 | :no-backtrace) | |
7dd98e0b MD |
36 | |
37 | (define emacs-escape-character #\sub) | |
38 | ||
39 | (define emacs-output-port (current-output-port)) | |
40 | ||
41 | (define (make-emacs-command char) | |
42 | (let ((cmd (list->string (list emacs-escape-character char)))) | |
43 | (lambda () | |
44 | (display cmd emacs-output-port)))) | |
45 | ||
1c215029 MD |
46 | (define enter-input-wait (make-emacs-command #\s)) |
47 | (define exit-input-wait (make-emacs-command #\f)) | |
7dd98e0b | 48 | (define enter-read-character #\r) |
1c215029 | 49 | (define sending-error (make-emacs-command #\F)) |
7dd98e0b MD |
50 | (define sending-backtrace (make-emacs-command #\B)) |
51 | (define sending-result (make-emacs-command #\x)) | |
1c215029 MD |
52 | (define end-of-text (make-emacs-command #\.)) |
53 | (define no-stack (make-emacs-command #\S)) | |
54 | (define no-source (make-emacs-command #\R)) | |
7dd98e0b MD |
55 | |
56 | ;; {Error handling} | |
57 | ;; | |
58 | ||
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) | |
63 | ||
64 | ;; {Repl} | |
65 | ;; | |
66 | ||
67 | (set-current-error-port emacs-output-port) | |
68 | ||
69 | (add-hook! before-read-hook | |
70 | (lambda () | |
71 | (enter-input-wait) | |
72 | (force-output emacs-output-port))) | |
73 | ||
74 | (add-hook! after-read-hook | |
75 | (lambda () | |
76 | (exit-input-wait) | |
77 | (force-output emacs-output-port))) | |
78 | ||
79 | ;;; {Misc.} | |
80 | ||
81 | (define (make-emacs-load-port orig-port) | |
82 | (letrec ((read-char-fn (lambda args | |
83 | (let ((c (read-char orig-port))) | |
84 | (if (eq? c #\soh) | |
85 | (throw 'end-of-chunk) | |
86 | c))))) | |
87 | ||
88 | (make-soft-port | |
89 | (vector #f #f #f | |
90 | read-char-fn | |
91 | (lambda () (close-port orig-port))) | |
92 | "r"))) | |
93 | ||
3ede541d | 94 | (set-current-input-port (make-emacs-load-port (current-input-port))) |
7dd98e0b | 95 | |
8c5a8bed MD |
96 | (define (result-to-emacs exp) |
97 | (sending-result) | |
98 | (write exp emacs-output-port) | |
99 | (end-of-text) | |
100 | (force-output emacs-output-port)) | |
101 | ||
7dd98e0b MD |
102 | (define load-acknowledge (make-emacs-command #\l)) |
103 | ||
104 | (define load-port (current-input-port)) | |
105 | ||
106 | (define (flush-line port) | |
107 | (let loop ((c (read-char port))) | |
108 | (if (not (eq? c #\nl)) | |
109 | (loop (read-char port))))) | |
110 | ||
8c3420ad | 111 | (define whitespace-chars (list #\space #\tab #\nl #\np)) |
7dd98e0b MD |
112 | |
113 | (define (flush-whitespace port) | |
114 | (catch 'end-of-chunk | |
115 | (lambda () | |
116 | (let loop ((c (read-char port))) | |
117 | (cond ((eq? c the-eof-object) | |
40fa5c3f | 118 | (error "End of file while receiving Emacs data")) |
7dd98e0b MD |
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)))) | |
122 | #f) | |
123 | (lambda args | |
124 | (read-char port) ; Read final newline | |
125 | #t))) | |
126 | ||
d43f8c97 | 127 | (define (emacs-load filename linum colnum module interactivep) |
50a63003 NJ |
128 | (define (read-and-eval! port) |
129 | (let ((x (read port))) | |
130 | (if (eof-object? x) | |
131 | (throw 'end-of-file) | |
132 | (primitive-eval x)))) | |
7dd98e0b | 133 | (set-port-filename! %%load-port filename) |
db75135d | 134 | (set-port-line! %%load-port linum) |
1c215029 | 135 | (set-port-column! %%load-port colnum) |
7dd98e0b MD |
136 | (lazy-catch #t |
137 | (lambda () | |
138 | (let loop ((endp (flush-whitespace %%load-port))) | |
139 | (if (not endp) | |
ef0d04e5 MD |
140 | (begin |
141 | (save-module-excursion | |
142 | (lambda () | |
143 | (if module | |
144 | (set-current-module (resolve-module module #f))) | |
145 | (let ((result | |
146 | (start-stack read-and-eval! | |
147 | (read-and-eval! %%load-port)))) | |
148 | (if interactivep | |
149 | (result-to-emacs result))))) | |
7dd98e0b MD |
150 | (loop (flush-whitespace %%load-port))) |
151 | (begin | |
31264e81 MD |
152 | (load-acknowledge))) |
153 | (set-port-filename! %%load-port #f))) ;reset port filename | |
7dd98e0b | 154 | (lambda (key . args) |
31264e81 | 155 | (set-port-filename! %%load-port #f) |
7dd98e0b | 156 | (cond ((eq? key 'end-of-chunk) |
a66c53a8 | 157 | (fluid-set! the-last-stack #f) |
7dd98e0b MD |
158 | (set! stack-saved? #t) |
159 | (scm-error 'misc-error | |
8c3420ad | 160 | #f |
7dd98e0b MD |
161 | "Incomplete expression" |
162 | '() | |
163 | '())) | |
164 | ((eq? key 'exit)) | |
165 | (else | |
eb7ec1e8 | 166 | (save-stack 2) |
7dd98e0b MD |
167 | (catch 'end-of-chunk |
168 | (lambda () | |
169 | (let loop () | |
170 | (read-char %%load-port) | |
171 | (loop))) | |
172 | (lambda args | |
173 | #f)) | |
174 | (apply throw key args)))))) | |
175 | ||
1c215029 | 176 | (define (emacs-eval-request form) |
a71aca7a | 177 | (result-to-emacs (eval form (interaction-environment)))) |
1c215029 | 178 | |
52f1b046 | 179 | ;;*fixme* Not necessary to use flags no-stack and no-source |
1c215029 | 180 | (define (get-frame-source frame) |
a66c53a8 MD |
181 | (if (or (not (fluid-ref the-last-stack)) |
182 | (>= frame (stack-length (fluid-ref the-last-stack)))) | |
1c215029 MD |
183 | (begin |
184 | (no-stack) | |
185 | #f) | |
a66c53a8 MD |
186 | (let* ((frame (stack-ref (fluid-ref the-last-stack) |
187 | (frame-number->index frame))) | |
1c215029 MD |
188 | (source (frame-source frame))) |
189 | (or source | |
190 | (begin (no-source) | |
191 | #f))))) | |
192 | ||
193 | (define (emacs-select-frame frame) | |
194 | (let ((source (get-frame-source frame))) | |
195 | (if source | |
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) | |
201 | (begin (no-source) | |
202 | '()))) | |
203 | '()))) | |
204 | ||
52f1b046 MD |
205 | (define (object->string x . method) |
206 | (with-output-to-string | |
207 | (lambda () | |
208 | ((if (null? method) | |
209 | write | |
210 | (car method)) | |
211 | x)))) | |
212 | ||
213 | (define (format template . rest) | |
214 | (let loop ((chars (string->list template)) | |
0b6925fe MD |
215 | (result '()) |
216 | (rest rest)) | |
52f1b046 MD |
217 | (cond ((null? chars) (list->string (reverse result))) |
218 | ((char=? (car chars) #\%) | |
219 | (loop (cddr chars) | |
220 | (append (reverse | |
221 | (string->list | |
222 | (case (cadr chars) | |
223 | ((#\S) (object->string (car rest))) | |
224 | ((#\s) (object->string (car rest) display))))) | |
0b6925fe MD |
225 | result) |
226 | (cdr rest))) | |
227 | (else (loop (cdr chars) (cons (car chars) result) rest))))) | |
52f1b046 MD |
228 | |
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)) | |
233 | ": " | |
234 | msg) | |
235 | msg))) | |
236 | ||
8397a3a6 | 237 | ;; FIXME: no longer working due to removal of local-eval |
1c215029 MD |
238 | (define (emacs-frame-eval frame form) |
239 | (let ((source (get-frame-source frame))) | |
52f1b046 MD |
240 | (if source |
241 | (catch #t | |
242 | (lambda () | |
243 | (list 'result | |
244 | (object->string | |
245 | (local-eval (with-input-from-string form read) | |
246 | (memoized-environment source))))) | |
247 | (lambda args | |
248 | (list (car args) | |
249 | (error-args->string args)))) | |
250 | (begin | |
251 | (no-source) | |
252 | '())))) | |
1c215029 MD |
253 | |
254 | (define (emacs-symdoc symbol) | |
255 | (if (or (not (module-bound? (current-module) symbol)) | |
544468de | 256 | (not (procedure? (eval symbol (interaction-environment))))) |
1c215029 | 257 | 'nil |
a71aca7a | 258 | (procedure-documentation (eval symbol (interaction-environment))))) |
1c215029 | 259 | |
7dd98e0b MD |
260 | ;;; A fix to get the emacs interface to work together with the module system. |
261 | ;;; | |
c81f296a MD |
262 | (for-each (lambda (name value) |
263 | (module-define! the-root-module name value)) | |
264 | '(%%load-port | |
265 | %%emacs-load | |
266 | %%emacs-eval-request | |
267 | %%emacs-select-frame | |
268 | %%emacs-frame-eval | |
269 | %%emacs-symdoc | |
270 | %%apropos-internal) | |
271 | (list load-port | |
272 | emacs-load | |
273 | emacs-eval-request | |
274 | emacs-select-frame | |
275 | emacs-frame-eval | |
276 | emacs-symdoc | |
277 | apropos-internal)) |