-;;; -*- 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
-;;;;
-
-\f
-
-;;; 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:
-
-\f
-
-(eval-when (compile)
- (define-syntax capture-env
- (syntax-rules ()
- ((_ (exp ...))
- (let ((env (exp ...)))
- (capture-env env)))
- ((_ env)
- (if (null? env)
- (current-module)
- (if (not env)
- ;; the and current-module checks that modules are booted,
- ;; and thus the-root-module is defined
- (and (current-module) the-root-module)
- env)))))
-
- ;; 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
- (cons* #,@(reverse formals) env))))))
- (iota *max-static-argument-count*))
- (else
- #,(let ((formals (make-formals *max-static-argument-count*)))
- #`(lambda (#,@formals . more)
- (let lp ((new-env (cons* #,@(reverse formals) env))
- (nreq (- nreq #,*max-static-argument-count*))
- (args more))
- (if (zero? nreq)
- (eval body
- (if (null? args)
- new-env
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f)))
- (if (null? args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f)
- (lp (cons (car args) new-env)
- (1- nreq)
- (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 (memoized-expression-typecode mx))
- (data (memoized-expression-data 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; see make-fixed-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 docstring 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
- (let lp ((env env)
- (nreq* nreq)
- (args %args))
- (if (> nreq* 0)
- ;; First, bind required arguments.
- (if (null? args)
- (if alt
- (apply alt-proc %args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f))
- (lp (cons (car args) env)
- (1- nreq*)
- (cdr args)))
- ;; Move on to optional arguments.
- (if (not kw)
- ;; Without keywords, bind optionals from arguments.
- (let lp ((env env)
- (nopt nopt)
- (args args)
- (inits inits))
- (if (zero? nopt)
- (if rest?
- (eval body (cons args env))
- (if (null? args)
- (eval body env)
- (if alt
- (apply alt-proc %args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f))))
- (if (null? args)
- (lp (cons (eval (car inits) env) env)
- (1- nopt) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt) (cdr args) (cdr inits)))))
- (let lp ((env env)
- (nopt* nopt)
- (args args)
- (inits inits))
- (cond
- ;; With keywords, we stop binding optionals at the
- ;; first keyword.
- ((> nopt* 0)
- (if (or (null? args) (keyword? (car args)))
- (lp (cons (eval (car inits) env) env)
- (1- nopt*) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt*) (cdr args) (cdr inits))))
- ;; Finished with optionals.
- ((and alt (pair? args) (not (keyword? (car args)))
- (not rest?))
- ;; Too many positional args, no #:rest arg,
- ;; and we have an alternate.
- (apply alt-proc %args))
- (else
- (let* ((aok (car kw))
- (kw (cdr kw))
- (kw-base (+ nopt nreq (if rest? 1 0)))
- (imax (let lp ((imax (1- kw-base)) (kw kw))
- (if (null? kw)
- imax
- (lp (max (cdar kw) imax)
- (cdr kw)))))
- ;; Fill in kwargs with "undefined" vals.
- (env (let lp ((i kw-base)
- ;; Also, here we bind the rest
- ;; arg, if any.
- (env (if rest?
- (cons args env)
- env)))
- (if (<= i imax)
- (lp (1+ i) (cons unbound-arg env))
- env))))
- ;; Now scan args for keywords.
- (let lp ((args args))
- (if (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.
- (list-set! env
- (- imax (cdr kw-pair)) v)
- ;; Unknown keyword.
- (if (not aok)
- (scm-error
- 'keyword-argument-error
- "eval" "Unrecognized keyword"
- '() (list (car args)))))
- (lp (cddr args)))
- (if (pair? args)
- (if rest?
- ;; Be lenient parsing rest args.
- (lp (cdr args))
- (scm-error 'keyword-argument-error
- "eval" "Invalid keyword"
- '() (list (car args))))
- ;; Finished parsing keywords. Fill in
- ;; uninitialized kwargs by evalling init
- ;; expressions in their appropriate
- ;; environment.
- (let lp ((i (- imax kw-base))
- (inits inits))
- (if (pair? inits)
- (let ((tail (list-tail env i)))
- (if (eq? (car tail) unbound-arg)
- (set-car! tail
- (eval (car inits)
- (cdr tail))))
- (lp (1- i) (cdr inits)))
- ;; Finally, eval the body.
- (eval body env))))))))))))))))
-
- ;; The "engine". EXP is a memoized expression.
- (define (eval exp env)
- (memoized-expression-case exp
- (('lexical-ref n)
- (list-ref env n))
-
- (('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
- (capture-env (if (pair? env)
- (cdr (last-pair env))
- env))))))
-
- (('if (test consequent . alternate))
- (if (eval test env)
- (eval consequent env)
- (eval alternate env)))
-
- (('quote x)
- x)
-
- (('let (inits . body))
- (let lp ((inits inits) (new-env (capture-env env)))
- (if (null? inits)
- (eval body new-env)
- (lp (cdr inits)
- (cons (eval (car inits) env) new-env)))))
-
- (('lambda (body docstring nreq . tail))
- (let ((proc
- (if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
- (if (null? (cdr tail))
- (make-general-closure (capture-env env) body
- nreq (car tail)
- 0 #f '() #f)
- (apply make-general-closure (capture-env env)
- body nreq tail)))))
- (when docstring
- (set-procedure-property! proc 'documentation docstring))
- proc))
-
- (('seq (head . tail))
- (begin
- (eval head env)
- (eval tail env)))
-
- (('lexical-set! (n . x))
- (let ((val (eval x env)))
- (list-set! env n val)))
-
- (('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))
- (let ((x (eval x env)))
- (if (and (procedure? x) (not (procedure-property x 'name)))
- (set-procedure-property! x 'name name))
- (define! name x)
- (if #f #f)))
-
- (('toplevel-set! (var-or-sym . x))
- (variable-set!
- (if (variable? var-or-sym)
- var-or-sym
- (memoize-variable-access! exp
- (capture-env (if (pair? env)
- (cdr (last-pair env))
- 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)))
- '()))))
+;;; -*- 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
+;;;;
+
+\f
+
+;;; 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:
+
+\f
+
+(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)))