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