[bpt/guile.git] / module / ice-9 / eval.scm

;;; -*- 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 (compile-top-call cenv loc args)
    (let* ((module (env-toplevel cenv))
           (var (%resolve-variable loc module)))
      (define (primitive=? name)
        "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-syntax-rule (maybe-primcall (prim ...) arg ...)
        (cond
         ((primitive=? 'prim) (lambda (env) (prim (arg env) ...)))
         ...
         (else (lambda (env) ((variable-ref var) (arg env) ...)))))
      (match args
        (()
         (lambda (env) ((variable-ref var))))
        ((a)
         (let ((a (compile a)))
           (maybe-primcall
            (null? nil? pair? struct? string? vector? symbol?
             keyword? variable? bitvector? char? zero?
             1+ 1- car cdr lognot not vector-length
             variable-ref string-length struct-vtable)
            a)))
        ((a b)
         (let ((a (compile a))
               (b (compile b)))
           (maybe-primcall
            (+ - * / eq? eqv? equal? = < > <= >=
               ash logand logior logxor logtest logbit?
               cons vector-ref struct-ref allocate-struct variable-set!)
            a b)))
        ((a b c)
         (let ((a (compile a))
               (b (compile b))
               (c (compile 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-if test 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)))
Commit	Line	Data
5161a3c0 AW	1	;;; -- mode: scheme; coding: utf-8; --
5161a3c0 AW	2
eb037656	3	;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
5161a3c0 AW	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
b2b554ef AW	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	;;;
95de4f52 AW	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.
5161a3c0 AW	34	;;;
	35
	36	;;; Code:
	37
	38	\f
	39
95de4f52 AW	40	(define (primitive-eval exp)
95de4f52 AW	41	"Evaluate @var{exp} in the current module."
cfc28c80 AW	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
95de4f52 AW	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
be6e40a1	83	(syntax-rules ()
95de4f52 AW	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
eb037656	90	(syntax-rules (_ quote unquote ?)
95de4f52 AW	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))
eb037656 AW	102	((_ v (? pred var) kt kf)
eb037656 AW	103	(if (pred v) (let ((var v)) kt) kf))
95de4f52 AW	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
5161a3c0 AW	108	(lambda (x)
5161a3c0 AW	109	(syntax-case x ()
95de4f52 AW	110	((_ type)
	111	(or (memoized-typecode (syntax->datum #'type))
	112	(error "not a typecode" (syntax->datum #'type)))))))
	113
d76d80d2 AW	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
95de4f52 AW	121	(define (compile-lexical-ref depth width)
	122	(lambda (env)
	123	(env-ref env depth width)))
	124
d76d80d2 AW	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) ...)))))
95de4f52	144	(match args
d76d80d2 AW	145	(()
d76d80d2 AW	146	(lambda (env) ((variable-ref var))))
95de4f52 AW	147	((a)
95de4f52 AW	148	(let ((a (compile a)))
d76d80d2 AW	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)))
95de4f52 AW	155	((a b)
	156	(let ((a (compile a))
	157	(b (compile b)))
d76d80d2 AW	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)))
95de4f52 AW	163	((a b c)
	164	(let ((a (compile a))
	165	(b (compile b))
	166	(c (compile c)))
d76d80d2	167	(maybe-primcall (vector-set! struct-set!) a b c)))
95de4f52 AW	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)
d76d80d2	177	(apply (variable-ref var) (a env) (b env) (c env)
95de4f52 AW	178	(let lp ((args args))
	179	(if (null? args)
	180	'()
	181	(cons ((car args) env) (lp (cdr args))))))))))))
	182
d76d80d2 AW	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)
95de4f52	224	(match box
d76d80d2 AW	225	((,(typecode resolve) . loc)
	226	(let ((var (%resolve-variable loc (env-toplevel cenv))))
	227	(lambda (env) (variable-ref var))))
95de4f52 AW	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
d76d80d2 AW	236	(define (compile-resolve cenv loc)
	237	(let ((var (%resolve-variable loc (env-toplevel cenv))))
	238	(lambda (env) var)))
95de4f52 AW	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))))))
d76d80d2	545	(let ((body (lazy (env) (compile body))))
95de4f52 AW	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
eb037656 AW	624	((,(typecode call) f . args)
eb037656 AW	625	(compile-call f args))
95de4f52 AW	626
95de4f52 AW	627	((,(typecode box-ref) . box)
d76d80d2	628	(lazy (env) (compile-box-ref env box)))
5161a3c0	629
d76d80d2 AW	630	((,(typecode resolve) . loc)
d76d80d2 AW	631	(lazy (env) (compile-resolve env loc)))
5161a3c0	632
95de4f52 AW	633	((,(typecode if) test consequent . alternate)
95de4f52 AW	634	(compile-if test consequent alternate))
21ec0bd9	635
95de4f52 AW	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))
5161a3c0	668
95de4f52 AW	669	((,(typecode call/cc) . proc)
	670	(compile-call/cc proc))))
	671
d76d80d2 AW	672	(let ((eval (compile
d76d80d2 AW	673	(memoize-expression
95de4f52 AW	674	(if (macroexpanded? exp)
	675	exp
	676	((module-transformer (current-module)) exp)))))
	677	(env #f))
d76d80d2	678	(eval env)))