Commit | Line | Data |
---|---|---|
0eaf5d77 | 1 | ;;;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc. |
7dd98e0b MD |
2 | ;;;; |
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. | |
7 | ;;;; | |
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. | |
12 | ;;;; | |
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 | |
15328041 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
7dd98e0b MD |
17 | ;;;; |
18 | ;;;; The author can be reached at djurfeldt@nada.kth.se | |
19 | ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN | |
67da6c57 | 20 | ;;;; (I didn't write this!) |
7dd98e0b MD |
21 | ;;;; |
22 | \f | |
23 | ||
67da6c57 MD |
24 | ;;; ********************************************************************* |
25 | ;;; * This is the Guile side of the Emacs interface * | |
26 | ;;; * Experimental hACK---the real version will be coming soon (almost) * | |
27 | ;;; ********************************************************************* | |
7dd98e0b MD |
28 | |
29 | ;;; {Session support for Emacs} | |
30 | ;;; | |
31 | ||
32 | (define-module (ice-9 emacs) | |
1c215029 | 33 | :use-module (ice-9 debug) |
7dd98e0b | 34 | :use-module (ice-9 threads) |
3267d4a1 MD |
35 | :use-module (ice-9 session) |
36 | :no-backtrace) | |
7dd98e0b MD |
37 | |
38 | (define emacs-escape-character #\sub) | |
39 | ||
40 | (define emacs-output-port (current-output-port)) | |
41 | ||
42 | (define (make-emacs-command char) | |
43 | (let ((cmd (list->string (list emacs-escape-character char)))) | |
44 | (lambda () | |
45 | (display cmd emacs-output-port)))) | |
46 | ||
1c215029 MD |
47 | (define enter-input-wait (make-emacs-command #\s)) |
48 | (define exit-input-wait (make-emacs-command #\f)) | |
7dd98e0b | 49 | (define enter-read-character #\r) |
1c215029 | 50 | (define sending-error (make-emacs-command #\F)) |
7dd98e0b MD |
51 | (define sending-backtrace (make-emacs-command #\B)) |
52 | (define sending-result (make-emacs-command #\x)) | |
1c215029 MD |
53 | (define end-of-text (make-emacs-command #\.)) |
54 | (define no-stack (make-emacs-command #\S)) | |
55 | (define no-source (make-emacs-command #\R)) | |
7dd98e0b MD |
56 | |
57 | ;; {Error handling} | |
58 | ;; | |
59 | ||
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) | |
64 | ||
65 | ;; {Repl} | |
66 | ;; | |
67 | ||
68 | (set-current-error-port emacs-output-port) | |
69 | ||
70 | (add-hook! before-read-hook | |
71 | (lambda () | |
72 | (enter-input-wait) | |
73 | (force-output emacs-output-port))) | |
74 | ||
75 | (add-hook! after-read-hook | |
76 | (lambda () | |
77 | (exit-input-wait) | |
78 | (force-output emacs-output-port))) | |
79 | ||
80 | ;;; {Misc.} | |
81 | ||
82 | (define (make-emacs-load-port orig-port) | |
83 | (letrec ((read-char-fn (lambda args | |
84 | (let ((c (read-char orig-port))) | |
85 | (if (eq? c #\soh) | |
86 | (throw 'end-of-chunk) | |
87 | c))))) | |
88 | ||
89 | (make-soft-port | |
90 | (vector #f #f #f | |
91 | read-char-fn | |
92 | (lambda () (close-port orig-port))) | |
93 | "r"))) | |
94 | ||
3ede541d | 95 | (set-current-input-port (make-emacs-load-port (current-input-port))) |
7dd98e0b | 96 | |
8c5a8bed MD |
97 | (define (result-to-emacs exp) |
98 | (sending-result) | |
99 | (write exp emacs-output-port) | |
100 | (end-of-text) | |
101 | (force-output emacs-output-port)) | |
102 | ||
7dd98e0b MD |
103 | (define load-acknowledge (make-emacs-command #\l)) |
104 | ||
105 | (define load-port (current-input-port)) | |
106 | ||
107 | (define (flush-line port) | |
108 | (let loop ((c (read-char port))) | |
109 | (if (not (eq? c #\nl)) | |
110 | (loop (read-char port))))) | |
111 | ||
8c3420ad | 112 | (define whitespace-chars (list #\space #\tab #\nl #\np)) |
7dd98e0b MD |
113 | |
114 | (define (flush-whitespace port) | |
115 | (catch 'end-of-chunk | |
116 | (lambda () | |
117 | (let loop ((c (read-char port))) | |
118 | (cond ((eq? c the-eof-object) | |
119 | (error "End of file while recieving 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)))) | |
123 | #f) | |
124 | (lambda args | |
125 | (read-char port) ; Read final newline | |
126 | #t))) | |
127 | ||
d43f8c97 | 128 | (define (emacs-load filename linum colnum module interactivep) |
7dd98e0b | 129 | (set-port-filename! %%load-port filename) |
db75135d | 130 | (set-port-line! %%load-port linum) |
1c215029 | 131 | (set-port-column! %%load-port colnum) |
7dd98e0b MD |
132 | (lazy-catch #t |
133 | (lambda () | |
134 | (let loop ((endp (flush-whitespace %%load-port))) | |
135 | (if (not endp) | |
ef0d04e5 MD |
136 | (begin |
137 | (save-module-excursion | |
138 | (lambda () | |
139 | (if module | |
140 | (set-current-module (resolve-module module #f))) | |
141 | (let ((result | |
142 | (start-stack read-and-eval! | |
143 | (read-and-eval! %%load-port)))) | |
144 | (if interactivep | |
145 | (result-to-emacs result))))) | |
7dd98e0b MD |
146 | (loop (flush-whitespace %%load-port))) |
147 | (begin | |
31264e81 MD |
148 | (load-acknowledge))) |
149 | (set-port-filename! %%load-port #f))) ;reset port filename | |
7dd98e0b | 150 | (lambda (key . args) |
31264e81 | 151 | (set-port-filename! %%load-port #f) |
7dd98e0b | 152 | (cond ((eq? key 'end-of-chunk) |
a66c53a8 | 153 | (fluid-set! the-last-stack #f) |
7dd98e0b MD |
154 | (set! stack-saved? #t) |
155 | (scm-error 'misc-error | |
8c3420ad | 156 | #f |
7dd98e0b MD |
157 | "Incomplete expression" |
158 | '() | |
159 | '())) | |
160 | ((eq? key 'exit)) | |
161 | (else | |
eb7ec1e8 | 162 | (save-stack 2) |
7dd98e0b MD |
163 | (catch 'end-of-chunk |
164 | (lambda () | |
165 | (let loop () | |
166 | (read-char %%load-port) | |
167 | (loop))) | |
168 | (lambda args | |
169 | #f)) | |
170 | (apply throw key args)))))) | |
171 | ||
1c215029 MD |
172 | (define (emacs-eval-request form) |
173 | (result-to-emacs (eval form))) | |
174 | ||
52f1b046 | 175 | ;;*fixme* Not necessary to use flags no-stack and no-source |
1c215029 | 176 | (define (get-frame-source frame) |
a66c53a8 MD |
177 | (if (or (not (fluid-ref the-last-stack)) |
178 | (>= frame (stack-length (fluid-ref the-last-stack)))) | |
1c215029 MD |
179 | (begin |
180 | (no-stack) | |
181 | #f) | |
a66c53a8 MD |
182 | (let* ((frame (stack-ref (fluid-ref the-last-stack) |
183 | (frame-number->index frame))) | |
1c215029 MD |
184 | (source (frame-source frame))) |
185 | (or source | |
186 | (begin (no-source) | |
187 | #f))))) | |
188 | ||
189 | (define (emacs-select-frame frame) | |
190 | (let ((source (get-frame-source frame))) | |
191 | (if source | |
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) | |
197 | (begin (no-source) | |
198 | '()))) | |
199 | '()))) | |
200 | ||
52f1b046 MD |
201 | (define (object->string x . method) |
202 | (with-output-to-string | |
203 | (lambda () | |
204 | ((if (null? method) | |
205 | write | |
206 | (car method)) | |
207 | x)))) | |
208 | ||
209 | (define (format template . rest) | |
210 | (let loop ((chars (string->list template)) | |
0b6925fe MD |
211 | (result '()) |
212 | (rest rest)) | |
52f1b046 MD |
213 | (cond ((null? chars) (list->string (reverse result))) |
214 | ((char=? (car chars) #\%) | |
215 | (loop (cddr chars) | |
216 | (append (reverse | |
217 | (string->list | |
218 | (case (cadr chars) | |
219 | ((#\S) (object->string (car rest))) | |
220 | ((#\s) (object->string (car rest) display))))) | |
0b6925fe MD |
221 | result) |
222 | (cdr rest))) | |
223 | (else (loop (cdr chars) (cons (car chars) result) rest))))) | |
52f1b046 MD |
224 | |
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)) | |
229 | ": " | |
230 | msg) | |
231 | msg))) | |
232 | ||
1c215029 MD |
233 | (define (emacs-frame-eval frame form) |
234 | (let ((source (get-frame-source frame))) | |
52f1b046 MD |
235 | (if source |
236 | (catch #t | |
237 | (lambda () | |
238 | (list 'result | |
239 | (object->string | |
240 | (local-eval (with-input-from-string form read) | |
241 | (memoized-environment source))))) | |
242 | (lambda args | |
243 | (list (car args) | |
244 | (error-args->string args)))) | |
245 | (begin | |
246 | (no-source) | |
247 | '())))) | |
1c215029 MD |
248 | |
249 | (define (emacs-symdoc symbol) | |
250 | (if (or (not (module-bound? (current-module) symbol)) | |
251 | (not (procedure? (eval symbol)))) | |
252 | 'nil | |
253 | (procedure-documentation (eval symbol)))) | |
254 | ||
7dd98e0b MD |
255 | ;;; A fix to get the emacs interface to work together with the module system. |
256 | ;;; | |
257 | (variable-set! (builtin-variable '%%load-port) load-port) | |
258 | (variable-set! (builtin-variable '%%emacs-load) emacs-load) | |
1c215029 MD |
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) |