1 ;;; -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
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.
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.
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
24 ;;; Scheme eval, written in Scheme.
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").
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
40 (define (primitive-eval exp)
41 "Evaluate @var{exp} in the current module."
42 (define-syntax env-toplevel
50 (define-syntax make-env
53 (let ((v (make-vector (1+ n) init)))
54 (vector-set! v 0 next)
57 (define-syntax make-env*
60 (vector next init ...))))
62 (define-syntax env-ref
65 (let lp ((e env) (d depth))
67 (vector-ref e (1+ width))
68 (lp (vector-ref e 0) (1- d)))))))
70 (define-syntax env-set!
72 ((_ env depth width val)
73 (let lp ((e env) (d depth))
75 (vector-set! e (1+ width) val)
76 (lp (vector-ref e 0) (1- d)))))))
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 ...)))
82 (define-syntax expand-clauses
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))))))
89 (define-syntax expand-pattern
90 (syntax-rules (_ quote unquote ?)
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))
99 (let ((vx (car v)) (vy (cdr v)))
100 (expand-pattern vx x (expand-pattern vy y kt kf) kf))
102 ((_ v (? pred var) kt kf)
103 (if (pred v) (let ((var v)) kt) kf))
104 ((_ v #f kt kf) (if (eqv? v #f) kt kf))
105 ((_ v var kt kf) (let ((var v)) kt))))
107 (define-syntax typecode
111 (or (memoized-typecode (syntax->datum #'type))
112 (error "not a typecode" (syntax->datum #'type)))))))
114 (define-syntax-rule (lazy (arg ...) exp)
115 (letrec ((proc (lambda (arg ...)
121 (define (compile-lexical-ref depth width)
123 (env-ref env depth width)))
125 (define (compile-top-call cenv loc args)
126 (let* ((module (env-toplevel cenv))
127 (var (%resolve-variable loc module)))
128 (define (primitive=? name)
129 "Return true if VAR is the same as the primitive bound to NAME."
133 ((mod name* . public?) (eq? name* name))
135 ;; `module' can be #f if the module system was not yet
136 ;; booted when the environment was captured.
138 (eq? var (module-local-variable the-root-module name)))))))
139 (define-syntax-rule (maybe-primcall (prim ...) arg ...)
141 ((primitive=? 'prim) (lambda (env) (prim (arg env) ...)))
143 (else (lambda (env) ((variable-ref var) (arg env) ...)))))
146 (lambda (env) ((variable-ref var))))
148 (let ((a (compile a)))
150 (null? nil? pair? struct? string? vector? symbol?
151 keyword? variable? bitvector? char? zero?
152 1+ 1- car cdr lognot not vector-length
153 variable-ref string-length struct-vtable)
156 (let ((a (compile a))
159 (+ - * / eq? eqv? equal? = < > <= >=
160 ash logand logior logxor logtest logbit?
161 cons vector-ref struct-ref allocate-struct variable-set!)
164 (let ((a (compile a))
167 (maybe-primcall (vector-set! struct-set!) a b c)))
169 (let ((a (compile a))
172 (args (let lp ((args args))
175 (cons (compile (car args)) (lp (cdr args)))))))
177 (apply (variable-ref var) (a env) (b env) (c env)
178 (let lp ((args args))
181 (cons ((car args) env) (lp (cdr args))))))))))))
183 (define (compile-call f args)
185 ((,(typecode box-ref) . (,(typecode resolve) . loc))
186 (lazy (env) (compile-top-call env loc args)))
190 (let ((f (compile f)))
191 (lambda (env) ((f env)))))
193 (let ((f (compile f))
195 (lambda (env) ((f env) (a env)))))
197 (let ((f (compile f))
200 (lambda (env) ((f env) (a env) (b env)))))
202 (let ((f (compile f))
206 (lambda (env) ((f env) (a env) (b env) (c env)))))
208 (let ((f (compile f))
212 (args (let lp ((args args))
215 (cons (compile (car args)) (lp (cdr args)))))))
217 (apply (f env) (a env) (b env) (c env)
218 (let lp ((args args))
221 (cons ((car args) env) (lp (cdr args)))))))))))))
223 (define (compile-box-ref cenv box)
225 ((,(typecode resolve) . loc)
226 (let ((var (%resolve-variable loc (env-toplevel cenv))))
227 (lambda (env) (variable-ref var))))
228 ((,(typecode lexical-ref) depth . width)
230 (variable-ref (env-ref env depth width))))
232 (let ((box (compile box)))
234 (variable-ref (box env)))))))
236 (define (compile-resolve cenv loc)
237 (let ((var (%resolve-variable loc (env-toplevel cenv))))
240 (define (compile-if test consequent alternate)
241 (let ((test (compile test))
242 (consequent (compile consequent))
243 (alternate (compile alternate)))
245 (if (test env) (consequent env) (alternate env)))))
247 (define (compile-quote x)
250 (define (compile-let inits body)
251 (let ((body (compile body))
252 (width (vector-length inits)))
255 (body (make-env* env))))
257 (let ((a (compile (vector-ref inits 0))))
259 (body (make-env* env (a env))))))
261 (let ((a (compile (vector-ref inits 0)))
262 (b (compile (vector-ref inits 1))))
264 (body (make-env* env (a env) (b env))))))
266 (let ((a (compile (vector-ref inits 0)))
267 (b (compile (vector-ref inits 1)))
268 (c (compile (vector-ref inits 2))))
270 (body (make-env* env (a env) (b env) (c env))))))
272 (let ((a (compile (vector-ref inits 0)))
273 (b (compile (vector-ref inits 1)))
274 (c (compile (vector-ref inits 2)))
275 (d (compile (vector-ref inits 3))))
277 (body (make-env* env (a env) (b env) (c env) (d env))))))
281 (make-env width #f env))))
286 (let ((init (compile (vector-ref inits (1- n)))))
288 (let* ((x (init env))
290 (env-set! new-env 0 (1- n) x)
293 (define (compile-fixed-lambda body nreq)
297 (body (make-env* env)))))
300 (body (make-env* env a)))))
303 (body (make-env* env a b)))))
306 (body (make-env* env a b c)))))
309 (body (make-env* env a b c d)))))
312 (body (make-env* env a b c d e)))))
314 (lambda (a b c d e f)
315 (body (make-env* env a b c d e f)))))
317 (lambda (a b c d e f g)
318 (body (make-env* env a b c d e f g)))))
321 (lambda (a b c d e f g . more)
322 (let ((env (make-env nreq #f env)))
330 (let lp ((n 7) (args more))
334 (scm-error 'wrong-number-of-args
335 "eval" "Wrong number of arguments"
339 (scm-error 'wrong-number-of-args
340 "eval" "Wrong number of arguments"
343 (env-set! env 0 n (car args))
344 (lp (1+ n) (cdr args)))))))))))
346 (define (compile-rest-lambda body nreq rest?)
350 (body (make-env* env rest)))))
353 (body (make-env* env a rest)))))
356 (body (make-env* env a b rest)))))
358 (lambda (a b c . rest)
359 (body (make-env* env a b c rest)))))
362 (lambda (a b c . more)
363 (let ((env (make-env (1+ nreq) #f env)))
367 (let lp ((n 3) (args more))
370 (env-set! env 0 n args)
373 (scm-error 'wrong-number-of-args
374 "eval" "Wrong number of arguments"
377 (env-set! env 0 n (car args))
378 (lp (1+ n) (cdr args)))))))))))
380 (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
382 (define alt (and make-alt (make-alt env)))
384 (let ((nargs (length args)))
386 ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
389 ((scm-error 'wrong-number-of-args
390 "eval" "Wrong number of arguments"
393 (let* ((nvals (+ nreq (if rest? 1 0) ninits))
394 (env (make-env nvals unbound env)))
395 (define (bind-req args)
396 (let lp ((i 0) (args args))
399 ;; Bind required arguments.
400 (env-set! env 0 i (car args))
401 (lp (1+ i) (cdr args)))
404 (define (bind-opt args)
405 (let lp ((i nreq) (args args))
407 ((and (< i (+ nreq nopt)) (< i nargs))
408 (env-set! env 0 i (car args))
409 (lp (1+ i) (cdr args)))
412 (define (bind-rest args)
414 (env-set! env 0 (+ nreq nopt) args))
416 (bind-req args))))))))
418 (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
419 (define allow-other-keys? (car kw))
420 (define keywords (cdr kw))
422 (define alt (and make-alt (make-alt env)))
424 (define (npositional args)
425 (let lp ((n 0) (args args))
427 (and (>= n nreq) (keyword? (car args))))
429 (lp (1+ n) (cdr args)))))
430 (let ((nargs (length args)))
433 (and alt (not rest?) (> (npositional args) (+ nreq nopt))))
436 ((scm-error 'wrong-number-of-args
437 "eval" "Wrong number of arguments"
440 (let* ((nvals (+ nreq (if rest? 1 0) ninits))
441 (env (make-env nvals unbound env)))
442 (define (bind-req args)
443 (let lp ((i 0) (args args))
446 ;; Bind required arguments.
447 (env-set! env 0 i (car args))
448 (lp (1+ i) (cdr args)))
451 (define (bind-opt args)
452 (let lp ((i nreq) (args args))
454 ((and (< i (+ nreq nopt)) (< i nargs)
455 (not (keyword? (car args))))
456 (env-set! env 0 i (car args))
457 (lp (1+ i) (cdr args)))
460 (define (bind-rest args)
462 (env-set! env 0 (+ nreq nopt) args))
464 (define (bind-kw args)
465 (let lp ((args args))
467 ((and (pair? args) (pair? (cdr args))
468 (keyword? (car args)))
469 (let ((kw-pair (assq (car args) keywords))
472 ;; Found a known keyword; set its value.
473 (env-set! env 0 (cdr kw-pair) v)
475 (if (not allow-other-keys?)
477 'keyword-argument-error
478 "eval" "Unrecognized keyword"
479 '() (list (car args))))))
483 ;; Be lenient parsing rest args.
485 ((scm-error 'keyword-argument-error
486 "eval" "Invalid keyword"
487 '() (list (car args))))))
490 (bind-req args))))))))
492 (define (compute-arity alt nreq rest? nopt kw)
493 (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
495 (let ((arglist (list nreq
500 (values arglist nreq nopt rest?))
501 (let* ((spec (cddr alt))
503 (rest?* (if (null? (cdr spec)) #f (cadr spec)))
504 (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
505 (nopt* (if tail (car tail) 0))
506 (alt* (and tail (car (cddddr tail)))))
507 (if (or (< nreq* nreq)
510 (and rest?* (> nopt* nopt))
511 (or rest?* (> nopt* nopt)))))
512 (lp alt* nreq* nopt* rest?*)
513 (lp alt* nreq nopt rest?))))))
515 (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
518 (compute-arity alt nreq rest? nopt kw))
519 (lambda (arglist min-nreq min-nopt min-rest?)
523 ((body meta nreq . tail)
524 (compile-lambda body meta nreq tail))))
527 (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
528 (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
530 (let ((proc (make-closure env)))
531 (set-procedure-property! proc 'arglist arglist)
532 (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
535 (define (compile-lambda body meta nreq tail)
536 (define (set-procedure-meta meta proc)
539 (((prop . val) . meta)
540 (set-procedure-meta meta
542 (let ((proc (proc env)))
543 (set-procedure-property! proc prop val)
545 (let ((body (lazy (env) (compile body))))
549 (() (compile-fixed-lambda body nreq))
552 (() (compile-rest-lambda body nreq rest?))
553 ((nopt kw ninits unbound alt)
554 (compile-general-lambda body nreq rest? nopt kw
555 ninits unbound alt))))))))
557 (define (compile-capture-env locs body)
558 (let ((body (compile body)))
560 (let* ((len (vector-length locs))
561 (new-env (make-env len #f (env-toplevel env))))
564 (match (vector-ref locs n)
566 (env-set! new-env 0 n (env-ref env depth width))))
570 (define (compile-seq head tail)
571 (let ((head (compile head))
572 (tail (compile tail)))
577 (define (compile-box-set! box val)
578 (let ((box (compile box))
581 (let ((val (val env)))
582 (variable-set! (box env) val)))))
584 (define (compile-lexical-set! depth width x)
585 (let ((x (compile x)))
587 (env-set! env depth width (x env)))))
589 (define (compile-call-with-values producer consumer)
590 (let ((producer (compile producer))
591 (consumer (compile consumer)))
593 (call-with-values (producer env)
596 (define (compile-apply f args)
597 (let ((f (compile f))
598 (args (compile args)))
600 (apply (f env) (args env)))))
602 (define (compile-capture-module x)
603 (let ((x (compile x)))
605 (x (current-module)))))
607 (define (compile-call-with-prompt tag thunk handler)
608 (let ((tag (compile tag))
609 (thunk (compile thunk))
610 (handler (compile handler)))
612 (call-with-prompt (tag env) (thunk env) (handler env)))))
614 (define (compile-call/cc proc)
615 (let ((proc (compile proc)))
617 (call/cc (proc env)))))
619 (define (compile exp)
621 ((,(typecode lexical-ref) depth . width)
622 (compile-lexical-ref depth width))
624 ((,(typecode call) f . args)
625 (compile-call f args))
627 ((,(typecode box-ref) . box)
628 (lazy (env) (compile-box-ref env box)))
630 ((,(typecode resolve) . loc)
631 (lazy (env) (compile-resolve env loc)))
633 ((,(typecode if) test consequent . alternate)
634 (compile-if test consequent alternate))
636 ((,(typecode quote) . x)
639 ((,(typecode let) inits . body)
640 (compile-let inits body))
642 ((,(typecode lambda) body meta nreq . tail)
643 (compile-lambda body meta nreq tail))
645 ((,(typecode capture-env) locs . body)
646 (compile-capture-env locs body))
648 ((,(typecode seq) head . tail)
649 (compile-seq head tail))
651 ((,(typecode box-set!) box . val)
652 (compile-box-set! box val))
654 ((,(typecode lexical-set!) (depth . width) . x)
655 (compile-lexical-set! depth width x))
657 ((,(typecode call-with-values) producer . consumer)
658 (compile-call-with-values producer consumer))
660 ((,(typecode apply) f args)
661 (compile-apply f args))
663 ((,(typecode capture-module) . x)
664 (compile-capture-module x))
666 ((,(typecode call-with-prompt) tag thunk . handler)
667 (compile-call-with-prompt tag thunk handler))
669 ((,(typecode call/cc) . proc)
670 (compile-call/cc proc))))
674 (if (macroexpanded? exp)
676 ((module-transformer (current-module)) exp)))))