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 | ;;; | |
30 | ;;; Environments are represented as linked lists of the form (VAL ... . | |
31 | ;;; MOD). If MOD is #f, it means the environment was captured before | |
32 | ;;; modules were booted. If MOD is the literal value '(), we are | |
33 | ;;; evaluating at the top level, and so should track changes to the | |
34 | ;;; current module. | |
35 | ;;; | |
36 | ;;; Evaluate this in Emacs to make code indentation work right: | |
37 | ;;; | |
38 | ;;; (put 'memoized-expression-case 'scheme-indent-function 1) | |
5161a3c0 AW |
39 | ;;; |
40 | ||
41 | ;;; Code: | |
42 | ||
43 | \f | |
44 | ||
5161a3c0 | 45 | (eval-when (compile) |
cfc28c80 AW |
46 | (define-syntax env-toplevel |
47 | (syntax-rules () | |
48 | ((_ env) | |
49 | (let lp ((e env)) | |
50 | (if (vector? e) | |
51 | (lp (vector-ref e 0)) | |
52 | e))))) | |
53 | ||
54 | (define-syntax make-env | |
55 | (syntax-rules () | |
56 | ((_ n init next) | |
57 | (let ((v (make-vector (1+ n) init))) | |
58 | (vector-set! v 0 next) | |
59 | v)))) | |
60 | ||
61 | (define-syntax make-env* | |
62 | (syntax-rules () | |
63 | ((_ next init ...) | |
64 | (vector next init ...)))) | |
65 | ||
66 | (define-syntax env-ref | |
67 | (syntax-rules () | |
68 | ((_ env depth width) | |
69 | (let lp ((e env) (d depth)) | |
70 | (if (zero? d) | |
71 | (vector-ref e (1+ width)) | |
72 | (lp (vector-ref e 0) (1- d))))))) | |
73 | ||
74 | (define-syntax env-set! | |
75 | (syntax-rules () | |
76 | ((_ env depth width val) | |
77 | (let lp ((e env) (d depth)) | |
78 | (if (zero? d) | |
79 | (vector-set! e (1+ width) val) | |
80 | (lp (vector-ref e 0) (1- d))))))) | |
81 | ||
be6e40a1 AW |
82 | ;; For evaluating the initializers in a "let" expression. We have to |
83 | ;; evaluate the initializers before creating the environment rib, to | |
84 | ;; prevent continuation-related shenanigans; see | |
85 | ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a | |
86 | ;; deeper discussion. | |
87 | ;; | |
88 | ;; This macro will inline evaluation of the first N initializers. | |
89 | ;; That number N is indicated by the number of template arguments | |
90 | ;; passed to the macro. It's a bit nasty but it's flexible and | |
91 | ;; optimizes well. | |
92 | (define-syntax let-env-evaluator | |
93 | (syntax-rules () | |
94 | ((eval-and-make-env eval env (template ...)) | |
95 | (let () | |
96 | (define-syntax eval-and-make-env | |
97 | (syntax-rules () | |
98 | ((eval-and-make-env inits width (template ...) k) | |
99 | (let lp ((n (length '(template ...))) (vals '())) | |
100 | (if (eqv? n width) | |
101 | (let ((env (make-env n #f env))) | |
102 | (let lp ((n (1- n)) (vals vals)) | |
103 | (if (null? vals) | |
104 | (k env) | |
105 | (begin | |
106 | (env-set! env 0 n (car vals)) | |
107 | (lp (1- n) (cdr vals)))))) | |
108 | (lp (1+ n) | |
109 | (cons (eval (vector-ref inits n) env) vals))))) | |
110 | ((eval-and-make-env inits width (var (... ...)) k) | |
111 | (let ((n (length '(var (... ...))))) | |
112 | (if (eqv? n width) | |
113 | (k (make-env n #f env)) | |
114 | (let* ((x (eval (vector-ref inits n) env)) | |
115 | (k (lambda (env) | |
116 | (env-set! env 0 n x) | |
117 | (k env)))) | |
118 | (eval-and-make-env inits width (x var (... ...)) k))))))) | |
119 | (lambda (inits) | |
120 | (let ((width (vector-length inits)) | |
121 | (k (lambda (env) env))) | |
122 | (eval-and-make-env inits width () k))))))) | |
123 | ||
d8a071fc AW |
124 | ;; Fast case for procedures with fixed arities. |
125 | (define-syntax make-fixed-closure | |
4abb824c | 126 | (lambda (x) |
9331f91c | 127 | (define *max-static-argument-count* 8) |
4abb824c AW |
128 | (define (make-formals n) |
129 | (map (lambda (i) | |
130 | (datum->syntax | |
c438cd71 | 131 | x |
4abb824c AW |
132 | (string->symbol |
133 | (string (integer->char (+ (char->integer #\a) i)))))) | |
134 | (iota n))) | |
135 | (syntax-case x () | |
d8a071fc | 136 | ((_ eval nreq body env) (not (identifier? #'env)) |
4abb824c | 137 | #'(let ((e env)) |
d8a071fc AW |
138 | (make-fixed-closure eval nreq body e))) |
139 | ((_ eval nreq body env) | |
4abb824c AW |
140 | #`(case nreq |
141 | #,@(map (lambda (nreq) | |
142 | (let ((formals (make-formals nreq))) | |
143 | #`((#,nreq) | |
d8a071fc AW |
144 | (lambda (#,@formals) |
145 | (eval body | |
cfc28c80 | 146 | (make-env* env #,@formals)))))) |
4abb824c AW |
147 | (iota *max-static-argument-count*)) |
148 | (else | |
149 | #,(let ((formals (make-formals *max-static-argument-count*))) | |
150 | #`(lambda (#,@formals . more) | |
cfc28c80 AW |
151 | (let ((env (make-env nreq #f env))) |
152 | #,@(map (lambda (formal n) | |
153 | #`(env-set! env 0 #,n #,formal)) | |
154 | formals (iota (length formals))) | |
155 | (let lp ((i #,*max-static-argument-count*) | |
156 | (args more)) | |
157 | (cond | |
158 | ((= i nreq) | |
4abb824c | 159 | (eval body |
d8a071fc | 160 | (if (null? args) |
cfc28c80 | 161 | env |
d8a071fc AW |
162 | (scm-error 'wrong-number-of-args |
163 | "eval" "Wrong number of arguments" | |
cfc28c80 AW |
164 | '() #f)))) |
165 | ((null? args) | |
166 | (scm-error 'wrong-number-of-args | |
167 | "eval" "Wrong number of arguments" | |
168 | '() #f)) | |
169 | (else | |
170 | (env-set! env 0 i (car args)) | |
171 | (lp (1+ i) (cdr args)))))))))))))) | |
4abb824c | 172 | |
a4b64fa2 AW |
173 | ;; Fast case for procedures with fixed arities and a rest argument. |
174 | (define-syntax make-rest-closure | |
175 | (lambda (x) | |
176 | (define *max-static-argument-count* 3) | |
177 | (define (make-formals n) | |
178 | (map (lambda (i) | |
179 | (datum->syntax | |
180 | x | |
181 | (string->symbol | |
182 | (string (integer->char (+ (char->integer #\a) i)))))) | |
183 | (iota n))) | |
184 | (syntax-case x () | |
185 | ((_ eval nreq body env) (not (identifier? #'env)) | |
186 | #'(let ((e env)) | |
187 | (make-rest-closure eval nreq body e))) | |
188 | ((_ eval nreq body env) | |
189 | #`(case nreq | |
190 | #,@(map (lambda (nreq) | |
191 | (let ((formals (make-formals nreq))) | |
192 | #`((#,nreq) | |
193 | (lambda (#,@formals . rest) | |
194 | (eval body | |
cfc28c80 | 195 | (make-env* env #,@formals rest)))))) |
a4b64fa2 AW |
196 | (iota *max-static-argument-count*)) |
197 | (else | |
198 | #,(let ((formals (make-formals *max-static-argument-count*))) | |
199 | #`(lambda (#,@formals . more) | |
cfc28c80 AW |
200 | (let ((env (make-env (1+ nreq) #f env))) |
201 | #,@(map (lambda (formal n) | |
202 | #`(env-set! env 0 #,n #,formal)) | |
203 | formals (iota (length formals))) | |
204 | (let lp ((i #,*max-static-argument-count*) | |
205 | (args more)) | |
206 | (cond | |
207 | ((= i nreq) | |
208 | (env-set! env 0 nreq args) | |
209 | (eval body env)) | |
210 | ((null? args) | |
211 | (scm-error 'wrong-number-of-args | |
212 | "eval" "Wrong number of arguments" | |
213 | '() #f)) | |
214 | (else | |
215 | (env-set! env 0 i (car args)) | |
216 | (lp (1+ i) (cdr args)))))))))))))) | |
a4b64fa2 | 217 | |
9331f91c AW |
218 | (define-syntax call |
219 | (lambda (x) | |
220 | (define *max-static-call-count* 4) | |
221 | (syntax-case x () | |
222 | ((_ eval proc nargs args env) (identifier? #'env) | |
223 | #`(case nargs | |
224 | #,@(map (lambda (nargs) | |
225 | #`((#,nargs) | |
226 | (proc | |
227 | #,@(map | |
228 | (lambda (n) | |
229 | (let lp ((n n) (args #'args)) | |
230 | (if (zero? n) | |
231 | #`(eval (car #,args) env) | |
232 | (lp (1- n) #`(cdr #,args))))) | |
233 | (iota nargs))))) | |
234 | (iota *max-static-call-count*)) | |
235 | (else | |
236 | (apply proc | |
237 | #,@(map | |
238 | (lambda (n) | |
239 | (let lp ((n n) (args #'args)) | |
240 | (if (zero? n) | |
241 | #`(eval (car #,args) env) | |
242 | (lp (1- n) #`(cdr #,args))))) | |
243 | (iota *max-static-call-count*)) | |
244 | (let lp ((exps #,(let lp ((n *max-static-call-count*) | |
245 | (args #'args)) | |
246 | (if (zero? n) | |
247 | args | |
248 | (lp (1- n) #`(cdr #,args))))) | |
249 | (args '())) | |
250 | (if (null? exps) | |
251 | (reverse args) | |
252 | (lp (cdr exps) | |
253 | (cons (eval (car exps) env) args))))))))))) | |
254 | ||
b2b554ef AW |
255 | ;; This macro could be more straightforward if the compiler had better |
256 | ;; copy propagation. As it is we do some copy propagation by hand. | |
5161a3c0 AW |
257 | (define-syntax mx-bind |
258 | (lambda (x) | |
259 | (syntax-case x () | |
260 | ((_ data () body) | |
261 | #'body) | |
262 | ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b)) | |
263 | #'(let ((a (car data)) | |
264 | (b (cdr data))) | |
265 | body)) | |
266 | ((_ data (a . b) body) (identifier? #'a) | |
267 | #'(let ((a (car data)) | |
268 | (xb (cdr data))) | |
269 | (mx-bind xb b body))) | |
270 | ((_ data (a . b) body) | |
271 | #'(let ((xa (car data)) | |
272 | (xb (cdr data))) | |
273 | (mx-bind xa a (mx-bind xb b body)))) | |
274 | ((_ data v body) (identifier? #'v) | |
275 | #'(let ((v data)) | |
276 | body))))) | |
277 | ||
b2b554ef AW |
278 | ;; The resulting nested if statements will be an O(n) dispatch. Once |
279 | ;; we compile `case' effectively, this situation will improve. | |
5161a3c0 AW |
280 | (define-syntax mx-match |
281 | (lambda (x) | |
282 | (syntax-case x (quote) | |
283 | ((_ mx data tag) | |
284 | #'(error "what" mx)) | |
285 | ((_ mx data tag (('type pat) body) c* ...) | |
286 | #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type)) | |
287 | (error "not a typecode" #'type))) | |
288 | (mx-bind data pat body) | |
289 | (mx-match mx data tag c* ...)))))) | |
290 | ||
291 | (define-syntax memoized-expression-case | |
292 | (lambda (x) | |
293 | (syntax-case x () | |
294 | ((_ mx c ...) | |
0720f70e AW |
295 | #'(let ((tag (car mx)) |
296 | (data (cdr mx))) | |
5161a3c0 AW |
297 | (mx-match mx data tag c ...))))))) |
298 | ||
299 | ||
21ec0bd9 AW |
300 | ;;; |
301 | ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression | |
302 | ;;; types occur when getting to a prompt on a fresh build. Here are the numbers | |
303 | ;;; I got: | |
304 | ;;; | |
305 | ;;; lexical-ref: 32933054 | |
306 | ;;; call: 20281547 | |
307 | ;;; toplevel-ref: 13228724 | |
308 | ;;; if: 9156156 | |
309 | ;;; quote: 6610137 | |
310 | ;;; let: 2619707 | |
311 | ;;; lambda: 1010921 | |
312 | ;;; begin: 948945 | |
313 | ;;; lexical-set: 509862 | |
314 | ;;; call-with-values: 139668 | |
315 | ;;; apply: 49402 | |
316 | ;;; module-ref: 14468 | |
317 | ;;; define: 1259 | |
318 | ;;; toplevel-set: 328 | |
21ec0bd9 AW |
319 | ;;; call/cc: 0 |
320 | ;;; module-set: 0 | |
321 | ;;; | |
322 | ;;; So until we compile `case' into a computed goto, we'll order the clauses in | |
323 | ;;; `eval' in this order, to put the most frequent cases first. | |
324 | ;;; | |
325 | ||
5161a3c0 AW |
326 | (define primitive-eval |
327 | (let () | |
a4b64fa2 AW |
328 | ;; We pre-generate procedures with fixed arities, up to some number |
329 | ;; of arguments, and some rest arities; see make-fixed-closure and | |
330 | ;; make-rest-closure above. | |
d8a071fc | 331 | |
7572ee52 AW |
332 | ;; Procedures with rest, optional, or keyword arguments, potentially with |
333 | ;; multiple arities, as with case-lambda. | |
cfdc8416 AW |
334 | (define (make-general-closure env body nreq rest? nopt kw ninits unbound |
335 | alt) | |
7572ee52 | 336 | (define alt-proc |
27ecfd36 | 337 | (and alt ; (body meta nreq ...) |
dc3e203e | 338 | (let* ((body (car alt)) |
c438cd71 LC |
339 | (spec (cddr alt)) |
340 | (nreq (car spec)) | |
341 | (rest (if (null? (cdr spec)) #f (cadr spec))) | |
342 | (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) | |
dc3e203e AW |
343 | (nopt (if tail (car tail) 0)) |
344 | (kw (and tail (cadr tail))) | |
cfdc8416 AW |
345 | (ninits (if tail (caddr tail) 0)) |
346 | (unbound (and tail (cadddr tail))) | |
347 | (alt (and tail (car (cddddr tail))))) | |
348 | (make-general-closure env body nreq rest nopt kw ninits unbound | |
349 | alt)))) | |
f3cf9421 AW |
350 | (define (set-procedure-arity! proc) |
351 | (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) | |
352 | (if (not alt) | |
fc835b1b AW |
353 | (begin |
354 | (set-procedure-property! proc 'arglist | |
355 | (list nreq | |
356 | nopt | |
357 | (if kw (cdr kw) '()) | |
358 | (and kw (car kw)) | |
359 | (and rest? '_))) | |
360 | (set-procedure-minimum-arity! proc nreq nopt rest?)) | |
c438cd71 LC |
361 | (let* ((spec (cddr alt)) |
362 | (nreq* (car spec)) | |
363 | (rest?* (if (null? (cdr spec)) #f (cadr spec))) | |
364 | (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) | |
f3cf9421 | 365 | (nopt* (if tail (car tail) 0)) |
cfdc8416 | 366 | (alt* (and tail (car (cddddr tail))))) |
f3cf9421 AW |
367 | (if (or (< nreq* nreq) |
368 | (and (= nreq* nreq) | |
369 | (if rest? | |
370 | (and rest?* (> nopt* nopt)) | |
371 | (or rest?* (> nopt* nopt))))) | |
372 | (lp alt* nreq* nopt* rest?*) | |
373 | (lp alt* nreq nopt rest?))))) | |
374 | proc) | |
375 | (set-procedure-arity! | |
376 | (lambda %args | |
cfc28c80 AW |
377 | (define (npositional args) |
378 | (let lp ((n 0) (args args)) | |
379 | (if (or (null? args) | |
380 | (and (>= n nreq) (keyword? (car args)))) | |
381 | n | |
382 | (lp (1+ n) (cdr args))))) | |
383 | (let ((nargs (length %args))) | |
384 | (cond | |
385 | ((or (< nargs nreq) | |
386 | (and (not kw) (not rest?) (> nargs (+ nreq nopt))) | |
6a59420a | 387 | (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt)))) |
cfc28c80 AW |
388 | (if alt |
389 | (apply alt-proc %args) | |
390 | ((scm-error 'wrong-number-of-args | |
391 | "eval" "Wrong number of arguments" | |
392 | '() #f)))) | |
393 | (else | |
cfdc8416 AW |
394 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) |
395 | (env (make-env nvals unbound env))) | |
cfc28c80 AW |
396 | (let lp ((i 0) (args %args)) |
397 | (cond | |
398 | ((< i nreq) | |
399 | ;; Bind required arguments. | |
400 | (env-set! env 0 i (car args)) | |
401 | (lp (1+ i) (cdr args))) | |
402 | ((not kw) | |
403 | ;; Optional args (possibly), but no keyword args. | |
cfdc8416 | 404 | (let lp ((i i) (args args)) |
581f410f | 405 | (cond |
cfdc8416 AW |
406 | ((and (< i (+ nreq nopt)) (< i nargs)) |
407 | (env-set! env 0 i (car args)) | |
408 | (lp (1+ i) (cdr args))) | |
581f410f | 409 | (else |
cfc28c80 | 410 | (when rest? |
cfdc8416 | 411 | (env-set! env 0 (+ nreq nopt) args)) |
cfc28c80 AW |
412 | (eval body env))))) |
413 | (else | |
414 | ;; Optional args. As before, but stop at the first | |
415 | ;; keyword. | |
cfdc8416 | 416 | (let lp ((i i) (args args)) |
cfc28c80 | 417 | (cond |
cfdc8416 AW |
418 | ((and (< i (+ nreq nopt)) |
419 | (< i nargs) | |
420 | (not (keyword? (car args)))) | |
421 | (env-set! env 0 i (car args)) | |
422 | (lp (1+ i) (cdr args))) | |
cfc28c80 AW |
423 | (else |
424 | (when rest? | |
cfdc8416 | 425 | (env-set! env 0 (+ nreq nopt) args)) |
cfc28c80 | 426 | (let ((aok (car kw)) |
cfdc8416 | 427 | (kw (cdr kw))) |
581f410f AW |
428 | ;; Now scan args for keywords. |
429 | (let lp ((args args)) | |
cfc28c80 AW |
430 | (cond |
431 | ((and (pair? args) (pair? (cdr args)) | |
432 | (keyword? (car args))) | |
433 | (let ((kw-pair (assq (car args) kw)) | |
434 | (v (cadr args))) | |
435 | (if kw-pair | |
436 | ;; Found a known keyword; set its value. | |
437 | (env-set! env 0 (cdr kw-pair) v) | |
438 | ;; Unknown keyword. | |
439 | (if (not aok) | |
440 | ((scm-error | |
441 | 'keyword-argument-error | |
442 | "eval" "Unrecognized keyword" | |
443 | '() (list (car args)))))) | |
444 | (lp (cddr args)))) | |
445 | ((pair? args) | |
446 | (if rest? | |
447 | ;; Be lenient parsing rest args. | |
448 | (lp (cdr args)) | |
449 | ((scm-error 'keyword-argument-error | |
450 | "eval" "Invalid keyword" | |
451 | '() (list (car args)))))) | |
452 | (else | |
cfdc8416 AW |
453 | ;; Finally, eval the body. |
454 | (eval body env)))))))))))))))))) | |
d8a071fc | 455 | |
b2b554ef | 456 | ;; The "engine". EXP is a memoized expression. |
5161a3c0 AW |
457 | (define (eval exp env) |
458 | (memoized-expression-case exp | |
cfc28c80 AW |
459 | (('lexical-ref (depth . width)) |
460 | (env-ref env depth width)) | |
bb0c8157 | 461 | |
21ec0bd9 AW |
462 | (('call (f nargs . args)) |
463 | (let ((proc (eval f env))) | |
464 | (call eval proc nargs args env))) | |
465 | ||
466 | (('toplevel-ref var-or-sym) | |
467 | (variable-ref | |
468 | (if (variable? var-or-sym) | |
469 | var-or-sym | |
ef47c422 | 470 | (memoize-variable-access! exp (env-toplevel env))))) |
21ec0bd9 | 471 | |
5161a3c0 AW |
472 | (('if (test consequent . alternate)) |
473 | (if (eval test env) | |
474 | (eval consequent env) | |
475 | (eval alternate env))) | |
476 | ||
21ec0bd9 AW |
477 | (('quote x) |
478 | x) | |
479 | ||
5161a3c0 | 480 | (('let (inits . body)) |
be6e40a1 | 481 | (eval body ((let-env-evaluator eval env (_ _ _ _)) inits))) |
c438cd71 | 482 | |
27ecfd36 | 483 | (('lambda (body meta nreq . tail)) |
c438cd71 LC |
484 | (let ((proc |
485 | (if (null? tail) | |
ef47c422 | 486 | (make-fixed-closure eval nreq body env) |
d0d8a552 AW |
487 | (mx-bind |
488 | tail (rest? . tail) | |
489 | (if (null? tail) | |
490 | (make-rest-closure eval nreq body env) | |
491 | (mx-bind | |
cfdc8416 | 492 | tail (nopt kw ninits unbound alt) |
d0d8a552 | 493 | (make-general-closure env body nreq rest? |
cfdc8416 AW |
494 | nopt kw ninits unbound |
495 | alt))))))) | |
27ecfd36 AW |
496 | (let lp ((meta meta)) |
497 | (unless (null? meta) | |
498 | (set-procedure-property! proc (caar meta) (cdar meta)) | |
499 | (lp (cdr meta)))) | |
c438cd71 | 500 | proc)) |
d8a071fc | 501 | |
6fc3eae4 AW |
502 | (('seq (head . tail)) |
503 | (begin | |
504 | (eval head env) | |
505 | (eval tail env))) | |
506 | ||
cfc28c80 AW |
507 | (('lexical-set! ((depth . width) . x)) |
508 | (env-set! env depth width (eval x env))) | |
5161a3c0 | 509 | |
21ec0bd9 AW |
510 | (('call-with-values (producer . consumer)) |
511 | (call-with-values (eval producer env) | |
512 | (eval consumer env))) | |
513 | ||
514 | (('apply (f args)) | |
515 | (apply (eval f env) (eval args env))) | |
516 | ||
517 | (('module-ref var-or-spec) | |
5161a3c0 | 518 | (variable-ref |
21ec0bd9 AW |
519 | (if (variable? var-or-spec) |
520 | var-or-spec | |
521 | (memoize-variable-access! exp #f)))) | |
5161a3c0 | 522 | |
21ec0bd9 | 523 | (('define (name . x)) |
27ecfd36 AW |
524 | (begin |
525 | (define! name (eval x env)) | |
adb8054c | 526 | (if #f #f))) |
ef47c422 AW |
527 | |
528 | (('capture-module x) | |
529 | (eval x (current-module))) | |
530 | ||
5161a3c0 AW |
531 | (('toplevel-set! (var-or-sym . x)) |
532 | (variable-set! | |
533 | (if (variable? var-or-sym) | |
534 | var-or-sym | |
ef47c422 | 535 | (memoize-variable-access! exp (env-toplevel env))) |
5161a3c0 AW |
536 | (eval x env))) |
537 | ||
1773bc7d AW |
538 | (('call-with-prompt (tag thunk . handler)) |
539 | (call-with-prompt | |
540 | (eval tag env) | |
541 | (eval thunk env) | |
542 | (eval handler env))) | |
747022e4 | 543 | |
21ec0bd9 AW |
544 | (('call/cc proc) |
545 | (call/cc (eval proc env))) | |
5161a3c0 AW |
546 | |
547 | (('module-set! (x . var-or-spec)) | |
548 | (variable-set! | |
549 | (if (variable? var-or-spec) | |
550 | var-or-spec | |
551 | (memoize-variable-access! exp #f)) | |
552 | (eval x env))))) | |
553 | ||
b2b554ef | 554 | ;; primitive-eval |
5161a3c0 | 555 | (lambda (exp) |
b2b554ef | 556 | "Evaluate @var{exp} in the current module." |
5161a3c0 | 557 | (eval |
a310a1d1 AW |
558 | (memoize-expression |
559 | (if (macroexpanded? exp) | |
560 | exp | |
561 | ((module-transformer (current-module)) exp))) | |
ef47c422 | 562 | #f)))) |