blob: 937f93e0e656b87d1f8e6ce89183ddd026107f27 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
; "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)))))
|
