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