Commit | Line | Data |
---|---|---|
51248e6e DK |
1 | ;;; Guile Emac Lisp |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language elisp compile-tree-il) | |
5d221ca3 | 23 | #:use-module (language elisp bindings) |
51248e6e DK |
24 | #:use-module (language tree-il) |
25 | #:use-module (system base pmatch) | |
74c009da | 26 | #:use-module (system base compile) |
51248e6e DK |
27 | #:export (compile-tree-il)) |
28 | ||
29 | ||
30 | ; Find the source properties of some parsed expression if there are any | |
31 | ; associated with it. | |
32 | ||
33 | (define (location x) | |
34 | (and (pair? x) | |
35 | (let ((props (source-properties x))) | |
36 | (and (not (null? props)) | |
37 | props)))) | |
38 | ||
39 | ||
de9f26b5 | 40 | ; Values to use for Elisp's nil and t. |
4530432e | 41 | |
de9f26b5 DK |
42 | (define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value))) |
43 | (define (t-value loc) (make-const loc (@ (language elisp runtime) t-value))) | |
4530432e DK |
44 | |
45 | ||
344927c3 DK |
46 | ; Modules that contain the value and function slot bindings. |
47 | ||
48 | (define runtime '(language elisp runtime)) | |
49 | (define value-slot '(language elisp runtime value-slot)) | |
50 | (define function-slot '(language elisp runtime function-slot)) | |
74c009da | 51 | (define macro-slot '(language elisp runtime macro-slot)) |
344927c3 DK |
52 | |
53 | ||
9b5ff6a6 DK |
54 | ; The backquoting works the same as quasiquotes in Scheme, but the forms are |
55 | ; named differently; to make easy adaptions, we define these predicates checking | |
56 | ; for a symbol being the car of an unquote/unquote-splicing/backquote form. | |
57 | ||
58 | ; FIXME: Remove the quasiquote/unquote/unquote-splicing symbols when real elisp | |
59 | ; reader is there. | |
60 | ||
61 | (define (backquote? sym) | |
62 | (and (symbol? sym) (or (eq? sym 'quasiquote) | |
63 | (eq? sym '\`)))) | |
64 | ||
65 | (define (unquote? sym) | |
66 | (and (symbol? sym) (or (eq? sym 'unquote) | |
67 | (eq? sym '\,)))) | |
68 | ||
69 | (define (unquote-splicing? sym) | |
70 | (and (symbol? sym) (or (eq? sym 'unquote-splicing) | |
71 | (eq? sym '\,@)))) | |
72 | ||
73 | ||
50abfe76 DK |
74 | ; Build a call to a primitive procedure nicely. |
75 | ||
76 | (define (call-primitive loc sym . args) | |
77 | (make-application loc (make-primitive-ref loc sym) args)) | |
78 | ||
79 | ||
80 | ; Error reporting routine for syntax/compilation problems or build code for | |
81 | ; a runtime-error output. | |
344927c3 DK |
82 | |
83 | (define (report-error loc . args) | |
84 | (apply error args)) | |
85 | ||
50abfe76 DK |
86 | (define (runtime-error loc msg . args) |
87 | (make-application loc (make-primitive-ref loc 'error) | |
88 | (cons (make-const loc msg) args))) | |
89 | ||
344927c3 DK |
90 | |
91 | ; Generate code to ensure a fluid is there for further use of a given symbol. | |
5d221ca3 DK |
92 | ; In general during the compilation, fluids needed are only tracked with the |
93 | ; bindings data structure. Afterwards, however, for all those needed symbols | |
94 | ; the fluids are really generated with this routine. | |
344927c3 | 95 | |
5d221ca3 | 96 | (define (generate-ensure-fluid loc sym module) |
f28de791 | 97 | (let ((resolved-module (call-primitive loc 'resolve-module |
1e018f6c DK |
98 | (make-const loc module))) |
99 | (resolved-intf (call-primitive loc 'resolve-interface | |
100 | (make-const loc module)))) | |
f28de791 | 101 | (make-conditional loc |
1e018f6c | 102 | (call-primitive loc 'module-defined? resolved-intf (make-const loc sym)) |
f28de791 DK |
103 | (make-void loc) |
104 | (make-sequence loc | |
105 | (list (call-primitive loc 'module-define! | |
106 | resolved-module (make-const loc sym) | |
107 | (call-primitive loc 'make-fluid)) | |
108 | (call-primitive loc 'module-export! | |
109 | resolved-module | |
1e018f6c DK |
110 | (call-primitive loc 'list (make-const loc sym))) |
111 | (call-primitive loc 'fluid-set! | |
112 | (make-module-ref loc module sym #t) | |
113 | (make-module-ref loc runtime 'void #t))))))) | |
f28de791 | 114 | |
344927c3 | 115 | |
344927c3 DK |
116 | ; Generate code to reference a fluid saved variable. |
117 | ||
5d221ca3 DK |
118 | (define (reference-variable loc bind sym module) |
119 | (mark-fluid-needed! bind sym module) | |
120 | (call-primitive loc 'fluid-ref | |
121 | (make-module-ref loc module sym #t))) | |
344927c3 DK |
122 | |
123 | ||
124 | ; Reference a variable and error if the value is void. | |
125 | ||
5d221ca3 | 126 | (define (reference-with-check loc bind sym module) |
344927c3 | 127 | (let ((var (gensym))) |
5d221ca3 | 128 | (make-let loc '(value) `(,var) `(,(reference-variable loc bind sym module)) |
344927c3 | 129 | (make-conditional loc |
50abfe76 DK |
130 | (call-primitive loc 'eq? |
131 | (make-module-ref loc runtime 'void #t) | |
132 | (make-lexical-ref loc 'value var)) | |
133 | (runtime-error loc "variable is void:" (make-const loc sym)) | |
344927c3 DK |
134 | (make-lexical-ref loc 'value var))))) |
135 | ||
136 | ||
137 | ; Generate code to set a fluid saved variable. | |
138 | ||
5d221ca3 DK |
139 | (define (set-variable! loc bind sym module value) |
140 | (mark-fluid-needed! bind sym module) | |
141 | (call-primitive loc 'fluid-set! | |
142 | (make-module-ref loc module sym #t) value)) | |
344927c3 DK |
143 | |
144 | ||
3a4b8635 DK |
145 | ; Process the bindings part of a let or let* expression; that is, check for |
146 | ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...). | |
147 | ||
148 | (define (process-let-bindings loc bindings) | |
149 | (map (lambda (b) | |
150 | (if (symbol? b) | |
151 | (cons b 'nil) | |
152 | (if (or (not (list? b)) | |
153 | (not (= (length b) 2))) | |
154 | (report-error loc "expected symbol or list of 2 elements in let") | |
155 | (if (not (symbol? (car b))) | |
156 | (report-error loc "expected symbol in let") | |
157 | (cons (car b) (cadr b)))))) | |
158 | bindings)) | |
159 | ||
160 | ||
50abfe76 DK |
161 | ; Split the argument list of a lambda expression into required, optional and |
162 | ; rest arguments and also check it is actually valid. | |
163 | ||
164 | (define (split-lambda-arguments loc args) | |
165 | (let iterate ((tail args) | |
166 | (mode 'required) | |
167 | (required '()) | |
168 | (optional '())) | |
169 | (cond | |
170 | ||
171 | ((null? tail) | |
172 | (values (reverse required) (reverse optional) #f)) | |
173 | ||
174 | ((and (eq? mode 'required) | |
175 | (eq? (car tail) '&optional)) | |
176 | (iterate (cdr tail) 'optional required optional)) | |
177 | ||
178 | ((eq? (car tail) '&rest) | |
179 | (if (or (null? (cdr tail)) | |
180 | (not (null? (cddr tail)))) | |
181 | (report-error loc "expected exactly one symbol after &rest") | |
182 | (values (reverse required) (reverse optional) (cadr tail)))) | |
183 | ||
184 | (else | |
185 | (if (not (symbol? (car tail))) | |
186 | (report-error loc "expected symbol in argument list, got" (car tail)) | |
187 | (case mode | |
188 | ((required) (iterate (cdr tail) mode | |
189 | (cons (car tail) required) optional)) | |
190 | ((optional) (iterate (cdr tail) mode | |
191 | required (cons (car tail) optional))) | |
192 | ((else) (error "invalid mode in split-lambda-arguments" mode)))))))) | |
193 | ||
194 | ||
195 | ; Compile a lambda expression. Things get a little complicated because TreeIL | |
196 | ; does not allow optional arguments but only one rest argument, and also the | |
197 | ; rest argument should be nil instead of '() for no values given. Because of | |
198 | ; this, we have to do a little preprocessing to get everything done before the | |
199 | ; real body is called. | |
200 | ; | |
201 | ; (lambda (a &optional b &rest c) body) should become: | |
202 | ; (lambda (a_ . rest_) | |
203 | ; (with-fluids* (list a b c) (list a_ nil nil) | |
204 | ; (lambda () | |
205 | ; (if (not (null? rest_)) | |
206 | ; (begin | |
207 | ; (fluid-set! b (car rest_)) | |
208 | ; (set! rest_ (cdr rest_)) | |
209 | ; (if (not (null? rest_)) | |
210 | ; (fluid-set! c rest_)))) | |
211 | ; body))) | |
212 | ; | |
213 | ; This is formulated quite imperatively, but I think in this case that is quite | |
214 | ; clear and better than creating a lot of nested let's. | |
215 | ||
5d221ca3 | 216 | (define (compile-lambda loc bind args body) |
de9f26b5 DK |
217 | (if (not (list? args)) |
218 | (error "expected list for argument-list" args)) | |
219 | (if (null? body) | |
220 | (error "function body might not be empty")) | |
50abfe76 DK |
221 | (call-with-values |
222 | (lambda () | |
223 | (split-lambda-arguments loc args)) | |
224 | (lambda (required optional rest) | |
50abfe76 DK |
225 | (let ((required-sym (map (lambda (sym) (gensym)) required)) |
226 | (rest-sym (if (or rest (not (null? optional))) (gensym) '()))) | |
cef997e8 DK |
227 | (let ((real-args (append required-sym rest-sym)) |
228 | (locals `(,@required ,@optional ,@(if rest (list rest) '())))) | |
229 | (make-lambda loc | |
230 | real-args real-args '() | |
5d221ca3 DK |
231 | (begin |
232 | (for-each (lambda (sym) | |
233 | (mark-fluid-needed! bind sym value-slot)) | |
234 | locals) | |
cef997e8 DK |
235 | (call-primitive loc 'with-fluids* |
236 | (make-application loc (make-primitive-ref loc 'list) | |
237 | (map (lambda (sym) (make-module-ref loc value-slot sym #t)) | |
238 | locals)) | |
239 | (make-application loc (make-primitive-ref loc 'list) | |
240 | (append (map (lambda (sym) (make-lexical-ref loc sym sym)) | |
241 | required-sym) | |
242 | (map (lambda (sym) (nil-value loc)) | |
243 | (if rest | |
244 | `(,@optional ,rest-sym) | |
245 | optional)))) | |
246 | (make-lambda loc '() '() '() | |
247 | (make-sequence loc | |
5d221ca3 DK |
248 | `(,(process-optionals loc bind optional rest-sym) |
249 | ,(process-rest loc bind rest rest-sym) | |
250 | ,@(map (compiler bind) body)))))))))))) | |
50abfe76 DK |
251 | |
252 | ; Build the code to handle setting of optional arguments that are present | |
253 | ; and updating the rest list. | |
5d221ca3 | 254 | (define (process-optionals loc bind optional rest-sym) |
50abfe76 DK |
255 | (let iterate ((tail optional)) |
256 | (if (null? tail) | |
257 | (make-void loc) | |
258 | (make-conditional loc | |
259 | (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym)) | |
260 | (make-void loc) | |
261 | (make-sequence loc | |
5d221ca3 | 262 | (list (set-variable! loc bind (car tail) value-slot |
50abfe76 DK |
263 | (call-primitive loc 'car |
264 | (make-lexical-ref loc rest-sym rest-sym))) | |
265 | (make-lexical-set loc rest-sym rest-sym | |
266 | (call-primitive loc 'cdr | |
267 | (make-lexical-ref loc rest-sym rest-sym))) | |
268 | (iterate (cdr tail)))))))) | |
269 | ||
270 | ; This builds the code to set the rest variable to nil if it is empty. | |
5d221ca3 | 271 | (define (process-rest loc bind rest rest-sym) |
50abfe76 DK |
272 | (let ((rest-empty (call-primitive loc 'null? |
273 | (make-lexical-ref loc rest-sym rest-sym)))) | |
274 | (cond | |
275 | (rest | |
276 | (make-conditional loc rest-empty | |
277 | (make-void loc) | |
5d221ca3 | 278 | (set-variable! loc bind rest value-slot |
50abfe76 DK |
279 | (make-lexical-ref loc rest-sym rest-sym)))) |
280 | ((not (null? rest-sym)) | |
281 | (make-conditional loc rest-empty | |
282 | (make-void loc) | |
283 | (runtime-error loc "too many arguments and no rest argument"))) | |
284 | (else (make-void loc))))) | |
285 | ||
286 | ||
de9f26b5 DK |
287 | ; Handle the common part of defconst and defvar, that is, checking for a correct |
288 | ; doc string and arguments as well as maybe in the future handling the docstring | |
289 | ; somehow. | |
290 | ||
291 | (define (handle-var-def loc sym doc) | |
292 | (cond | |
293 | ((not (symbol? sym)) (report-error loc "expected symbol, got" sym)) | |
294 | ((> (length doc) 1) (report-error loc "too many arguments to defvar")) | |
295 | ((and (not (null? doc)) (not (string? (car doc)))) | |
296 | (report-error loc "expected string as third argument of defvar, got" | |
297 | (car doc))) | |
298 | ; TODO: Handle doc string if present. | |
299 | (else #t))) | |
300 | ||
301 | ||
74c009da DK |
302 | ; Handle macro bindings. |
303 | ||
304 | (define (is-macro? sym) | |
305 | (module-defined? (resolve-interface macro-slot) sym)) | |
306 | ||
307 | (define (define-macro! loc sym definition) | |
308 | (let ((resolved (resolve-module macro-slot))) | |
309 | (if (is-macro? sym) | |
310 | (report-error loc "macro is already defined" sym) | |
311 | (begin | |
312 | (module-define! resolved sym definition) | |
313 | (module-export! resolved (list sym)))))) | |
314 | ||
315 | (define (get-macro sym) | |
316 | (module-ref (resolve-module macro-slot) sym)) | |
317 | ||
318 | ||
9b5ff6a6 DK |
319 | ; See if a (backquoted) expression contains any unquotes. |
320 | ||
321 | (define (contains-unquotes? expr) | |
322 | (if (pair? expr) | |
323 | (if (or (unquote? (car expr)) (unquote-splicing? (car expr))) | |
324 | #t | |
325 | (or (contains-unquotes? (car expr)) | |
326 | (contains-unquotes? (cdr expr)))) | |
327 | #f)) | |
328 | ||
329 | ||
330 | ; Process a backquoted expression by building up the needed cons/append calls. | |
331 | ; For splicing, it is assumed that the expression spliced in evaluates to a | |
332 | ; list. The emacs manual does not really state either it has to or what to do | |
333 | ; if it does not, but Scheme explicitly forbids it and this seems reasonable | |
334 | ; also for elisp. | |
335 | ||
336 | (define (unquote-cell? expr) | |
337 | (and (list? expr) (= (length expr) 2) (unquote? (car expr)))) | |
338 | (define (unquote-splicing-cell? expr) | |
339 | (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr)))) | |
340 | ||
5d221ca3 | 341 | (define (process-backquote loc bind expr) |
9b5ff6a6 DK |
342 | (if (contains-unquotes? expr) |
343 | (if (pair? expr) | |
344 | (if (or (unquote-cell? expr) (unquote-splicing-cell? expr)) | |
5d221ca3 | 345 | (compile-expr bind (cadr expr)) |
9b5ff6a6 | 346 | (let* ((head (car expr)) |
5d221ca3 | 347 | (processed-tail (process-backquote loc bind (cdr expr))) |
9b5ff6a6 DK |
348 | (head-is-list-2 (and (list? head) (= (length head) 2))) |
349 | (head-unquote (and head-is-list-2 (unquote? (car head)))) | |
350 | (head-unquote-splicing (and head-is-list-2 | |
351 | (unquote-splicing? (car head))))) | |
352 | (if head-unquote-splicing | |
353 | (call-primitive loc 'append | |
5d221ca3 | 354 | (compile-expr bind (cadr head)) processed-tail) |
9b5ff6a6 DK |
355 | (call-primitive loc 'cons |
356 | (if head-unquote | |
5d221ca3 DK |
357 | (compile-expr bind (cadr head)) |
358 | (process-backquote loc bind head)) | |
9b5ff6a6 DK |
359 | processed-tail)))) |
360 | (error "non-pair expression contains unquotes" expr)) | |
361 | (make-const loc expr))) | |
362 | ||
fb66a47a DK |
363 | ; Compile a dolist construct. |
364 | ; This is compiled to something along: | |
365 | ; (with-fluid* iter-var %nil | |
366 | ; (lambda () | |
367 | ; (let iterate ((tail list)) | |
368 | ; (if (null? tail) | |
369 | ; result | |
370 | ; (begin | |
371 | ; (fluid-set! iter-var (car tail)) | |
372 | ; body | |
373 | ; (iterate (cdr tail))))))) | |
374 | ||
5d221ca3 | 375 | (define (compile-dolist loc bind var iter-list result body) |
fb66a47a DK |
376 | (let* ((tailvar (gensym)) |
377 | (iterate (gensym)) | |
378 | (tailref (make-lexical-ref loc tailvar tailvar)) | |
379 | (iterate-func (make-lambda loc `(,tailvar) `(,tailvar) '() | |
380 | (make-conditional loc | |
381 | (call-primitive loc 'null? tailref) | |
5d221ca3 | 382 | (compile-expr bind result) |
fb66a47a | 383 | (make-sequence loc |
5d221ca3 | 384 | `(,(set-variable! loc bind var value-slot |
fb66a47a | 385 | (call-primitive loc 'car tailref)) |
5d221ca3 | 386 | ,@(map (compiler bind) body) |
fb66a47a DK |
387 | ,(make-application loc |
388 | (make-lexical-ref loc iterate iterate) | |
389 | (list (call-primitive loc 'cdr | |
390 | tailref))))))))) | |
5d221ca3 DK |
391 | (mark-fluid-needed! bind var value-slot) |
392 | (call-primitive loc 'with-fluid* | |
393 | (make-module-ref loc value-slot var #t) | |
394 | (nil-value loc) | |
395 | (make-lambda loc '() '() '() | |
396 | (make-letrec loc `(,iterate) `(,iterate) `(,iterate-func) | |
397 | (make-application loc | |
398 | (make-lexical-ref loc iterate iterate) | |
399 | (list (compile-expr bind iter-list)))))))) | |
fb66a47a DK |
400 | |
401 | ||
9b5ff6a6 | 402 | |
51248e6e DK |
403 | ; Compile a symbol expression. This is a variable reference or maybe some |
404 | ; special value like nil. | |
405 | ||
5d221ca3 | 406 | (define (compile-symbol loc bind sym) |
51248e6e | 407 | (case sym |
fdfb36de | 408 | ((nil) (nil-value loc)) |
fdfb36de | 409 | ((t) (t-value loc)) |
5d221ca3 | 410 | (else (reference-with-check loc bind sym value-slot)))) |
51248e6e DK |
411 | |
412 | ||
413 | ; Compile a pair-expression (that is, any structure-like construct). | |
414 | ||
5d221ca3 | 415 | (define (compile-pair loc bind expr) |
51248e6e DK |
416 | (pmatch expr |
417 | ||
418 | ((progn . ,forms) | |
5d221ca3 | 419 | (make-sequence loc (map (compiler bind) forms))) |
51248e6e | 420 | |
fb66a47a DK |
421 | ; I chose to implement prog1 directly (not with macros) so that the |
422 | ; temporary variable used can be a lexical one that is not backed by a fluid | |
423 | ; for better performance. | |
424 | ((prog1 ,form1 . ,forms) | |
425 | (let ((temp (gensym))) | |
5d221ca3 | 426 | (make-let loc `(,temp) `(,temp) `(,(compile-expr bind form1)) |
fb66a47a | 427 | (make-sequence loc |
5d221ca3 | 428 | (append (map (compiler bind) forms) |
fb66a47a DK |
429 | (list (make-lexical-ref loc temp temp))))))) |
430 | ||
51248e6e | 431 | ((if ,condition ,ifclause) |
5d221ca3 DK |
432 | (make-conditional loc (compile-expr bind condition) |
433 | (compile-expr bind ifclause) | |
4530432e | 434 | (nil-value loc))) |
51248e6e | 435 | ((if ,condition ,ifclause ,elseclause) |
5d221ca3 DK |
436 | (make-conditional loc (compile-expr bind condition) |
437 | (compile-expr bind ifclause) | |
438 | (compile-expr bind elseclause))) | |
51248e6e | 439 | ((if ,condition ,ifclause . ,elses) |
5d221ca3 DK |
440 | (make-conditional loc (compile-expr bind condition) |
441 | (compile-expr bind ifclause) | |
442 | (make-sequence loc (map (compiler bind) elses)))) | |
51248e6e | 443 | |
a4316739 DK |
444 | ; For (cond ...) forms, a special case is a (condition) clause without |
445 | ; body. In this case, the value of condition itself should be returned, | |
446 | ; and thus is saved in a local variable for testing and returning, if it | |
447 | ; is found true. | |
51248e6e DK |
448 | ((cond . ,clauses) (guard (and-map (lambda (el) |
449 | (and (list? el) (not (null? el)))) | |
450 | clauses)) | |
451 | (let iterate ((tail clauses)) | |
452 | (if (null? tail) | |
4530432e | 453 | (nil-value loc) |
51248e6e | 454 | (let ((cur (car tail))) |
a4316739 DK |
455 | (if (null? (cdr cur)) |
456 | (let ((var (gensym))) | |
457 | (make-let loc | |
5d221ca3 | 458 | '(condition) `(,var) `(,(compile-expr bind (car cur))) |
a4316739 DK |
459 | (make-conditional loc |
460 | (make-lexical-ref loc 'condition var) | |
461 | (make-lexical-ref loc 'condition var) | |
462 | (iterate (cdr tail))))) | |
463 | (make-conditional loc | |
5d221ca3 DK |
464 | (compile-expr bind (car cur)) |
465 | (make-sequence loc (map (compiler bind) (cdr cur))) | |
a4316739 | 466 | (iterate (cdr tail)))))))) |
51248e6e | 467 | |
fdfb36de | 468 | ((and) (t-value loc)) |
51248e6e DK |
469 | ((and . ,expressions) |
470 | (let iterate ((tail expressions)) | |
471 | (if (null? (cdr tail)) | |
5d221ca3 | 472 | (compile-expr bind (car tail)) |
51248e6e | 473 | (make-conditional loc |
5d221ca3 | 474 | (compile-expr bind (car tail)) |
51248e6e | 475 | (iterate (cdr tail)) |
4530432e | 476 | (nil-value loc))))) |
51248e6e | 477 | |
fdfb36de DK |
478 | ((or . ,expressions) |
479 | (let iterate ((tail expressions)) | |
480 | (if (null? tail) | |
481 | (nil-value loc) | |
482 | (let ((var (gensym))) | |
483 | (make-let loc | |
5d221ca3 | 484 | '(condition) `(,var) `(,(compile-expr bind (car tail))) |
fdfb36de DK |
485 | (make-conditional loc |
486 | (make-lexical-ref loc 'condition var) | |
487 | (make-lexical-ref loc 'condition var) | |
488 | (iterate (cdr tail)))))))) | |
489 | ||
de9f26b5 DK |
490 | ((defconst ,sym ,value . ,doc) |
491 | (if (handle-var-def loc sym doc) | |
492 | (make-sequence loc | |
5d221ca3 | 493 | (list (set-variable! loc bind sym value-slot (compile-expr bind value)) |
de9f26b5 DK |
494 | (make-const loc sym))))) |
495 | ||
496 | ((defvar ,sym) (make-const loc sym)) | |
497 | ((defvar ,sym ,value . ,doc) | |
498 | (if (handle-var-def loc sym doc) | |
499 | (make-sequence loc | |
500 | (list (make-conditional loc | |
501 | (call-primitive loc 'eq? | |
502 | (make-module-ref loc runtime 'void #t) | |
5d221ca3 DK |
503 | (reference-variable loc bind sym value-slot)) |
504 | (set-variable! loc bind sym value-slot | |
505 | (compile-expr bind value)) | |
de9f26b5 DK |
506 | (make-void loc)) |
507 | (make-const loc sym))))) | |
508 | ||
344927c3 DK |
509 | ; Build a set form for possibly multiple values. The code is not formulated |
510 | ; tail recursive because it is clearer this way and large lists of symbol | |
511 | ; expression pairs are very unlikely. | |
570c12ac | 512 | ((setq . ,args) (guard (not (null? args))) |
344927c3 DK |
513 | (make-sequence loc |
514 | (let iterate ((tail args)) | |
570c12ac DK |
515 | (let ((sym (car tail)) |
516 | (tailtail (cdr tail))) | |
517 | (if (not (symbol? sym)) | |
518 | (report-error loc "expected symbol in setq") | |
519 | (if (null? tailtail) | |
520 | (report-error loc "missing value for symbol in setq" sym) | |
5d221ca3 DK |
521 | (let* ((val (compile-expr bind (car tailtail))) |
522 | (op (set-variable! loc bind sym value-slot val))) | |
570c12ac DK |
523 | (if (null? (cdr tailtail)) |
524 | (let* ((temp (gensym)) | |
525 | (ref (make-lexical-ref loc temp temp))) | |
526 | (list (make-let loc `(,temp) `(,temp) `(,val) | |
527 | (make-sequence loc | |
5d221ca3 | 528 | (list (set-variable! loc bind sym value-slot ref) |
570c12ac | 529 | ref))))) |
5d221ca3 | 530 | (cons (set-variable! loc bind sym value-slot val) |
570c12ac | 531 | (iterate (cdr tailtail))))))))))) |
344927c3 | 532 | |
3a4b8635 | 533 | ; Let is done with a single call to with-fluids* binding them locally to new |
5d221ca3 | 534 | ; values all "at once". |
3a4b8635 DK |
535 | ((let ,bindings . ,body) (guard (and (list? bindings) |
536 | (list? body) | |
537 | (not (null? bindings)) | |
538 | (not (null? body)))) | |
5d221ca3 DK |
539 | (let ((let-bind (process-let-bindings loc bindings))) |
540 | (begin | |
541 | (for-each (lambda (sym) | |
542 | (mark-fluid-needed! bind sym value-slot)) | |
543 | (map car let-bind)) | |
f28de791 DK |
544 | (call-primitive loc 'with-fluids* |
545 | (make-application loc (make-primitive-ref loc 'list) | |
546 | (map (lambda (el) | |
5d221ca3 DK |
547 | (make-module-ref loc value-slot (car el) #t)) |
548 | let-bind)) | |
f28de791 DK |
549 | (make-application loc (make-primitive-ref loc 'list) |
550 | (map (lambda (el) | |
5d221ca3 DK |
551 | (compile-expr bind (cdr el))) |
552 | let-bind)) | |
f28de791 | 553 | (make-lambda loc '() '() '() |
5d221ca3 | 554 | (make-sequence loc (map (compiler bind) body))))))) |
3a4b8635 DK |
555 | |
556 | ; Let* is compiled to a cascaded set of with-fluid* for each binding in turn | |
557 | ; so that each one already sees the preceding bindings. | |
558 | ((let* ,bindings . ,body) (guard (and (list? bindings) | |
559 | (list? body) | |
560 | (not (null? bindings)) | |
561 | (not (null? body)))) | |
5d221ca3 DK |
562 | (let ((let-bind (process-let-bindings loc bindings))) |
563 | (begin | |
564 | (for-each (lambda (sym) | |
565 | (mark-fluid-needed! bind sym value-slot)) | |
566 | (map car let-bind)) | |
567 | (let iterate ((tail let-bind)) | |
f28de791 | 568 | (if (null? tail) |
5d221ca3 | 569 | (make-sequence loc (map (compiler bind) body)) |
f28de791 DK |
570 | (call-primitive loc 'with-fluid* |
571 | (make-module-ref loc value-slot (caar tail) #t) | |
5d221ca3 | 572 | (compile-expr bind (cdar tail)) |
f28de791 | 573 | (make-lambda loc '() '() '() (iterate (cdr tail))))))))) |
3a4b8635 | 574 | |
d221c18b DK |
575 | ; A while construct is transformed into a tail-recursive loop like this: |
576 | ; (letrec ((iterate (lambda () | |
577 | ; (if condition | |
578 | ; (begin body | |
579 | ; (iterate)) | |
580 | ; %nil)))) | |
581 | ; (iterate)) | |
582 | ((while ,condition . ,body) | |
583 | (let* ((itersym (gensym)) | |
5d221ca3 | 584 | (compiled-body (map (compiler bind) body)) |
d221c18b DK |
585 | (iter-call (make-application loc |
586 | (make-lexical-ref loc 'iterate itersym) | |
587 | (list))) | |
588 | (full-body (make-sequence loc | |
cef997e8 | 589 | `(,@compiled-body ,iter-call))) |
d221c18b | 590 | (lambda-body (make-conditional loc |
5d221ca3 | 591 | (compile-expr bind condition) |
d221c18b DK |
592 | full-body |
593 | (nil-value loc))) | |
594 | (iter-thunk (make-lambda loc '() '() '() lambda-body))) | |
595 | (make-letrec loc '(iterate) (list itersym) (list iter-thunk) | |
596 | iter-call))) | |
597 | ||
fb66a47a DK |
598 | ; dolist is treated here rather than as macro because it can take advantage |
599 | ; of a non-fluid-based variable. | |
600 | ((dolist (,var ,iter-list) . ,body) (guard (symbol? var)) | |
5d221ca3 | 601 | (compile-dolist loc bind var iter-list 'nil body)) |
fb66a47a | 602 | ((dolist (,var ,iter-list ,result) . ,body) (guard (symbol? var)) |
5d221ca3 | 603 | (compile-dolist loc bind var iter-list result body)) |
fb66a47a | 604 | |
35b2e41d DK |
605 | ; catch and throw can mainly be implemented directly using Guile's |
606 | ; primitives for exceptions, the only difficulty is that the keys used | |
607 | ; within Guile must be symbols, while elisp allows any value and checks | |
608 | ; for matches using eq (eq?). We handle this by using always #t as key | |
609 | ; for the Guile primitives and check for matches inside the handler; if | |
610 | ; the elisp keys are not eq?, we rethrow the exception. | |
611 | ||
612 | ((catch ,tag . ,body) (guard (not (null? body))) | |
613 | (let* ((tag-value (gensym)) | |
614 | (tag-ref (make-lexical-ref loc tag-value tag-value))) | |
615 | (make-let loc `(,tag-value) `(,tag-value) `(,(compile-expr bind tag)) | |
616 | (call-primitive loc 'catch | |
617 | (make-const loc #t) | |
618 | (make-lambda loc '() '() '() | |
619 | (make-sequence loc (map (compiler bind) body))) | |
620 | (let* ((dummy-key (gensym)) | |
621 | (dummy-ref (make-lexical-ref loc dummy-key dummy-key)) | |
622 | (elisp-key (gensym)) | |
623 | (key-ref (make-lexical-ref loc elisp-key elisp-key)) | |
624 | (value (gensym)) | |
625 | (value-ref (make-lexical-ref loc value value)) | |
626 | (arglist `(,dummy-key ,elisp-key ,value))) | |
627 | (make-lambda loc arglist arglist '() | |
628 | (make-conditional loc | |
629 | (call-primitive loc 'eq? key-ref tag-ref) | |
630 | value-ref | |
631 | (call-primitive loc 'throw | |
632 | dummy-ref key-ref value-ref)))))))) | |
633 | ||
634 | ((throw ,tag ,value) | |
635 | (call-primitive loc 'throw | |
636 | (make-const loc 'elisp-exception) | |
637 | (compile-expr bind tag) | |
638 | (compile-expr bind value))) | |
639 | ||
50abfe76 DK |
640 | ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression |
641 | ; that should be compiled. | |
de9f26b5 | 642 | ((lambda ,args . ,body) |
5d221ca3 | 643 | (compile-lambda loc bind args body)) |
de9f26b5 | 644 | ((function (lambda ,args . ,body)) |
5d221ca3 | 645 | (compile-lambda loc bind args body)) |
50abfe76 | 646 | |
de9f26b5 DK |
647 | ; Build a lambda and also assign it to the function cell of some symbol. |
648 | ((defun ,name ,args . ,body) | |
649 | (if (not (symbol? name)) | |
650 | (error "expected symbol as function name" name) | |
651 | (make-sequence loc | |
5d221ca3 DK |
652 | (list (set-variable! loc bind name function-slot |
653 | (compile-lambda loc bind args body)) | |
de9f26b5 DK |
654 | (make-const loc name))))) |
655 | ||
74c009da DK |
656 | ; Define a macro (this is done directly at compile-time!). |
657 | ; FIXME: Recursive macros don't work! | |
658 | ((defmacro ,name ,args . ,body) | |
659 | (if (not (symbol? name)) | |
660 | (error "expected symbol as macro name" name) | |
5d221ca3 | 661 | (let* ((tree-il (compile-lambda loc (make-bindings) args body)) |
74c009da DK |
662 | (object (compile tree-il #:from 'tree-il #:to 'value))) |
663 | (define-macro! loc name object) | |
664 | (make-const loc name)))) | |
665 | ||
9b5ff6a6 | 666 | ((,backq ,val) (guard (backquote? backq)) |
5d221ca3 | 667 | (process-backquote loc bind val)) |
9b5ff6a6 DK |
668 | |
669 | ; XXX: Why do we need 'quote here instead of quote? | |
1e018f6c DK |
670 | (('quote ,val) |
671 | (make-const loc val)) | |
672 | ||
74c009da DK |
673 | ; Macro calls are simply expanded and recursively compiled. |
674 | ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro))) | |
675 | (let ((expander (get-macro macro))) | |
5d221ca3 | 676 | (compile-expr bind (apply expander args)))) |
74c009da | 677 | |
cef997e8 DK |
678 | ; Function calls using (function args) standard notation; here, we have to |
679 | ; take the function value of a symbol if it is one. It seems that functions | |
680 | ; in form of uncompiled lists are not supported in this syntax, so we don't | |
681 | ; have to care for them. | |
682 | ((,func . ,args) | |
683 | (make-application loc | |
684 | (if (symbol? func) | |
5d221ca3 DK |
685 | (reference-with-check loc bind func function-slot) |
686 | (compile-expr bind func)) | |
687 | (map (compiler bind) args))) | |
cef997e8 | 688 | |
51248e6e | 689 | (else |
344927c3 | 690 | (report-error loc "unrecognized elisp" expr)))) |
51248e6e DK |
691 | |
692 | ||
35b2e41d DK |
693 | ; Compile a single expression to TreeIL and create a closure over a bindings |
694 | ; data structure for easy map'ing of compile-expr. | |
51248e6e | 695 | |
5d221ca3 | 696 | (define (compile-expr bind expr) |
51248e6e DK |
697 | (let ((loc (location expr))) |
698 | (cond | |
699 | ((symbol? expr) | |
5d221ca3 | 700 | (compile-symbol loc bind expr)) |
51248e6e | 701 | ((pair? expr) |
5d221ca3 | 702 | (compile-pair loc bind expr)) |
51248e6e DK |
703 | (else (make-const loc expr))))) |
704 | ||
5d221ca3 DK |
705 | (define (compiler bind) |
706 | (lambda (expr) | |
707 | (compile-expr bind expr))) | |
708 | ||
51248e6e DK |
709 | |
710 | ; Entry point for compilation to TreeIL. | |
35b2e41d DK |
711 | ; This creates the bindings data structure, and after compiling the main |
712 | ; expression we need to make sure all fluids for symbols used during the | |
713 | ; compilation are created using the generate-ensure-fluid function. | |
51248e6e DK |
714 | |
715 | (define (compile-tree-il expr env opts) | |
716 | (values | |
5d221ca3 DK |
717 | (let* ((bind (make-bindings)) |
718 | (loc (location expr)) | |
719 | (compiled (compile-expr bind expr))) | |
720 | (make-sequence loc | |
721 | `(,@(map-fluids-needed bind (lambda (mod sym) | |
722 | (generate-ensure-fluid loc sym mod))) | |
723 | ,compiled))) | |
51248e6e DK |
724 | env |
725 | env)) |