summaryrefslogtreecommitdiffstats
path: root/dynamic.scm
diff options
context:
space:
mode:
Diffstat (limited to 'dynamic.scm')
-rw-r--r--dynamic.scm75
1 files changed, 75 insertions, 0 deletions
diff --git a/dynamic.scm b/dynamic.scm
new file mode 100644
index 0000000..937f93e
--- /dev/null
+++ b/dynamic.scm
@@ -0,0 +1,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)))))