| 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 cenv box) |
| 217 | (match box |
| 218 | ((,(typecode resolve) . loc) |
| 219 | (let ((var (%resolve-variable loc (env-toplevel cenv)))) |
| 220 | (lambda (env) (variable-ref var)))) |
| 221 | ((,(typecode lexical-ref) depth . width) |
| 222 | (lambda (env) |
| 223 | (variable-ref (env-ref env depth width)))) |
| 224 | (_ |
| 225 | (let ((box (compile box))) |
| 226 | (lambda (env) |
| 227 | (variable-ref (box env))))))) |
| 228 | |
| 229 | (define (compile-resolve cenv loc) |
| 230 | (let ((var (%resolve-variable loc (env-toplevel cenv)))) |
| 231 | (lambda (env) var))) |
| 232 | |
| 233 | (define (compile-top-branch cenv loc args consequent alternate) |
| 234 | (let* ((module (env-toplevel cenv)) |
| 235 | (var (%resolve-variable loc module)) |
| 236 | (consequent (compile consequent)) |
| 237 | (alternate (compile alternate))) |
| 238 | (define (generic-top-branch) |
| 239 | (let ((test (compile-top-call cenv loc args))) |
| 240 | (lambda (env) |
| 241 | (if (test env) (consequent env) (alternate env))))) |
| 242 | (define-syntax-rule (maybe-primcall (prim ...) arg ...) |
| 243 | (cond |
| 244 | ((primitive=? 'prim loc module var) |
| 245 | (let ((arg (compile arg)) |
| 246 | ...) |
| 247 | (lambda (env) |
| 248 | (if (prim (arg env) ...) |
| 249 | (consequent env) |
| 250 | (alternate env))))) |
| 251 | ... |
| 252 | (else (generic-top-branch)))) |
| 253 | (match args |
| 254 | ((a) |
| 255 | (maybe-primcall (null? nil? pair? struct? string? vector? symbol? |
| 256 | keyword? variable? bitvector? char? zero? not) |
| 257 | a)) |
| 258 | ((a b) |
| 259 | (maybe-primcall (eq? eqv? equal? = < > <= >= logtest logbit?) |
| 260 | a b)) |
| 261 | (_ |
| 262 | (generic-top-branch))))) |
| 263 | |
| 264 | (define (compile-if test consequent alternate) |
| 265 | (match test |
| 266 | ((,(typecode call) |
| 267 | (,(typecode box-ref) . (,(typecode resolve) . loc)) |
| 268 | . args) |
| 269 | (lazy (env) (compile-top-branch env loc args consequent alternate))) |
| 270 | (_ |
| 271 | (let ((test (compile test)) |
| 272 | (consequent (compile consequent)) |
| 273 | (alternate (compile alternate))) |
| 274 | (lambda (env) |
| 275 | (if (test env) (consequent env) (alternate env))))))) |
| 276 | |
| 277 | (define (compile-quote x) |
| 278 | (lambda (env) x)) |
| 279 | |
| 280 | (define (compile-let inits body) |
| 281 | (let ((body (compile body)) |
| 282 | (width (vector-length inits))) |
| 283 | (case width |
| 284 | ((0) (lambda (env) |
| 285 | (body (make-env* env)))) |
| 286 | ((1) |
| 287 | (let ((a (compile (vector-ref inits 0)))) |
| 288 | (lambda (env) |
| 289 | (body (make-env* env (a env)))))) |
| 290 | ((2) |
| 291 | (let ((a (compile (vector-ref inits 0))) |
| 292 | (b (compile (vector-ref inits 1)))) |
| 293 | (lambda (env) |
| 294 | (body (make-env* env (a env) (b env)))))) |
| 295 | ((3) |
| 296 | (let ((a (compile (vector-ref inits 0))) |
| 297 | (b (compile (vector-ref inits 1))) |
| 298 | (c (compile (vector-ref inits 2)))) |
| 299 | (lambda (env) |
| 300 | (body (make-env* env (a env) (b env) (c env)))))) |
| 301 | ((4) |
| 302 | (let ((a (compile (vector-ref inits 0))) |
| 303 | (b (compile (vector-ref inits 1))) |
| 304 | (c (compile (vector-ref inits 2))) |
| 305 | (d (compile (vector-ref inits 3)))) |
| 306 | (lambda (env) |
| 307 | (body (make-env* env (a env) (b env) (c env) (d env)))))) |
| 308 | (else |
| 309 | (let lp ((n width) |
| 310 | (k (lambda (env) |
| 311 | (make-env width #f env)))) |
| 312 | (if (zero? n) |
| 313 | (lambda (env) |
| 314 | (body (k env))) |
| 315 | (lp (1- n) |
| 316 | (let ((init (compile (vector-ref inits (1- n))))) |
| 317 | (lambda (env) |
| 318 | (let* ((x (init env)) |
| 319 | (new-env (k env))) |
| 320 | (env-set! new-env 0 (1- n) x) |
| 321 | new-env)))))))))) |
| 322 | |
| 323 | (define (compile-fixed-lambda body nreq) |
| 324 | (case nreq |
| 325 | ((0) (lambda (env) |
| 326 | (lambda () |
| 327 | (body (make-env* env))))) |
| 328 | ((1) (lambda (env) |
| 329 | (lambda (a) |
| 330 | (body (make-env* env a))))) |
| 331 | ((2) (lambda (env) |
| 332 | (lambda (a b) |
| 333 | (body (make-env* env a b))))) |
| 334 | ((3) (lambda (env) |
| 335 | (lambda (a b c) |
| 336 | (body (make-env* env a b c))))) |
| 337 | ((4) (lambda (env) |
| 338 | (lambda (a b c d) |
| 339 | (body (make-env* env a b c d))))) |
| 340 | ((5) (lambda (env) |
| 341 | (lambda (a b c d e) |
| 342 | (body (make-env* env a b c d e))))) |
| 343 | ((6) (lambda (env) |
| 344 | (lambda (a b c d e f) |
| 345 | (body (make-env* env a b c d e f))))) |
| 346 | ((7) (lambda (env) |
| 347 | (lambda (a b c d e f g) |
| 348 | (body (make-env* env a b c d e f g))))) |
| 349 | (else |
| 350 | (lambda (env) |
| 351 | (lambda (a b c d e f g . more) |
| 352 | (let ((env (make-env nreq #f env))) |
| 353 | (env-set! env 0 0 a) |
| 354 | (env-set! env 0 1 b) |
| 355 | (env-set! env 0 2 c) |
| 356 | (env-set! env 0 3 d) |
| 357 | (env-set! env 0 4 e) |
| 358 | (env-set! env 0 5 f) |
| 359 | (env-set! env 0 6 g) |
| 360 | (let lp ((n 7) (args more)) |
| 361 | (cond |
| 362 | ((= n nreq) |
| 363 | (unless (null? args) |
| 364 | (scm-error 'wrong-number-of-args |
| 365 | "eval" "Wrong number of arguments" |
| 366 | '() #f)) |
| 367 | (body env)) |
| 368 | ((null? args) |
| 369 | (scm-error 'wrong-number-of-args |
| 370 | "eval" "Wrong number of arguments" |
| 371 | '() #f)) |
| 372 | (else |
| 373 | (env-set! env 0 n (car args)) |
| 374 | (lp (1+ n) (cdr args))))))))))) |
| 375 | |
| 376 | (define (compile-rest-lambda body nreq rest?) |
| 377 | (case nreq |
| 378 | ((0) (lambda (env) |
| 379 | (lambda rest |
| 380 | (body (make-env* env rest))))) |
| 381 | ((1) (lambda (env) |
| 382 | (lambda (a . rest) |
| 383 | (body (make-env* env a rest))))) |
| 384 | ((2) (lambda (env) |
| 385 | (lambda (a b . rest) |
| 386 | (body (make-env* env a b rest))))) |
| 387 | ((3) (lambda (env) |
| 388 | (lambda (a b c . rest) |
| 389 | (body (make-env* env a b c rest))))) |
| 390 | (else |
| 391 | (lambda (env) |
| 392 | (lambda (a b c . more) |
| 393 | (let ((env (make-env (1+ nreq) #f env))) |
| 394 | (env-set! env 0 0 a) |
| 395 | (env-set! env 0 1 b) |
| 396 | (env-set! env 0 2 c) |
| 397 | (let lp ((n 3) (args more)) |
| 398 | (cond |
| 399 | ((= n nreq) |
| 400 | (env-set! env 0 n args) |
| 401 | (body env)) |
| 402 | ((null? args) |
| 403 | (scm-error 'wrong-number-of-args |
| 404 | "eval" "Wrong number of arguments" |
| 405 | '() #f)) |
| 406 | (else |
| 407 | (env-set! env 0 n (car args)) |
| 408 | (lp (1+ n) (cdr args))))))))))) |
| 409 | |
| 410 | (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt) |
| 411 | (lambda (env) |
| 412 | (define alt (and make-alt (make-alt env))) |
| 413 | (lambda args |
| 414 | (let ((nargs (length args))) |
| 415 | (cond |
| 416 | ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt)))) |
| 417 | (if alt |
| 418 | (apply alt args) |
| 419 | ((scm-error 'wrong-number-of-args |
| 420 | "eval" "Wrong number of arguments" |
| 421 | '() #f)))) |
| 422 | (else |
| 423 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) |
| 424 | (env (make-env nvals unbound env))) |
| 425 | (define (bind-req args) |
| 426 | (let lp ((i 0) (args args)) |
| 427 | (cond |
| 428 | ((< i nreq) |
| 429 | ;; Bind required arguments. |
| 430 | (env-set! env 0 i (car args)) |
| 431 | (lp (1+ i) (cdr args))) |
| 432 | (else |
| 433 | (bind-opt args))))) |
| 434 | (define (bind-opt args) |
| 435 | (let lp ((i nreq) (args args)) |
| 436 | (cond |
| 437 | ((and (< i (+ nreq nopt)) (< i nargs)) |
| 438 | (env-set! env 0 i (car args)) |
| 439 | (lp (1+ i) (cdr args))) |
| 440 | (else |
| 441 | (bind-rest args))))) |
| 442 | (define (bind-rest args) |
| 443 | (when rest? |
| 444 | (env-set! env 0 (+ nreq nopt) args)) |
| 445 | (body env)) |
| 446 | (bind-req args)))))))) |
| 447 | |
| 448 | (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) |
| 449 | (define allow-other-keys? (car kw)) |
| 450 | (define keywords (cdr kw)) |
| 451 | (lambda (env) |
| 452 | (define alt (and make-alt (make-alt env))) |
| 453 | (lambda args |
| 454 | (define (npositional args) |
| 455 | (let lp ((n 0) (args args)) |
| 456 | (if (or (null? args) |
| 457 | (and (>= n nreq) (keyword? (car args)))) |
| 458 | n |
| 459 | (lp (1+ n) (cdr args))))) |
| 460 | (let ((nargs (length args))) |
| 461 | (cond |
| 462 | ((or (< nargs nreq) |
| 463 | (and alt (not rest?) (> (npositional args) (+ nreq nopt)))) |
| 464 | (if alt |
| 465 | (apply alt args) |
| 466 | ((scm-error 'wrong-number-of-args |
| 467 | "eval" "Wrong number of arguments" |
| 468 | '() #f)))) |
| 469 | (else |
| 470 | (let* ((nvals (+ nreq (if rest? 1 0) ninits)) |
| 471 | (env (make-env nvals unbound env))) |
| 472 | (define (bind-req args) |
| 473 | (let lp ((i 0) (args args)) |
| 474 | (cond |
| 475 | ((< i nreq) |
| 476 | ;; Bind required arguments. |
| 477 | (env-set! env 0 i (car args)) |
| 478 | (lp (1+ i) (cdr args))) |
| 479 | (else |
| 480 | (bind-opt args))))) |
| 481 | (define (bind-opt args) |
| 482 | (let lp ((i nreq) (args args)) |
| 483 | (cond |
| 484 | ((and (< i (+ nreq nopt)) (< i nargs) |
| 485 | (not (keyword? (car args)))) |
| 486 | (env-set! env 0 i (car args)) |
| 487 | (lp (1+ i) (cdr args))) |
| 488 | (else |
| 489 | (bind-rest args))))) |
| 490 | (define (bind-rest args) |
| 491 | (when rest? |
| 492 | (env-set! env 0 (+ nreq nopt) args)) |
| 493 | (bind-kw args)) |
| 494 | (define (bind-kw args) |
| 495 | (let lp ((args args)) |
| 496 | (cond |
| 497 | ((and (pair? args) (pair? (cdr args)) |
| 498 | (keyword? (car args))) |
| 499 | (let ((kw-pair (assq (car args) keywords)) |
| 500 | (v (cadr args))) |
| 501 | (if kw-pair |
| 502 | ;; Found a known keyword; set its value. |
| 503 | (env-set! env 0 (cdr kw-pair) v) |
| 504 | ;; Unknown keyword. |
| 505 | (if (not allow-other-keys?) |
| 506 | ((scm-error |
| 507 | 'keyword-argument-error |
| 508 | "eval" "Unrecognized keyword" |
| 509 | '() (list (car args)))))) |
| 510 | (lp (cddr args)))) |
| 511 | ((pair? args) |
| 512 | (if rest? |
| 513 | ;; Be lenient parsing rest args. |
| 514 | (lp (cdr args)) |
| 515 | ((scm-error 'keyword-argument-error |
| 516 | "eval" "Invalid keyword" |
| 517 | '() (list (car args)))))) |
| 518 | (else |
| 519 | (body env))))) |
| 520 | (bind-req args)))))))) |
| 521 | |
| 522 | (define (compute-arity alt nreq rest? nopt kw) |
| 523 | (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) |
| 524 | (if (not alt) |
| 525 | (let ((arglist (list nreq |
| 526 | nopt |
| 527 | (if kw (cdr kw) '()) |
| 528 | (and kw (car kw)) |
| 529 | (and rest? '_)))) |
| 530 | (values arglist nreq nopt rest?)) |
| 531 | (let* ((spec (cddr alt)) |
| 532 | (nreq* (car spec)) |
| 533 | (rest?* (if (null? (cdr spec)) #f (cadr spec))) |
| 534 | (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) |
| 535 | (nopt* (if tail (car tail) 0)) |
| 536 | (alt* (and tail (car (cddddr tail))))) |
| 537 | (if (or (< nreq* nreq) |
| 538 | (and (= nreq* nreq) |
| 539 | (if rest? |
| 540 | (and rest?* (> nopt* nopt)) |
| 541 | (or rest?* (> nopt* nopt))))) |
| 542 | (lp alt* nreq* nopt* rest?*) |
| 543 | (lp alt* nreq nopt rest?)))))) |
| 544 | |
| 545 | (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt) |
| 546 | (call-with-values |
| 547 | (lambda () |
| 548 | (compute-arity alt nreq rest? nopt kw)) |
| 549 | (lambda (arglist min-nreq min-nopt min-rest?) |
| 550 | (define make-alt |
| 551 | (match alt |
| 552 | (#f #f) |
| 553 | ((body meta nreq . tail) |
| 554 | (compile-lambda body meta nreq tail)))) |
| 555 | (define make-closure |
| 556 | (if kw |
| 557 | (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) |
| 558 | (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt))) |
| 559 | (lambda (env) |
| 560 | (let ((proc (make-closure env))) |
| 561 | (set-procedure-property! proc 'arglist arglist) |
| 562 | (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?) |
| 563 | proc))))) |
| 564 | |
| 565 | (define (compile-lambda body meta nreq tail) |
| 566 | (define (set-procedure-meta meta proc) |
| 567 | (match meta |
| 568 | (() proc) |
| 569 | (((prop . val) . meta) |
| 570 | (set-procedure-meta meta |
| 571 | (lambda (env) |
| 572 | (let ((proc (proc env))) |
| 573 | (set-procedure-property! proc prop val) |
| 574 | proc)))))) |
| 575 | (let ((body (lazy (env) (compile body)))) |
| 576 | (set-procedure-meta |
| 577 | meta |
| 578 | (match tail |
| 579 | (() (compile-fixed-lambda body nreq)) |
| 580 | ((rest? . tail) |
| 581 | (match tail |
| 582 | (() (compile-rest-lambda body nreq rest?)) |
| 583 | ((nopt kw ninits unbound alt) |
| 584 | (compile-general-lambda body nreq rest? nopt kw |
| 585 | ninits unbound alt)))))))) |
| 586 | |
| 587 | (define (compile-capture-env locs body) |
| 588 | (let ((body (compile body))) |
| 589 | (lambda (env) |
| 590 | (let* ((len (vector-length locs)) |
| 591 | (new-env (make-env len #f (env-toplevel env)))) |
| 592 | (let lp ((n 0)) |
| 593 | (when (< n len) |
| 594 | (match (vector-ref locs n) |
| 595 | ((depth . width) |
| 596 | (env-set! new-env 0 n (env-ref env depth width)))) |
| 597 | (lp (1+ n)))) |
| 598 | (body new-env))))) |
| 599 | |
| 600 | (define (compile-seq head tail) |
| 601 | (let ((head (compile head)) |
| 602 | (tail (compile tail))) |
| 603 | (lambda (env) |
| 604 | (head env) |
| 605 | (tail env)))) |
| 606 | |
| 607 | (define (compile-box-set! box val) |
| 608 | (let ((box (compile box)) |
| 609 | (val (compile val))) |
| 610 | (lambda (env) |
| 611 | (let ((val (val env))) |
| 612 | (variable-set! (box env) val))))) |
| 613 | |
| 614 | (define (compile-lexical-set! depth width x) |
| 615 | (let ((x (compile x))) |
| 616 | (lambda (env) |
| 617 | (env-set! env depth width (x env))))) |
| 618 | |
| 619 | (define (compile-call-with-values producer consumer) |
| 620 | (let ((producer (compile producer)) |
| 621 | (consumer (compile consumer))) |
| 622 | (lambda (env) |
| 623 | (call-with-values (producer env) |
| 624 | (consumer env))))) |
| 625 | |
| 626 | (define (compile-apply f args) |
| 627 | (let ((f (compile f)) |
| 628 | (args (compile args))) |
| 629 | (lambda (env) |
| 630 | (apply (f env) (args env))))) |
| 631 | |
| 632 | (define (compile-capture-module x) |
| 633 | (let ((x (compile x))) |
| 634 | (lambda (env) |
| 635 | (x (current-module))))) |
| 636 | |
| 637 | (define (compile-call-with-prompt tag thunk handler) |
| 638 | (let ((tag (compile tag)) |
| 639 | (thunk (compile thunk)) |
| 640 | (handler (compile handler))) |
| 641 | (lambda (env) |
| 642 | (call-with-prompt (tag env) (thunk env) (handler env))))) |
| 643 | |
| 644 | (define (compile-call/cc proc) |
| 645 | (let ((proc (compile proc))) |
| 646 | (lambda (env) |
| 647 | (call/cc (proc env))))) |
| 648 | |
| 649 | (define (compile exp) |
| 650 | (match exp |
| 651 | ((,(typecode lexical-ref) depth . width) |
| 652 | (compile-lexical-ref depth width)) |
| 653 | |
| 654 | ((,(typecode call) f . args) |
| 655 | (compile-call f args)) |
| 656 | |
| 657 | ((,(typecode box-ref) . box) |
| 658 | (lazy (env) (compile-box-ref env box))) |
| 659 | |
| 660 | ((,(typecode resolve) . loc) |
| 661 | (lazy (env) (compile-resolve env loc))) |
| 662 | |
| 663 | ((,(typecode if) test consequent . alternate) |
| 664 | (compile-if test consequent alternate)) |
| 665 | |
| 666 | ((,(typecode quote) . x) |
| 667 | (compile-quote x)) |
| 668 | |
| 669 | ((,(typecode let) inits . body) |
| 670 | (compile-let inits body)) |
| 671 | |
| 672 | ((,(typecode lambda) body meta nreq . tail) |
| 673 | (compile-lambda body meta nreq tail)) |
| 674 | |
| 675 | ((,(typecode capture-env) locs . body) |
| 676 | (compile-capture-env locs body)) |
| 677 | |
| 678 | ((,(typecode seq) head . tail) |
| 679 | (compile-seq head tail)) |
| 680 | |
| 681 | ((,(typecode box-set!) box . val) |
| 682 | (compile-box-set! box val)) |
| 683 | |
| 684 | ((,(typecode lexical-set!) (depth . width) . x) |
| 685 | (compile-lexical-set! depth width x)) |
| 686 | |
| 687 | ((,(typecode call-with-values) producer . consumer) |
| 688 | (compile-call-with-values producer consumer)) |
| 689 | |
| 690 | ((,(typecode apply) f args) |
| 691 | (compile-apply f args)) |
| 692 | |
| 693 | ((,(typecode capture-module) . x) |
| 694 | (compile-capture-module x)) |
| 695 | |
| 696 | ((,(typecode call-with-prompt) tag thunk . handler) |
| 697 | (compile-call-with-prompt tag thunk handler)) |
| 698 | |
| 699 | ((,(typecode call/cc) . proc) |
| 700 | (compile-call/cc proc)))) |
| 701 | |
| 702 | (let ((eval (compile |
| 703 | (memoize-expression |
| 704 | (if (macroexpanded? exp) |
| 705 | exp |
| 706 | ((module-transformer (current-module)) exp))))) |
| 707 | (env #f)) |
| 708 | (eval env))) |