diff options
Diffstat (limited to 'module/ice-9/eval.scm')
-rw-r--r-- | module/ice-9/eval.scm | 472 |
1 files changed, 271 insertions, 201 deletions
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index c9711134c..f95bbe90a 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 2009, 2010, 2012, 2013 Free Software Foundation, Inc. +;;;; 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 @@ -43,19 +43,83 @@ (eval-when (compile) - (define-syntax capture-env + (define-syntax env-toplevel (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))))) + (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))))))) + + ;; For evaluating the initializers in a "let" expression. We have to + ;; evaluate the initializers before creating the environment rib, to + ;; prevent continuation-related shenanigans; see + ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a + ;; deeper discussion. + ;; + ;; This macro will inline evaluation of the first N initializers. + ;; That number N is indicated by the number of template arguments + ;; passed to the macro. It's a bit nasty but it's flexible and + ;; optimizes well. + (define-syntax let-env-evaluator + (syntax-rules () + ((eval-and-make-env eval env (template ...)) + (let () + (define-syntax eval-and-make-env + (syntax-rules () + ((eval-and-make-env inits width (template ...) k) + (let lp ((n (length '(template ...))) (vals '())) + (if (eqv? n width) + (let ((env (make-env n #f env))) + (let lp ((n (1- n)) (vals vals)) + (if (null? vals) + (k env) + (begin + (env-set! env 0 n (car vals)) + (lp (1- n) (cdr vals)))))) + (lp (1+ n) + (cons (eval (vector-ref inits n) env) vals))))) + ((eval-and-make-env inits width (var (... ...)) k) + (let ((n (length '(var (... ...))))) + (if (eqv? n width) + (k (make-env n #f env)) + (let* ((x (eval (vector-ref inits n) env)) + (k (lambda (env) + (env-set! env 0 n x) + (k env)))) + (eval-and-make-env inits width (x var (... ...)) k))))))) + (lambda (inits) + (let ((width (vector-length inits)) + (k (lambda (env) env))) + (eval-and-make-env inits width () k))))))) ;; Fast case for procedures with fixed arities. (define-syntax make-fixed-closure @@ -79,28 +143,77 @@ #`((#,nreq) (lambda (#,@formals) (eval body - (cons* #,@(reverse formals) env)))))) + (make-env* env #,@formals)))))) (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) + (let ((env (make-env nreq #f env))) + #,@(map (lambda (formal n) + #`(env-set! env 0 #,n #,formal)) + formals (iota (length formals))) + (let lp ((i #,*max-static-argument-count*) + (args more)) + (cond + ((= i nreq) (eval body (if (null? args) - new-env + 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))))))))))))) + '() #f)))) + ((null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (else + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args)))))))))))))) + + ;; Fast case for procedures with fixed arities and a rest argument. + (define-syntax make-rest-closure + (lambda (x) + (define *max-static-argument-count* 3) + (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-rest-closure eval nreq body e))) + ((_ eval nreq body env) + #`(case nreq + #,@(map (lambda (nreq) + (let ((formals (make-formals nreq))) + #`((#,nreq) + (lambda (#,@formals . rest) + (eval body + (make-env* env #,@formals rest)))))) + (iota *max-static-argument-count*)) + (else + #,(let ((formals (make-formals *max-static-argument-count*))) + #`(lambda (#,@formals . more) + (let ((env (make-env (1+ nreq) #f env))) + #,@(map (lambda (formal n) + #`(env-set! env 0 #,n #,formal)) + formals (iota (length formals))) + (let lp ((i #,*max-static-argument-count*) + (args more)) + (cond + ((= i nreq) + (env-set! env 0 nreq args) + (eval body env)) + ((null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (else + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args)))))))))))))) (define-syntax call (lambda (x) @@ -179,8 +292,8 @@ (lambda (x) (syntax-case x () ((_ mx c ...) - #'(let ((tag (memoized-expression-typecode mx)) - (data (memoized-expression-data mx))) + #'(let ((tag (car mx)) + (data (cdr mx))) (mx-match mx data tag c ...))))))) @@ -203,8 +316,6 @@ ;;; module-ref: 14468 ;;; define: 1259 ;;; toplevel-set: 328 -;;; dynwind: 162 -;;; with-fluids: 0 ;;; call/cc: 0 ;;; module-set: 0 ;;; @@ -214,8 +325,9 @@ (define primitive-eval (let () - ;; We pre-generate procedures with fixed arities, up to some number of - ;; arguments; see make-fixed-closure above. + ;; We pre-generate procedures with fixed arities, up to some number + ;; of arguments, and some rest arities; see make-fixed-closure and + ;; make-rest-closure above. ;; A unique marker for unbound keywords. (define unbound-arg (list 'unbound-arg)) @@ -224,7 +336,7 @@ ;; 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 ...) + (and alt ; (body meta nreq ...) (let* ((body (car alt)) (spec (cddr alt)) (nreq (car spec)) @@ -262,125 +374,110 @@ 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)) + (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 (not kw) (not rest?) (> nargs (+ nreq nopt))) + (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt)))) + (if alt + (apply alt-proc %args) + ((scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)))) + (else + (let* ((nvals (+ nreq (if rest? 1 0) (length inits))) + (env (make-env nvals unbound-arg env))) + (let lp ((i 0) (args %args)) + (cond + ((< i nreq) + ;; Bind required arguments. + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) + ((not kw) + ;; Optional args (possibly), but no keyword args. + (let lp ((i i) (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)) + ((< i (+ nreq nopt)) + (cond + ((< i nargs) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args) (cdr inits))) + (else + (env-set! env 0 i (eval (car inits) env)) + (lp (1+ i) args (cdr inits))))) (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)))) + (when rest? + (env-set! env 0 i args)) + (eval body env))))) + (else + ;; Optional args. As before, but stop at the first + ;; keyword. + (let lp ((i i) (args args) (inits inits)) + (cond + ((< i (+ nreq nopt)) + (cond + ((and (< i nargs) (not (keyword? (car args)))) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args) (cdr inits))) + (else + (env-set! env 0 i (eval (car inits) env)) + (lp (1+ i) args (cdr inits))))) + (else + (when rest? + (env-set! env 0 i args)) + (let ((aok (car kw)) + (kw (cdr kw)) + (kw-base (if rest? (1+ i) i))) ;; 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)))))))))))))))) + (cond + ((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. + (env-set! env 0 (cdr kw-pair) v) + ;; Unknown keyword. + (if (not aok) + ((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 + ;; Finished parsing keywords. Fill in + ;; uninitialized kwargs by evalling init + ;; expressions in their appropriate + ;; environment. + (let lp ((i kw-base) (inits inits)) + (cond + ((pair? inits) + (when (eq? (env-ref env 0 i) unbound-arg) + (env-set! env 0 i (eval (car inits) env))) + (lp (1+ i) (cdr inits))) + (else + ;; 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)) + (('lexical-ref (depth . width)) + (env-ref env depth width)) (('call (f nargs . args)) (let ((proc (eval f env))) @@ -390,10 +487,7 @@ (variable-ref (if (variable? var-or-sym) var-or-sym - (memoize-variable-access! exp - (capture-env (if (pair? env) - (cdr (last-pair env)) - env)))))) + (memoize-variable-access! exp (env-toplevel env))))) (('if (test consequent . alternate)) (if (eval test env) @@ -404,37 +498,28 @@ 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))))) + (eval body ((let-env-evaluator eval env (_ _ _ _)) inits))) - (('lambda (body docstring nreq . tail)) + (('lambda (body meta nreq . tail)) (let ((proc (if (null? tail) - (make-fixed-closure eval nreq body (capture-env env)) + (make-fixed-closure eval nreq body 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)) + (make-rest-closure eval nreq body env) + (apply make-general-closure env body nreq tail))))) + (let lp ((meta meta)) + (unless (null? meta) + (set-procedure-property! proc (caar meta) (cdar meta)) + (lp (cdr meta)))) proc)) - (('begin (first . rest)) - (let lp ((first first) (rest rest)) - (if (null? rest) - (eval first env) - (begin - (eval first env) - (lp (car rest) (cdr rest)))))) - - (('lexical-set! (n . x)) - (let ((val (eval x env))) - (list-set! env n val))) + (('seq (head . tail)) + (begin + (eval head env) + (eval tail env))) + + (('lexical-set! ((depth . width) . x)) + (env-set! env depth width (eval x env))) (('call-with-values (producer . consumer)) (call-with-values (eval producer env) @@ -450,40 +535,25 @@ (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) + (begin + (define! name (eval x env)) (if #f #f))) - + + (('capture-module x) + (eval x (current-module))) + (('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)))) + (memoize-variable-access! exp (env-toplevel env))) (eval x env))) - (('dynwind (in exp . out)) - (dynamic-wind (eval in env) - (lambda () (eval exp env)) - (eval out env))) - - (('with-fluids (fluids vals . exp)) - (let* ((fluids (map (lambda (x) (eval x env)) fluids)) - (vals (map (lambda (x) (eval x env)) vals))) - (let lp ((fluids fluids) (vals vals)) - (if (null? fluids) - (eval exp env) - (with-fluids (((car fluids) (car vals))) - (lp (cdr fluids) (cdr vals))))))) - - (('prompt (tag exp . handler)) - (@prompt (eval tag env) - (eval exp env) - (eval handler 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))) @@ -503,4 +573,4 @@ (if (macroexpanded? exp) exp ((module-transformer (current-module)) exp))) - '())))) + #f)))) |