source: project/release/4/environments/branches/rewrite/environments.scm @ 25669

Last change on this file since 25669 was 25669, checked in by Moritz Heidkamp, 10 years ago

environments rewrite: add a second argument to make-environment' which can be used to name an environment; add environment' syntax which creates an anonymous module and returns its `module-environment'.

File size: 6.4 KB
Line 
1(module environments
2
3(make-environment
4 environment-copy
5 environment?
6 interaction-environment?
7 environment-empty?
8 environment-extendable?
9 environment-set-mutable!
10 environment-mutable?
11 environment-ref
12 environment-set!
13 environment-extend!
14 environment-includes?
15 environment-has-binding?
16 environment-remove!
17 environment-for-each
18 environment-symbols
19 environment)
20
21(import chicken scheme)
22(use data-structures srfi-1)
23
24(define-record environment
25  name
26  (setter bindings)
27  extendable?)
28
29(define-syntax define*
30  (syntax-rules ()
31    ((_ name val)
32     (begin
33       (define-for-syntax name val)
34       (define name val)))))
35
36(define* *environment-name* "(anonymous)")
37
38(define (unbind! binding)
39  (unless (pair? (cdr binding))
40    (##sys#setslot (cdr binding) 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))))
41
42(define (environment-finalize! env)
43  (for-each unbind! (environment-bindings env)))
44
45;; make-environment          (make-environment [EXTENSIBLE?])
46(set! make-environment
47      (let ((make-env make-environment))
48        (lambda (extendable? #!optional (name *environment-name*))
49          (set-finalizer! (make-env name '() extendable?)
50                          environment-finalize!))))
51
52(define (module-environment? env)
53  (symbol? (environment-name env)))
54
55(set! environment-extendable?
56      (let ((ext? environment-extendable?))
57        (lambda (env)
58          (and (not (module-environment? env))
59               (ext? env)))))
60
61;;   environment-extend!       (environment-extend! ENV SYMBOL [VALUE [MUTABLE?]])
62;; TODO: respect `mutable?'
63(define (environment-extend! env symbol
64                             #!optional
65                             (value (##sys#slot '##sys#arbitrary-unbound-symbol 0))
66                             (mutable? #t))
67  (let* ((alias (gensym symbol))
68         (bindings (environment-bindings env))
69         (old-alias (assq symbol bindings)))
70    (when old-alias
71      (unbind! old-alias))
72    (##sys#setslot alias 0 value)
73    (set! (environment-bindings env)
74          (alist-update! symbol alias bindings))))
75
76;;   environment-set!          (environment-set! ENV SYMBOL VALUE)
77(define (environment-set! env symbol value)
78  (if (not (environment-extendable? env))
79      (error 'environment-extend! "environment is not extendable" env)
80      (environment-extend! env symbol value)))
81
82;;   environment-set-mutable!  (environment-set-mutable! ENV SYMBOL MUTABLE?)
83(define (environment-set-mutable! env symbol mutable?)
84  (error 'environment-set-mutable! "not implemented, yet"))
85
86(define (binding->value binding)
87  (##sys#slot (or (and (symbol? binding)
88                       (get binding '##core#primitive))
89                  binding) 0))
90
91;; environment-copy          (environment-copy ENV [EXTENSIBLE? [SYMBOLS [MUTABLE?]]])
92(define (environment-copy env #!optional extendable? symbols (mutable? extendable?))
93  (let ((new (make-environment extendable?))
94        (bindings (environment-bindings env)))
95    (set! (environment-bindings new)
96          (fold (lambda (binding bindings)
97                  (if (pair? (cdr binding))
98                      (cons binding bindings)
99                      (let* ((sym (car binding))
100                             (val (binding->value (cdr binding)))
101                             (alias (gensym sym)))
102                        (##sys#setslot alias 0 val)
103                        (alist-cons sym alias bindings))))
104                '()
105                (if symbols
106                    (map (lambda (sym)
107                           (or (assq sym bindings)
108                               (error 'environment-copy "symbol not bound in environment" sym)))
109                         symbols)
110                    bindings)))
111    new))
112
113;;   environment-empty?        (environment-empty? ENV) => boolean
114(define (environment-empty? env)
115  (null? (environment-bindings env)))
116
117;;   environment-for-each      (environment-for-each ENV PROC)
118(define (environment-for-each env proc)
119  (for-each (lambda (binding)
120              (proc (car binding) (##sys#slot (cdr binding) 0)))
121            (environment-bindings env)))
122
123;;   interaction-environment?  (interaction-environment? X) => boolean
124(define (interaction-environment? env)
125  (eq? (interaction-environment) env))
126
127;;   environment-has-binding?  (environment-has-binding? ENV SYMBOL) => boolean
128(define (environment-has-binding? env symbol)
129  (any (lambda (binding)
130         (eq? (car binding) symbol))
131       (or (environment-bindings env) '()))) ; interaction-environment's bindings are #f
132
133;;   environment-includes?     (environment-includes? ENV SYMBOL) => boolean
134(define (environment-includes? env symbol)
135  (or (interaction-environment? env)
136      (environment-has-binding? env symbol)))
137
138;;   environment-mutable?      (environment-mutable? ENV SYMBOL) => boolean
139(define (environment-mutable? env symbol)
140  (error 'environment-mutable? "not implemented, yet"))
141
142;;   environment-ref           (environment-ref ENV SYMBOL) => *
143(define (environment-ref env symbol)
144  (let ((binding (alist-ref symbol (environment-bindings env))))
145    (cond ((not binding)
146           (error 'environment-ref "symbol is not bound in environment" symbol))
147          ((pair? binding)
148           (error 'environment-bindings "can't reference macro" symbol))
149          (else (binding->value binding)))))
150
151;;   environment-remove!       (environment-remove! ENV SYMBOLS [SILENT? [INEXTENSIBLE?]])
152(define (environment-remove! env symbols #!optional silent? (inextensible? #t))
153  (set! (environment-bindings env)
154        (fold (lambda (sym bindings)
155                (let ((binding (assq sym bindings)))
156                  (unbind! binding)
157                  (alist-delete! sym bindings)))
158              (environment-bindings env)
159              (if (pair? symbols)
160                  symbols
161                  (list symbols)))))
162
163;;   environment-symbols       (environment-symbols ENV) => list
164(define (environment-symbols env)
165  (map car (environment-bindings env)))
166
167(import-for-syntax srfi-1)
168
169(define-syntax environment
170  (ir-macro-transformer
171   (lambda (x i c)
172     (let ((exports (cadr x))
173           (body (cddr x))
174           (env  (gensym 'environment)))
175       `(begin
176          (module ,env ,exports . ,body)
177          (let ((env (module-environment ',env)))
178            (##sys#setslot env 1 ,*environment-name*)
179            ;; don't clutter the modle-table. is this a good idea?
180            (set! ##sys#module-table (alist-delete! ',env ##sys#module-table))
181            env))))))
182
183)
Note: See TracBrowser for help on using the repository browser.