Commit | Line | Data |
---|---|---|
5161a3c0 AW |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ||
1487367e | 3 | ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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 | |
90 | (syntax-rules (_ quote unquote) | |
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)) | |
102 | ((_ v #f kt kf) (if (eqv? v #f) kt kf)) | |
103 | ((_ v var kt kf) (let ((var v)) kt)))) | |
104 | ||
105 | (define-syntax typecode | |
5161a3c0 AW |
106 | (lambda (x) |
107 | (syntax-case x () | |
95de4f52 AW |
108 | ((_ type) |
109 | (or (memoized-typecode (syntax->datum #'type)) | |
110 | (error "not a typecode" (syntax->datum #'type))))))) | |
111 | ||
112 | (define (compile-lexical-ref depth width) | |
113 | (lambda (env) | |
114 | (env-ref env depth width))) | |
115 | ||
116 | (define (compile-call f nargs args) | |
117 | (let ((f (compile f))) | |
118 | (match args | |
119 | (() (lambda (env) ((f env)))) | |
120 | ((a) | |
121 | (let ((a (compile a))) | |
122 | (lambda (env) ((f env) (a env))))) | |
123 | ((a b) | |
124 | (let ((a (compile a)) | |
125 | (b (compile b))) | |
126 | (lambda (env) ((f env) (a env) (b env))))) | |
127 | ((a b c) | |
128 | (let ((a (compile a)) | |
129 | (b (compile b)) | |
130 | (c (compile c))) | |
131 | (lambda (env) ((f env) (a env) (b env) (c env))))) | |
132 | ((a b c . args) | |
133 | (let ((a (compile a)) | |
134 | (b (compile b)) | |
135 | (c (compile c)) | |
136 | (args (let lp ((args args)) | |
137 | (if (null? args) | |
138 | '() | |
139 | (cons (compile (car args)) (lp (cdr args))))))) | |
140 | (lambda (env) | |
141 | (apply (f env) (a env) (b env) (c env) | |
142 | (let lp ((args args)) | |
143 | (if (null? args) | |
144 | '() | |
145 | (cons ((car args) env) (lp (cdr args)))))))))))) | |
146 | ||
147 | (define (compile-box-ref box) | |
148 | (match box | |
149 | ((,(typecode resolve) . var-or-loc) | |
150 | (lambda (env) | |
151 | (cond | |
152 | ((variable? var-or-loc) (variable-ref var-or-loc)) | |
153 | (else | |
154 | (set! var-or-loc | |
155 | (%resolve-variable var-or-loc (env-toplevel env))) | |
156 | (variable-ref var-or-loc))))) | |
157 | ((,(typecode lexical-ref) depth . width) | |
158 | (lambda (env) | |
159 | (variable-ref (env-ref env depth width)))) | |
160 | (_ | |
161 | (let ((box (compile box))) | |
162 | (lambda (env) | |
163 | (variable-ref (box env))))))) | |
164 | ||
165 | (define (compile-resolve var-or-loc) | |
166 | (lambda (env) | |
167 | (cond | |
168 | ((variable? var-or-loc) var-or-loc) | |
169 | (else | |
170 | (set! var-or-loc (%resolve-variable var-or-loc (env-toplevel env))) | |
171 | var-or-loc)))) | |
172 | ||
173 | (define (compile-if test consequent alternate) | |
174 | (let ((test (compile test)) | |
175 | (consequent (compile consequent)) | |
176 | (alternate (compile alternate))) | |
177 | (lambda (env) | |
178 | (if (test env) (consequent env) (alternate env))))) | |
179 | ||
180 | (define (compile-quote x) | |
181 | (lambda (env) x)) | |
182 | ||
183 | (define (compile-let inits body) | |
184 | (let ((body (compile body)) | |
185 | (width (vector-length inits))) | |
186 | (case width | |
187 | ((0) (lambda (env) | |
188 | (body (make-env* env)))) | |
189 | ((1) | |
190 | (let ((a (compile (vector-ref inits 0)))) | |
191 | (lambda (env) | |
192 | (body (make-env* env (a env)))))) | |
193 | ((2) | |
194 | (let ((a (compile (vector-ref inits 0))) | |
195 | (b (compile (vector-ref inits 1)))) | |
196 | (lambda (env) | |
197 | (body (make-env* env (a env) (b env)))))) | |
198 | ((3) | |
199 | (let ((a (compile (vector-ref inits 0))) | |
200 | (b (compile (vector-ref inits 1))) | |
201 | (c (compile (vector-ref inits 2)))) | |
202 | (lambda (env) | |
203 | (body (make-env* env (a env) (b env) (c env)))))) | |
204 | ((4) | |
205 | (let ((a (compile (vector-ref inits 0))) | |
206 | (b (compile (vector-ref inits 1))) | |
207 | (c (compile (vector-ref inits 2))) | |
208 | (d (compile (vector-ref inits 3)))) | |
209 | (lambda (env) | |
210 | (body (make-env* env (a env) (b env) (c env) (d env)))))) | |
211 | (else | |
212 | (let lp ((n width) | |
213 | (k (lambda (env) | |
214 | (make-env width #f env)))) | |
215 | (if (zero? n) | |
216 | (lambda (env) | |
217 | (body (k env))) | |
218 | (lp (1- n) | |
219 | (let ((init (compile (vector-ref inits (1- n))))) | |
220 | (lambda (env) | |
221 | (let* ((x (init env)) | |
222 | (new-env (k env))) | |
223 | (env-set! new-env 0 (1- n) x) | |
224 | new-env)))))))))) | |
225 | ||
226 | (define (compile-fixed-lambda body nreq) | |
227 | (case nreq | |
228 | ((0) (lambda (env) | |
229 | (lambda () | |
230 | (body (make-env* env))))) | |
231 | ((1) (lambda (env) | |
232 | (lambda (a) | |
233 | (body (make-env* env a))))) | |
234 | ((2) (lambda (env) | |
235 | (lambda (a b) | |
236 | (body (make-env* env a b))))) | |
237 | ((3) (lambda (env) | |
238 | (lambda (a b c) | |
239 | (body (make-env* env a b c))))) | |
240 | ((4) (lambda (env) | |
241 | (lambda (a b c d) | |
242 | (body (make-env* env a b c d))))) | |
243 | ((5) (lambda (env) | |
244 | (lambda (a b c d e) | |
245 | (body (make-env* env a b c d e))))) | |
246 | ((6) (lambda (env) | |
247 | (lambda (a b c d e f) | |
248 | (body (make-env* env a b c d e f))))) | |
249 | ((7) (lambda (env) | |
250 | (lambda (a b c d e f g) | |
251 | (body (make-env* env a b c d e f g))))) | |
252 | (else | |
253 | (lambda (env) | |
254 | (lambda (a b c d e f g . more) | |
255 | (let ((env (make-env nreq #f env))) | |
256 | (env-set! env 0 0 a) | |
257 | (env-set! env 0 1 b) | |
258 | (env-set! env 0 2 c) | |
259 | (env-set! env 0 3 d) | |
260 | (env-set! env 0 4 e) | |
261 | (env-set! env 0 5 f) | |
262 | (env-set! env 0 6 g) | |
263 | (let lp ((n 7) (args more)) | |
264 | (cond | |
265 | ((= n nreq) | |
266 | (unless (null? args) | |
267 | (scm-error 'wrong-number-of-args | |
268 | "eval" "Wrong number of arguments" | |
269 | '() #f)) | |
270 | (body env)) | |
271 | ((null? args) | |
272 | (scm-error 'wrong-number-of-args | |
273 | "eval" "Wrong number of arguments" | |
274 | '() #f)) | |
275 | (else | |
276 | (env-set! env 0 n (car args)) | |
277 | (lp (1+ n) (cdr args))))))))))) | |
278 | ||
279 | (define (compile-rest-lambda body nreq rest?) | |
280 | (case nreq | |
281 | ((0) (lambda (env) | |
282 | (lambda rest | |
283 | (body (make-env* env rest))))) | |
284 | ((1) (lambda (env) | |
285 | (lambda (a . rest) | |
286 | (body (make-env* env a rest))))) | |
287 | ((2) (lambda (env) | |
288 | (lambda (a b . rest) | |
289 | (body (make-env* env a b rest))))) | |
290 | ((3) (lambda (env) | |
291 | (lambda (a b c . rest) | |
292 | (body (make-env* env a b c rest))))) | |
293 | (else | |
294 | (lambda (env) | |
295 | (lambda (a b c . more) | |
296 | (let ((env (make-env (1+ nreq) #f env))) | |
297 | (env-set! env 0 0 a) | |
298 | (env-set! env 0 1 b) | |
299 | (env-set! env 0 2 c) | |
300 | (let lp ((n 3) (args more)) | |
301 | (cond | |
302 | ((= n nreq) | |
303 | (env-set! env 0 n args) | |
304 | (body env)) | |
305 | ((null? args) | |
306 | (scm-error 'wrong-number-of-args | |
307 | "eval" "Wrong number of arguments" | |
308 | '() #f)) | |
309 | (else | |
310 | (env-set! env 0 n (car args)) | |
311 | (lp (1+ n) (cdr args))))))))))) | |
312 | ||
313 | (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt) | |
314 | (lambda (env) | |
315 | (define alt (and make-alt (make-alt env))) | |
316 | (lambda args | |
317 | (let ((nargs (length args))) | |
318 | (cond | |
319 | ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt)))) | |
320 | (if alt | |
321 | (apply alt args) | |
322 | ((scm-error 'wrong-number-of-args | |
323 | "eval" "Wrong number of arguments" | |
324 | '() #f)))) | |
325 | (else | |
326 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) | |
327 | (env (make-env nvals unbound env))) | |
328 | (define (bind-req args) | |
329 | (let lp ((i 0) (args args)) | |
330 | (cond | |
331 | ((< i nreq) | |
332 | ;; Bind required arguments. | |
333 | (env-set! env 0 i (car args)) | |
334 | (lp (1+ i) (cdr args))) | |
335 | (else | |
336 | (bind-opt args))))) | |
337 | (define (bind-opt args) | |
338 | (let lp ((i nreq) (args args)) | |
339 | (cond | |
340 | ((and (< i (+ nreq nopt)) (< i nargs)) | |
341 | (env-set! env 0 i (car args)) | |
342 | (lp (1+ i) (cdr args))) | |
343 | (else | |
344 | (bind-rest args))))) | |
345 | (define (bind-rest args) | |
346 | (when rest? | |
347 | (env-set! env 0 (+ nreq nopt) args)) | |
348 | (body env)) | |
349 | (bind-req args)))))))) | |
350 | ||
351 | (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) | |
352 | (define allow-other-keys? (car kw)) | |
353 | (define keywords (cdr kw)) | |
354 | (lambda (env) | |
355 | (define alt (and make-alt (make-alt env))) | |
356 | (lambda args | |
357 | (define (npositional args) | |
358 | (let lp ((n 0) (args args)) | |
359 | (if (or (null? args) | |
360 | (and (>= n nreq) (keyword? (car args)))) | |
361 | n | |
362 | (lp (1+ n) (cdr args))))) | |
363 | (let ((nargs (length args))) | |
364 | (cond | |
365 | ((or (< nargs nreq) | |
366 | (and alt (not rest?) (> (npositional args) (+ nreq nopt)))) | |
367 | (if alt | |
368 | (apply alt args) | |
369 | ((scm-error 'wrong-number-of-args | |
370 | "eval" "Wrong number of arguments" | |
371 | '() #f)))) | |
372 | (else | |
373 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) | |
374 | (env (make-env nvals unbound env))) | |
375 | (define (bind-req args) | |
376 | (let lp ((i 0) (args args)) | |
377 | (cond | |
378 | ((< i nreq) | |
379 | ;; Bind required arguments. | |
380 | (env-set! env 0 i (car args)) | |
381 | (lp (1+ i) (cdr args))) | |
382 | (else | |
383 | (bind-opt args))))) | |
384 | (define (bind-opt args) | |
385 | (let lp ((i nreq) (args args)) | |
386 | (cond | |
387 | ((and (< i (+ nreq nopt)) (< i nargs) | |
388 | (not (keyword? (car args)))) | |
389 | (env-set! env 0 i (car args)) | |
390 | (lp (1+ i) (cdr args))) | |
391 | (else | |
392 | (bind-rest args))))) | |
393 | (define (bind-rest args) | |
394 | (when rest? | |
395 | (env-set! env 0 (+ nreq nopt) args)) | |
396 | (bind-kw args)) | |
397 | (define (bind-kw args) | |
398 | (let lp ((args args)) | |
399 | (cond | |
400 | ((and (pair? args) (pair? (cdr args)) | |
401 | (keyword? (car args))) | |
402 | (let ((kw-pair (assq (car args) keywords)) | |
403 | (v (cadr args))) | |
404 | (if kw-pair | |
405 | ;; Found a known keyword; set its value. | |
406 | (env-set! env 0 (cdr kw-pair) v) | |
407 | ;; Unknown keyword. | |
408 | (if (not allow-other-keys?) | |
409 | ((scm-error | |
410 | 'keyword-argument-error | |
411 | "eval" "Unrecognized keyword" | |
412 | '() (list (car args)))))) | |
413 | (lp (cddr args)))) | |
414 | ((pair? args) | |
415 | (if rest? | |
416 | ;; Be lenient parsing rest args. | |
417 | (lp (cdr args)) | |
418 | ((scm-error 'keyword-argument-error | |
419 | "eval" "Invalid keyword" | |
420 | '() (list (car args)))))) | |
421 | (else | |
422 | (body env))))) | |
423 | (bind-req args)))))))) | |
424 | ||
425 | (define (compute-arity alt nreq rest? nopt kw) | |
426 | (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) | |
427 | (if (not alt) | |
428 | (let ((arglist (list nreq | |
429 | nopt | |
430 | (if kw (cdr kw) '()) | |
431 | (and kw (car kw)) | |
432 | (and rest? '_)))) | |
433 | (values arglist nreq nopt rest?)) | |
434 | (let* ((spec (cddr alt)) | |
435 | (nreq* (car spec)) | |
436 | (rest?* (if (null? (cdr spec)) #f (cadr spec))) | |
437 | (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) | |
438 | (nopt* (if tail (car tail) 0)) | |
439 | (alt* (and tail (car (cddddr tail))))) | |
440 | (if (or (< nreq* nreq) | |
441 | (and (= nreq* nreq) | |
442 | (if rest? | |
443 | (and rest?* (> nopt* nopt)) | |
444 | (or rest?* (> nopt* nopt))))) | |
445 | (lp alt* nreq* nopt* rest?*) | |
446 | (lp alt* nreq nopt rest?)))))) | |
447 | ||
448 | (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt) | |
449 | (call-with-values | |
450 | (lambda () | |
451 | (compute-arity alt nreq rest? nopt kw)) | |
452 | (lambda (arglist min-nreq min-nopt min-rest?) | |
453 | (define make-alt | |
454 | (match alt | |
455 | (#f #f) | |
456 | ((body meta nreq . tail) | |
457 | (compile-lambda body meta nreq tail)))) | |
458 | (define make-closure | |
459 | (if kw | |
460 | (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) | |
461 | (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt))) | |
462 | (lambda (env) | |
463 | (let ((proc (make-closure env))) | |
464 | (set-procedure-property! proc 'arglist arglist) | |
465 | (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?) | |
466 | proc))))) | |
467 | ||
468 | (define (compile-lambda body meta nreq tail) | |
469 | (define (set-procedure-meta meta proc) | |
470 | (match meta | |
471 | (() proc) | |
472 | (((prop . val) . meta) | |
473 | (set-procedure-meta meta | |
474 | (lambda (env) | |
475 | (let ((proc (proc env))) | |
476 | (set-procedure-property! proc prop val) | |
477 | proc)))))) | |
478 | (let ((body (compile body))) | |
479 | (set-procedure-meta | |
480 | meta | |
481 | (match tail | |
482 | (() (compile-fixed-lambda body nreq)) | |
483 | ((rest? . tail) | |
484 | (match tail | |
485 | (() (compile-rest-lambda body nreq rest?)) | |
486 | ((nopt kw ninits unbound alt) | |
487 | (compile-general-lambda body nreq rest? nopt kw | |
488 | ninits unbound alt)))))))) | |
489 | ||
490 | (define (compile-capture-env locs body) | |
491 | (let ((body (compile body))) | |
492 | (lambda (env) | |
493 | (let* ((len (vector-length locs)) | |
494 | (new-env (make-env len #f (env-toplevel env)))) | |
495 | (let lp ((n 0)) | |
496 | (when (< n len) | |
497 | (match (vector-ref locs n) | |
498 | ((depth . width) | |
499 | (env-set! new-env 0 n (env-ref env depth width)))) | |
500 | (lp (1+ n)))) | |
501 | (body new-env))))) | |
502 | ||
503 | (define (compile-seq head tail) | |
504 | (let ((head (compile head)) | |
505 | (tail (compile tail))) | |
506 | (lambda (env) | |
507 | (head env) | |
508 | (tail env)))) | |
509 | ||
510 | (define (compile-box-set! box val) | |
511 | (let ((box (compile box)) | |
512 | (val (compile val))) | |
513 | (lambda (env) | |
514 | (let ((val (val env))) | |
515 | (variable-set! (box env) val))))) | |
516 | ||
517 | (define (compile-lexical-set! depth width x) | |
518 | (let ((x (compile x))) | |
519 | (lambda (env) | |
520 | (env-set! env depth width (x env))))) | |
521 | ||
522 | (define (compile-call-with-values producer consumer) | |
523 | (let ((producer (compile producer)) | |
524 | (consumer (compile consumer))) | |
525 | (lambda (env) | |
526 | (call-with-values (producer env) | |
527 | (consumer env))))) | |
528 | ||
529 | (define (compile-apply f args) | |
530 | (let ((f (compile f)) | |
531 | (args (compile args))) | |
532 | (lambda (env) | |
533 | (apply (f env) (args env))))) | |
534 | ||
535 | (define (compile-capture-module x) | |
536 | (let ((x (compile x))) | |
537 | (lambda (env) | |
538 | (x (current-module))))) | |
539 | ||
540 | (define (compile-call-with-prompt tag thunk handler) | |
541 | (let ((tag (compile tag)) | |
542 | (thunk (compile thunk)) | |
543 | (handler (compile handler))) | |
544 | (lambda (env) | |
545 | (call-with-prompt (tag env) (thunk env) (handler env))))) | |
546 | ||
547 | (define (compile-call/cc proc) | |
548 | (let ((proc (compile proc))) | |
549 | (lambda (env) | |
550 | (call/cc (proc env))))) | |
551 | ||
552 | (define (compile exp) | |
553 | (match exp | |
554 | ((,(typecode lexical-ref) depth . width) | |
555 | (compile-lexical-ref depth width)) | |
556 | ||
557 | ((,(typecode call) f nargs . args) | |
558 | (compile-call f nargs args)) | |
559 | ||
560 | ((,(typecode box-ref) . box) | |
561 | (compile-box-ref box)) | |
5161a3c0 | 562 | |
95de4f52 AW |
563 | ((,(typecode resolve) . var-or-loc) |
564 | (compile-resolve var-or-loc)) | |
5161a3c0 | 565 | |
95de4f52 AW |
566 | ((,(typecode if) test consequent . alternate) |
567 | (compile-if test consequent alternate)) | |
21ec0bd9 | 568 | |
95de4f52 AW |
569 | ((,(typecode quote) . x) |
570 | (compile-quote x)) | |
571 | ||
572 | ((,(typecode let) inits . body) | |
573 | (compile-let inits body)) | |
574 | ||
575 | ((,(typecode lambda) body meta nreq . tail) | |
576 | (compile-lambda body meta nreq tail)) | |
577 | ||
578 | ((,(typecode capture-env) locs . body) | |
579 | (compile-capture-env locs body)) | |
580 | ||
581 | ((,(typecode seq) head . tail) | |
582 | (compile-seq head tail)) | |
583 | ||
584 | ((,(typecode box-set!) box . val) | |
585 | (compile-box-set! box val)) | |
586 | ||
587 | ((,(typecode lexical-set!) (depth . width) . x) | |
588 | (compile-lexical-set! depth width x)) | |
589 | ||
590 | ((,(typecode call-with-values) producer . consumer) | |
591 | (compile-call-with-values producer consumer)) | |
592 | ||
593 | ((,(typecode apply) f args) | |
594 | (compile-apply f args)) | |
595 | ||
596 | ((,(typecode capture-module) . x) | |
597 | (compile-capture-module x)) | |
598 | ||
599 | ((,(typecode call-with-prompt) tag thunk . handler) | |
600 | (compile-call-with-prompt tag thunk handler)) | |
5161a3c0 | 601 | |
95de4f52 AW |
602 | ((,(typecode call/cc) . proc) |
603 | (compile-call/cc proc)))) | |
604 | ||
605 | (let ((proc (compile | |
606 | (memoize-expression | |
607 | (if (macroexpanded? exp) | |
608 | exp | |
609 | ((module-transformer (current-module)) exp))))) | |
610 | (env #f)) | |
611 | (proc env))) |