; "dynamic.scm", DYNAMIC data type for Scheme ; Copyright 1992 Andrew Wilcox. ; ; You may freely copy, redistribute and modify this package. (require 'record) (require 'dynamic-wind) (define dynamic-environment-rtd (make-record-type "dynamic environment" '(dynamic value parent))) (define make-dynamic-environment (record-constructor dynamic-environment-rtd)) (define dynamic-environment:dynamic (record-accessor dynamic-environment-rtd 'dynamic)) (define dynamic-environment:value (record-accessor dynamic-environment-rtd 'value)) (define dynamic-environment:set-value! (record-modifier dynamic-environment-rtd 'value)) (define dynamic-environment:parent (record-accessor dynamic-environment-rtd 'parent)) (define *current-dynamic-environment* #f) (define (extend-current-dynamic-environment dynamic obj) (set! *current-dynamic-environment* (make-dynamic-environment dynamic obj *current-dynamic-environment*))) (define dynamic-rtd (make-record-type "dynamic" '())) ;@ (define make-dynamic (let ((dynamic-constructor (record-constructor dynamic-rtd))) (lambda (obj) (let ((dynamic (dynamic-constructor))) (extend-current-dynamic-environment dynamic obj) dynamic)))) ;@ (define dynamic? (record-predicate dynamic-rtd)) (define (guarantee-dynamic dynamic) (or (dynamic? dynamic) (slib:error "Not a dynamic" dynamic))) (define dynamic:errmsg "No value defined for this dynamic in the current dynamic environment") ;@ (define (dynamic-ref dynamic) (guarantee-dynamic dynamic) (let loop ((env *current-dynamic-environment*)) (cond ((not env) (slib:error dynamic:errmsg dynamic)) ((eq? (dynamic-environment:dynamic env) dynamic) (dynamic-environment:value env)) (else (loop (dynamic-environment:parent env)))))) ;@ (define (dynamic-set! dynamic obj) (guarantee-dynamic dynamic) (let loop ((env *current-dynamic-environment*)) (cond ((not env) (slib:error dynamic:errmsg dynamic)) ((eq? (dynamic-environment:dynamic env) dynamic) (dynamic-environment:set-value! env obj)) (else (loop (dynamic-environment:parent env)))))) ;@ (define (call-with-dynamic-binding dynamic obj thunk) (let ((out-thunk-env #f) (in-thunk-env (make-dynamic-environment dynamic obj *current-dynamic-environment*))) (dynamic-wind (lambda () (set! out-thunk-env *current-dynamic-environment*) (set! *current-dynamic-environment* in-thunk-env)) thunk (lambda () (set! in-thunk-env *current-dynamic-environment*) (set! *current-dynamic-environment* out-thunk-env)))))