Commit | Line | Data |
---|---|---|
5161a3c0 AW |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ||
eb037656 | 3 | ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. |
5161a3c0 AW |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library 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 GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ;;;; | |
19 | ||
20 | \f | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
b2b554ef AW |
24 | ;;; Scheme eval, written in Scheme. |
25 | ;;; | |
26 | ;;; Expressions are first expanded, by the syntax expander (i.e. | |
27 | ;;; psyntax), then memoized into internal forms. The evaluator itself | |
28 | ;;; only operates on the internal forms ("memoized expressions"). | |
29 | ;;; | |
95de4f52 AW |
30 | ;;; Environments are represented as a chain of vectors, linked through |
31 | ;;; their first elements. The terminal element of an environment is the | |
32 | ;;; module that was current when the outer lexical environment was | |
33 | ;;; entered. | |
5161a3c0 AW |
34 | ;;; |
35 | ||
36 | ;;; Code: | |
37 | ||
38 | \f | |
39 | ||
95de4f52 AW |
40 | (define (primitive-eval exp) |
41 | "Evaluate @var{exp} in the current module." | |
cfc28c80 AW |
42 | (define-syntax env-toplevel |
43 | (syntax-rules () | |
44 | ((_ env) | |
45 | (let lp ((e env)) | |
46 | (if (vector? e) | |
47 | (lp (vector-ref e 0)) | |
48 | e))))) | |
49 | ||
50 | (define-syntax make-env | |
51 | (syntax-rules () | |
52 | ((_ n init next) | |
53 | (let ((v (make-vector (1+ n) init))) | |
54 | (vector-set! v 0 next) | |
55 | v)))) | |
56 | ||
57 | (define-syntax make-env* | |
58 | (syntax-rules () | |
59 | ((_ next init ...) | |
60 | (vector next init ...)))) | |
61 | ||
62 | (define-syntax env-ref | |
63 | (syntax-rules () | |
64 | ((_ env depth width) | |
65 | (let lp ((e env) (d depth)) | |
66 | (if (zero? d) | |
67 | (vector-ref e (1+ width)) | |
68 | (lp (vector-ref e 0) (1- d))))))) | |
69 | ||
70 | (define-syntax env-set! | |
71 | (syntax-rules () | |
72 | ((_ env depth width val) | |
73 | (let lp ((e env) (d depth)) | |
74 | (if (zero? d) | |
75 | (vector-set! e (1+ width) val) | |
76 | (lp (vector-ref e 0) (1- d))))))) | |
77 | ||
95de4f52 AW |
78 | ;; This is a modified version of Oleg Kiselyov's "pmatch". |
79 | (define-syntax-rule (match e cs ...) | |
80 | (let ((v e)) (expand-clauses v cs ...))) | |
81 | ||
82 | (define-syntax expand-clauses | |
be6e40a1 | 83 | (syntax-rules () |
95de4f52 AW |
84 | ((_ v) ((error "unreachable"))) |
85 | ((_ v (pat e0 e ...) cs ...) | |
86 | (let ((fk (lambda () (expand-clauses v cs ...)))) | |
87 | (expand-pattern v pat (let () e0 e ...) (fk)))))) | |
88 | ||
89 | (define-syntax expand-pattern | |
eb037656 | 90 | (syntax-rules (_ quote unquote ?) |
95de4f52 AW |
91 | ((_ v _ kt kf) kt) |
92 | ((_ v () kt kf) (if (null? v) kt kf)) | |
93 | ((_ v (quote lit) kt kf) | |
94 | (if (equal? v (quote lit)) kt kf)) | |
95 | ((_ v (unquote exp) kt kf) | |
96 | (if (equal? v exp) kt kf)) | |
97 | ((_ v (x . y) kt kf) | |
98 | (if (pair? v) | |
99 | (let ((vx (car v)) (vy (cdr v))) | |
100 | (expand-pattern vx x (expand-pattern vy y kt kf) kf)) | |
101 | kf)) | |
eb037656 AW |
102 | ((_ v (? pred var) kt kf) |
103 | (if (pred v) (let ((var v)) kt) kf)) | |
95de4f52 AW |
104 | ((_ v #f kt kf) (if (eqv? v #f) kt kf)) |
105 | ((_ v var kt kf) (let ((var v)) kt)))) | |
106 | ||
107 | (define-syntax typecode | |
5161a3c0 AW |
108 | (lambda (x) |
109 | (syntax-case x () | |
95de4f52 AW |
110 | ((_ type) |
111 | (or (memoized-typecode (syntax->datum #'type)) | |
112 | (error "not a typecode" (syntax->datum #'type))))))) | |
113 | ||
114 | (define (compile-lexical-ref depth width) | |
115 | (lambda (env) | |
116 | (env-ref env depth width))) | |
117 | ||
eb037656 | 118 | (define (compile-call f args) |
95de4f52 AW |
119 | (let ((f (compile f))) |
120 | (match args | |
121 | (() (lambda (env) ((f env)))) | |
122 | ((a) | |
123 | (let ((a (compile a))) | |
124 | (lambda (env) ((f env) (a env))))) | |
125 | ((a b) | |
126 | (let ((a (compile a)) | |
127 | (b (compile b))) | |
128 | (lambda (env) ((f env) (a env) (b env))))) | |
129 | ((a b c) | |
130 | (let ((a (compile a)) | |
131 | (b (compile b)) | |
132 | (c (compile c))) | |
133 | (lambda (env) ((f env) (a env) (b env) (c env))))) | |
134 | ((a b c . args) | |
135 | (let ((a (compile a)) | |
136 | (b (compile b)) | |
137 | (c (compile c)) | |
138 | (args (let lp ((args args)) | |
139 | (if (null? args) | |
140 | '() | |
141 | (cons (compile (car args)) (lp (cdr args))))))) | |
142 | (lambda (env) | |
143 | (apply (f env) (a env) (b env) (c env) | |
144 | (let lp ((args args)) | |
145 | (if (null? args) | |
146 | '() | |
147 | (cons ((car args) env) (lp (cdr args)))))))))))) | |
148 | ||
149 | (define (compile-box-ref box) | |
150 | (match box | |
151 | ((,(typecode resolve) . var-or-loc) | |
152 | (lambda (env) | |
153 | (cond | |
154 | ((variable? var-or-loc) (variable-ref var-or-loc)) | |
155 | (else | |
156 | (set! var-or-loc | |
157 | (%resolve-variable var-or-loc (env-toplevel env))) | |
158 | (variable-ref var-or-loc))))) | |
159 | ((,(typecode lexical-ref) depth . width) | |
160 | (lambda (env) | |
161 | (variable-ref (env-ref env depth width)))) | |
162 | (_ | |
163 | (let ((box (compile box))) | |
164 | (lambda (env) | |
165 | (variable-ref (box env))))))) | |
166 | ||
167 | (define (compile-resolve var-or-loc) | |
168 | (lambda (env) | |
169 | (cond | |
170 | ((variable? var-or-loc) var-or-loc) | |
171 | (else | |
172 | (set! var-or-loc (%resolve-variable var-or-loc (env-toplevel env))) | |
173 | var-or-loc)))) | |
174 | ||
175 | (define (compile-if test consequent alternate) | |
176 | (let ((test (compile test)) | |
177 | (consequent (compile consequent)) | |
178 | (alternate (compile alternate))) | |
179 | (lambda (env) | |
180 | (if (test env) (consequent env) (alternate env))))) | |
181 | ||
182 | (define (compile-quote x) | |
183 | (lambda (env) x)) | |
184 | ||
185 | (define (compile-let inits body) | |
186 | (let ((body (compile body)) | |
187 | (width (vector-length inits))) | |
188 | (case width | |
189 | ((0) (lambda (env) | |
190 | (body (make-env* env)))) | |
191 | ((1) | |
192 | (let ((a (compile (vector-ref inits 0)))) | |
193 | (lambda (env) | |
194 | (body (make-env* env (a env)))))) | |
195 | ((2) | |
196 | (let ((a (compile (vector-ref inits 0))) | |
197 | (b (compile (vector-ref inits 1)))) | |
198 | (lambda (env) | |
199 | (body (make-env* env (a env) (b env)))))) | |
200 | ((3) | |
201 | (let ((a (compile (vector-ref inits 0))) | |
202 | (b (compile (vector-ref inits 1))) | |
203 | (c (compile (vector-ref inits 2)))) | |
204 | (lambda (env) | |
205 | (body (make-env* env (a env) (b env) (c env)))))) | |
206 | ((4) | |
207 | (let ((a (compile (vector-ref inits 0))) | |
208 | (b (compile (vector-ref inits 1))) | |
209 | (c (compile (vector-ref inits 2))) | |
210 | (d (compile (vector-ref inits 3)))) | |
211 | (lambda (env) | |
212 | (body (make-env* env (a env) (b env) (c env) (d env)))))) | |
213 | (else | |
214 | (let lp ((n width) | |
215 | (k (lambda (env) | |
216 | (make-env width #f env)))) | |
217 | (if (zero? n) | |
218 | (lambda (env) | |
219 | (body (k env))) | |
220 | (lp (1- n) | |
221 | (let ((init (compile (vector-ref inits (1- n))))) | |
222 | (lambda (env) | |
223 | (let* ((x (init env)) | |
224 | (new-env (k env))) | |
225 | (env-set! new-env 0 (1- n) x) | |
226 | new-env)))))))))) | |
227 | ||
228 | (define (compile-fixed-lambda body nreq) | |
229 | (case nreq | |
230 | ((0) (lambda (env) | |
231 | (lambda () | |
232 | (body (make-env* env))))) | |
233 | ((1) (lambda (env) | |
234 | (lambda (a) | |
235 | (body (make-env* env a))))) | |
236 | ((2) (lambda (env) | |
237 | (lambda (a b) | |
238 | (body (make-env* env a b))))) | |
239 | ((3) (lambda (env) | |
240 | (lambda (a b c) | |
241 | (body (make-env* env a b c))))) | |
242 | ((4) (lambda (env) | |
243 | (lambda (a b c d) | |
244 | (body (make-env* env a b c d))))) | |
245 | ((5) (lambda (env) | |
246 | (lambda (a b c d e) | |
247 | (body (make-env* env a b c d e))))) | |
248 | ((6) (lambda (env) | |
249 | (lambda (a b c d e f) | |
250 | (body (make-env* env a b c d e f))))) | |
251 | ((7) (lambda (env) | |
252 | (lambda (a b c d e f g) | |
253 | (body (make-env* env a b c d e f g))))) | |
254 | (else | |
255 | (lambda (env) | |
256 | (lambda (a b c d e f g . more) | |
257 | (let ((env (make-env nreq #f env))) | |
258 | (env-set! env 0 0 a) | |
259 | (env-set! env 0 1 b) | |
260 | (env-set! env 0 2 c) | |
261 | (env-set! env 0 3 d) | |
262 | (env-set! env 0 4 e) | |
263 | (env-set! env 0 5 f) | |
264 | (env-set! env 0 6 g) | |
265 | (let lp ((n 7) (args more)) | |
266 | (cond | |
267 | ((= n nreq) | |
268 | (unless (null? args) | |
269 | (scm-error 'wrong-number-of-args | |
270 | "eval" "Wrong number of arguments" | |
271 | '() #f)) | |
272 | (body env)) | |
273 | ((null? args) | |
274 | (scm-error 'wrong-number-of-args | |
275 | "eval" "Wrong number of arguments" | |
276 | '() #f)) | |
277 | (else | |
278 | (env-set! env 0 n (car args)) | |
279 | (lp (1+ n) (cdr args))))))))))) | |
280 | ||
281 | (define (compile-rest-lambda body nreq rest?) | |
282 | (case nreq | |
283 | ((0) (lambda (env) | |
284 | (lambda rest | |
285 | (body (make-env* env rest))))) | |
286 | ((1) (lambda (env) | |
287 | (lambda (a . rest) | |
288 | (body (make-env* env a rest))))) | |
289 | ((2) (lambda (env) | |
290 | (lambda (a b . rest) | |
291 | (body (make-env* env a b rest))))) | |
292 | ((3) (lambda (env) | |
293 | (lambda (a b c . rest) | |
294 | (body (make-env* env a b c rest))))) | |
295 | (else | |
296 | (lambda (env) | |
297 | (lambda (a b c . more) | |
298 | (let ((env (make-env (1+ nreq) #f env))) | |
299 | (env-set! env 0 0 a) | |
300 | (env-set! env 0 1 b) | |
301 | (env-set! env 0 2 c) | |
302 | (let lp ((n 3) (args more)) | |
303 | (cond | |
304 | ((= n nreq) | |
305 | (env-set! env 0 n args) | |
306 | (body env)) | |
307 | ((null? args) | |
308 | (scm-error 'wrong-number-of-args | |
309 | "eval" "Wrong number of arguments" | |
310 | '() #f)) | |
311 | (else | |
312 | (env-set! env 0 n (car args)) | |
313 | (lp (1+ n) (cdr args))))))))))) | |
314 | ||
315 | (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt) | |
316 | (lambda (env) | |
317 | (define alt (and make-alt (make-alt env))) | |
318 | (lambda args | |
319 | (let ((nargs (length args))) | |
320 | (cond | |
321 | ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt)))) | |
322 | (if alt | |
323 | (apply alt args) | |
324 | ((scm-error 'wrong-number-of-args | |
325 | "eval" "Wrong number of arguments" | |
326 | '() #f)))) | |
327 | (else | |
328 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) | |
329 | (env (make-env nvals unbound env))) | |
330 | (define (bind-req args) | |
331 | (let lp ((i 0) (args args)) | |
332 | (cond | |
333 | ((< i nreq) | |
334 | ;; Bind required arguments. | |
335 | (env-set! env 0 i (car args)) | |
336 | (lp (1+ i) (cdr args))) | |
337 | (else | |
338 | (bind-opt args))))) | |
339 | (define (bind-opt args) | |
340 | (let lp ((i nreq) (args args)) | |
341 | (cond | |
342 | ((and (< i (+ nreq nopt)) (< i nargs)) | |
343 | (env-set! env 0 i (car args)) | |
344 | (lp (1+ i) (cdr args))) | |
345 | (else | |
346 | (bind-rest args))))) | |
347 | (define (bind-rest args) | |
348 | (when rest? | |
349 | (env-set! env 0 (+ nreq nopt) args)) | |
350 | (body env)) | |
351 | (bind-req args)))))))) | |
352 | ||
353 | (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) | |
354 | (define allow-other-keys? (car kw)) | |
355 | (define keywords (cdr kw)) | |
356 | (lambda (env) | |
357 | (define alt (and make-alt (make-alt env))) | |
358 | (lambda args | |
359 | (define (npositional args) | |
360 | (let lp ((n 0) (args args)) | |
361 | (if (or (null? args) | |
362 | (and (>= n nreq) (keyword? (car args)))) | |
363 | n | |
364 | (lp (1+ n) (cdr args))))) | |
365 | (let ((nargs (length args))) | |
366 | (cond | |
367 | ((or (< nargs nreq) | |
368 | (and alt (not rest?) (> (npositional args) (+ nreq nopt)))) | |
369 | (if alt | |
370 | (apply alt args) | |
371 | ((scm-error 'wrong-number-of-args | |
372 | "eval" "Wrong number of arguments" | |
373 | '() #f)))) | |
374 | (else | |
375 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) | |
376 | (env (make-env nvals unbound env))) | |
377 | (define (bind-req args) | |
378 | (let lp ((i 0) (args args)) | |
379 | (cond | |
380 | ((< i nreq) | |
381 | ;; Bind required arguments. | |
382 | (env-set! env 0 i (car args)) | |
383 | (lp (1+ i) (cdr args))) | |
384 | (else | |
385 | (bind-opt args))))) | |
386 | (define (bind-opt args) | |
387 | (let lp ((i nreq) (args args)) | |
388 | (cond | |
389 | ((and (< i (+ nreq nopt)) (< i nargs) | |
390 | (not (keyword? (car args)))) | |
391 | (env-set! env 0 i (car args)) | |
392 | (lp (1+ i) (cdr args))) | |
393 | (else | |
394 | (bind-rest args))))) | |
395 | (define (bind-rest args) | |
396 | (when rest? | |
397 | (env-set! env 0 (+ nreq nopt) args)) | |
398 | (bind-kw args)) | |
399 | (define (bind-kw args) | |
400 | (let lp ((args args)) | |
401 | (cond | |
402 | ((and (pair? args) (pair? (cdr args)) | |
403 | (keyword? (car args))) | |
404 | (let ((kw-pair (assq (car args) keywords)) | |
405 | (v (cadr args))) | |
406 | (if kw-pair | |
407 | ;; Found a known keyword; set its value. | |
408 | (env-set! env 0 (cdr kw-pair) v) | |
409 | ;; Unknown keyword. | |
410 | (if (not allow-other-keys?) | |
411 | ((scm-error | |
412 | 'keyword-argument-error | |
413 | "eval" "Unrecognized keyword" | |
414 | '() (list (car args)))))) | |
415 | (lp (cddr args)))) | |
416 | ((pair? args) | |
417 | (if rest? | |
418 | ;; Be lenient parsing rest args. | |
419 | (lp (cdr args)) | |
420 | ((scm-error 'keyword-argument-error | |
421 | "eval" "Invalid keyword" | |
422 | '() (list (car args)))))) | |
423 | (else | |
424 | (body env))))) | |
425 | (bind-req args)))))))) | |
426 | ||
427 | (define (compute-arity alt nreq rest? nopt kw) | |
428 | (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) | |
429 | (if (not alt) | |
430 | (let ((arglist (list nreq | |
431 | nopt | |
432 | (if kw (cdr kw) '()) | |
433 | (and kw (car kw)) | |
434 | (and rest? '_)))) | |
435 | (values arglist nreq nopt rest?)) | |
436 | (let* ((spec (cddr alt)) | |
437 | (nreq* (car spec)) | |
438 | (rest?* (if (null? (cdr spec)) #f (cadr spec))) | |
439 | (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) | |
440 | (nopt* (if tail (car tail) 0)) | |
441 | (alt* (and tail (car (cddddr tail))))) | |
442 | (if (or (< nreq* nreq) | |
443 | (and (= nreq* nreq) | |
444 | (if rest? | |
445 | (and rest?* (> nopt* nopt)) | |
446 | (or rest?* (> nopt* nopt))))) | |
447 | (lp alt* nreq* nopt* rest?*) | |
448 | (lp alt* nreq nopt rest?)))))) | |
449 | ||
450 | (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt) | |
451 | (call-with-values | |
452 | (lambda () | |
453 | (compute-arity alt nreq rest? nopt kw)) | |
454 | (lambda (arglist min-nreq min-nopt min-rest?) | |
455 | (define make-alt | |
456 | (match alt | |
457 | (#f #f) | |
458 | ((body meta nreq . tail) | |
459 | (compile-lambda body meta nreq tail)))) | |
460 | (define make-closure | |
461 | (if kw | |
462 | (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) | |
463 | (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt))) | |
464 | (lambda (env) | |
465 | (let ((proc (make-closure env))) | |
466 | (set-procedure-property! proc 'arglist arglist) | |
467 | (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?) | |
468 | proc))))) | |
469 | ||
470 | (define (compile-lambda body meta nreq tail) | |
471 | (define (set-procedure-meta meta proc) | |
472 | (match meta | |
473 | (() proc) | |
474 | (((prop . val) . meta) | |
475 | (set-procedure-meta meta | |
476 | (lambda (env) | |
477 | (let ((proc (proc env))) | |
478 | (set-procedure-property! proc prop val) | |
479 | proc)))))) | |
480 | (let ((body (compile body))) | |
481 | (set-procedure-meta | |
482 | meta | |
483 | (match tail | |
484 | (() (compile-fixed-lambda body nreq)) | |
485 | ((rest? . tail) | |
486 | (match tail | |
487 | (() (compile-rest-lambda body nreq rest?)) | |
488 | ((nopt kw ninits unbound alt) | |
489 | (compile-general-lambda body nreq rest? nopt kw | |
490 | ninits unbound alt)))))))) | |
491 | ||
492 | (define (compile-capture-env locs body) | |
493 | (let ((body (compile body))) | |
494 | (lambda (env) | |
495 | (let* ((len (vector-length locs)) | |
496 | (new-env (make-env len #f (env-toplevel env)))) | |
497 | (let lp ((n 0)) | |
498 | (when (< n len) | |
499 | (match (vector-ref locs n) | |
500 | ((depth . width) | |
501 | (env-set! new-env 0 n (env-ref env depth width)))) | |
502 | (lp (1+ n)))) | |
503 | (body new-env))))) | |
504 | ||
505 | (define (compile-seq head tail) | |
506 | (let ((head (compile head)) | |
507 | (tail (compile tail))) | |
508 | (lambda (env) | |
509 | (head env) | |
510 | (tail env)))) | |
511 | ||
512 | (define (compile-box-set! box val) | |
513 | (let ((box (compile box)) | |
514 | (val (compile val))) | |
515 | (lambda (env) | |
516 | (let ((val (val env))) | |
517 | (variable-set! (box env) val))))) | |
518 | ||
519 | (define (compile-lexical-set! depth width x) | |
520 | (let ((x (compile x))) | |
521 | (lambda (env) | |
522 | (env-set! env depth width (x env))))) | |
523 | ||
524 | (define (compile-call-with-values producer consumer) | |
525 | (let ((producer (compile producer)) | |
526 | (consumer (compile consumer))) | |
527 | (lambda (env) | |
528 | (call-with-values (producer env) | |
529 | (consumer env))))) | |
530 | ||
531 | (define (compile-apply f args) | |
532 | (let ((f (compile f)) | |
533 | (args (compile args))) | |
534 | (lambda (env) | |
535 | (apply (f env) (args env))))) | |
536 | ||
537 | (define (compile-capture-module x) | |
538 | (let ((x (compile x))) | |
539 | (lambda (env) | |
540 | (x (current-module))))) | |
541 | ||
542 | (define (compile-call-with-prompt tag thunk handler) | |
543 | (let ((tag (compile tag)) | |
544 | (thunk (compile thunk)) | |
545 | (handler (compile handler))) | |
546 | (lambda (env) | |
547 | (call-with-prompt (tag env) (thunk env) (handler env))))) | |
548 | ||
549 | (define (compile-call/cc proc) | |
550 | (let ((proc (compile proc))) | |
551 | (lambda (env) | |
552 | (call/cc (proc env))))) | |
553 | ||
554 | (define (compile exp) | |
555 | (match exp | |
556 | ((,(typecode lexical-ref) depth . width) | |
557 | (compile-lexical-ref depth width)) | |
558 | ||
eb037656 AW |
559 | ((,(typecode call) f . args) |
560 | (compile-call f args)) | |
95de4f52 AW |
561 | |
562 | ((,(typecode box-ref) . box) | |
563 | (compile-box-ref box)) | |
5161a3c0 | 564 | |
95de4f52 AW |
565 | ((,(typecode resolve) . var-or-loc) |
566 | (compile-resolve var-or-loc)) | |
5161a3c0 | 567 | |
95de4f52 AW |
568 | ((,(typecode if) test consequent . alternate) |
569 | (compile-if test consequent alternate)) | |
21ec0bd9 | 570 | |
95de4f52 AW |
571 | ((,(typecode quote) . x) |
572 | (compile-quote x)) | |
573 | ||
574 | ((,(typecode let) inits . body) | |
575 | (compile-let inits body)) | |
576 | ||
577 | ((,(typecode lambda) body meta nreq . tail) | |
578 | (compile-lambda body meta nreq tail)) | |
579 | ||
580 | ((,(typecode capture-env) locs . body) | |
581 | (compile-capture-env locs body)) | |
582 | ||
583 | ((,(typecode seq) head . tail) | |
584 | (compile-seq head tail)) | |
585 | ||
586 | ((,(typecode box-set!) box . val) | |
587 | (compile-box-set! box val)) | |
588 | ||
589 | ((,(typecode lexical-set!) (depth . width) . x) | |
590 | (compile-lexical-set! depth width x)) | |
591 | ||
592 | ((,(typecode call-with-values) producer . consumer) | |
593 | (compile-call-with-values producer consumer)) | |
594 | ||
595 | ((,(typecode apply) f args) | |
596 | (compile-apply f args)) | |
597 | ||
598 | ((,(typecode capture-module) . x) | |
599 | (compile-capture-module x)) | |
600 | ||
601 | ((,(typecode call-with-prompt) tag thunk . handler) | |
602 | (compile-call-with-prompt tag thunk handler)) | |
5161a3c0 | 603 | |
95de4f52 AW |
604 | ((,(typecode call/cc) . proc) |
605 | (compile-call/cc proc)))) | |
606 | ||
607 | (let ((proc (compile | |
608 | (memoize-expression | |
609 | (if (macroexpanded? exp) | |
610 | exp | |
611 | ((module-transformer (current-module)) exp))))) | |
612 | (env #f)) | |
613 | (proc env))) |