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