
(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))))))))))))
)
      
;;;; Dynamics.scheme
;;;; Copyright Ó 1989, 1991 by Xerox Corporation.  All rights reserved.
;;;; Last changed by Pavel on August 9, 1989 1:11:04 pm PDT
Ê7  •NewlineDelimiter
–(cedarcode) style™ ™JšœÐetœ7™GJ™;—J˜ ˜7J˜-J˜ J˜CJ˜ J˜6J˜0J˜;J˜?J˜ J˜ J˜ ˜˜˜˜ J˜—˜J˜——J˜4——J˜ ˜!˜˜˜ ˜J˜——˜J˜!——J˜5——J˜ ˜4˜˜?˜˜,˜/J˜!———˜J˜J˜J˜——J˜B——J˜ ˜˜˜˜J˜˜1J˜/˜:˜8J˜ J˜—˜J˜˜˜3J˜—˜3˜
J˜'———————————J˜— …—      õ  