Import Upstream version 2a6upstream/2a6

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)))))