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

;;; -*- 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"
                                          '() #f)))
                                 (lp (cddr args)))
                               (if (pair? args)
                                   (if rest?
                                       ;; Be lenient parsing rest args.
                                       (lp (cdr args))
                                       (scm-error 'keyword-argument-error
                                                  "eval" "Invalid keyword"
                                                  '() #f))
                                   ;; 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)))
       '()))))
Commit	Line	Data
5161a3c0 AW	1	;;; -- mode: scheme; coding: utf-8; --
5161a3c0 AW	2
747bd534	3	;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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	;;;
	30	;;; Environments are represented as linked lists of the form (VAL ... .
	31	;;; MOD). If MOD is #f, it means the environment was captured before
	32	;;; modules were booted. If MOD is the literal value '(), we are
	33	;;; evaluating at the top level, and so should track changes to the
	34	;;; current module.
	35	;;;
	36	;;; Evaluate this in Emacs to make code indentation work right:
	37	;;;
	38	;;; (put 'memoized-expression-case 'scheme-indent-function 1)
5161a3c0 AW	39	;;;
	40
	41	;;; Code:
	42
	43	\f
	44
5161a3c0 AW	45	(eval-when (compile)
	46	(define-syntax capture-env
	47	(syntax-rules ()
bb0c8157 AW	48	((_ (exp ...))
	49	(let ((env (exp ...)))
	50	(capture-env env)))
5161a3c0 AW	51	((_ env)
	52	(if (null? env)
	53	(current-module)
	54	(if (not env)
b2b554ef AW	55	;; the and current-module checks that modules are booted,
b2b554ef AW	56	;; and thus the-root-module is defined
5f161164	57	(and (current-module) the-root-module)
5161a3c0 AW	58	env)))))
5161a3c0 AW	59
d8a071fc AW	60	;; Fast case for procedures with fixed arities.
d8a071fc AW	61	(define-syntax make-fixed-closure
4abb824c	62	(lambda (x)
9331f91c	63	(define max-static-argument-count 8)
4abb824c AW	64	(define (make-formals n)
	65	(map (lambda (i)
	66	(datum->syntax
c438cd71	67	x
4abb824c AW	68	(string->symbol
	69	(string (integer->char (+ (char->integer #\a) i))))))
	70	(iota n)))
	71	(syntax-case x ()
d8a071fc	72	((_ eval nreq body env) (not (identifier? #'env))
4abb824c	73	#'(let ((e env))
d8a071fc AW	74	(make-fixed-closure eval nreq body e)))
d8a071fc AW	75	((_ eval nreq body env)
4abb824c AW	76	#`(case nreq
	77	#,@(map (lambda (nreq)
	78	(let ((formals (make-formals nreq)))
	79	#`((#,nreq)
d8a071fc AW	80	(lambda (#,@formals)
	81	(eval body
	82	(cons* #,@(reverse formals) env))))))
4abb824c AW	83	(iota max-static-argument-count))
	84	(else
	85	#,(let ((formals (make-formals max-static-argument-count)))
	86	#`(lambda (#,@formals . more)
	87	(let lp ((new-env (cons* #,@(reverse formals) env))
	88	(nreq (- nreq #,max-static-argument-count))
	89	(args more))
	90	(if (zero? nreq)
	91	(eval body
d8a071fc AW	92	(if (null? args)
	93	new-env
	94	(scm-error 'wrong-number-of-args
	95	"eval" "Wrong number of arguments"
	96	'() #f)))
4abb824c AW	97	(if (null? args)
	98	(scm-error 'wrong-number-of-args
	99	"eval" "Wrong number of arguments"
	100	'() #f)
	101	(lp (cons (car args) new-env)
	102	(1- nreq)
	103	(cdr args)))))))))))))
	104
9331f91c AW	105	(define-syntax call
	106	(lambda (x)
	107	(define max-static-call-count 4)
	108	(syntax-case x ()
	109	((_ eval proc nargs args env) (identifier? #'env)
	110	#`(case nargs
	111	#,@(map (lambda (nargs)
	112	#`((#,nargs)
	113	(proc
	114	#,@(map
	115	(lambda (n)
	116	(let lp ((n n) (args #'args))
	117	(if (zero? n)
	118	#`(eval (car #,args) env)
	119	(lp (1- n) #`(cdr #,args)))))
	120	(iota nargs)))))
	121	(iota max-static-call-count))
	122	(else
	123	(apply proc
	124	#,@(map
	125	(lambda (n)
	126	(let lp ((n n) (args #'args))
	127	(if (zero? n)
	128	#`(eval (car #,args) env)
	129	(lp (1- n) #`(cdr #,args)))))
	130	(iota max-static-call-count))
	131	(let lp ((exps #,(let lp ((n max-static-call-count)
	132	(args #'args))
	133	(if (zero? n)
	134	args
	135	(lp (1- n) #`(cdr #,args)))))
	136	(args '()))
	137	(if (null? exps)
	138	(reverse args)
	139	(lp (cdr exps)
	140	(cons (eval (car exps) env) args)))))))))))
	141
b2b554ef AW	142	;; This macro could be more straightforward if the compiler had better
b2b554ef AW	143	;; copy propagation. As it is we do some copy propagation by hand.
5161a3c0 AW	144	(define-syntax mx-bind
	145	(lambda (x)
	146	(syntax-case x ()
	147	((_ data () body)
	148	#'body)
	149	((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
	150	#'(let ((a (car data))
	151	(b (cdr data)))
	152	body))
	153	((_ data (a . b) body) (identifier? #'a)
	154	#'(let ((a (car data))
	155	(xb (cdr data)))
	156	(mx-bind xb b body)))
	157	((_ data (a . b) body)
	158	#'(let ((xa (car data))
	159	(xb (cdr data)))
	160	(mx-bind xa a (mx-bind xb b body))))
	161	((_ data v body) (identifier? #'v)
	162	#'(let ((v data))
	163	body)))))
	164
b2b554ef AW	165	;; The resulting nested if statements will be an O(n) dispatch. Once
b2b554ef AW	166	;; we compile `case' effectively, this situation will improve.
5161a3c0 AW	167	(define-syntax mx-match
	168	(lambda (x)
	169	(syntax-case x (quote)
	170	((_ mx data tag)
	171	#'(error "what" mx))
	172	((_ mx data tag (('type pat) body) c* ...)
	173	#`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
	174	(error "not a typecode" #'type)))
	175	(mx-bind data pat body)
	176	(mx-match mx data tag c* ...))))))
	177
	178	(define-syntax memoized-expression-case
	179	(lambda (x)
	180	(syntax-case x ()
	181	((_ mx c ...)
	182	#'(let ((tag (memoized-expression-typecode mx))
	183	(data (memoized-expression-data mx)))
	184	(mx-match mx data tag c ...)))))))
	185
	186
21ec0bd9 AW	187	;;;
	188	;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
	189	;;; types occur when getting to a prompt on a fresh build. Here are the numbers
	190	;;; I got:
	191	;;;
	192	;;; lexical-ref: 32933054
	193	;;; call: 20281547
	194	;;; toplevel-ref: 13228724
	195	;;; if: 9156156
	196	;;; quote: 6610137
	197	;;; let: 2619707
	198	;;; lambda: 1010921
	199	;;; begin: 948945
	200	;;; lexical-set: 509862
	201	;;; call-with-values: 139668
	202	;;; apply: 49402
	203	;;; module-ref: 14468
	204	;;; define: 1259
	205	;;; toplevel-set: 328
21ec0bd9 AW	206	;;; call/cc: 0
	207	;;; module-set: 0
	208	;;;
	209	;;; So until we compile `case' into a computed goto, we'll order the clauses in
	210	;;; `eval' in this order, to put the most frequent cases first.
	211	;;;
	212
5161a3c0 AW	213	(define primitive-eval
5161a3c0 AW	214	(let ()
d8a071fc AW	215	;; We pre-generate procedures with fixed arities, up to some number of
	216	;; arguments; see make-fixed-closure above.
	217
	218	;; A unique marker for unbound keywords.
	219	(define unbound-arg (list 'unbound-arg))
	220
7572ee52 AW	221	;; Procedures with rest, optional, or keyword arguments, potentially with
7572ee52 AW	222	;; multiple arities, as with case-lambda.
d8a071fc	223	(define (make-general-closure env body nreq rest? nopt kw inits alt)
7572ee52	224	(define alt-proc
c438cd71	225	(and alt ; (body docstring nreq ...)
dc3e203e	226	(let* ((body (car alt))
c438cd71 LC	227	(spec (cddr alt))
	228	(nreq (car spec))
	229	(rest (if (null? (cdr spec)) #f (cadr spec)))
	230	(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
dc3e203e AW	231	(nopt (if tail (car tail) 0))
	232	(kw (and tail (cadr tail)))
	233	(inits (if tail (caddr tail) '()))
	234	(alt (and tail (cadddr tail))))
	235	(make-general-closure env body nreq rest nopt kw inits alt))))
f3cf9421 AW	236	(define (set-procedure-arity! proc)
	237	(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
	238	(if (not alt)
fc835b1b AW	239	(begin
	240	(set-procedure-property! proc 'arglist
	241	(list nreq
	242	nopt
	243	(if kw (cdr kw) '())
	244	(and kw (car kw))
	245	(and rest? '_)))
	246	(set-procedure-minimum-arity! proc nreq nopt rest?))
c438cd71 LC	247	(let* ((spec (cddr alt))
	248	(nreq* (car spec))
	249	(rest?* (if (null? (cdr spec)) #f (cadr spec)))
	250	(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
f3cf9421 AW	251	(nopt* (if tail (car tail) 0))
	252	(alt* (and tail (cadddr tail))))
	253	(if (or (< nreq* nreq)
	254	(and (= nreq* nreq)
	255	(if rest?
	256	(and rest?* (> nopt* nopt))
	257	(or rest?* (> nopt* nopt)))))
	258	(lp alt* nreq* nopt* rest?*)
	259	(lp alt* nreq nopt rest?)))))
	260	proc)
	261	(set-procedure-arity!
	262	(lambda %args
	263	(let lp ((env env)
	264	(nreq* nreq)
	265	(args %args))
	266	(if (> nreq* 0)
	267	;; First, bind required arguments.
	268	(if (null? args)
	269	(if alt
	270	(apply alt-proc %args)
	271	(scm-error 'wrong-number-of-args
	272	"eval" "Wrong number of arguments"
	273	'() #f))
	274	(lp (cons (car args) env)
	275	(1- nreq*)
	276	(cdr args)))
	277	;; Move on to optional arguments.
	278	(if (not kw)
	279	;; Without keywords, bind optionals from arguments.
	280	(let lp ((env env)
	281	(nopt nopt)
	282	(args args)
	283	(inits inits))
	284	(if (zero? nopt)
	285	(if rest?
	286	(eval body (cons args env))
	287	(if (null? args)
	288	(eval body env)
	289	(if alt
	290	(apply alt-proc %args)
	291	(scm-error 'wrong-number-of-args
	292	"eval" "Wrong number of arguments"
	293	'() #f))))
	294	(if (null? args)
	295	(lp (cons (eval (car inits) env) env)
	296	(1- nopt) args (cdr inits))
	297	(lp (cons (car args) env)
	298	(1- nopt) (cdr args) (cdr inits)))))
f3cf9421 AW	299	(let lp ((env env)
	300	(nopt* nopt)
	301	(args args)
	302	(inits inits))
581f410f AW	303	(cond
	304	;; With keywords, we stop binding optionals at the
	305	;; first keyword.
	306	((> nopt* 0)
	307	(if (or (null? args) (keyword? (car args)))
	308	(lp (cons (eval (car inits) env) env)
	309	(1- nopt*) args (cdr inits))
	310	(lp (cons (car args) env)
	311	(1- nopt*) (cdr args) (cdr inits))))
	312	;; Finished with optionals.
	313	((and alt (pair? args) (not (keyword? (car args)))
	314	(not rest?))
	315	;; Too many positional args, no #:rest arg,
	316	;; and we have an alternate.
	317	(apply alt-proc %args))
	318	(else
	319	(let* ((aok (car kw))
	320	(kw (cdr kw))
	321	(kw-base (+ nopt nreq (if rest? 1 0)))
	322	(imax (let lp ((imax (1- kw-base)) (kw kw))
	323	(if (null? kw)
	324	imax
	325	(lp (max (cdar kw) imax)
	326	(cdr kw)))))
	327	;; Fill in kwargs with "undefined" vals.
	328	(env (let lp ((i kw-base)
	329	;; Also, here we bind the rest
	330	;; arg, if any.
	331	(env (if rest?
	332	(cons args env)
	333	env)))
	334	(if (<= i imax)
	335	(lp (1+ i) (cons unbound-arg env))
	336	env))))
	337	;; Now scan args for keywords.
	338	(let lp ((args args))
	339	(if (and (pair? args) (pair? (cdr args))
	340	(keyword? (car args)))
	341	(let ((kw-pair (assq (car args) kw))
	342	(v (cadr args)))
	343	(if kw-pair
	344	;; Found a known keyword; set its value.
	345	(list-set! env
	346	(- imax (cdr kw-pair)) v)
	347	;; Unknown keyword.
	348	(if (not aok)
	349	(scm-error
	350	'keyword-argument-error
	351	"eval" "Unrecognized keyword"
	352	'() #f)))
	353	(lp (cddr args)))
	354	(if (pair? args)
	355	(if rest?
	356	;; Be lenient parsing rest args.
	357	(lp (cdr args))
	358	(scm-error 'keyword-argument-error
	359	"eval" "Invalid keyword"
	360	'() #f))
	361	;; Finished parsing keywords. Fill in
	362	;; uninitialized kwargs by evalling init
	363	;; expressions in their appropriate
	364	;; environment.
	365	(let lp ((i (- imax kw-base))
	366	(inits inits))
367	(if (pair? inits)
368	(let ((tail (list-tail env i)))
369	(if (eq? (car tail) unbound-arg)
370	(set-car! tail
371	(eval (car inits)
372	(cdr tail))))
373	(lp (1- i) (cdr inits)))
374	;; Finally, eval the body.
375	(eval body env))))))))))))))))
d8a071fc	376
b2b554ef	377	;; The "engine". EXP is a memoized expression.
5161a3c0 AW	378	(define (eval exp env)
5161a3c0 AW	379	(memoized-expression-case exp
21ec0bd9	380	(('lexical-ref n)
bb0c8157 AW	381	(list-ref env n))
bb0c8157 AW	382
21ec0bd9 AW	383	(('call (f nargs . args))
	384	(let ((proc (eval f env)))
	385	(call eval proc nargs args env)))
	386
	387	(('toplevel-ref var-or-sym)
	388	(variable-ref
	389	(if (variable? var-or-sym)
	390	var-or-sym
bb0c8157 AW	391	(memoize-variable-access! exp
	392	(capture-env (if (pair? env)
	393	(cdr (last-pair env))
	394	env))))))
21ec0bd9	395
5161a3c0 AW	396	(('if (test consequent . alternate))
	397	(if (eval test env)
	398	(eval consequent env)
	399	(eval alternate env)))
	400
21ec0bd9 AW	401	(('quote x)
	402	x)
	403
5161a3c0 AW	404	(('let (inits . body))
	405	(let lp ((inits inits) (new-env (capture-env env)))
	406	(if (null? inits)
	407	(eval body new-env)
	408	(lp (cdr inits)
	409	(cons (eval (car inits) env) new-env)))))
c438cd71 LC	410
	411	(('lambda (body docstring nreq . tail))
	412	(let ((proc
	413	(if (null? tail)
	414	(make-fixed-closure eval nreq body (capture-env env))
	415	(if (null? (cdr tail))
	416	(make-general-closure (capture-env env) body
	417	nreq (car tail)
	418	0 #f '() #f)
	419	(apply make-general-closure (capture-env env)
	420	body nreq tail)))))
	421	(when docstring
	422	(set-procedure-property! proc 'documentation docstring))
	423	proc))
d8a071fc	424
6fc3eae4 AW	425	(('seq (head . tail))
	426	(begin
	427	(eval head env)
	428	(eval tail env)))
	429
5161a3c0 AW	430	(('lexical-set! (n . x))
5161a3c0 AW	431	(let ((val (eval x env)))
bb0c8157	432	(list-set! env n val)))
5161a3c0	433
21ec0bd9 AW	434	(('call-with-values (producer . consumer))
	435	(call-with-values (eval producer env)
	436	(eval consumer env)))
	437
	438	(('apply (f args))
	439	(apply (eval f env) (eval args env)))
	440
	441	(('module-ref var-or-spec)
5161a3c0	442	(variable-ref
21ec0bd9 AW	443	(if (variable? var-or-spec)
	444	var-or-spec
	445	(memoize-variable-access! exp #f))))
5161a3c0	446
21ec0bd9	447	(('define (name . x))
ee15aa46 AW	448	(let ((x (eval x env)))
	449	(if (and (procedure? x) (not (procedure-property x 'name)))
	450	(set-procedure-property! x 'name name))
adb8054c MW	451	(define! name x)
adb8054c MW	452	(if #f #f)))
21ec0bd9	453
5161a3c0 AW	454	(('toplevel-set! (var-or-sym . x))
	455	(variable-set!
	456	(if (variable? var-or-sym)
	457	var-or-sym
bb0c8157 AW	458	(memoize-variable-access! exp
	459	(capture-env (if (pair? env)
	460	(cdr (last-pair env))
	461	env))))
5161a3c0 AW	462	(eval x env)))
5161a3c0 AW	463
1773bc7d AW	464	(('call-with-prompt (tag thunk . handler))
	465	(call-with-prompt
	466	(eval tag env)
	467	(eval thunk env)
	468	(eval handler env)))
747022e4	469
21ec0bd9 AW	470	(('call/cc proc)
21ec0bd9 AW	471	(call/cc (eval proc env)))
5161a3c0 AW	472
	473	(('module-set! (x . var-or-spec))
	474	(variable-set!
	475	(if (variable? var-or-spec)
	476	var-or-spec
	477	(memoize-variable-access! exp #f))
	478	(eval x env)))))
	479
b2b554ef	480	;; primitive-eval
5161a3c0	481	(lambda (exp)
b2b554ef	482	"Evaluate @var{exp} in the current module."
5161a3c0	483	(eval
a310a1d1 AW	484	(memoize-expression
	485	(if (macroexpanded? exp)
	486	exp
	487	((module-transformer (current-module)) exp)))
5161a3c0	488	'()))))