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 | ||
a90d9c85 DK |
30 | ; Certain common parameters (like the bindings data structure or compiler |
31 | ; options) are not always passed around but accessed using fluids. | |
32 | ||
33 | ; The bindings data structure to keep track of symbol binding related data. | |
34 | (define bindings-data (make-fluid)) | |
35 | ||
36 | ; Store for which symbols (or all/none) void checks are disabled. | |
a0899974 | 37 | (define disable-void-check (make-fluid)) |
a90d9c85 DK |
38 | |
39 | ||
51248e6e DK |
40 | ; Find the source properties of some parsed expression if there are any |
41 | ; associated with it. | |
42 | ||
43 | (define (location x) | |
44 | (and (pair? x) | |
45 | (let ((props (source-properties x))) | |
46 | (and (not (null? props)) | |
47 | props)))) | |
48 | ||
49 | ||
de9f26b5 | 50 | ; Values to use for Elisp's nil and t. |
4530432e | 51 | |
de9f26b5 DK |
52 | (define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value))) |
53 | (define (t-value loc) (make-const loc (@ (language elisp runtime) t-value))) | |
4530432e DK |
54 | |
55 | ||
344927c3 DK |
56 | ; Modules that contain the value and function slot bindings. |
57 | ||
58 | (define runtime '(language elisp runtime)) | |
74c009da | 59 | (define macro-slot '(language elisp runtime macro-slot)) |
37099846 DK |
60 | (define value-slot (@ (language elisp runtime) value-slot-module)) |
61 | (define function-slot (@ (language elisp runtime) function-slot-module)) | |
344927c3 DK |
62 | |
63 | ||
9b5ff6a6 DK |
64 | ; The backquoting works the same as quasiquotes in Scheme, but the forms are |
65 | ; named differently; to make easy adaptions, we define these predicates checking | |
66 | ; for a symbol being the car of an unquote/unquote-splicing/backquote form. | |
67 | ||
68 | ; FIXME: Remove the quasiquote/unquote/unquote-splicing symbols when real elisp | |
69 | ; reader is there. | |
70 | ||
71 | (define (backquote? sym) | |
72 | (and (symbol? sym) (or (eq? sym 'quasiquote) | |
73 | (eq? sym '\`)))) | |
74 | ||
75 | (define (unquote? sym) | |
76 | (and (symbol? sym) (or (eq? sym 'unquote) | |
77 | (eq? sym '\,)))) | |
78 | ||
79 | (define (unquote-splicing? sym) | |
80 | (and (symbol? sym) (or (eq? sym 'unquote-splicing) | |
81 | (eq? sym '\,@)))) | |
82 | ||
83 | ||
50abfe76 DK |
84 | ; Build a call to a primitive procedure nicely. |
85 | ||
86 | (define (call-primitive loc sym . args) | |
87 | (make-application loc (make-primitive-ref loc sym) args)) | |
88 | ||
89 | ||
90 | ; Error reporting routine for syntax/compilation problems or build code for | |
91 | ; a runtime-error output. | |
344927c3 DK |
92 | |
93 | (define (report-error loc . args) | |
94 | (apply error args)) | |
95 | ||
50abfe76 DK |
96 | (define (runtime-error loc msg . args) |
97 | (make-application loc (make-primitive-ref loc 'error) | |
98 | (cons (make-const loc msg) args))) | |
99 | ||
344927c3 DK |
100 | |
101 | ; Generate code to ensure a fluid is there for further use of a given symbol. | |
5d221ca3 DK |
102 | ; In general during the compilation, fluids needed are only tracked with the |
103 | ; bindings data structure. Afterwards, however, for all those needed symbols | |
104 | ; the fluids are really generated with this routine. | |
344927c3 | 105 | |
5d221ca3 | 106 | (define (generate-ensure-fluid loc sym module) |
37099846 DK |
107 | (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t) |
108 | (list (make-const loc module) | |
109 | (make-const loc sym)))) | |
f28de791 | 110 | |
344927c3 | 111 | |
a0899974 DK |
112 | ; See if we should do a void-check for a given variable. That means, check |
113 | ; that this check is not disabled via the compiler options for this symbol. | |
f3df67e2 | 114 | ; Disabling of void check is only done for the value-slot module! |
a0899974 | 115 | |
f3df67e2 | 116 | (define (want-void-check? sym module) |
a0899974 | 117 | (let ((disabled (fluid-ref disable-void-check))) |
f3df67e2 DK |
118 | (or (not (equal? module value-slot)) |
119 | (and (not (eq? disabled 'all)) | |
120 | (not (memq sym disabled)))))) | |
a0899974 DK |
121 | |
122 | ||
a6a5cf03 DK |
123 | ; Handle access to a variable (reference/setting) correctly depending on |
124 | ; whether it is currently lexically or dynamically bound. | |
125 | ; lexical access is done only for references to the value-slot module! | |
126 | ||
127 | (define (access-variable loc sym module handle-lexical handle-dynamic) | |
128 | (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym))) | |
129 | (if (and lexical (equal? module value-slot)) | |
130 | (handle-lexical lexical) | |
131 | (handle-dynamic)))) | |
132 | ||
133 | ||
134 | ; Generate code to reference a variable. | |
135 | ; For references in the value-slot module, we may want to generate a lexical | |
136 | ; reference instead if the variable has a lexical binding. | |
344927c3 | 137 | |
a90d9c85 | 138 | (define (reference-variable loc sym module) |
a6a5cf03 DK |
139 | (access-variable loc sym module |
140 | (lambda (lexical) | |
141 | (make-lexical-ref loc lexical lexical)) | |
142 | (lambda () | |
143 | (mark-fluid-needed! (fluid-ref bindings-data) sym module) | |
144 | (call-primitive loc 'fluid-ref | |
145 | (make-module-ref loc module sym #t))))) | |
344927c3 DK |
146 | |
147 | ||
148 | ; Reference a variable and error if the value is void. | |
149 | ||
a90d9c85 | 150 | (define (reference-with-check loc sym module) |
f3df67e2 | 151 | (if (want-void-check? sym module) |
a0899974 DK |
152 | (let ((var (gensym))) |
153 | (make-let loc '(value) `(,var) `(,(reference-variable loc sym module)) | |
154 | (make-conditional loc | |
155 | (call-primitive loc 'eq? | |
156 | (make-module-ref loc runtime 'void #t) | |
157 | (make-lexical-ref loc 'value var)) | |
158 | (runtime-error loc "variable is void:" (make-const loc sym)) | |
159 | (make-lexical-ref loc 'value var)))) | |
160 | (reference-variable loc sym module))) | |
344927c3 DK |
161 | |
162 | ||
a6a5cf03 DK |
163 | ; Generate code to set a variable. |
164 | ; Just as with reference-variable, in case of a reference to value-slot, | |
165 | ; we want to generate a lexical set when the variable has a lexical binding. | |
344927c3 | 166 | |
a90d9c85 | 167 | (define (set-variable! loc sym module value) |
a6a5cf03 DK |
168 | (access-variable loc sym module |
169 | (lambda (lexical) | |
170 | (make-lexical-set loc lexical lexical value)) | |
171 | (lambda () | |
172 | (mark-fluid-needed! (fluid-ref bindings-data) sym module) | |
173 | (call-primitive loc 'fluid-set! | |
174 | (make-module-ref loc module sym #t) | |
175 | value)))) | |
344927c3 DK |
176 | |
177 | ||
3a4b8635 DK |
178 | ; Process the bindings part of a let or let* expression; that is, check for |
179 | ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...). | |
180 | ||
181 | (define (process-let-bindings loc bindings) | |
182 | (map (lambda (b) | |
183 | (if (symbol? b) | |
184 | (cons b 'nil) | |
185 | (if (or (not (list? b)) | |
186 | (not (= (length b) 2))) | |
187 | (report-error loc "expected symbol or list of 2 elements in let") | |
188 | (if (not (symbol? (car b))) | |
189 | (report-error loc "expected symbol in let") | |
190 | (cons (car b) (cadr b)))))) | |
191 | bindings)) | |
192 | ||
193 | ||
a6a5cf03 DK |
194 | ; Split the let bindings into a list to be done lexically and one dynamically. |
195 | ; A symbol will be bound lexically if and only if: | |
196 | ; We're processing a lexical-let (i.e. module is 'lexical), OR | |
197 | ; we're processing a value-slot binding AND | |
198 | ; the symbol is already lexically bound. | |
199 | ||
200 | (define (bind-lexically? sym module) | |
201 | (or (eq? module 'lexical) | |
202 | (and (equal? module value-slot) | |
203 | (get-lexical-binding (fluid-ref bindings-data) sym)))) | |
204 | ||
205 | (define (split-let-bindings bindings module) | |
206 | (let iterate ((tail bindings) | |
207 | (lexical '()) | |
208 | (dynamic '())) | |
209 | (if (null? tail) | |
210 | (values (reverse lexical) (reverse dynamic)) | |
211 | (if (bind-lexically? (caar tail) module) | |
212 | (iterate (cdr tail) (cons (car tail) lexical) dynamic) | |
213 | (iterate (cdr tail) lexical (cons (car tail) dynamic)))))) | |
214 | ||
215 | ||
216 | ; Compile let and let* expressions. The code here is used both for let/let* | |
217 | ; and flet/flet*, just with a different bindings module. | |
218 | ; | |
219 | ; A special module value 'lexical means that we're doing a lexical-let instead | |
220 | ; and the bindings should not be safed to fluids at all but be done with the | |
221 | ; lexical framework instead. | |
222 | ||
223 | ; Let is done with a single call to with-fluids* binding them locally to new | |
224 | ; values all "at once". If there is at least one variable to bind lexically | |
225 | ; among the bindings, we first do a let for all of them to evaluate all | |
226 | ; values before any bindings take place, and then call with-fluids* for the | |
227 | ; variables to bind dynamically. | |
228 | (define (generate-let loc module bindings body) | |
229 | (let ((bind (process-let-bindings loc bindings))) | |
230 | (call-with-values | |
231 | (lambda () | |
232 | (split-let-bindings bind module)) | |
233 | (lambda (lexical dynamic) | |
234 | (for-each (lambda (sym) | |
235 | (mark-fluid-needed! (fluid-ref bindings-data) sym module)) | |
236 | (map car dynamic)) | |
237 | (let ((fluids (make-application loc (make-primitive-ref loc 'list) | |
238 | (map (lambda (el) | |
239 | (make-module-ref loc module (car el) #t)) | |
240 | dynamic))) | |
241 | (make-values (lambda (for) | |
242 | (map (lambda (el) | |
243 | (compile-expr (cdr el))) | |
244 | for))) | |
245 | (make-body (lambda () | |
246 | (make-sequence loc (map compile-expr body))))) | |
247 | (if (null? lexical) | |
248 | (call-primitive loc 'with-fluids* | |
249 | fluids | |
250 | (make-application loc (make-primitive-ref loc 'list) | |
251 | (make-values dynamic)) | |
252 | (make-lambda loc '() '() '() (make-body))) | |
253 | (let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) | |
254 | (dynamic-syms (map (lambda (el) (gensym)) dynamic)) | |
255 | (all-syms (append lexical-syms dynamic-syms)) | |
256 | (vals (append (make-values lexical) (make-values dynamic)))) | |
257 | (make-let loc all-syms all-syms vals | |
258 | (with-lexical-bindings (fluid-ref bindings-data) | |
259 | (map car lexical) lexical-syms | |
260 | (lambda () | |
261 | (if (null? dynamic) | |
262 | (make-body) | |
263 | (call-primitive loc 'with-fluids* | |
264 | fluids | |
265 | (make-application loc (make-primitive-ref loc 'list) | |
266 | (map (lambda (sym) (make-lexical-ref loc sym sym)) | |
267 | dynamic-syms)) | |
268 | (make-lambda loc '() '() '() (make-body)))))))))))))) | |
269 | ||
270 | ||
271 | ; Let* is compiled to a cascaded set of "small lets" for each binding in turn | |
272 | ; so that each one already sees the preceding bindings. | |
273 | (define (generate-let* loc module bindings body) | |
274 | (let ((bind (process-let-bindings loc bindings))) | |
275 | (begin | |
276 | (for-each (lambda (sym) | |
277 | (if (not (bind-lexically? sym module)) | |
278 | (mark-fluid-needed! (fluid-ref bindings-data) sym module))) | |
279 | (map car bind)) | |
280 | (let iterate ((tail bind)) | |
281 | (if (null? tail) | |
282 | (make-sequence loc (map compile-expr body)) | |
283 | (let ((sym (caar tail)) | |
284 | (value (compile-expr (cdar tail)))) | |
285 | (if (bind-lexically? sym module) | |
286 | (let ((target (gensym))) | |
287 | (make-let loc `(,target) `(,target) `(,value) | |
288 | (with-lexical-bindings (fluid-ref bindings-data) | |
289 | `(,sym) `(,target) | |
290 | (lambda () | |
291 | (iterate (cdr tail)))))) | |
292 | (call-primitive loc 'with-fluid* | |
293 | (make-module-ref loc module (caar tail) #t) value | |
294 | (make-lambda loc '() '() '() (iterate (cdr tail))))))))))) | |
295 | ||
296 | ||
50abfe76 DK |
297 | ; Split the argument list of a lambda expression into required, optional and |
298 | ; rest arguments and also check it is actually valid. | |
299 | ||
300 | (define (split-lambda-arguments loc args) | |
301 | (let iterate ((tail args) | |
302 | (mode 'required) | |
303 | (required '()) | |
304 | (optional '())) | |
305 | (cond | |
306 | ||
307 | ((null? tail) | |
308 | (values (reverse required) (reverse optional) #f)) | |
309 | ||
310 | ((and (eq? mode 'required) | |
311 | (eq? (car tail) '&optional)) | |
312 | (iterate (cdr tail) 'optional required optional)) | |
313 | ||
314 | ((eq? (car tail) '&rest) | |
315 | (if (or (null? (cdr tail)) | |
316 | (not (null? (cddr tail)))) | |
317 | (report-error loc "expected exactly one symbol after &rest") | |
318 | (values (reverse required) (reverse optional) (cadr tail)))) | |
319 | ||
320 | (else | |
321 | (if (not (symbol? (car tail))) | |
322 | (report-error loc "expected symbol in argument list, got" (car tail)) | |
323 | (case mode | |
324 | ((required) (iterate (cdr tail) mode | |
325 | (cons (car tail) required) optional)) | |
326 | ((optional) (iterate (cdr tail) mode | |
327 | required (cons (car tail) optional))) | |
328 | ((else) (error "invalid mode in split-lambda-arguments" mode)))))))) | |
329 | ||
330 | ||
331 | ; Compile a lambda expression. Things get a little complicated because TreeIL | |
332 | ; does not allow optional arguments but only one rest argument, and also the | |
333 | ; rest argument should be nil instead of '() for no values given. Because of | |
334 | ; this, we have to do a little preprocessing to get everything done before the | |
335 | ; real body is called. | |
336 | ; | |
337 | ; (lambda (a &optional b &rest c) body) should become: | |
338 | ; (lambda (a_ . rest_) | |
339 | ; (with-fluids* (list a b c) (list a_ nil nil) | |
340 | ; (lambda () | |
341 | ; (if (not (null? rest_)) | |
342 | ; (begin | |
343 | ; (fluid-set! b (car rest_)) | |
344 | ; (set! rest_ (cdr rest_)) | |
345 | ; (if (not (null? rest_)) | |
346 | ; (fluid-set! c rest_)))) | |
347 | ; body))) | |
348 | ; | |
a6a5cf03 | 349 | ; This is formulated very imperatively, but I think in this case that is quite |
50abfe76 | 350 | ; clear and better than creating a lot of nested let's. |
a6a5cf03 DK |
351 | ; |
352 | ; Another thing we have to be aware of is that lambda arguments are always | |
353 | ; dynamically bound, even when a lexical binding is in tact for a symbol. | |
50abfe76 | 354 | |
a90d9c85 | 355 | (define (compile-lambda loc args body) |
de9f26b5 DK |
356 | (if (not (list? args)) |
357 | (error "expected list for argument-list" args)) | |
358 | (if (null? body) | |
359 | (error "function body might not be empty")) | |
a6a5cf03 | 360 | (with-dynamic-bindings (fluid-ref bindings-data) args |
50abfe76 | 361 | (lambda () |
a6a5cf03 DK |
362 | (call-with-values |
363 | (lambda () | |
364 | (split-lambda-arguments loc args)) | |
365 | (lambda (required optional rest) | |
366 | (let ((required-sym (map (lambda (sym) (gensym)) required)) | |
367 | (rest-sym (if (or rest (not (null? optional))) (gensym) '()))) | |
368 | (let ((real-args (append required-sym rest-sym)) | |
369 | (locals `(,@required ,@optional ,@(if rest (list rest) '())))) | |
370 | (make-lambda loc | |
371 | real-args real-args '() | |
372 | (begin | |
373 | (for-each (lambda (sym) | |
374 | (mark-fluid-needed! (fluid-ref bindings-data) | |
375 | sym value-slot)) | |
376 | locals) | |
377 | (call-primitive loc 'with-fluids* | |
378 | (make-application loc (make-primitive-ref loc 'list) | |
379 | (map (lambda (sym) | |
380 | (make-module-ref loc value-slot sym #t)) | |
381 | locals)) | |
382 | (make-application loc (make-primitive-ref loc 'list) | |
383 | (append (map (lambda (sym) (make-lexical-ref loc sym sym)) | |
384 | required-sym) | |
385 | (map (lambda (sym) (nil-value loc)) | |
386 | (if rest | |
387 | `(,@optional ,rest-sym) | |
388 | optional)))) | |
389 | (make-lambda loc '() '() '() | |
390 | (make-sequence loc | |
391 | `(,(process-optionals loc optional rest-sym) | |
392 | ,(process-rest loc rest rest-sym) | |
393 | ,@(map compile-expr body)))))))))))))) | |
50abfe76 DK |
394 | |
395 | ; Build the code to handle setting of optional arguments that are present | |
396 | ; and updating the rest list. | |
a90d9c85 | 397 | (define (process-optionals loc optional rest-sym) |
50abfe76 DK |
398 | (let iterate ((tail optional)) |
399 | (if (null? tail) | |
400 | (make-void loc) | |
401 | (make-conditional loc | |
402 | (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym)) | |
403 | (make-void loc) | |
404 | (make-sequence loc | |
a90d9c85 | 405 | (list (set-variable! loc (car tail) value-slot |
50abfe76 DK |
406 | (call-primitive loc 'car |
407 | (make-lexical-ref loc rest-sym rest-sym))) | |
408 | (make-lexical-set loc rest-sym rest-sym | |
409 | (call-primitive loc 'cdr | |
410 | (make-lexical-ref loc rest-sym rest-sym))) | |
411 | (iterate (cdr tail)))))))) | |
412 | ||
413 | ; This builds the code to set the rest variable to nil if it is empty. | |
a90d9c85 | 414 | (define (process-rest loc rest rest-sym) |
50abfe76 DK |
415 | (let ((rest-empty (call-primitive loc 'null? |
416 | (make-lexical-ref loc rest-sym rest-sym)))) | |
417 | (cond | |
418 | (rest | |
419 | (make-conditional loc rest-empty | |
420 | (make-void loc) | |
a90d9c85 | 421 | (set-variable! loc rest value-slot |
50abfe76 DK |
422 | (make-lexical-ref loc rest-sym rest-sym)))) |
423 | ((not (null? rest-sym)) | |
424 | (make-conditional loc rest-empty | |
425 | (make-void loc) | |
426 | (runtime-error loc "too many arguments and no rest argument"))) | |
427 | (else (make-void loc))))) | |
428 | ||
429 | ||
de9f26b5 DK |
430 | ; Handle the common part of defconst and defvar, that is, checking for a correct |
431 | ; doc string and arguments as well as maybe in the future handling the docstring | |
432 | ; somehow. | |
433 | ||
434 | (define (handle-var-def loc sym doc) | |
435 | (cond | |
436 | ((not (symbol? sym)) (report-error loc "expected symbol, got" sym)) | |
437 | ((> (length doc) 1) (report-error loc "too many arguments to defvar")) | |
438 | ((and (not (null? doc)) (not (string? (car doc)))) | |
439 | (report-error loc "expected string as third argument of defvar, got" | |
440 | (car doc))) | |
441 | ; TODO: Handle doc string if present. | |
442 | (else #t))) | |
443 | ||
444 | ||
74c009da DK |
445 | ; Handle macro bindings. |
446 | ||
447 | (define (is-macro? sym) | |
448 | (module-defined? (resolve-interface macro-slot) sym)) | |
449 | ||
450 | (define (define-macro! loc sym definition) | |
451 | (let ((resolved (resolve-module macro-slot))) | |
452 | (if (is-macro? sym) | |
453 | (report-error loc "macro is already defined" sym) | |
454 | (begin | |
455 | (module-define! resolved sym definition) | |
456 | (module-export! resolved (list sym)))))) | |
457 | ||
458 | (define (get-macro sym) | |
459 | (module-ref (resolve-module macro-slot) sym)) | |
460 | ||
461 | ||
9b5ff6a6 DK |
462 | ; See if a (backquoted) expression contains any unquotes. |
463 | ||
464 | (define (contains-unquotes? expr) | |
465 | (if (pair? expr) | |
466 | (if (or (unquote? (car expr)) (unquote-splicing? (car expr))) | |
467 | #t | |
468 | (or (contains-unquotes? (car expr)) | |
469 | (contains-unquotes? (cdr expr)))) | |
470 | #f)) | |
471 | ||
472 | ||
473 | ; Process a backquoted expression by building up the needed cons/append calls. | |
474 | ; For splicing, it is assumed that the expression spliced in evaluates to a | |
475 | ; list. The emacs manual does not really state either it has to or what to do | |
476 | ; if it does not, but Scheme explicitly forbids it and this seems reasonable | |
477 | ; also for elisp. | |
478 | ||
479 | (define (unquote-cell? expr) | |
480 | (and (list? expr) (= (length expr) 2) (unquote? (car expr)))) | |
481 | (define (unquote-splicing-cell? expr) | |
482 | (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr)))) | |
483 | ||
a90d9c85 | 484 | (define (process-backquote loc expr) |
9b5ff6a6 DK |
485 | (if (contains-unquotes? expr) |
486 | (if (pair? expr) | |
487 | (if (or (unquote-cell? expr) (unquote-splicing-cell? expr)) | |
a90d9c85 | 488 | (compile-expr (cadr expr)) |
9b5ff6a6 | 489 | (let* ((head (car expr)) |
a90d9c85 | 490 | (processed-tail (process-backquote loc (cdr expr))) |
9b5ff6a6 DK |
491 | (head-is-list-2 (and (list? head) (= (length head) 2))) |
492 | (head-unquote (and head-is-list-2 (unquote? (car head)))) | |
493 | (head-unquote-splicing (and head-is-list-2 | |
494 | (unquote-splicing? (car head))))) | |
495 | (if head-unquote-splicing | |
496 | (call-primitive loc 'append | |
a90d9c85 | 497 | (compile-expr (cadr head)) processed-tail) |
9b5ff6a6 DK |
498 | (call-primitive loc 'cons |
499 | (if head-unquote | |
a90d9c85 DK |
500 | (compile-expr (cadr head)) |
501 | (process-backquote loc head)) | |
9b5ff6a6 DK |
502 | processed-tail)))) |
503 | (error "non-pair expression contains unquotes" expr)) | |
504 | (make-const loc expr))) | |
505 | ||
e8f18b3f | 506 | |
fb66a47a DK |
507 | ; Compile a dolist construct. |
508 | ; This is compiled to something along: | |
509 | ; (with-fluid* iter-var %nil | |
510 | ; (lambda () | |
511 | ; (let iterate ((tail list)) | |
512 | ; (if (null? tail) | |
513 | ; result | |
514 | ; (begin | |
515 | ; (fluid-set! iter-var (car tail)) | |
516 | ; body | |
517 | ; (iterate (cdr tail))))))) | |
518 | ||
a90d9c85 | 519 | (define (compile-dolist loc var iter-list result body) |
fb66a47a DK |
520 | (let* ((tailvar (gensym)) |
521 | (iterate (gensym)) | |
522 | (tailref (make-lexical-ref loc tailvar tailvar)) | |
523 | (iterate-func (make-lambda loc `(,tailvar) `(,tailvar) '() | |
524 | (make-conditional loc | |
525 | (call-primitive loc 'null? tailref) | |
a90d9c85 | 526 | (compile-expr result) |
fb66a47a | 527 | (make-sequence loc |
a90d9c85 | 528 | `(,(set-variable! loc var value-slot |
fb66a47a | 529 | (call-primitive loc 'car tailref)) |
a90d9c85 | 530 | ,@(map compile-expr body) |
fb66a47a DK |
531 | ,(make-application loc |
532 | (make-lexical-ref loc iterate iterate) | |
533 | (list (call-primitive loc 'cdr | |
534 | tailref))))))))) | |
a90d9c85 | 535 | (mark-fluid-needed! (fluid-ref bindings-data) var value-slot) |
5d221ca3 DK |
536 | (call-primitive loc 'with-fluid* |
537 | (make-module-ref loc value-slot var #t) | |
538 | (nil-value loc) | |
539 | (make-lambda loc '() '() '() | |
540 | (make-letrec loc `(,iterate) `(,iterate) `(,iterate-func) | |
541 | (make-application loc | |
542 | (make-lexical-ref loc iterate iterate) | |
a90d9c85 | 543 | (list (compile-expr iter-list)))))))) |
fb66a47a DK |
544 | |
545 | ||
51248e6e DK |
546 | ; Compile a symbol expression. This is a variable reference or maybe some |
547 | ; special value like nil. | |
548 | ||
a90d9c85 | 549 | (define (compile-symbol loc sym) |
51248e6e | 550 | (case sym |
fdfb36de | 551 | ((nil) (nil-value loc)) |
fdfb36de | 552 | ((t) (t-value loc)) |
a90d9c85 | 553 | (else (reference-with-check loc sym value-slot)))) |
51248e6e DK |
554 | |
555 | ||
556 | ; Compile a pair-expression (that is, any structure-like construct). | |
557 | ||
a90d9c85 | 558 | (define (compile-pair loc expr) |
51248e6e DK |
559 | (pmatch expr |
560 | ||
561 | ((progn . ,forms) | |
a90d9c85 | 562 | (make-sequence loc (map compile-expr forms))) |
51248e6e | 563 | |
fb66a47a DK |
564 | ; I chose to implement prog1 directly (not with macros) so that the |
565 | ; temporary variable used can be a lexical one that is not backed by a fluid | |
566 | ; for better performance. | |
567 | ((prog1 ,form1 . ,forms) | |
568 | (let ((temp (gensym))) | |
a90d9c85 | 569 | (make-let loc `(,temp) `(,temp) `(,(compile-expr form1)) |
fb66a47a | 570 | (make-sequence loc |
a90d9c85 | 571 | (append (map compile-expr forms) |
fb66a47a DK |
572 | (list (make-lexical-ref loc temp temp))))))) |
573 | ||
51248e6e | 574 | ((if ,condition ,ifclause) |
a90d9c85 DK |
575 | (make-conditional loc (compile-expr condition) |
576 | (compile-expr ifclause) | |
4530432e | 577 | (nil-value loc))) |
51248e6e | 578 | ((if ,condition ,ifclause ,elseclause) |
a90d9c85 DK |
579 | (make-conditional loc (compile-expr condition) |
580 | (compile-expr ifclause) | |
581 | (compile-expr elseclause))) | |
51248e6e | 582 | ((if ,condition ,ifclause . ,elses) |
a90d9c85 DK |
583 | (make-conditional loc (compile-expr condition) |
584 | (compile-expr ifclause) | |
585 | (make-sequence loc (map compile-expr elses)))) | |
51248e6e | 586 | |
a4316739 DK |
587 | ; For (cond ...) forms, a special case is a (condition) clause without |
588 | ; body. In this case, the value of condition itself should be returned, | |
589 | ; and thus is saved in a local variable for testing and returning, if it | |
590 | ; is found true. | |
51248e6e DK |
591 | ((cond . ,clauses) (guard (and-map (lambda (el) |
592 | (and (list? el) (not (null? el)))) | |
593 | clauses)) | |
594 | (let iterate ((tail clauses)) | |
595 | (if (null? tail) | |
4530432e | 596 | (nil-value loc) |
51248e6e | 597 | (let ((cur (car tail))) |
a4316739 DK |
598 | (if (null? (cdr cur)) |
599 | (let ((var (gensym))) | |
600 | (make-let loc | |
a90d9c85 | 601 | '(condition) `(,var) `(,(compile-expr (car cur))) |
a4316739 DK |
602 | (make-conditional loc |
603 | (make-lexical-ref loc 'condition var) | |
604 | (make-lexical-ref loc 'condition var) | |
605 | (iterate (cdr tail))))) | |
606 | (make-conditional loc | |
a90d9c85 DK |
607 | (compile-expr (car cur)) |
608 | (make-sequence loc (map compile-expr (cdr cur))) | |
a4316739 | 609 | (iterate (cdr tail)))))))) |
51248e6e | 610 | |
fdfb36de | 611 | ((and) (t-value loc)) |
51248e6e DK |
612 | ((and . ,expressions) |
613 | (let iterate ((tail expressions)) | |
614 | (if (null? (cdr tail)) | |
a90d9c85 | 615 | (compile-expr (car tail)) |
51248e6e | 616 | (make-conditional loc |
a90d9c85 | 617 | (compile-expr (car tail)) |
51248e6e | 618 | (iterate (cdr tail)) |
4530432e | 619 | (nil-value loc))))) |
51248e6e | 620 | |
fdfb36de DK |
621 | ((or . ,expressions) |
622 | (let iterate ((tail expressions)) | |
623 | (if (null? tail) | |
624 | (nil-value loc) | |
625 | (let ((var (gensym))) | |
626 | (make-let loc | |
a90d9c85 | 627 | '(condition) `(,var) `(,(compile-expr (car tail))) |
fdfb36de DK |
628 | (make-conditional loc |
629 | (make-lexical-ref loc 'condition var) | |
630 | (make-lexical-ref loc 'condition var) | |
631 | (iterate (cdr tail)))))))) | |
632 | ||
de9f26b5 DK |
633 | ((defconst ,sym ,value . ,doc) |
634 | (if (handle-var-def loc sym doc) | |
635 | (make-sequence loc | |
a90d9c85 | 636 | (list (set-variable! loc sym value-slot (compile-expr value)) |
de9f26b5 DK |
637 | (make-const loc sym))))) |
638 | ||
639 | ((defvar ,sym) (make-const loc sym)) | |
640 | ((defvar ,sym ,value . ,doc) | |
641 | (if (handle-var-def loc sym doc) | |
642 | (make-sequence loc | |
643 | (list (make-conditional loc | |
644 | (call-primitive loc 'eq? | |
645 | (make-module-ref loc runtime 'void #t) | |
a90d9c85 DK |
646 | (reference-variable loc sym value-slot)) |
647 | (set-variable! loc sym value-slot | |
648 | (compile-expr value)) | |
de9f26b5 DK |
649 | (make-void loc)) |
650 | (make-const loc sym))))) | |
651 | ||
344927c3 DK |
652 | ; Build a set form for possibly multiple values. The code is not formulated |
653 | ; tail recursive because it is clearer this way and large lists of symbol | |
654 | ; expression pairs are very unlikely. | |
570c12ac | 655 | ((setq . ,args) (guard (not (null? args))) |
344927c3 DK |
656 | (make-sequence loc |
657 | (let iterate ((tail args)) | |
570c12ac DK |
658 | (let ((sym (car tail)) |
659 | (tailtail (cdr tail))) | |
660 | (if (not (symbol? sym)) | |
661 | (report-error loc "expected symbol in setq") | |
662 | (if (null? tailtail) | |
663 | (report-error loc "missing value for symbol in setq" sym) | |
a90d9c85 DK |
664 | (let* ((val (compile-expr (car tailtail))) |
665 | (op (set-variable! loc sym value-slot val))) | |
570c12ac DK |
666 | (if (null? (cdr tailtail)) |
667 | (let* ((temp (gensym)) | |
668 | (ref (make-lexical-ref loc temp temp))) | |
669 | (list (make-let loc `(,temp) `(,temp) `(,val) | |
670 | (make-sequence loc | |
a90d9c85 | 671 | (list (set-variable! loc sym value-slot ref) |
570c12ac | 672 | ref))))) |
a90d9c85 | 673 | (cons (set-variable! loc sym value-slot val) |
570c12ac | 674 | (iterate (cdr tailtail))))))))))) |
344927c3 | 675 | |
a6a5cf03 DK |
676 | ; All lets (let, flet, lexical-let and let* forms) are done using the |
677 | ; generate-let/generate-let* methods. | |
e8f18b3f | 678 | |
3a4b8635 | 679 | ((let ,bindings . ,body) (guard (and (list? bindings) |
3a4b8635 DK |
680 | (not (null? bindings)) |
681 | (not (null? body)))) | |
a90d9c85 | 682 | (generate-let loc value-slot bindings body)) |
a6a5cf03 DK |
683 | ((lexical-let ,bindings . ,body) (guard (and (list? bindings) |
684 | (not (null? bindings)) | |
685 | (not (null? body)))) | |
686 | (generate-let loc 'lexical bindings body)) | |
e8f18b3f DK |
687 | ((flet ,bindings . ,body) (guard (and (list? bindings) |
688 | (not (null? bindings)) | |
689 | (not (null? body)))) | |
a90d9c85 | 690 | (generate-let loc function-slot bindings body)) |
e8f18b3f | 691 | |
3a4b8635 | 692 | ((let* ,bindings . ,body) (guard (and (list? bindings) |
3a4b8635 DK |
693 | (not (null? bindings)) |
694 | (not (null? body)))) | |
a90d9c85 | 695 | (generate-let* loc value-slot bindings body)) |
a6a5cf03 DK |
696 | ((lexical-let* ,bindings . ,body) (guard (and (list? bindings) |
697 | (not (null? bindings)) | |
698 | (not (null? body)))) | |
699 | (generate-let* loc 'lexical bindings body)) | |
e8f18b3f DK |
700 | ((flet* ,bindings . ,body) (guard (and (list? bindings) |
701 | (not (null? bindings)) | |
702 | (not (null? body)))) | |
a90d9c85 | 703 | (generate-let* loc function-slot bindings body)) |
3a4b8635 | 704 | |
f3df67e2 DK |
705 | ; Temporarily disable void checks for certain symbols within the lexical |
706 | ; scope of without-void-checks. | |
707 | ((without-void-checks ,syms . ,body) | |
708 | (guard (and (list? body) (not (null? body)) | |
709 | (or (eq? syms 'all) | |
710 | (and (list? syms) (and-map symbol? syms))))) | |
711 | (let ((disabled (fluid-ref disable-void-check)) | |
712 | (make-body (lambda () | |
713 | (make-sequence loc (map compile-expr body))))) | |
714 | (if (eq? disabled 'all) | |
715 | (make-body) | |
716 | (let ((new-disabled (if (eq? syms 'all) | |
717 | 'all | |
718 | (append syms disabled)))) | |
719 | (with-fluid* disable-void-check new-disabled make-body))))) | |
720 | ||
721 | ||
33da12ee | 722 | ; guile-ref allows building TreeIL's module references from within |
c61ec8e2 | 723 | ; elisp as a way to access data within |
33da12ee DK |
724 | ; the Guile universe. The module and symbol referenced are static values, |
725 | ; just like (@ module symbol) does! | |
726 | ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym))) | |
727 | (make-module-ref loc module sym #t)) | |
728 | ||
c61ec8e2 DK |
729 | ; guile-primitive allows to create primitive references, which are still |
730 | ; a little faster. | |
731 | ((guile-primitive ,sym) (guard (symbol? sym)) | |
732 | (make-primitive-ref loc sym)) | |
733 | ||
d221c18b DK |
734 | ; A while construct is transformed into a tail-recursive loop like this: |
735 | ; (letrec ((iterate (lambda () | |
736 | ; (if condition | |
737 | ; (begin body | |
738 | ; (iterate)) | |
739 | ; %nil)))) | |
740 | ; (iterate)) | |
741 | ((while ,condition . ,body) | |
742 | (let* ((itersym (gensym)) | |
a90d9c85 | 743 | (compiled-body (map compile-expr body)) |
d221c18b DK |
744 | (iter-call (make-application loc |
745 | (make-lexical-ref loc 'iterate itersym) | |
746 | (list))) | |
747 | (full-body (make-sequence loc | |
cef997e8 | 748 | `(,@compiled-body ,iter-call))) |
d221c18b | 749 | (lambda-body (make-conditional loc |
a90d9c85 | 750 | (compile-expr condition) |
d221c18b DK |
751 | full-body |
752 | (nil-value loc))) | |
753 | (iter-thunk (make-lambda loc '() '() '() lambda-body))) | |
754 | (make-letrec loc '(iterate) (list itersym) (list iter-thunk) | |
755 | iter-call))) | |
756 | ||
fb66a47a DK |
757 | ; dolist is treated here rather than as macro because it can take advantage |
758 | ; of a non-fluid-based variable. | |
759 | ((dolist (,var ,iter-list) . ,body) (guard (symbol? var)) | |
a90d9c85 | 760 | (compile-dolist loc var iter-list 'nil body)) |
fb66a47a | 761 | ((dolist (,var ,iter-list ,result) . ,body) (guard (symbol? var)) |
a90d9c85 | 762 | (compile-dolist loc var iter-list result body)) |
fb66a47a | 763 | |
35b2e41d DK |
764 | ; catch and throw can mainly be implemented directly using Guile's |
765 | ; primitives for exceptions, the only difficulty is that the keys used | |
766 | ; within Guile must be symbols, while elisp allows any value and checks | |
767 | ; for matches using eq (eq?). We handle this by using always #t as key | |
768 | ; for the Guile primitives and check for matches inside the handler; if | |
769 | ; the elisp keys are not eq?, we rethrow the exception. | |
33da12ee DK |
770 | ; |
771 | ; throw is implemented as built-in function. | |
35b2e41d DK |
772 | |
773 | ((catch ,tag . ,body) (guard (not (null? body))) | |
774 | (let* ((tag-value (gensym)) | |
775 | (tag-ref (make-lexical-ref loc tag-value tag-value))) | |
a90d9c85 | 776 | (make-let loc `(,tag-value) `(,tag-value) `(,(compile-expr tag)) |
35b2e41d DK |
777 | (call-primitive loc 'catch |
778 | (make-const loc #t) | |
779 | (make-lambda loc '() '() '() | |
a90d9c85 | 780 | (make-sequence loc (map compile-expr body))) |
35b2e41d DK |
781 | (let* ((dummy-key (gensym)) |
782 | (dummy-ref (make-lexical-ref loc dummy-key dummy-key)) | |
783 | (elisp-key (gensym)) | |
784 | (key-ref (make-lexical-ref loc elisp-key elisp-key)) | |
785 | (value (gensym)) | |
786 | (value-ref (make-lexical-ref loc value value)) | |
787 | (arglist `(,dummy-key ,elisp-key ,value))) | |
788 | (make-lambda loc arglist arglist '() | |
789 | (make-conditional loc | |
790 | (call-primitive loc 'eq? key-ref tag-ref) | |
791 | value-ref | |
792 | (call-primitive loc 'throw | |
793 | dummy-ref key-ref value-ref)))))))) | |
794 | ||
33da12ee DK |
795 | ; unwind-protect is just some weaker construct as dynamic-wind, so |
796 | ; straight-forward to implement. | |
797 | ((unwind-protect ,body . ,clean-ups) (guard (not (null? clean-ups))) | |
798 | (call-primitive loc 'dynamic-wind | |
799 | (make-lambda loc '() '() '() (make-void loc)) | |
800 | (make-lambda loc '() '() '() | |
a90d9c85 | 801 | (compile-expr body)) |
33da12ee DK |
802 | (make-lambda loc '() '() '() |
803 | (make-sequence loc | |
a90d9c85 | 804 | (map compile-expr clean-ups))))) |
35b2e41d | 805 | |
50abfe76 DK |
806 | ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression |
807 | ; that should be compiled. | |
de9f26b5 | 808 | ((lambda ,args . ,body) |
a90d9c85 | 809 | (compile-lambda loc args body)) |
de9f26b5 | 810 | ((function (lambda ,args . ,body)) |
a90d9c85 | 811 | (compile-lambda loc args body)) |
50abfe76 | 812 | |
de9f26b5 DK |
813 | ; Build a lambda and also assign it to the function cell of some symbol. |
814 | ((defun ,name ,args . ,body) | |
815 | (if (not (symbol? name)) | |
816 | (error "expected symbol as function name" name) | |
817 | (make-sequence loc | |
a90d9c85 DK |
818 | (list (set-variable! loc name function-slot |
819 | (compile-lambda loc args body)) | |
de9f26b5 DK |
820 | (make-const loc name))))) |
821 | ||
74c009da DK |
822 | ; Define a macro (this is done directly at compile-time!). |
823 | ; FIXME: Recursive macros don't work! | |
824 | ((defmacro ,name ,args . ,body) | |
825 | (if (not (symbol? name)) | |
826 | (error "expected symbol as macro name" name) | |
a90d9c85 DK |
827 | (let* ((tree-il (with-fluid* bindings-data (make-bindings) |
828 | (lambda () | |
829 | (compile-lambda loc args body)))) | |
74c009da DK |
830 | (object (compile tree-il #:from 'tree-il #:to 'value))) |
831 | (define-macro! loc name object) | |
832 | (make-const loc name)))) | |
833 | ||
9b5ff6a6 | 834 | ((,backq ,val) (guard (backquote? backq)) |
a90d9c85 | 835 | (process-backquote loc val)) |
9b5ff6a6 DK |
836 | |
837 | ; XXX: Why do we need 'quote here instead of quote? | |
1e018f6c DK |
838 | (('quote ,val) |
839 | (make-const loc val)) | |
840 | ||
74c009da DK |
841 | ; Macro calls are simply expanded and recursively compiled. |
842 | ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro))) | |
843 | (let ((expander (get-macro macro))) | |
a90d9c85 | 844 | (compile-expr (apply expander args)))) |
74c009da | 845 | |
cef997e8 DK |
846 | ; Function calls using (function args) standard notation; here, we have to |
847 | ; take the function value of a symbol if it is one. It seems that functions | |
848 | ; in form of uncompiled lists are not supported in this syntax, so we don't | |
849 | ; have to care for them. | |
850 | ((,func . ,args) | |
851 | (make-application loc | |
852 | (if (symbol? func) | |
a90d9c85 DK |
853 | (reference-with-check loc func function-slot) |
854 | (compile-expr func)) | |
855 | (map compile-expr args))) | |
cef997e8 | 856 | |
51248e6e | 857 | (else |
344927c3 | 858 | (report-error loc "unrecognized elisp" expr)))) |
51248e6e DK |
859 | |
860 | ||
a90d9c85 | 861 | ; Compile a single expression to TreeIL. |
51248e6e | 862 | |
a90d9c85 | 863 | (define (compile-expr expr) |
51248e6e DK |
864 | (let ((loc (location expr))) |
865 | (cond | |
866 | ((symbol? expr) | |
a90d9c85 | 867 | (compile-symbol loc expr)) |
51248e6e | 868 | ((pair? expr) |
a90d9c85 | 869 | (compile-pair loc expr)) |
51248e6e DK |
870 | (else (make-const loc expr))))) |
871 | ||
872 | ||
a0899974 DK |
873 | ; Process the compiler options. |
874 | ; FIXME: Why is '(()) passed as options by the REPL? | |
875 | ||
876 | (define (process-options! opt) | |
877 | (if (and (not (null? opt)) | |
878 | (not (equal? opt '(())))) | |
879 | (if (null? (cdr opt)) | |
880 | (error "Invalid compiler options" opt) | |
881 | (let ((key (car opt)) | |
882 | (value (cadr opt))) | |
883 | (case key | |
884 | ((#:disable-void-check) | |
885 | (if (and (not (eq? value 'all)) | |
886 | (not (and (list? value) (and-map symbol? value)))) | |
887 | (error "Invalid value for #:disable-void-check" value) | |
888 | (fluid-set! disable-void-check value))) | |
889 | (else (error "Invalid compiler option" key))))))) | |
890 | ||
891 | ||
51248e6e | 892 | ; Entry point for compilation to TreeIL. |
35b2e41d DK |
893 | ; This creates the bindings data structure, and after compiling the main |
894 | ; expression we need to make sure all fluids for symbols used during the | |
895 | ; compilation are created using the generate-ensure-fluid function. | |
51248e6e DK |
896 | |
897 | (define (compile-tree-il expr env opts) | |
898 | (values | |
a0899974 DK |
899 | (with-fluids* (list bindings-data disable-void-check) |
900 | (list (make-bindings) '()) | |
a90d9c85 | 901 | (lambda () |
a0899974 | 902 | (process-options! opts) |
a90d9c85 DK |
903 | (let ((loc (location expr)) |
904 | (compiled (compile-expr expr))) | |
905 | (make-sequence loc | |
906 | `(,@(map-fluids-needed (fluid-ref bindings-data) | |
907 | (lambda (mod sym) | |
908 | (generate-ensure-fluid loc sym mod))) | |
909 | ,compiled))))) | |
51248e6e DK |
910 | env |
911 | env)) |