X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/9b95f3ced4f4cc4c7d0ffa59c530a2e1a17a19fc..7fee63b947730fbafb073b08bee8eceb6a07c975:/module/ice-9/eval.scm

diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
dissimilarity index 90%
index f95bbe90a..f5bcc16b4 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,576 +1,708 @@
-;;; -*- mode: scheme; coding: utf-8; -*-
-
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-
-
-
-;;; Commentary:
-
-;;; Scheme eval, written in Scheme.
-;;;
-;;; Expressions are first expanded, by the syntax expander (i.e.
-;;; psyntax), then memoized into internal forms. The evaluator itself
-;;; only operates on the internal forms ("memoized expressions").
-;;;
-;;; Environments are represented as linked lists of the form (VAL ... .
-;;; MOD). If MOD is #f, it means the environment was captured before
-;;; modules were booted. If MOD is the literal value '(), we are
-;;; evaluating at the top level, and so should track changes to the
-;;; current module.
-;;;
-;;; Evaluate this in Emacs to make code indentation work right:
-;;;
-;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
-;;;
-
-;;; Code:
-
-
-
-(eval-when (compile)
-  (define-syntax env-toplevel
-    (syntax-rules ()
-      ((_ env)
-       (let lp ((e env))
-         (if (vector? e)
-             (lp (vector-ref e 0))
-             e)))))
-
-  (define-syntax make-env
-    (syntax-rules ()
-      ((_ n init next)
-       (let ((v (make-vector (1+ n) init)))
-         (vector-set! v 0 next)
-         v))))
-
-  (define-syntax make-env*
-    (syntax-rules ()
-      ((_ next init ...)
-       (vector next init ...))))
-
-  (define-syntax env-ref
-    (syntax-rules ()
-      ((_ env depth width)
-       (let lp ((e env) (d depth))
-         (if (zero? d)
-             (vector-ref e (1+ width))
-             (lp (vector-ref e 0) (1- d)))))))
-
-  (define-syntax env-set!
-    (syntax-rules ()
-      ((_ env depth width val)
-       (let lp ((e env) (d depth))
-         (if (zero? d)
-             (vector-set! e (1+ width) val)
-             (lp (vector-ref e 0) (1- d)))))))
-
-  ;; For evaluating the initializers in a "let" expression.  We have to
-  ;; evaluate the initializers before creating the environment rib, to
-  ;; prevent continuation-related shenanigans; see
-  ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
-  ;; deeper discussion.
-  ;;
-  ;; This macro will inline evaluation of the first N initializers.
-  ;; That number N is indicated by the number of template arguments
-  ;; passed to the macro.  It's a bit nasty but it's flexible and
-  ;; optimizes well.
-  (define-syntax let-env-evaluator
-    (syntax-rules ()
-      ((eval-and-make-env eval env (template ...))
-       (let ()
-         (define-syntax eval-and-make-env
-           (syntax-rules ()
-             ((eval-and-make-env inits width (template ...) k)
-              (let lp ((n (length '(template ...))) (vals '()))
-                (if (eqv? n width)
-                    (let ((env (make-env n #f env)))
-                      (let lp ((n (1- n)) (vals vals))
-                        (if (null? vals)
-                            (k env)
-                            (begin
-                              (env-set! env 0 n (car vals))
-                              (lp (1- n) (cdr vals))))))
-                    (lp (1+ n)
-                        (cons (eval (vector-ref inits n) env) vals)))))
-             ((eval-and-make-env inits width (var (... ...)) k)
-              (let ((n (length '(var (... ...)))))
-                (if (eqv? n width)
-                    (k (make-env n #f env))
-                    (let* ((x (eval (vector-ref inits n) env))
-                           (k (lambda (env)
-                                (env-set! env 0 n x)
-                                (k env))))
-                      (eval-and-make-env inits width (x var (... ...)) k)))))))
-         (lambda (inits)
-           (let ((width (vector-length inits))
-                 (k (lambda (env) env)))
-             (eval-and-make-env inits width () k)))))))
-
-  ;; Fast case for procedures with fixed arities.
-  (define-syntax make-fixed-closure
-    (lambda (x)
-      (define *max-static-argument-count* 8)
-      (define (make-formals n)
-        (map (lambda (i)
-               (datum->syntax
-                x
-                (string->symbol
-                 (string (integer->char (+ (char->integer #\a) i))))))
-             (iota n)))
-      (syntax-case x ()
-        ((_ eval nreq body env) (not (identifier? #'env))
-         #'(let ((e env))
-             (make-fixed-closure eval nreq body e)))
-        ((_ eval nreq body env)
-         #`(case nreq
-             #,@(map (lambda (nreq)
-                       (let ((formals (make-formals nreq)))
-                         #`((#,nreq)
-                            (lambda (#,@formals)
-                              (eval body
-                                    (make-env* env #,@formals))))))
-                     (iota *max-static-argument-count*))
-             (else
-              #,(let ((formals (make-formals *max-static-argument-count*)))
-                  #`(lambda (#,@formals . more)
-                      (let ((env (make-env nreq #f env)))
-                        #,@(map (lambda (formal n)
-                                  #`(env-set! env 0 #,n #,formal))
-                                formals (iota (length formals)))
-                        (let lp ((i #,*max-static-argument-count*)
-                                 (args more))
-                          (cond
-                           ((= i nreq)
-                            (eval body
-                                  (if (null? args)
-                                      env
-                                      (scm-error 'wrong-number-of-args
-                                                 "eval" "Wrong number of arguments"
-                                                 '() #f))))
-                           ((null? args)
-                            (scm-error 'wrong-number-of-args
-                                       "eval" "Wrong number of arguments"
-                                       '() #f))
-                           (else
-                            (env-set! env 0 i (car args))
-                            (lp (1+ i) (cdr args))))))))))))))
-
-  ;; Fast case for procedures with fixed arities and a rest argument.
-  (define-syntax make-rest-closure
-    (lambda (x)
-      (define *max-static-argument-count* 3)
-      (define (make-formals n)
-        (map (lambda (i)
-               (datum->syntax
-                x
-                (string->symbol
-                 (string (integer->char (+ (char->integer #\a) i))))))
-             (iota n)))
-      (syntax-case x ()
-        ((_ eval nreq body env) (not (identifier? #'env))
-         #'(let ((e env))
-             (make-rest-closure eval nreq body e)))
-        ((_ eval nreq body env)
-         #`(case nreq
-             #,@(map (lambda (nreq)
-                       (let ((formals (make-formals nreq)))
-                         #`((#,nreq)
-                            (lambda (#,@formals . rest)
-                              (eval body
-                                    (make-env* env #,@formals rest))))))
-                     (iota *max-static-argument-count*))
-             (else
-              #,(let ((formals (make-formals *max-static-argument-count*)))
-                  #`(lambda (#,@formals . more)
-                      (let ((env (make-env (1+ nreq) #f env)))
-                        #,@(map (lambda (formal n)
-                                  #`(env-set! env 0 #,n #,formal))
-                                formals (iota (length formals)))
-                        (let lp ((i #,*max-static-argument-count*)
-                                 (args more))
-                          (cond
-                           ((= i nreq)
-                            (env-set! env 0 nreq args)
-                            (eval body env))
-                           ((null? args)
-                            (scm-error 'wrong-number-of-args
-                                       "eval" "Wrong number of arguments"
-                                       '() #f))
-                           (else
-                            (env-set! env 0 i (car args))
-                            (lp (1+ i) (cdr args))))))))))))))
-
-  (define-syntax call
-    (lambda (x)
-      (define *max-static-call-count* 4)
-      (syntax-case x ()
-        ((_ eval proc nargs args env) (identifier? #'env)
-         #`(case nargs
-             #,@(map (lambda (nargs)
-                       #`((#,nargs)
-                          (proc
-                           #,@(map
-                               (lambda (n)
-                                 (let lp ((n n) (args #'args))
-                                   (if (zero? n)
-                                       #`(eval (car #,args) env)
-                                       (lp (1- n) #`(cdr #,args)))))
-                               (iota nargs)))))
-                     (iota *max-static-call-count*))
-             (else
-              (apply proc
-                     #,@(map
-                         (lambda (n)
-                           (let lp ((n n) (args #'args))
-                             (if (zero? n)
-                                 #`(eval (car #,args) env)
-                                 (lp (1- n) #`(cdr #,args)))))
-                         (iota *max-static-call-count*))
-                     (let lp ((exps #,(let lp ((n *max-static-call-count*)
-                                               (args #'args))
-                                        (if (zero? n)
-                                            args
-                                            (lp (1- n) #`(cdr #,args)))))
-                              (args '()))
-                       (if (null? exps)
-                           (reverse args)
-                           (lp (cdr exps)
-                               (cons (eval (car exps) env) args)))))))))))
-
-  ;; This macro could be more straightforward if the compiler had better
-  ;; copy propagation. As it is we do some copy propagation by hand.
-  (define-syntax mx-bind
-    (lambda (x)
-      (syntax-case x ()
-        ((_ data () body)
-         #'body)
-        ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
-         #'(let ((a (car data))
-                 (b (cdr data)))
-             body))
-        ((_ data (a . b) body) (identifier? #'a)
-         #'(let ((a (car data))
-                 (xb (cdr data)))
-             (mx-bind xb b body)))
-        ((_ data (a . b) body) 
-         #'(let ((xa (car data))
-                 (xb (cdr data)))
-             (mx-bind xa a (mx-bind xb b body))))
-        ((_ data v body) (identifier? #'v)
-         #'(let ((v data))
-             body)))))
-  
-  ;; The resulting nested if statements will be an O(n) dispatch. Once
-  ;; we compile `case' effectively, this situation will improve.
-  (define-syntax mx-match
-    (lambda (x)
-      (syntax-case x (quote)
-        ((_ mx data tag)
-         #'(error "what" mx))
-        ((_ mx data tag (('type pat) body) c* ...)
-         #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
-                               (error "not a typecode" #'type)))
-               (mx-bind data pat body)
-               (mx-match mx data tag c* ...))))))
-
-  (define-syntax memoized-expression-case
-    (lambda (x)
-      (syntax-case x ()
-        ((_ mx c ...)
-         #'(let ((tag (car mx))
-                 (data (cdr mx)))
-             (mx-match mx data tag c ...)))))))
-
-
-;;;
-;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
-;;; types occur when getting to a prompt on a fresh build. Here are the numbers
-;;; I got:
-;;;
-;;;      lexical-ref: 32933054
-;;;             call: 20281547
-;;;     toplevel-ref: 13228724
-;;;               if: 9156156
-;;;            quote: 6610137
-;;;              let: 2619707
-;;;           lambda: 1010921
-;;;            begin: 948945
-;;;      lexical-set: 509862
-;;; call-with-values: 139668
-;;;            apply: 49402
-;;;       module-ref: 14468
-;;;           define: 1259
-;;;     toplevel-set: 328
-;;;          call/cc: 0
-;;;       module-set: 0
-;;;
-;;; So until we compile `case' into a computed goto, we'll order the clauses in
-;;; `eval' in this order, to put the most frequent cases first.
-;;;
-
-(define primitive-eval
-  (let ()
-    ;; We pre-generate procedures with fixed arities, up to some number
-    ;; of arguments, and some rest arities; see make-fixed-closure and
-    ;; make-rest-closure above.
-
-    ;; A unique marker for unbound keywords.
-    (define unbound-arg (list 'unbound-arg))
-
-    ;; Procedures with rest, optional, or keyword arguments, potentially with
-    ;; multiple arities, as with case-lambda.
-    (define (make-general-closure env body nreq rest? nopt kw inits alt)
-      (define alt-proc
-        (and alt                        ; (body meta nreq ...)
-             (let* ((body (car alt))
-                    (spec (cddr alt))
-                    (nreq (car spec))
-                    (rest (if (null? (cdr spec)) #f (cadr spec)))
-                    (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
-                    (nopt (if tail (car tail) 0))
-                    (kw (and tail (cadr tail)))
-                    (inits (if tail (caddr tail) '()))
-                    (alt (and tail (cadddr tail))))
-               (make-general-closure env body nreq rest nopt kw inits alt))))
-      (define (set-procedure-arity! proc)
-        (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
-          (if (not alt)
-              (begin
-                (set-procedure-property! proc 'arglist
-                                         (list nreq
-                                               nopt
-                                               (if kw (cdr kw) '())
-                                               (and kw (car kw))
-                                               (and rest? '_)))
-                (set-procedure-minimum-arity! proc nreq nopt rest?))
-              (let* ((spec (cddr alt))
-                     (nreq* (car spec))
-                     (rest?* (if (null? (cdr spec)) #f (cadr spec)))
-                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
-                     (nopt* (if tail (car tail) 0))
-                     (alt* (and tail (cadddr tail))))
-                (if (or (< nreq* nreq)
-                        (and (= nreq* nreq)
-                             (if rest?
-                                 (and rest?* (> nopt* nopt))
-                                 (or rest?* (> nopt* nopt)))))
-                    (lp alt* nreq* nopt* rest?*)
-                    (lp alt* nreq nopt rest?)))))
-        proc)
-      (set-procedure-arity!
-       (lambda %args
-         (define (npositional args)
-           (let lp ((n 0) (args args))
-             (if (or (null? args)
-                     (and (>= n nreq) (keyword? (car args))))
-                 n
-                 (lp (1+ n) (cdr args)))))
-         (let ((nargs (length %args)))
-           (cond
-            ((or (< nargs nreq)
-                 (and (not kw) (not rest?) (> nargs (+ nreq nopt)))
-                 (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt))))
-             (if alt
-                 (apply alt-proc %args)
-                 ((scm-error 'wrong-number-of-args
-                             "eval" "Wrong number of arguments"
-                             '() #f))))
-            (else
-             (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
-                    (env (make-env nvals unbound-arg env)))
-               (let lp ((i 0) (args %args))
-                 (cond
-                  ((< i nreq)
-                   ;; Bind required arguments.
-                   (env-set! env 0 i (car args))
-                   (lp (1+ i) (cdr args)))
-                  ((not kw)
-                   ;; Optional args (possibly), but no keyword args.
-                   (let lp ((i i) (args args) (inits inits))
-                     (cond
-                      ((< i (+ nreq nopt))
-                       (cond
-                        ((< i nargs)
-                         (env-set! env 0 i (car args))
-                         (lp (1+ i) (cdr args) (cdr inits)))
-                        (else
-                         (env-set! env 0 i (eval (car inits) env))
-                         (lp (1+ i) args (cdr inits)))))
-                      (else
-                       (when rest?
-                         (env-set! env 0 i args))
-                       (eval body env)))))
-                  (else
-                   ;; Optional args.  As before, but stop at the first
-                   ;; keyword.
-                   (let lp ((i i) (args args) (inits inits))
-                     (cond
-                      ((< i (+ nreq nopt))
-                       (cond
-                        ((and (< i nargs) (not (keyword? (car args))))
-                         (env-set! env 0 i (car args))
-                         (lp (1+ i) (cdr args) (cdr inits)))
-                        (else
-                         (env-set! env 0 i (eval (car inits) env))
-                         (lp (1+ i) args (cdr inits)))))
-                      (else
-                       (when rest?
-                         (env-set! env 0 i args))
-                       (let ((aok (car kw))
-                             (kw (cdr kw))
-                             (kw-base (if rest? (1+ i) i)))
-                         ;; Now scan args for keywords.
-                         (let lp ((args args))
-                           (cond
-                            ((and (pair? args) (pair? (cdr args))
-                                  (keyword? (car args)))
-                             (let ((kw-pair (assq (car args) kw))
-                                   (v (cadr args)))
-                               (if kw-pair
-                                   ;; Found a known keyword; set its value.
-                                   (env-set! env 0 (cdr kw-pair) v)
-                                   ;; Unknown keyword.
-                                   (if (not aok)
-                                       ((scm-error
-                                         'keyword-argument-error
-                                         "eval" "Unrecognized keyword"
-                                         '() (list (car args))))))
-                               (lp (cddr args))))
-                            ((pair? args)
-                             (if rest?
-                                 ;; Be lenient parsing rest args.
-                                 (lp (cdr args))
-                                 ((scm-error 'keyword-argument-error
-                                             "eval" "Invalid keyword"
-                                             '() (list (car args))))))
-                            (else
-                             ;; Finished parsing keywords. Fill in
-                             ;; uninitialized kwargs by evalling init
-                             ;; expressions in their appropriate
-                             ;; environment.
-                             (let lp ((i kw-base) (inits inits))
-                               (cond
-                                ((pair? inits)
-                                 (when (eq? (env-ref env 0 i) unbound-arg)
-                                   (env-set! env 0 i (eval (car inits) env)))
-                                 (lp (1+ i) (cdr inits)))
-                                (else
-                                 ;; Finally, eval the body.
-                                 (eval body env)))))))))))))))))))))
-
-    ;; The "engine". EXP is a memoized expression.
-    (define (eval exp env)
-      (memoized-expression-case exp
-        (('lexical-ref (depth . width))
-         (env-ref env depth width))
-        
-        (('call (f nargs . args))
-         (let ((proc (eval f env)))
-           (call eval proc nargs args env)))
-        
-        (('toplevel-ref var-or-sym)
-         (variable-ref
-          (if (variable? var-or-sym)
-              var-or-sym
-              (memoize-variable-access! exp (env-toplevel env)))))
-
-        (('if (test consequent . alternate))
-         (if (eval test env)
-             (eval consequent env)
-             (eval alternate env)))
-      
-        (('quote x)
-         x)
-
-        (('let (inits . body))
-         (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
-
-        (('lambda (body meta nreq . tail))
-         (let ((proc
-                (if (null? tail)
-                    (make-fixed-closure eval nreq body env)
-                    (if (null? (cdr tail))
-                        (make-rest-closure eval nreq body env)
-                        (apply make-general-closure env body nreq tail)))))
-           (let lp ((meta meta))
-             (unless (null? meta)
-               (set-procedure-property! proc (caar meta) (cdar meta))
-               (lp (cdr meta))))
-           proc))
-
-        (('seq (head . tail))
-         (begin
-           (eval head env)
-           (eval tail env)))
-        
-        (('lexical-set! ((depth . width) . x))
-         (env-set! env depth width (eval x env)))
-        
-        (('call-with-values (producer . consumer))
-         (call-with-values (eval producer env)
-           (eval consumer env)))
-
-        (('apply (f args))
-         (apply (eval f env) (eval args env)))
-
-        (('module-ref var-or-spec)
-         (variable-ref
-          (if (variable? var-or-spec)
-              var-or-spec
-              (memoize-variable-access! exp #f))))
-
-        (('define (name . x))
-         (begin
-           (define! name (eval x env))
-           (if #f #f)))
-
-        (('capture-module x)
-         (eval x (current-module)))
-
-        (('toplevel-set! (var-or-sym . x))
-         (variable-set!
-          (if (variable? var-or-sym)
-              var-or-sym
-              (memoize-variable-access! exp (env-toplevel env)))
-          (eval x env)))
-      
-        (('call-with-prompt (tag thunk . handler))
-         (call-with-prompt
-          (eval tag env)
-          (eval thunk env)
-          (eval handler env)))
-        
-        (('call/cc proc)
-         (call/cc (eval proc env)))
-
-        (('module-set! (x . var-or-spec))
-         (variable-set!
-          (if (variable? var-or-spec)
-              var-or-spec
-              (memoize-variable-access! exp #f))
-          (eval x env)))))
-  
-    ;; primitive-eval
-    (lambda (exp)
-      "Evaluate @var{exp} in the current module."
-      (eval 
-       (memoize-expression 
-        (if (macroexpanded? exp)
-            exp
-            ((module-transformer (current-module)) exp)))
-       #f))))
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+
+;;; Commentary:
+
+;;; Scheme eval, written in Scheme.
+;;;
+;;; Expressions are first expanded, by the syntax expander (i.e.
+;;; psyntax), then memoized into internal forms. The evaluator itself
+;;; only operates on the internal forms ("memoized expressions").
+;;;
+;;; Environments are represented as a chain of vectors, linked through
+;;; their first elements.  The terminal element of an environment is the
+;;; module that was current when the outer lexical environment was
+;;; entered.
+;;;
+
+;;; Code:
+
+
+
+(define (primitive-eval exp)
+  "Evaluate @var{exp} in the current module."
+  (define-syntax env-toplevel
+    (syntax-rules ()
+      ((_ env)
+       (let lp ((e env))
+         (if (vector? e)
+             (lp (vector-ref e 0))
+             e)))))
+
+  (define-syntax make-env
+    (syntax-rules ()
+      ((_ n init next)
+       (let ((v (make-vector (1+ n) init)))
+         (vector-set! v 0 next)
+         v))))
+
+  (define-syntax make-env*
+    (syntax-rules ()
+      ((_ next init ...)
+       (vector next init ...))))
+
+  (define-syntax env-ref
+    (syntax-rules ()
+      ((_ env depth width)
+       (let lp ((e env) (d depth))
+         (if (zero? d)
+             (vector-ref e (1+ width))
+             (lp (vector-ref e 0) (1- d)))))))
+
+  (define-syntax env-set!
+    (syntax-rules ()
+      ((_ env depth width val)
+       (let lp ((e env) (d depth))
+         (if (zero? d)
+             (vector-set! e (1+ width) val)
+             (lp (vector-ref e 0) (1- d)))))))
+
+  ;; This is a modified version of Oleg Kiselyov's "pmatch".
+  (define-syntax-rule (match e cs ...)
+    (let ((v e)) (expand-clauses v cs ...)))
+
+  (define-syntax expand-clauses
+    (syntax-rules ()
+      ((_ v) ((error "unreachable")))
+      ((_ v (pat e0 e ...) cs ...)
+       (let ((fk (lambda () (expand-clauses v cs ...))))
+         (expand-pattern v pat (let () e0 e ...) (fk))))))
+
+  (define-syntax expand-pattern
+    (syntax-rules (_ quote unquote ?)
+      ((_ v _ kt kf) kt)
+      ((_ v () kt kf) (if (null? v) kt kf))
+      ((_ v (quote lit) kt kf)
+       (if (equal? v (quote lit)) kt kf))
+      ((_ v (unquote exp) kt kf)
+       (if (equal? v exp) kt kf))
+      ((_ v (x . y) kt kf)
+       (if (pair? v)
+           (let ((vx (car v)) (vy (cdr v)))
+             (expand-pattern vx x (expand-pattern vy y kt kf) kf))
+           kf))
+      ((_ v (? pred var) kt kf)
+       (if (pred v) (let ((var v)) kt) kf))
+      ((_ v #f kt kf) (if (eqv? v #f) kt kf))
+      ((_ v var kt kf) (let ((var v)) kt))))
+
+  (define-syntax typecode
+    (lambda (x)
+      (syntax-case x ()
+        ((_ type)
+         (or (memoized-typecode (syntax->datum #'type))
+             (error "not a typecode" (syntax->datum #'type)))))))
+
+  (define-syntax-rule (lazy (arg ...) exp)
+    (letrec ((proc (lambda (arg ...)
+                     (set! proc exp)
+                     (proc arg ...))))
+      (lambda (arg ...)
+        (proc arg ...))))
+
+  (define (compile-lexical-ref depth width)
+    (lambda (env)
+      (env-ref env depth width)))
+
+  (define (primitive=? name loc module var)
+    "Return true if VAR is the same as the primitive bound to NAME."
+    (match loc
+      ((mode . loc)
+       (and (match loc
+              ((mod name* . public?) (eq? name* name))
+              (_ (eq? loc name)))
+            ;; `module' can be #f if the module system was not yet
+            ;; booted when the environment was captured.
+            (or (not module)
+                (eq? var (module-local-variable the-root-module name)))))))
+
+  (define (compile-top-call cenv loc args)
+    (let* ((module (env-toplevel cenv))
+           (var (%resolve-variable loc module)))
+      (define-syntax-rule (maybe-primcall (prim ...) arg ...)
+        (let ((arg (compile arg))
+              ...)
+          (cond
+           ((primitive=? 'prim loc module var)
+            (lambda (env) (prim (arg env) ...)))
+           ...
+           (else (lambda (env) ((variable-ref var) (arg env) ...))))))
+      (match args
+        (()
+         (lambda (env) ((variable-ref var))))
+        ((a)
+         (maybe-primcall (1+ 1- car cdr lognot vector-length
+                          variable-ref string-length struct-vtable)
+                         a))
+        ((a b)
+         (maybe-primcall (+ - * / ash logand logior logxor
+                          cons vector-ref struct-ref allocate-struct variable-set!)
+                         a b))
+        ((a b c)
+         (maybe-primcall (vector-set! struct-set!) a b c))
+        ((a b c . args)
+         (let ((a (compile a))
+               (b (compile b))
+               (c (compile c))
+               (args (let lp ((args args))
+                       (if (null? args)
+                           '()
+                           (cons (compile (car args)) (lp (cdr args)))))))
+           (lambda (env)
+             (apply (variable-ref var) (a env) (b env) (c env)
+                    (let lp ((args args))
+                      (if (null? args)
+                          '()
+                          (cons ((car args) env) (lp (cdr args))))))))))))
+
+  (define (compile-call f args)
+    (match f
+      ((,(typecode box-ref) . (,(typecode resolve) . loc))
+       (lazy (env) (compile-top-call env loc args)))
+      (_
+       (match args
+         (()
+          (let ((f (compile f)))
+            (lambda (env) ((f env)))))
+         ((a)
+          (let ((f (compile f))
+                (a (compile a)))
+            (lambda (env) ((f env) (a env)))))
+         ((a b)
+          (let ((f (compile f))
+                (a (compile a))
+                (b (compile b)))
+            (lambda (env) ((f env) (a env) (b env)))))
+         ((a b c)
+          (let ((f (compile f))
+                (a (compile a))
+                (b (compile b))
+                (c (compile c)))
+            (lambda (env) ((f env) (a env) (b env) (c env)))))
+         ((a b c . args)
+          (let ((f (compile f))
+                (a (compile a))
+                (b (compile b))
+                (c (compile c))
+                (args (let lp ((args args))
+                        (if (null? args)
+                            '()
+                            (cons (compile (car args)) (lp (cdr args)))))))
+            (lambda (env)
+              (apply (f env) (a env) (b env) (c env)
+                     (let lp ((args args))
+                       (if (null? args)
+                           '()
+                           (cons ((car args) env) (lp (cdr args)))))))))))))
+
+  (define (compile-box-ref cenv box)
+    (match box
+      ((,(typecode resolve) . loc)
+       (let ((var (%resolve-variable loc (env-toplevel cenv))))
+         (lambda (env) (variable-ref var))))
+      ((,(typecode lexical-ref) depth . width)
+       (lambda (env)
+         (variable-ref (env-ref env depth width))))
+      (_
+       (let ((box (compile box)))
+         (lambda (env)
+           (variable-ref (box env)))))))
+
+  (define (compile-resolve cenv loc)
+    (let ((var (%resolve-variable loc (env-toplevel cenv))))
+      (lambda (env) var)))
+
+  (define (compile-top-branch cenv loc args consequent alternate)
+    (let* ((module (env-toplevel cenv))
+           (var (%resolve-variable loc module))
+           (consequent (compile consequent))
+           (alternate (compile alternate)))
+      (define (generic-top-branch)
+        (let ((test (compile-top-call cenv loc args)))
+          (lambda (env)
+            (if (test env) (consequent env) (alternate env)))))
+      (define-syntax-rule (maybe-primcall (prim ...) arg ...)
+        (cond
+         ((primitive=? 'prim loc module var)
+          (let ((arg (compile arg))
+                ...)
+            (lambda (env)
+              (if (prim (arg env) ...)
+                  (consequent env)
+                  (alternate env)))))
+         ...
+         (else (generic-top-branch))))
+      (match args
+        ((a)
+         (maybe-primcall (null? nil? pair? struct? string? vector? symbol?
+                          keyword? variable? bitvector? char? zero? not)
+                         a))
+        ((a b)
+         (maybe-primcall (eq? eqv? equal? = < > <= >= logtest logbit?)
+                         a b))
+        (_
+         (generic-top-branch)))))
+
+  (define (compile-if test consequent alternate)
+    (match test
+      ((,(typecode call)
+        (,(typecode box-ref) . (,(typecode resolve) . loc))
+        . args)
+       (lazy (env) (compile-top-branch env loc args consequent alternate)))
+      (_
+       (let ((test (compile test))
+             (consequent (compile consequent))
+             (alternate (compile alternate)))
+         (lambda (env)
+           (if (test env) (consequent env) (alternate env)))))))
+
+  (define (compile-quote x)
+    (lambda (env) x))
+
+  (define (compile-let inits body)
+    (let ((body (compile body))
+          (width (vector-length inits)))
+      (case width
+        ((0) (lambda (env)
+               (body (make-env* env))))
+        ((1)
+         (let ((a (compile (vector-ref inits 0))))
+           (lambda (env)
+             (body (make-env* env (a env))))))
+        ((2)
+         (let ((a (compile (vector-ref inits 0)))
+               (b (compile (vector-ref inits 1))))
+           (lambda (env)
+             (body (make-env* env (a env) (b env))))))
+        ((3)
+         (let ((a (compile (vector-ref inits 0)))
+               (b (compile (vector-ref inits 1)))
+               (c (compile (vector-ref inits 2))))
+           (lambda (env)
+             (body (make-env* env (a env) (b env) (c env))))))
+        ((4)
+         (let ((a (compile (vector-ref inits 0)))
+               (b (compile (vector-ref inits 1)))
+               (c (compile (vector-ref inits 2)))
+               (d (compile (vector-ref inits 3))))
+           (lambda (env)
+             (body (make-env* env (a env) (b env) (c env) (d env))))))
+        (else
+         (let lp ((n width)
+                  (k (lambda (env)
+                       (make-env width #f env))))
+           (if (zero? n)
+               (lambda (env)
+                 (body (k env)))
+               (lp (1- n)
+                   (let ((init (compile (vector-ref inits (1- n)))))
+                     (lambda (env)
+                       (let* ((x (init env))
+                              (new-env (k env)))
+                         (env-set! new-env 0 (1- n) x)
+                         new-env))))))))))
+
+  (define (compile-fixed-lambda body nreq)
+    (case nreq
+      ((0) (lambda (env)
+             (lambda ()
+               (body (make-env* env)))))
+      ((1) (lambda (env)
+             (lambda (a)
+               (body (make-env* env a)))))
+      ((2) (lambda (env)
+             (lambda (a b)
+               (body (make-env* env a b)))))
+      ((3) (lambda (env)
+             (lambda (a b c)
+               (body (make-env* env a b c)))))
+      ((4) (lambda (env)
+             (lambda (a b c d)
+               (body (make-env* env a b c d)))))
+      ((5) (lambda (env)
+             (lambda (a b c d e)
+               (body (make-env* env a b c d e)))))
+      ((6) (lambda (env)
+             (lambda (a b c d e f)
+               (body (make-env* env a b c d e f)))))
+      ((7) (lambda (env)
+             (lambda (a b c d e f g)
+               (body (make-env* env a b c d e f g)))))
+      (else
+       (lambda (env)
+         (lambda (a b c d e f g . more)
+           (let ((env (make-env nreq #f env)))
+             (env-set! env 0 0 a)
+             (env-set! env 0 1 b)
+             (env-set! env 0 2 c)
+             (env-set! env 0 3 d)
+             (env-set! env 0 4 e)
+             (env-set! env 0 5 f)
+             (env-set! env 0 6 g)
+             (let lp ((n 7) (args more))
+               (cond
+                ((= n nreq)
+                 (unless (null? args)
+                   (scm-error 'wrong-number-of-args
+                              "eval" "Wrong number of arguments"
+                              '() #f))
+                 (body env))
+                ((null? args)
+                 (scm-error 'wrong-number-of-args
+                            "eval" "Wrong number of arguments"
+                            '() #f))
+                (else
+                 (env-set! env 0 n (car args))
+                 (lp (1+ n) (cdr args)))))))))))
+
+  (define (compile-rest-lambda body nreq rest?)
+    (case nreq
+      ((0) (lambda (env)
+             (lambda rest
+               (body (make-env* env rest)))))
+      ((1) (lambda (env)
+             (lambda (a . rest)
+               (body (make-env* env a rest)))))
+      ((2) (lambda (env)
+             (lambda (a b . rest)
+               (body (make-env* env a b rest)))))
+      ((3) (lambda (env)
+             (lambda (a b c . rest)
+               (body (make-env* env a b c rest)))))
+      (else
+       (lambda (env)
+         (lambda (a b c . more)
+           (let ((env (make-env (1+ nreq) #f env)))
+             (env-set! env 0 0 a)
+             (env-set! env 0 1 b)
+             (env-set! env 0 2 c)
+             (let lp ((n 3) (args more))
+               (cond
+                ((= n nreq)
+                 (env-set! env 0 n args)
+                 (body env))
+                ((null? args)
+                 (scm-error 'wrong-number-of-args
+                            "eval" "Wrong number of arguments"
+                            '() #f))
+                (else
+                 (env-set! env 0 n (car args))
+                 (lp (1+ n) (cdr args)))))))))))
+
+  (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
+    (lambda (env)
+      (define alt (and make-alt (make-alt env)))
+      (lambda args
+        (let ((nargs (length args)))
+          (cond
+           ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
+            (if alt
+                (apply alt args)
+                ((scm-error 'wrong-number-of-args
+                            "eval" "Wrong number of arguments"
+                            '() #f))))
+           (else
+            (let* ((nvals (+ nreq (if rest? 1 0) ninits))
+                   (env (make-env nvals unbound env)))
+              (define (bind-req args)
+                (let lp ((i 0) (args args))
+                  (cond
+                   ((< i nreq)
+                    ;; Bind required arguments.
+                    (env-set! env 0 i (car args))
+                    (lp (1+ i) (cdr args)))
+                   (else
+                    (bind-opt args)))))
+              (define (bind-opt args)
+                (let lp ((i nreq) (args args))
+                  (cond
+                   ((and (< i (+ nreq nopt)) (< i nargs))
+                    (env-set! env 0 i (car args))
+                    (lp (1+ i) (cdr args)))
+                   (else
+                    (bind-rest args)))))
+              (define (bind-rest args)
+                (when rest?
+                  (env-set! env 0 (+ nreq nopt) args))
+                (body env))
+              (bind-req args))))))))
+
+  (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
+    (define allow-other-keys? (car kw))
+    (define keywords (cdr kw))
+    (lambda (env)
+      (define alt (and make-alt (make-alt env)))
+      (lambda args
+        (define (npositional args)
+          (let lp ((n 0) (args args))
+            (if (or (null? args)
+                    (and (>= n nreq) (keyword? (car args))))
+                n
+                (lp (1+ n) (cdr args)))))
+        (let ((nargs (length args)))
+          (cond
+           ((or (< nargs nreq)
+                (and alt (not rest?) (> (npositional args) (+ nreq nopt))))
+            (if alt
+                (apply alt args)
+                ((scm-error 'wrong-number-of-args
+                            "eval" "Wrong number of arguments"
+                            '() #f))))
+           (else
+            (let* ((nvals (+ nreq (if rest? 1 0) ninits))
+                   (env (make-env nvals unbound env)))
+              (define (bind-req args)
+                (let lp ((i 0) (args args))
+                  (cond
+                   ((< i nreq)
+                    ;; Bind required arguments.
+                    (env-set! env 0 i (car args))
+                    (lp (1+ i) (cdr args)))
+                   (else
+                    (bind-opt args)))))
+              (define (bind-opt args)
+                (let lp ((i nreq) (args args))
+                  (cond
+                   ((and (< i (+ nreq nopt)) (< i nargs)
+                         (not (keyword? (car args))))
+                    (env-set! env 0 i (car args))
+                    (lp (1+ i) (cdr args)))
+                   (else
+                    (bind-rest args)))))
+              (define (bind-rest args)
+                (when rest?
+                  (env-set! env 0 (+ nreq nopt) args))
+                (bind-kw args))
+              (define (bind-kw args)
+                (let lp ((args args))
+                  (cond
+                   ((and (pair? args) (pair? (cdr args))
+                         (keyword? (car args)))
+                    (let ((kw-pair (assq (car args) keywords))
+                          (v (cadr args)))
+                      (if kw-pair
+                          ;; Found a known keyword; set its value.
+                          (env-set! env 0 (cdr kw-pair) v)
+                          ;; Unknown keyword.
+                          (if (not allow-other-keys?)
+                              ((scm-error
+                                'keyword-argument-error
+                                "eval" "Unrecognized keyword"
+                                '() (list (car args))))))
+                      (lp (cddr args))))
+                   ((pair? args)
+                    (if rest?
+                        ;; Be lenient parsing rest args.
+                        (lp (cdr args))
+                        ((scm-error 'keyword-argument-error
+                                    "eval" "Invalid keyword"
+                                    '() (list (car args))))))
+                   (else
+                    (body env)))))
+              (bind-req args))))))))
+
+  (define (compute-arity alt nreq rest? nopt kw)
+    (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
+      (if (not alt)
+          (let ((arglist (list nreq
+                               nopt
+                               (if kw (cdr kw) '())
+                               (and kw (car kw))
+                               (and rest? '_))))
+            (values arglist nreq nopt rest?))
+          (let* ((spec (cddr alt))
+                 (nreq* (car spec))
+                 (rest?* (if (null? (cdr spec)) #f (cadr spec)))
+                 (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
+                 (nopt* (if tail (car tail) 0))
+                 (alt* (and tail (car (cddddr tail)))))
+            (if (or (< nreq* nreq)
+                    (and (= nreq* nreq)
+                         (if rest?
+                             (and rest?* (> nopt* nopt))
+                             (or rest?* (> nopt* nopt)))))
+                (lp alt* nreq* nopt* rest?*)
+                (lp alt* nreq nopt rest?))))))
+
+  (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
+    (call-with-values
+        (lambda ()
+          (compute-arity alt nreq rest? nopt kw))
+      (lambda (arglist min-nreq min-nopt min-rest?)
+        (define make-alt
+          (match alt
+            (#f #f)
+            ((body meta nreq . tail)
+             (compile-lambda body meta nreq tail))))
+        (define make-closure
+          (if kw
+              (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
+              (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
+        (lambda (env)
+          (let ((proc (make-closure env)))
+            (set-procedure-property! proc 'arglist arglist)
+            (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
+            proc)))))
+
+  (define (compile-lambda body meta nreq tail)
+    (define (set-procedure-meta meta proc)
+      (match meta
+        (() proc)
+        (((prop . val) . meta)
+         (set-procedure-meta meta
+                             (lambda (env)
+                               (let ((proc (proc env)))
+                                 (set-procedure-property! proc prop val)
+                                 proc))))))
+    (let ((body (lazy (env) (compile body))))
+      (set-procedure-meta
+       meta
+       (match tail
+         (() (compile-fixed-lambda body nreq))
+         ((rest? . tail)
+          (match tail
+            (() (compile-rest-lambda body nreq rest?))
+            ((nopt kw ninits unbound alt)
+             (compile-general-lambda body nreq rest? nopt kw
+                                     ninits unbound alt))))))))
+
+  (define (compile-capture-env locs body)
+    (let ((body (compile body)))
+      (lambda (env)
+        (let* ((len (vector-length locs))
+               (new-env (make-env len #f (env-toplevel env))))
+          (let lp ((n 0))
+            (when (< n len)
+              (match (vector-ref locs n)
+                ((depth . width)
+                 (env-set! new-env 0 n (env-ref env depth width))))
+              (lp (1+ n))))
+          (body new-env)))))
+
+  (define (compile-seq head tail)
+    (let ((head (compile head))
+          (tail (compile tail)))
+      (lambda (env)
+        (head env)
+        (tail env))))
+
+  (define (compile-box-set! box val)
+    (let ((box (compile box))
+          (val (compile val)))
+      (lambda (env)
+        (let ((val (val env)))
+          (variable-set! (box env) val)))))
+
+  (define (compile-lexical-set! depth width x)
+    (let ((x (compile x)))
+      (lambda (env)
+        (env-set! env depth width (x env)))))
+
+  (define (compile-call-with-values producer consumer)
+    (let ((producer (compile producer))
+          (consumer (compile consumer)))
+      (lambda (env)
+        (call-with-values (producer env)
+          (consumer env)))))
+
+  (define (compile-apply f args)
+    (let ((f (compile f))
+          (args (compile args)))
+      (lambda (env)
+        (apply (f env) (args env)))))
+
+  (define (compile-capture-module x)
+    (let ((x (compile x)))
+      (lambda (env)
+        (x (current-module)))))
+
+  (define (compile-call-with-prompt tag thunk handler)
+    (let ((tag (compile tag))
+          (thunk (compile thunk))
+          (handler (compile handler)))
+      (lambda (env)
+        (call-with-prompt (tag env) (thunk env) (handler env)))))
+
+  (define (compile-call/cc proc)
+    (let ((proc (compile proc)))
+      (lambda (env)
+        (call/cc (proc env)))))
+
+  (define (compile exp)
+    (match exp
+      ((,(typecode lexical-ref) depth . width)
+       (compile-lexical-ref depth width))
+      
+      ((,(typecode call) f . args)
+       (compile-call f args))
+      
+      ((,(typecode box-ref) . box)
+       (lazy (env) (compile-box-ref env box)))
+
+      ((,(typecode resolve) . loc)
+       (lazy (env) (compile-resolve env loc)))
+
+      ((,(typecode if) test consequent . alternate)
+       (compile-if test consequent alternate))
+
+      ((,(typecode quote) . x)
+       (compile-quote x))
+
+      ((,(typecode let) inits . body)
+       (compile-let inits body))
+
+      ((,(typecode lambda) body meta nreq . tail)
+       (compile-lambda body meta nreq tail))
+
+      ((,(typecode capture-env) locs . body)
+       (compile-capture-env locs body))
+
+      ((,(typecode seq) head . tail)
+       (compile-seq head tail))
+      
+      ((,(typecode box-set!) box . val)
+       (compile-box-set! box val))
+
+      ((,(typecode lexical-set!) (depth . width) . x)
+       (compile-lexical-set! depth width x))
+      
+      ((,(typecode call-with-values) producer . consumer)
+       (compile-call-with-values producer consumer))
+
+      ((,(typecode apply) f args)
+       (compile-apply f args))
+
+      ((,(typecode capture-module) . x)
+       (compile-capture-module x))
+
+      ((,(typecode call-with-prompt) tag thunk . handler)
+       (compile-call-with-prompt tag thunk handler))
+      
+      ((,(typecode call/cc) . proc)
+       (compile-call/cc proc))))
+
+  (let ((eval (compile
+               (memoize-expression
+                (if (macroexpanded? exp)
+                    exp
+                    ((module-transformer (current-module)) exp)))))
+        (env #f))
+    (eval env)))