source: project/contexts/trunk/contexts.scm @ 3051

Last change on this file since 3051 was 3051, checked in by arto, 14 years ago

Imported the initial development version of the contexts egg.

File size: 10.7 KB
Line 
1;;;; Evaluation contexts for building experimental Lisp1 interpreters.
2;;
3;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
4;;
5;; Permission is hereby granted, free of charge, to any person obtaining a copy
6;; of this software and associated documentation files (the "Software"), to
7;; deal in the Software without restriction, including without limitation the
8;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
9;; sell copies of the Software, and to permit persons to whom the Software is
10;; furnished to do so, subject to the following conditions:
11;;
12;; The above copyright notice and this permission notice shall be included in   
13;; all copies or substantial portions of the Software.
14;;
15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
21;; IN THE SOFTWARE.
22
23(require-extension (srfi 1) lolevel environments)
24
25(declare
26  ;(unit contexts)
27  (uses srfi-1 lolevel)
28  (usual-integrations)
29  (fixnum-arithmetic)
30  (no-bound-checks)
31  (export
32    context context-copy
33    context->environment context->alist context->hash-table
34    context? context-has-parent? context-ancestor?
35    context-extensible? context-mutable? context-flag?
36    context-empty? context-bound? context-exists?
37    context-flags context-bindings context-size
38    context-depth context-parent context-ancestors context-children
39    context-symbols context-values context-walk context-for-each
40    context-ref context-lookup
41    context-set! context-remove! context-import! context-merge!
42    context-eval context-load context-spawn ) )
43
44
45;;; Internals
46
47;(define unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0))
48(define-macro (unbound) `(##sys#slot '##sys#arbitrary-unbound-symbol 0))
49(define-inline (unbound? obj) (eq? (##sys#slot '##sys#arbitrary-unbound-symbol 0) obj))
50(define-macro (unbound-or name default) `(if (unbound? ,name) ,default ,name))
51(define-inline (->boolean obj) (not (not obj)) )
52(define list-sort sort)
53
54(define-record context
55  parent     ; #f (none) | #t (global) | <context>
56  flags      ; <list>
57  bindings ) ; <environment> | ((<symbol> . value) ...) | <vector>
58
59(define-record-printer context
60  (lambda (ctx out)
61    (fprintf out "(context parent: ~S flags: ~S bindings: ~S)"
62             (context-parent ctx)
63             (context-flags ctx)
64             (context-bindings ctx) ) ) )
65
66(define (context-sanity-check! loc parent flags bindings)
67  (unless (or (not parent) (context? parent))
68    (error loc "expected <context> or #f, got" parent) )
69  (unless (list? flags)
70    (error loc "expected <list>, got" flags) )
71  (unless (or (list? bindings) (environment? bindings))
72    (error loc "expected <environment> or <list>, got" bindings) ) )
73
74;; Dummy macro to make this often-repeated conditional slightly cleaner:
75(define-macro (context-case ctx bindings pair env)
76  `(let ((,bindings (context-bindings ,ctx)))
77     (cond
78       ((pair? ,bindings) ,@(cdr pair))
79       (else ,@(cdr env)) ) ) )
80
81
82;;; Constructors
83
84(define (context #!key (parent #f) (extensible #t) (flags '()) (bindings #f))
85  (let ((bindings (or bindings (make-environment (->boolean extensible)))))
86    (context-sanity-check! 'context parent flags bindings)
87    (make-context parent flags bindings) ) )
88
89(define (context-copy ctx #!key (parent (unbound)) (extensible (unbound)) (flags (unbound)) (filter #f))
90  (define (filter-bindings extensible)
91    (unless (or (not filter) (list? filter))
92      (error 'context-copy "expected <list>, got" filter) )
93    (context-case ctx bindings
94      ((pair?)
95       (let ((bindings (alist-copy bindings)))
96         (if (list? filter)
97             (filter-map (lambda (x) (and (memq (car x) filter) x))
98                         bindings)
99             bindings ) ) )
100      ((env?)
101       (environment-copy bindings extensible
102                         (if (list? filter) filter #f)) ) ) )
103  (let* ((parent     (unbound-or parent (context-parent ctx)))
104         (extensible (->boolean (unbound-or extensible (context-extensible? ctx))))
105         (flags      (unbound-or flags (context-flags ctx)))
106         (bindings   (filter-bindings extensible)) )
107    (context-sanity-check! 'context-copy parent flags bindings)
108    (make-context parent flags bindings) ) )
109
110
111;;; Conversion
112
113(define (context->environment ctx)
114  (define (alist->environment lst)
115    (let ((env (make-environment (context-extensible? ctx))))
116      (for-each (lambda (binding)
117                  (environment-set! env (car binding) (cdr binding)))
118                lst )
119      env ) )
120  (context-case ctx bindings
121    ((pair?) (alist->environment bindings))
122    ((env?)  bindings) ) )
123
124(define (context->alist ctx)
125  (define (environment->alist env)
126    (let ((alist '()))
127      (environment-for-each env
128                            (lambda (sym val)
129                              (set! alist (cons (cons sym val) alist)) ) )
130      alist ) )
131  (context-case ctx bindings
132    ((pair?) bindings)
133    ((env?)  (environment->alist bindings)) ) )
134
135(define (context->hash-table ctx)
136  (alist->hash-table (context->alist ctx)) )
137
138
139;;; Predicates
140
141(define context? context?)
142
143(define (context-has-parent? ctx)
144  (->boolean (context-parent ctx)) )
145
146(define (context-ancestor? ctx1 ctx2)
147  (let ((ancestors (context-ancestors ctx1)))
148    (->boolean (memq ctx2 ancestors)) ) )
149
150(define (context-extensible? ctx)
151  (context-case ctx bindings
152    ((pair?) #t)
153    ((env?)  (environment-extendable? bindings)) ) )
154
155(define (context-mutable? ctx #!optional (symbol #f))
156  (context-case ctx bindings
157    ((pair?) #t)
158    ((env?)  (if (not symbol) #t
159                 (environment-mutable? bindings symbol) ) ) ) )
160
161(define (context-flag? ctx flag #!optional (default #f))
162  (cdr (or (assq flag (context-flags ctx))
163           (cons #f default) ) ) )
164
165(define (context-empty? ctx)
166  (fx= (context-size ctx) 0) )
167
168(define (context-bound? ctx symbol)
169  (context-case ctx bindings
170    ((pair?) (->boolean (assq symbol bindings)) )
171    ((env?)  (environment-has-binding? bindings symbol)) ) )
172
173(define (context-exists? ctx symbol)
174  (or (context-bound? ctx symbol)
175      (let ((parent (context-parent ctx)))
176        (and parent (context-exists? parent symbol)) ) ) )
177
178
179;;; Accessors
180
181(define context-flags context-flags)
182
183(define context-bindings context-bindings)
184
185(define (context-size ctx)
186  (context-case ctx bindings
187    ((pair?) (length bindings))
188    ((env?)  (length (environment-symbols bindings))) ) )
189
190
191;;; Hierarchy
192
193(define (context-depth ctx)
194  (length (context-ancestors ctx)) )
195
196(define context-parent context-parent)
197
198(define (context-ancestors ctx)
199  (let ((parent (context-parent ctx)))
200    (if (not parent) '()
201        (cons parent (context-ancestors parent)) ) ) )
202
203(define (context-children ctx)
204  (context-values ctx filter: context? unique: #t) )
205
206
207;;; Introspection
208
209(define (context-symbols ctx #!key (sort #f))
210  (define (symbol<? a b)
211    (string<? (symbol->string a) (symbol->string b)) )
212  (define sort
213    (if sort (lambda (list) (list-sort list symbol<?)) identity))
214  (define symbols
215    (context-case ctx bindings
216      ((pair?) (map car bindings))
217      ((env?)  (environment-symbols bindings)) ) )
218  (sort symbols) )
219
220(define (context-values ctx #!key (filter #f) (unique #f))
221  (define unique
222    (if unique (lambda (list) (delete-duplicates list eq?)) identity))
223  (define values
224    (context-case ctx bindings
225      ((pair?)
226       (if (procedure? filter)
227           (filter-map (lambda (x)
228                         (and (filter (cdr x)) (cdr x))) bindings)
229           (map cdr bindings) ) )
230      ((env?)
231       (let* ((values   '())
232              (filter?  (if (procedure? filter) filter any?))
233              (collect! (lambda (s v)
234                          (when (filter? v)
235                            (set! values (cons v values))) ) ) )
236         (environment-for-each bindings collect!)
237         values ) ) ) )
238  (unique values) )
239
240(define (context-walk ctx proc)
241  (context-case ctx bindings
242    ((pair?) (for-each (lambda (binding)
243                         (proc (car binding) (cdr binding)) )
244                       bindings ) )
245    ((env?)  (environment-for-each bindings proc)) ) )
246
247(define context-for-each context-walk)
248
249
250;;; Lookup
251
252(define (context-ref ctx symbol #!optional (default (unbound)))
253  (context-case ctx bindings
254    ((pair?) (cdr (or (assq symbol bindings)
255                      (cons #f default) ) ) )
256    ((env?)  (handle-exceptions exn default
257                                (environment-ref bindings symbol) ) ) ) )
258
259(define (context-lookup ctx symbol #!optional (default (unbound)))
260  (let loop ((ctx ctx))
261    (let ((value (context-ref ctx symbol)))
262      (cond
263        ((not (unbound? value))     value)
264        ((not (context-parent ctx)) default)
265        (else
266         (loop (context-parent ctx)) ) ) ) ) )
267
268
269;;; Mutation
270
271(define (context-set! ctx symbol value)
272  (context-case ctx bindings
273    ((pair?) #f)
274    ((env?)  (environment-set! bindings symbol value)) ) )
275
276(define (context-remove! ctx symbol #!optional (silent? #f))
277  (context-case ctx bindings
278    ((pair?) #f)
279    ((env?)  (environment-remove! bindings symbol silent?)) ) )
280
281(define (context-import! ctx1 ctx2 #!key (filter #f) (prefix #f))
282  (define (prefix-symbol symbol)
283    (string->symbol (string-append (->string prefix)
284                                   (symbol->string symbol) ) ) )
285  (define include?
286    (cond
287      ((procedure? filter)  filter)
288      ((list? filter)       (lambda (symbol) (pair? (memq symbol filter))))
289      ((boolean? filter)    (lambda _ (not filter)))
290      (else
291       (error 'context-import!
292              "expected <procedure>, <list> or <boolean>, got" filter ) ) ) )
293  (define (copy-binding! sym val)
294    (when (include? symbol)
295      (context-set! ctx1 (if prefix (prefix-symbol sym) sym) val) ) )
296  (context-walk ctx2 copy-binding!) )
297
298(define (context-merge! ctx1 ctx2 . ctx*)
299  (for-each (lambda (ctx2) (context-import! ctx1 ctx2 #t))
300            (cons ctx2 ctx*) ) )
301
302
303;;; Evaluation
304
305(define (context-eval ctx exp)
306  ;; TODO: implementation based on the sandbox egg.
307  (eval exp (context->environment ctx)) )
308
309(define (context-load ctx file-or-port)
310  (let loop ((exp* (read-file file-or-port)))
311    (unless (null? exp*)
312      (context-eval ctx (car exp*))
313      (loop (cdr exp*)) ) ) )
314
315(define (context-spawn ctx exp #!key (name #f) (start #t))
316  (let* ((thunk  (lambda () (context-eval ctx exp)))
317         (name   (if (symbol? name) name (gensym 'context)))
318         (thread (make-thread thunk name)) )
319    (when (->boolean start)
320      (thread-start! thread) )
321    thread ) )
Note: See TracBrowser for help on using the repository browser.