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