summaryrefslogtreecommitdiff
path: root/module/ice-9/eval.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/eval.scm')
-rw-r--r--module/ice-9/eval.scm472
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))))