summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-03 12:16:49 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-03 12:16:49 +0100
commitbe6e40a1df4cc97d1bf3d4567e980b92454d5180 (patch)
tree5d661a188b36a0b6eca4090de19c59159d7f68d6
parent91fc226e24bea970b5d6814fdceebd3c97c54a28 (diff)
downloadguile-be6e40a1df4cc97d1bf3d4567e980b92454d5180.tar.gz
Eval evaluates initializers before creating environment ribs.
* module/ice-9/eval.scm (let-env-evaluator, primitive-eval): Evaluate initializers of let expressions before creating the environment rib. This prevents call/cc-related shenanigans.
-rw-r--r--module/ice-9/eval.scm50
1 files changed, 43 insertions, 7 deletions
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index e34c08715..51cdb654b 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -79,6 +79,48 @@
(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
(lambda (x)
@@ -456,13 +498,7 @@
x)
(('let (inits . body))
- (let* ((width (vector-length inits))
- (new-env (make-env width #f env)))
- (let lp ((i 0))
- (when (< i width)
- (env-set! new-env 0 i (eval (vector-ref inits i) env))
- (lp (1+ i))))
- (eval body new-env)))
+ (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
(('lambda (body meta nreq . tail))
(let ((proc