;;;; Dynamics.scheme
;;;; Copyright Ó 1989, 1991 by Xerox Corporation. All rights reserved.
;;;; Last changed by Pavel on August 9, 1989 1:11:04 pm PDT
(export (make-dynamic dynamic? dynamic-ref dynamic-set!
dynamic-bind call-with-dynamic-binding)
(define dynamic-rtd (make-record-type "Dynamic Variable" '(value)))
(define make-dynamic (record-constructor dynamic-rtd))
(define dynamic? (record-predicate dynamic-rtd))
(define dynamic-value (record-accessor dynamic-rtd 'value))
(define set-dynamic-value! (record-updater dynamic-rtd 'value))
(define dynamic-environment '())
(define (dynamic-ref dvar)
(if (dynamic? dvar)
(cond
((assv dvar dynamic-environment)
=> cdr)
(else
(dynamic-value dvar)))
(error 'dynamic-ref dvar "Not a dynamic variable")))
(define (dynamic-set! dvar value)
(if (dynamic? dvar)
(cond
((assv dvar dynamic-environment)
=> (lambda (entry)
(set-cdr! entry value)))
(else
(set-dynamic-value! dvar value)))
(error 'dynamic-set! dvar "Not a dynamic variable")))
(define (call-with-dynamic-binding dvar value thunk)
(if (dynamic? dvar)
(let* ((saved-env (cons (cons dvar value) dynamic-environment))
(swap! (lambda ()
(let ((temp dynamic-environment))
(set! dynamic-environment saved-env)
(set! saved-env temp)))))
(dynamic-wind
swap!
thunk
swap!))
(error 'call-with-dynamic-binding dvar "Not a dynamic variable")))
(define dynamic-bind
(make-syntax
(lambda (bindings . body)
(if (null? bindings)
`(let () ,@body)
(let ((vars (map (lambda (b) (gensym)) bindings))
(vals (map (lambda (b) (gensym)) bindings)))
`(let (,@(map (lambda (v b) `(,v ,(car b))) vars bindings)
,@(map (lambda (v b) `(,v ,(cadr b))) vals bindings)
(body-thunk (lambda () ,@body))
)
,(let loop ((vars vars)
(vals vals))
(if (null? (cdr vars))
`(call-with-dynamic-binding ,(car vars) ,(car vals)
body-thunk)
`(call-with-dynamic-binding ,(car vars) ,(car vals)
(lambda ()
,(loop (cdr vars) (cdr vals))))))))))))