aboutsummaryrefslogtreecommitdiffstats
path: root/srfi-39.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:06:40 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:06:40 -0800
commita69c9fb665459e2bfdbda1bf80741a0af31a7faf (patch)
treef0bc974f8805049e6b9a4e6864886298fbaa05a4 /srfi-39.scm
parent4684239efa63dc1b2c1cbe37ef7d3062029f5532 (diff)
downloadslib-a69c9fb665459e2bfdbda1bf80741a0af31a7faf.tar.gz
slib-a69c9fb665459e2bfdbda1bf80741a0af31a7faf.zip
New upstream version 3b5upstream/3b5upstream
Diffstat (limited to 'srfi-39.scm')
-rwxr-xr-xsrfi-39.scm81
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 ...)))))