1 files changed, 81 insertions, 0 deletions
diff --git a/srfi-39.scm b/srfi-39.scm
new file mode 100755
index 0000000..f5af915
--- /dev/null
+++ b/srfi-39.scm
@@ -0,0 +1,81 @@
+;; Copyright (C) Marc Feeley 2002. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+
+;; The following implementation uses association lists to represent
+;; local dynamic environments.  The global dynamic environment binding
+;; is stored in the parameter object itself.  Since we are assuming
+;; that there is a single thread, the current local dynamic
+;; environment can be bound to a global variable, dynamic-env-local.
+;; Mutations of this variable are wrapped in a dynamic-wind so that
+;; the local dynamic environment returns to its previous value when
+;; control exits the body of the parameterize.
+
+(define (make-parameter init . conv)
+  (let ((converter
+	 (if (null? conv) identity (car conv))))
+    (let ((global-cell
+	   (cons #f (converter init))))
+      (letrec ((parameter
+		(lambda new-val
+		  (let ((cell (dynamic-lookup parameter global-cell)))
+		    (cond ((null? new-val)
+			   (cdr cell))
+			  ((null? (cdr new-val))
+			   (set-cdr! cell (converter (car new-val))))
+			  (else ; this case is needed for parameterize
+			   (converter (car new-val))))))))
+	(set-car! global-cell parameter)
+	parameter))))
+
+(define (dynamic-bind parameters values body)
+  (let* ((old-local
+	  (dynamic-env-local-get))
+	 (new-cells
+	  (map (lambda (parameter value)
+		 (cons parameter (parameter value #f)))
+	       parameters
+	       values))
+	 (new-local
+	  (append new-cells old-local)))
+    (dynamic-wind
+	(lambda () (dynamic-env-local-set! new-local))
+	body
+	(lambda () (dynamic-env-local-set! old-local)))))
+
+(define (dynamic-lookup parameter global-cell)
+  (or (assq parameter (dynamic-env-local-get))
+      global-cell))
+
+(define dynamic-env-local '())
+
+(define (dynamic-env-local-get)
+  dynamic-env-local)
+
+(define (dynamic-env-local-set! new-env)
+  (set! dynamic-env-local new-env))
+
+(define-syntax parameterize
+  (syntax-rules ()
+    ((parameterize ((expr1 expr2) ...) body ...)
+     (dynamic-bind (list expr1 ...)
+		   (list expr2 ...)
+		   (lambda () body ...)))))