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
76
77
78
79
80
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 ...)))))
|
