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