mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

Eval evaluates initializers before creating environment ribs.

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-11-03 12:16:49 +01:00
parent 91fc226e24
commit be6e40a1df
1 changed files with 43 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

50
module/ice-9/eval.scm
View file

@ -79,6 +79,48 @@
(vector-set! e (1+ width) val) (vector-set! e (1+ width) val)
(lp (vector-ref e 0) (1- d))))))) (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. ;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure (define-syntax make-fixed-closure
(lambda (x) (lambda (x)
@ -456,13 +498,7 @@
x) x)
(('let (inits . body)) (('let (inits . body))
(let* ((width (vector-length inits)) (eval body ((let-env-evaluator eval env (_ _ _ _)) 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)))
(('lambda (body meta nreq . tail)) (('lambda (body meta nreq . tail))
(let ((proc (let ((proc