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