module/ice-9/eval.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
   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
  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 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.
  34 ;;;
  35
  36 ;;; Code:
  37
  38 \f
  39
  40 (define (primitive-eval exp)
  41   "Evaluate @var{exp} in the current module."
  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
  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
  83     (syntax-rules ()
  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 (? 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))))
 106
 107   (define-syntax typecode
 108     (lambda (x)
 109       (syntax-case x ()
 110         ((_ type)
 111          (or (memoized-typecode (syntax->datum #'type))
 112              (error "not a typecode" (syntax->datum #'type)))))))
 113
 114   (define-syntax-rule (lazy (arg ...) exp)
 115     (letrec ((proc (lambda (arg ...)
 116                      (set! proc exp)
 117                      (proc arg ...))))
 118       (lambda (arg ...)
 119         (proc arg ...))))
 120
 121   (define (compile-lexical-ref depth width)
 122     (lambda (env)
 123       (env-ref env depth width)))
 124
 125   (define (primitive=? name loc module var)
 126     "Return true if VAR is the same as the primitive bound to NAME."
 127     (match loc
 128       ((mode . loc)
 129        (and (match loc
 130               ((mod name* . public?) (eq? name* name))
 131               (_ (eq? loc name)))
 132             ;; `module' can be #f if the module system was not yet
 133             ;; booted when the environment was captured.
 134             (or (not module)
 135                 (eq? var (module-local-variable the-root-module name)))))))
 136
 137   (define (compile-top-call cenv loc args)
 138     (let* ((module (env-toplevel cenv))
 139            (var (%resolve-variable loc module)))
 140       (define-syntax-rule (maybe-primcall (prim ...) arg ...)
 141         (let ((arg (compile arg))
 142               ...)
 143           (cond
 144            ((primitive=? 'prim loc module var)
 145             (lambda (env) (prim (arg env) ...)))
 146            ...
 147            (else (lambda (env) ((variable-ref var) (arg env) ...))))))
 148       (match args
 149         (()
 150          (lambda (env) ((variable-ref var))))
 151         ((a)
 152          (maybe-primcall (1+ 1- car cdr lognot vector-length
 153                           variable-ref string-length struct-vtable)
 154                          a))
 155         ((a b)
 156          (maybe-primcall (+ - * / ash logand logior logxor
 157                           cons vector-ref struct-ref allocate-struct variable-set!)
 158                          a b))
 159         ((a b c)
 160          (maybe-primcall (vector-set! struct-set!) a b c))
 161         ((a b c . args)
 162          (let ((a (compile a))
 163                (b (compile b))
 164                (c (compile c))
 165                (args (let lp ((args args))
 166                        (if (null? args)
 167                            '()
 168                            (cons (compile (car args)) (lp (cdr args)))))))
 169            (lambda (env)
 170              (apply (variable-ref var) (a env) (b env) (c env)
 171                     (let lp ((args args))
 172                       (if (null? args)
 173                           '()
 174                           (cons ((car args) env) (lp (cdr args))))))))))))
 175
 176   (define (compile-call f args)
 177     (match f
 178       ((,(typecode box-ref) . (,(typecode resolve) . loc))
 179        (lazy (env) (compile-top-call env loc args)))
 180       (_
 181        (match args
 182          (()
 183           (let ((f (compile f)))
 184             (lambda (env) ((f env)))))
 185          ((a)
 186           (let ((f (compile f))
 187                 (a (compile a)))
 188             (lambda (env) ((f env) (a env)))))
 189          ((a b)
 190           (let ((f (compile f))
 191                 (a (compile a))
 192                 (b (compile b)))
 193             (lambda (env) ((f env) (a env) (b env)))))
 194          ((a b c)
 195           (let ((f (compile f))
 196                 (a (compile a))
 197                 (b (compile b))
 198                 (c (compile c)))
 199             (lambda (env) ((f env) (a env) (b env) (c env)))))
 200          ((a b c . args)
 201           (let ((f (compile f))
 202                 (a (compile a))
 203                 (b (compile b))
 204                 (c (compile c))
 205                 (args (let lp ((args args))
 206                         (if (null? args)
 207                             '()
 208                             (cons (compile (car args)) (lp (cdr args)))))))
 209             (lambda (env)
 210               (apply (f env) (a env) (b env) (c env)
 211                      (let lp ((args args))
 212                        (if (null? args)
 213                            '()
 214                            (cons ((car args) env) (lp (cdr args)))))))))))))
 215
 216   (define (compile-box-ref box)
 217     (match box
 218       ((,(typecode resolve) . loc)
 219        (lazy (cenv)
 220          (let ((var (%resolve-variable loc (env-toplevel cenv))))
 221            (lambda (env) (variable-ref var)))))
 222       ((,(typecode lexical-ref) depth . width)
 223        (lambda (env)
 224          (variable-ref (env-ref env depth width))))
 225       (_
 226        (let ((box (compile box)))
 227          (lambda (env)
 228            (variable-ref (box env)))))))
 229
 230   (define (compile-resolve cenv loc)
 231     (let ((var (%resolve-variable loc (env-toplevel cenv))))
 232       (lambda (env) var)))
 233
 234   (define (compile-top-branch cenv loc args consequent alternate)
 235     (let* ((module (env-toplevel cenv))
 236            (var (%resolve-variable loc module))
 237            (consequent (compile consequent))
 238            (alternate (compile alternate)))
 239       (define (generic-top-branch)
 240         (let ((test (compile-top-call cenv loc args)))
 241           (lambda (env)
 242             (if (test env) (consequent env) (alternate env)))))
 243       (define-syntax-rule (maybe-primcall (prim ...) arg ...)
 244         (cond
 245          ((primitive=? 'prim loc module var)
 246           (let ((arg (compile arg))
 247                 ...)
 248             (lambda (env)
 249               (if (prim (arg env) ...)
 250                   (consequent env)
 251                   (alternate env)))))
 252          ...
 253          (else (generic-top-branch))))
 254       (match args
 255         ((a)
 256          (maybe-primcall (null? nil? pair? struct? string? vector? symbol?
 257                           keyword? variable? bitvector? char? zero? not)
 258                          a))
 259         ((a b)
 260          (maybe-primcall (eq? eqv? equal? = < > <= >= logtest logbit?)
 261                          a b))
 262         (_
 263          (generic-top-branch)))))
 264
 265   (define (compile-if test consequent alternate)
 266     (match test
 267       ((,(typecode call)
 268         (,(typecode box-ref) . (,(typecode resolve) . loc))
 269         . args)
 270        (lazy (env) (compile-top-branch env loc args consequent alternate)))
 271       (_
 272        (let ((test (compile test))
 273              (consequent (compile consequent))
 274              (alternate (compile alternate)))
 275          (lambda (env)
 276            (if (test env) (consequent env) (alternate env)))))))
 277
 278   (define (compile-quote x)
 279     (lambda (env) x))
 280
 281   (define (compile-let inits body)
 282     (let ((body (compile body))
 283           (width (vector-length inits)))
 284       (case width
 285         ((0) (lambda (env)
 286                (body (make-env* env))))
 287         ((1)
 288          (let ((a (compile (vector-ref inits 0))))
 289            (lambda (env)
 290              (body (make-env* env (a env))))))
 291         ((2)
 292          (let ((a (compile (vector-ref inits 0)))
 293                (b (compile (vector-ref inits 1))))
 294            (lambda (env)
 295              (body (make-env* env (a env) (b env))))))
 296         ((3)
 297          (let ((a (compile (vector-ref inits 0)))
 298                (b (compile (vector-ref inits 1)))
 299                (c (compile (vector-ref inits 2))))
 300            (lambda (env)
 301              (body (make-env* env (a env) (b env) (c env))))))
 302         ((4)
 303          (let ((a (compile (vector-ref inits 0)))
 304                (b (compile (vector-ref inits 1)))
 305                (c (compile (vector-ref inits 2)))
 306                (d (compile (vector-ref inits 3))))
 307            (lambda (env)
 308              (body (make-env* env (a env) (b env) (c env) (d env))))))
 309         (else
 310          (let lp ((n width)
 311                   (k (lambda (env)
 312                        (make-env width #f env))))
 313            (if (zero? n)
 314                (lambda (env)
 315                  (body (k env)))
 316                (lp (1- n)
 317                    (let ((init (compile (vector-ref inits (1- n)))))
 318                      (lambda (env)
 319                        (let* ((x (init env))
 320                               (new-env (k env)))
 321                          (env-set! new-env 0 (1- n) x)
 322                          new-env))))))))))
 323
 324   (define (compile-fixed-lambda body nreq)
 325     (case nreq
 326       ((0) (lambda (env)
 327              (lambda ()
 328                (body (make-env* env)))))
 329       ((1) (lambda (env)
 330              (lambda (a)
 331                (body (make-env* env a)))))
 332       ((2) (lambda (env)
 333              (lambda (a b)
 334                (body (make-env* env a b)))))
 335       ((3) (lambda (env)
 336              (lambda (a b c)
 337                (body (make-env* env a b c)))))
 338       ((4) (lambda (env)
 339              (lambda (a b c d)
 340                (body (make-env* env a b c d)))))
 341       ((5) (lambda (env)
 342              (lambda (a b c d e)
 343                (body (make-env* env a b c d e)))))
 344       ((6) (lambda (env)
 345              (lambda (a b c d e f)
 346                (body (make-env* env a b c d e f)))))
 347       ((7) (lambda (env)
 348              (lambda (a b c d e f g)
 349                (body (make-env* env a b c d e f g)))))
 350       (else
 351        (lambda (env)
 352          (lambda (a b c d e f g . more)
 353            (let ((env (make-env nreq #f env)))
 354              (env-set! env 0 0 a)
 355              (env-set! env 0 1 b)
 356              (env-set! env 0 2 c)
 357              (env-set! env 0 3 d)
 358              (env-set! env 0 4 e)
 359              (env-set! env 0 5 f)
 360              (env-set! env 0 6 g)
 361              (let lp ((n 7) (args more))
 362                (cond
 363                 ((= n nreq)
 364                  (unless (null? args)
 365                    (scm-error 'wrong-number-of-args
 366                               "eval" "Wrong number of arguments"
 367                               '() #f))
 368                  (body env))
 369                 ((null? args)
 370                  (scm-error 'wrong-number-of-args
 371                             "eval" "Wrong number of arguments"
 372                             '() #f))
 373                 (else
 374                  (env-set! env 0 n (car args))
 375                  (lp (1+ n) (cdr args)))))))))))
 376
 377   (define (compile-rest-lambda body nreq rest?)
 378     (case nreq
 379       ((0) (lambda (env)
 380              (lambda rest
 381                (body (make-env* env rest)))))
 382       ((1) (lambda (env)
 383              (lambda (a . rest)
 384                (body (make-env* env a rest)))))
 385       ((2) (lambda (env)
 386              (lambda (a b . rest)
 387                (body (make-env* env a b rest)))))
 388       ((3) (lambda (env)
 389              (lambda (a b c . rest)
 390                (body (make-env* env a b c rest)))))
 391       (else
 392        (lambda (env)
 393          (lambda (a b c . more)
 394            (let ((env (make-env (1+ nreq) #f env)))
 395              (env-set! env 0 0 a)
 396              (env-set! env 0 1 b)
 397              (env-set! env 0 2 c)
 398              (let lp ((n 3) (args more))
 399                (cond
 400                 ((= n nreq)
 401                  (env-set! env 0 n args)
 402                  (body env))
 403                 ((null? args)
 404                  (scm-error 'wrong-number-of-args
 405                             "eval" "Wrong number of arguments"
 406                             '() #f))
 407                 (else
 408                  (env-set! env 0 n (car args))
 409                  (lp (1+ n) (cdr args)))))))))))
 410
 411   (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
 412     (lambda (env)
 413       (define alt (and make-alt (make-alt env)))
 414       (lambda args
 415         (let ((nargs (length args)))
 416           (cond
 417            ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
 418             (if alt
 419                 (apply alt args)
 420                 ((scm-error 'wrong-number-of-args
 421                             "eval" "Wrong number of arguments"
 422                             '() #f))))
 423            (else
 424             (let* ((nvals (+ nreq (if rest? 1 0) ninits))
 425                    (env (make-env nvals unbound env)))
 426               (define (bind-req args)
 427                 (let lp ((i 0) (args args))
 428                   (cond
 429                    ((< i nreq)
 430                     ;; Bind required arguments.
 431                     (env-set! env 0 i (car args))
 432                     (lp (1+ i) (cdr args)))
 433                    (else
 434                     (bind-opt args)))))
 435               (define (bind-opt args)
 436                 (let lp ((i nreq) (args args))
 437                   (cond
 438                    ((and (< i (+ nreq nopt)) (< i nargs))
 439                     (env-set! env 0 i (car args))
 440                     (lp (1+ i) (cdr args)))
 441                    (else
 442                     (bind-rest args)))))
 443               (define (bind-rest args)
 444                 (when rest?
 445                   (env-set! env 0 (+ nreq nopt) args))
 446                 (body env))
 447               (bind-req args))))))))
 448
 449   (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
 450     (define allow-other-keys? (car kw))
 451     (define keywords (cdr kw))
 452     (lambda (env)
 453       (define alt (and make-alt (make-alt env)))
 454       (lambda args
 455         (define (npositional args)
 456           (let lp ((n 0) (args args))
 457             (if (or (null? args)
 458                     (and (>= n nreq) (keyword? (car args))))
 459                 n
 460                 (lp (1+ n) (cdr args)))))
 461         (let ((nargs (length args)))
 462           (cond
 463            ((or (< nargs nreq)
 464                 (and alt (not rest?) (> (npositional args) (+ nreq nopt))))
 465             (if alt
 466                 (apply alt args)
 467                 ((scm-error 'wrong-number-of-args
 468                             "eval" "Wrong number of arguments"
 469                             '() #f))))
 470            (else
 471             (let* ((nvals (+ nreq (if rest? 1 0) ninits))
 472                    (env (make-env nvals unbound env)))
 473               (define (bind-req args)
 474                 (let lp ((i 0) (args args))
 475                   (cond
 476                    ((< i nreq)
 477                     ;; Bind required arguments.
 478                     (env-set! env 0 i (car args))
 479                     (lp (1+ i) (cdr args)))
 480                    (else
 481                     (bind-opt args)))))
 482               (define (bind-opt args)
 483                 (let lp ((i nreq) (args args))
 484                   (cond
 485                    ((and (< i (+ nreq nopt)) (< i nargs)
 486                          (not (keyword? (car args))))
 487                     (env-set! env 0 i (car args))
 488                     (lp (1+ i) (cdr args)))
 489                    (else
 490                     (bind-rest args)))))
 491               (define (bind-rest args)
 492                 (when rest?
 493                   (env-set! env 0 (+ nreq nopt) args))
 494                 (bind-kw args))
 495               (define (bind-kw args)
 496                 (let lp ((args args))
 497                   (cond
 498                    ((and (pair? args) (pair? (cdr args))
 499                          (keyword? (car args)))
 500                     (let ((kw-pair (assq (car args) keywords))
 501                           (v (cadr args)))
 502                       (if kw-pair
 503                           ;; Found a known keyword; set its value.
 504                           (env-set! env 0 (cdr kw-pair) v)
 505                           ;; Unknown keyword.
 506                           (if (not allow-other-keys?)
 507                               ((scm-error
 508                                 'keyword-argument-error
 509                                 "eval" "Unrecognized keyword"
 510                                 '() (list (car args))))))
 511                       (lp (cddr args))))
 512                    ((pair? args)
 513                     (if rest?
 514                         ;; Be lenient parsing rest args.
 515                         (lp (cdr args))
 516                         ((scm-error 'keyword-argument-error
 517                                     "eval" "Invalid keyword"
 518                                     '() (list (car args))))))
 519                    (else
 520                     (body env)))))
 521               (bind-req args))))))))
 522
 523   (define (compute-arity alt nreq rest? nopt kw)
 524     (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
 525       (if (not alt)
 526           (let ((arglist (list nreq
 527                                nopt
 528                                (if kw (cdr kw) '())
 529                                (and kw (car kw))
 530                                (and rest? '_))))
 531             (values arglist nreq nopt rest?))
 532           (let* ((spec (cddr alt))
 533                  (nreq* (car spec))
 534                  (rest?* (if (null? (cdr spec)) #f (cadr spec)))
 535                  (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 536                  (nopt* (if tail (car tail) 0))
 537                  (alt* (and tail (car (cddddr tail)))))
 538             (if (or (< nreq* nreq)
 539                     (and (= nreq* nreq)
 540                          (if rest?
 541                              (and rest?* (> nopt* nopt))
 542                              (or rest?* (> nopt* nopt)))))
 543                 (lp alt* nreq* nopt* rest?*)
 544                 (lp alt* nreq nopt rest?))))))
 545
 546   (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
 547     (call-with-values
 548         (lambda ()
 549           (compute-arity alt nreq rest? nopt kw))
 550       (lambda (arglist min-nreq min-nopt min-rest?)
 551         (define make-alt
 552           (match alt
 553             (#f #f)
 554             ((body meta nreq . tail)
 555              (compile-lambda body meta nreq tail))))
 556         (define make-closure
 557           (if kw
 558               (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
 559               (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
 560         (lambda (env)
 561           (let ((proc (make-closure env)))
 562             (set-procedure-property! proc 'arglist arglist)
 563             (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
 564             proc)))))
 565
 566   (define (compile-lambda body meta nreq tail)
 567     (define (set-procedure-meta meta proc)
 568       (match meta
 569         (() proc)
 570         (((prop . val) . meta)
 571          (set-procedure-meta meta
 572                              (lambda (env)
 573                                (let ((proc (proc env)))
 574                                  (set-procedure-property! proc prop val)
 575                                  proc))))))
 576     (let ((body (lazy (env) (compile body))))
 577       (set-procedure-meta
 578        meta
 579        (match tail
 580          (() (compile-fixed-lambda body nreq))
 581          ((rest? . tail)
 582           (match tail
 583             (() (compile-rest-lambda body nreq rest?))
 584             ((nopt kw ninits unbound alt)
 585              (compile-general-lambda body nreq rest? nopt kw
 586                                      ninits unbound alt))))))))
 587
 588   (define (compile-capture-env locs body)
 589     (let ((body (compile body)))
 590       (lambda (env)
 591         (let* ((len (vector-length locs))
 592                (new-env (make-env len #f (env-toplevel env))))
 593           (let lp ((n 0))
 594             (when (< n len)
 595               (match (vector-ref locs n)
 596                 ((depth . width)
 597                  (env-set! new-env 0 n (env-ref env depth width))))
 598               (lp (1+ n))))
 599           (body new-env)))))
 600
 601   (define (compile-seq head tail)
 602     (let ((head (compile head))
 603           (tail (compile tail)))
 604       (lambda (env)
 605         (head env)
 606         (tail env))))
 607
 608   (define (compile-box-set! box val)
 609     (let ((box (compile box))
 610           (val (compile val)))
 611       (lambda (env)
 612         (let ((val (val env)))
 613           (variable-set! (box env) val)))))
 614
 615   (define (compile-lexical-set! depth width x)
 616     (let ((x (compile x)))
 617       (lambda (env)
 618         (env-set! env depth width (x env)))))
 619
 620   (define (compile-call-with-values producer consumer)
 621     (let ((producer (compile producer))
 622           (consumer (compile consumer)))
 623       (lambda (env)
 624         (call-with-values (producer env)
 625           (consumer env)))))
 626
 627   (define (compile-apply f args)
 628     (let ((f (compile f))
 629           (args (compile args)))
 630       (lambda (env)
 631         (apply (f env) (args env)))))
 632
 633   (define (compile-capture-module x)
 634     (let ((x (compile x)))
 635       (lambda (env)
 636         (x (current-module)))))
 637
 638   (define (compile-call-with-prompt tag thunk handler)
 639     (let ((tag (compile tag))
 640           (thunk (compile thunk))
 641           (handler (compile handler)))
 642       (lambda (env)
 643         (call-with-prompt (tag env) (thunk env) (handler env)))))
 644
 645   (define (compile-call/cc proc)
 646     (let ((proc (compile proc)))
 647       (lambda (env)
 648         (call/cc (proc env)))))
 649
 650   (define (compile exp)
 651     (match exp
 652       ((,(typecode lexical-ref) depth . width)
 653        (compile-lexical-ref depth width))
 654
 655       ((,(typecode call) f . args)
 656        (compile-call f args))
 657
 658       ((,(typecode box-ref) . box)
 659        (compile-box-ref box))
 660
 661       ((,(typecode resolve) . loc)
 662        (lazy (env) (compile-resolve env loc)))
 663
 664       ((,(typecode if) test consequent . alternate)
 665        (compile-if test consequent alternate))
 666
 667       ((,(typecode quote) . x)
 668        (compile-quote x))
 669
 670       ((,(typecode let) inits . body)
 671        (compile-let inits body))
 672
 673       ((,(typecode lambda) body meta nreq . tail)
 674        (compile-lambda body meta nreq tail))
 675
 676       ((,(typecode capture-env) locs . body)
 677        (compile-capture-env locs body))
 678
 679       ((,(typecode seq) head . tail)
 680        (compile-seq head tail))
 681
 682       ((,(typecode box-set!) box . val)
 683        (compile-box-set! box val))
 684
 685       ((,(typecode lexical-set!) (depth . width) . x)
 686        (compile-lexical-set! depth width x))
 687
 688       ((,(typecode call-with-values) producer . consumer)
 689        (compile-call-with-values producer consumer))
 690
 691       ((,(typecode apply) f args)
 692        (compile-apply f args))
 693
 694       ((,(typecode capture-module) . x)
 695        (compile-capture-module x))
 696
 697       ((,(typecode call-with-prompt) tag thunk . handler)
 698        (compile-call-with-prompt tag thunk handler))
 699
 700       ((,(typecode call/cc) . proc)
 701        (compile-call/cc proc))))
 702
 703   (let ((eval (compile
 704                (memoize-expression
 705                 (if (macroexpanded? exp)
 706                     exp
 707                     ((module-transformer (current-module)) exp)))))
 708         (env #f))
 709     (eval env)))