1;;;; environments.test                                    -*- scheme -*-
2;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
3;;;;
4;;;; This library is free software; you can redistribute it and/or
5;;;; modify it under the terms of the GNU Lesser General Public
6;;;; License as published by the Free Software Foundation; either
7;;;; version 2.1 of the License, or (at your option) any later version.
8;;;;
9;;;; This library is distributed in the hope that it will be useful,
10;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12;;;; Lesser General Public License for more details.
13;;;;
14;;;; You should have received a copy of the GNU Lesser General Public
15;;;; License along with this library; if not, write to the Free Software
16;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17
18(use-modules (ice-9 documentation))
19
20
21;;;
22;;; miscellaneous
23;;;
24
25(define exception:unbound-symbol
26  (cons 'misc-error "^Symbol .* not bound in environment"))
27
28(define (documented? object)
29  (not (not (object-documentation object))))
30
31(define (folder sym val res)
32  (cons (cons sym val) res))
33
34(define (make-observer-func)
35  (let* ((counter 0))
36    (lambda args
37      (if (null? args)
38	  counter
39	  (set! counter (+ counter 1))))))
40
41(define (make-erroneous-observer-func)
42  (let* ((func (make-observer-func)))
43    (lambda args
44      (if (null? args)
45	  (func)
46	  (begin
47	    (func args)
48	    (error))))))
49
50;;;
51;;; leaf-environments
52;;;
53
54(with-test-prefix "leaf-environments"
55
56  (with-test-prefix "leaf-environment?"
57
58    (pass-if "documented?"
59      (documented? leaf-environment?))
60
61    (pass-if "non-environment-object"
62      (not (leaf-environment? #f))))
63
64
65  (with-test-prefix "make-leaf-environment"
66
67    (pass-if "documented?"
68      (documented? make-leaf-environment))
69
70    (pass-if "produces an environment"
71      (environment? (make-leaf-environment)))
72
73    (pass-if "produces a leaf-environment"
74      (leaf-environment? (make-leaf-environment)))
75
76    (pass-if "produces always a new environment"
77      (not (eq? (make-leaf-environment) (make-leaf-environment)))))
78
79
80  (with-test-prefix "bound, define, ref, set!, cell"
81
82    (pass-if "symbols are unbound by default"
83      (let* ((env (make-leaf-environment)))
84	(and (not (environment-bound? env 'a))
85	     (not (environment-bound? env 'b))
86	     (not (environment-bound? env 'c)))))
87
88    (pass-if "symbol is bound after define"
89      (let* ((env (make-leaf-environment)))
90	(environment-bound? env 'a)
91	(environment-define env 'a #t)
92	(environment-bound? env 'a)))
93
94    (pass-if "ref a defined symbol"
95      (let* ((env (make-leaf-environment)))
96	(environment-bound? env 'a)
97	(environment-bound? env 'b)
98	(environment-define env 'a #t)
99	(environment-define env 'b #f)
100	(and (environment-ref env 'a)
101	     (not (environment-ref env 'b)))))
102
103    (pass-if "set! a defined symbol"
104      (let* ((env (make-leaf-environment)))
105	(environment-define env 'a #t)
106	(environment-define env 'b #f)
107	(environment-ref env 'a)
108	(environment-ref env 'b)
109	(environment-set! env 'a #f)
110	(environment-set! env 'b #t)
111	(and (not (environment-ref env 'a))
112	     (environment-ref env 'b))))
113
114    (pass-if "get a read-only cell"
115      (let* ((env (make-leaf-environment)))
116	(environment-define env 'a #t)
117	(let* ((cell (environment-cell env 'a #f)))
118	  (and (cdr cell)
119	       (begin
120		 (environment-set! env 'a #f)
121		 (not (cdr cell)))))))
122
123    (pass-if "a read-only cell gets rebound after define"
124      (let* ((env (make-leaf-environment)))
125	(environment-define env 'a #t)
126	(let* ((cell (environment-cell env 'a #f)))
127	  (environment-define env 'a #f)
128	  (not (eq? (environment-cell env 'a #f) cell)))))
129
130    (pass-if "get a writable cell"
131      (let* ((env (make-leaf-environment)))
132	(environment-define env 'a #t)
133	(let* ((readable (environment-cell env 'a #f))
134	       (writable (environment-cell env 'a #t)))
135	  (and (eq? readable writable)
136	       (begin
137		 (environment-set! env 'a #f)
138		 (not (cdr writable)))
139	       (begin
140		 (set-cdr! writable #t)
141		 (environment-ref env 'a))
142	       (begin
143		 (set-cdr! (environment-cell env 'a #t) #f)
144		 (not (cdr writable)))))))
145
146    (pass-if "a writable cell gets rebound after define"
147      (let* ((env (make-leaf-environment)))
148	(environment-define env 'a #t)
149	(let* ((cell (environment-cell env 'a #t)))
150	  (environment-define env 'a #f)
151	  (not (eq? (environment-cell env 'a #t) cell)))))
152
153    (pass-if-exception "reference an unbound symbol"
154      exception:unbound-symbol
155      (environment-ref (make-leaf-environment) 'a))
156
157    (pass-if-exception "set! an unbound symbol"
158      exception:unbound-symbol
159      (environment-set! (make-leaf-environment) 'a #f))
160
161    (pass-if-exception "get a readable cell for an unbound symbol"
162      exception:unbound-symbol
163      (environment-cell (make-leaf-environment) 'a #f))
164
165    (pass-if-exception "get a writable cell for an unbound symbol"
166      exception:unbound-symbol
167      (environment-cell (make-leaf-environment) 'a #t)))
168
169
170  (with-test-prefix "undefine"
171
172    (pass-if "undefine a defined symbol"
173      (let* ((env (make-leaf-environment)))
174	(environment-define env 'a 1)
175	(environment-ref env 'a)
176	(environment-undefine env 'a)
177	(not (environment-bound? env 'a))))
178
179    (pass-if "undefine an already undefined symbol"
180      (environment-undefine (make-leaf-environment) 'a)
181      #t))
182
183
184  (with-test-prefix "fold"
185
186    (pass-if "empty environment"
187      (let* ((env (make-leaf-environment)))
188	(eq? 'success (environment-fold env folder 'success))))
189
190    (pass-if "one symbol"
191      (let* ((env (make-leaf-environment)))
192	(environment-define env 'a #t)
193	(equal? '((a . #t)) (environment-fold env folder '()))))
194
195    (pass-if "two symbols"
196      (let* ((env (make-leaf-environment)))
197	(environment-define env 'a #t)
198	(environment-define env 'b #f)
199	(let ((folded (environment-fold env folder '())))
200	  (or (equal? folded '((a . #t) (b . #f)))
201	      (equal? folded '((b . #f) (a . #t))))))))
202
203
204  (with-test-prefix "observe"
205
206    (pass-if "observe an environment"
207      (let* ((env (make-leaf-environment)))
208	(environment-observe env (make-observer-func))
209	#t))
210
211    (pass-if "observe an environment twice"
212      (let* ((env (make-leaf-environment))
213	     (observer-1 (environment-observe env (make-observer-func)))
214	     (observer-2 (environment-observe env (make-observer-func))))
215	(not (eq? observer-1 observer-2))))
216
217    (pass-if "definition of an undefined symbol"
218      (let* ((env (make-leaf-environment))
219	     (func (make-observer-func)))
220	(environment-observe env func)
221	(environment-define env 'a 1)
222	(eqv? (func) 1)))
223
224    (pass-if "definition of an already defined symbol"
225      (let* ((env (make-leaf-environment)))
226	(environment-define env 'a 1)
227	(let* ((func (make-observer-func)))
228	  (environment-observe env func)
229	  (environment-define env 'a 1)
230	  (eqv? (func) 1))))
231
232    (pass-if "set!ing of a defined symbol"
233      (let* ((env (make-leaf-environment)))
234	(environment-define env 'a 1)
235	(let* ((func (make-observer-func)))
236	  (environment-observe env func)
237	  (environment-set! env 'a 1)
238	  (eqv? (func) 0))))
239
240    (pass-if "undefining a defined symbol"
241      (let* ((env (make-leaf-environment)))
242	(environment-define env 'a 1)
243	(let* ((func (make-observer-func)))
244	  (environment-observe env func)
245	  (environment-undefine env 'a)
246	  (eqv? (func) 1))))
247
248    (pass-if "undefining an already undefined symbol"
249      (let* ((env (make-leaf-environment))
250	     (func (make-observer-func)))
251	(environment-observe env func)
252	(environment-undefine env 'a)
253	(eqv? (func) 0)))
254
255    (pass-if "unobserve an active observer"
256      (let* ((env (make-leaf-environment))
257	     (func (make-observer-func))
258	     (observer (environment-observe env func)))
259	(environment-unobserve observer)
260	(environment-define env 'a 1)
261	(eqv? (func) 0)))
262
263    (pass-if "unobserve an inactive observer"
264      (let* ((env (make-leaf-environment))
265	     (func (make-observer-func))
266	     (observer (environment-observe env func)))
267	(environment-unobserve observer)
268	(environment-unobserve observer)
269	#t)))
270
271
272  (with-test-prefix "observe-weak"
273
274    (pass-if "observe an environment"
275      (let* ((env (make-leaf-environment)))
276	(environment-observe-weak env (make-observer-func))
277	#t))
278
279    (pass-if "observe an environment twice"
280      (let* ((env (make-leaf-environment))
281	     (observer-1 (environment-observe-weak env (make-observer-func)))
282	     (observer-2 (environment-observe-weak env (make-observer-func))))
283	(not (eq? observer-1 observer-2))))
284
285    (pass-if "definition of an undefined symbol"
286      (let* ((env (make-leaf-environment))
287	     (func (make-observer-func)))
288	(environment-observe-weak env func)
289	(environment-define env 'a 1)
290	(eqv? (func) 1)))
291
292    (pass-if "definition of an already defined symbol"
293      (let* ((env (make-leaf-environment)))
294	(environment-define env 'a 1)
295	(let* ((func (make-observer-func)))
296	  (environment-observe-weak env func)
297	  (environment-define env 'a 1)
298	  (eqv? (func) 1))))
299
300    (pass-if "set!ing of a defined symbol"
301      (let* ((env (make-leaf-environment)))
302	(environment-define env 'a 1)
303	(let* ((func (make-observer-func)))
304	  (environment-observe-weak env func)
305	  (environment-set! env 'a 1)
306	  (eqv? (func) 0))))
307
308    (pass-if "undefining a defined symbol"
309      (let* ((env (make-leaf-environment)))
310	(environment-define env 'a 1)
311	(let* ((func (make-observer-func)))
312	  (environment-observe-weak env func)
313	  (environment-undefine env 'a)
314	  (eqv? (func) 1))))
315
316    (pass-if "undefining an already undefined symbol"
317      (let* ((env (make-leaf-environment))
318	     (func (make-observer-func)))
319	(environment-observe-weak env func)
320	(environment-undefine env 'a)
321	(eqv? (func) 0)))
322
323    (pass-if "unobserve an active observer"
324      (let* ((env (make-leaf-environment))
325	     (func (make-observer-func))
326	     (observer (environment-observe-weak env func)))
327	(environment-unobserve observer)
328	(environment-define env 'a 1)
329	(eqv? (func) 0)))
330
331    (pass-if "unobserve an inactive observer"
332      (let* ((env (make-leaf-environment))
333	     (func (make-observer-func))
334	     (observer (environment-observe-weak env func)))
335	(environment-unobserve observer)
336	(environment-unobserve observer)
337	#t))
338
339    (pass-if "weak observer gets collected"
340      (gc)
341      (let* ((env (make-leaf-environment))
342	     (func (make-observer-func)))
343	(environment-observe-weak env func)
344	(gc)
345	(environment-define env 'a 1)
346	(if (not (eqv? (func) 0))
347	    (throw 'unresolved) ; note: conservative scanning
348	    #t))))
349
350
351  (with-test-prefix "erroneous observers"
352
353    (pass-if "update continues after error"
354      (let* ((env (make-leaf-environment))
355	     (func-1 (make-erroneous-observer-func))
356	     (func-2 (make-erroneous-observer-func)))
357	(environment-observe env func-1)
358	(environment-observe env func-2)
359	(catch #t
360	  (lambda ()
361	    (environment-define env 'a 1)
362	    #f)
363	  (lambda args
364	    (and (eq? (func-1) 1)
365		 (eq? (func-2) 1))))))))
366
367
368;;;
369;;; leaf-environment based eval-environments
370;;;
371
372(with-test-prefix "leaf-environment based eval-environments"
373
374  (with-test-prefix "eval-environment?"
375
376    (pass-if "documented?"
377      (documented? eval-environment?))
378
379    (pass-if "non-environment-object"
380      (not (eval-environment? #f)))
381
382    (pass-if "leaf-environment-object"
383      (not (eval-environment? (make-leaf-environment)))))
384
385
386  (with-test-prefix "make-eval-environment"
387
388    (pass-if "documented?"
389      (documented? make-eval-environment))
390
391    (let* ((local (make-leaf-environment))
392	   (imported (make-leaf-environment)))
393
394      (pass-if "produces an environment"
395	(environment? (make-eval-environment local imported)))
396
397      (pass-if "produces an eval-environment"
398	(eval-environment? (make-eval-environment local imported)))
399
400      (pass-if "produces always a new environment"
401	(not (eq? (make-eval-environment local imported)
402		  (make-eval-environment local imported))))))
403
404
405  (with-test-prefix "eval-environment-local"
406
407    (pass-if "documented?"
408      (documented? eval-environment-local))
409
410    (pass-if "returns local"
411      (let* ((local (make-leaf-environment))
412	     (imported (make-leaf-environment))
413	     (env (make-eval-environment local imported)))
414	(eq? (eval-environment-local env) local))))
415
416
417  (with-test-prefix "eval-environment-imported"
418
419    (pass-if "documented?"
420      (documented? eval-environment-imported))
421
422    (pass-if "returns imported"
423      (let* ((local (make-leaf-environment))
424	     (imported (make-leaf-environment))
425	     (env (make-eval-environment local imported)))
426	(eq? (eval-environment-imported env) imported))))
427
428
429  (with-test-prefix "bound, define, ref, set!, cell"
430
431    (pass-if "symbols are unbound by default"
432      (let* ((local (make-leaf-environment))
433	     (imported (make-leaf-environment))
434	     (env (make-eval-environment local imported)))
435	(and (not (environment-bound? env 'a))
436	     (not (environment-bound? env 'b))
437	     (not (environment-bound? env 'c)))))
438
439    (with-test-prefix "symbols bound in imported"
440
441      (pass-if "binding is visible"
442	(let* ((local (make-leaf-environment))
443	       (imported (make-leaf-environment))
444	       (env (make-eval-environment local imported)))
445	  (environment-bound? env 'a)
446	  (environment-define imported 'a #t)
447	  (environment-bound? env 'a)))
448
449      (pass-if "ref works"
450	(let* ((local (make-leaf-environment))
451	       (imported (make-leaf-environment))
452	       (env (make-eval-environment local imported)))
453	  (environment-bound? env 'a)
454	  (environment-define imported 'a #t)
455	  (environment-ref env 'a)))
456
457      (pass-if "set! works"
458	(let* ((local (make-leaf-environment))
459	       (imported (make-leaf-environment))
460	       (env (make-eval-environment local imported)))
461	  (environment-define imported 'a #f)
462	  (environment-set! env 'a #t)
463	  (environment-ref imported 'a)))
464
465      (pass-if "cells are passed through"
466	(let* ((local (make-leaf-environment))
467	       (imported (make-leaf-environment))
468	       (env (make-eval-environment local imported)))
469	  (environment-define imported 'a #t)
470	  (let* ((imported-cell (environment-cell imported 'a #f))
471		 (env-cell (environment-cell env 'a #f)))
472	    (eq? env-cell imported-cell)))))
473
474    (with-test-prefix "symbols bound in local"
475
476      (pass-if "binding is visible"
477	(let* ((local (make-leaf-environment))
478	       (imported (make-leaf-environment))
479	       (env (make-eval-environment local imported)))
480	  (environment-bound? env 'a)
481	  (environment-define local 'a #t)
482	  (environment-bound? env 'a)))
483
484      (pass-if "ref works"
485	(let* ((local (make-leaf-environment))
486	       (imported (make-leaf-environment))
487	       (env (make-eval-environment local imported)))
488	  (environment-define local 'a #t)
489	  (environment-ref env 'a)))
490
491      (pass-if "set! works"
492	(let* ((local (make-leaf-environment))
493	       (imported (make-leaf-environment))
494	       (env (make-eval-environment local imported)))
495	  (environment-define local 'a #f)
496	  (environment-set! env 'a #t)
497	  (environment-ref local 'a)))
498
499      (pass-if "cells are passed through"
500	(let* ((local (make-leaf-environment))
501	       (imported (make-leaf-environment))
502	       (env (make-eval-environment local imported)))
503	  (environment-define local 'a #t)
504	  (let* ((local-cell (environment-cell local 'a #f))
505		 (env-cell (environment-cell env 'a #f)))
506	    (eq? env-cell local-cell)))))
507
508    (with-test-prefix "symbols bound in local and imported"
509
510      (pass-if "binding is visible"
511	(let* ((local (make-leaf-environment))
512	       (imported (make-leaf-environment))
513	       (env (make-eval-environment local imported)))
514	  (environment-bound? env 'a)
515	  (environment-define imported 'a #t)
516	  (environment-define local 'a #f)
517	  (environment-bound? env 'a)))
518
519      (pass-if "ref works"
520	(let* ((local (make-leaf-environment))
521	       (imported (make-leaf-environment))
522	       (env (make-eval-environment local imported)))
523	  (environment-define imported 'a #f)
524	  (environment-define local 'a #t)
525	  (environment-ref env 'a)))
526
527      (pass-if "set! changes local"
528	(let* ((local (make-leaf-environment))
529	       (imported (make-leaf-environment))
530	       (env (make-eval-environment local imported)))
531	  (environment-define imported 'a #f)
532	  (environment-define local 'a #f)
533	  (environment-set! env 'a #t)
534	  (environment-ref local 'a)))
535
536      (pass-if "set! does not touch imported"
537	(let* ((local (make-leaf-environment))
538	       (imported (make-leaf-environment))
539	       (env (make-eval-environment local imported)))
540	  (environment-define imported 'a #t)
541	  (environment-define local 'a #t)
542	  (environment-set! env 'a #f)
543	  (environment-ref imported 'a)))
544
545      (pass-if "cells from local are passed through"
546	(let* ((local (make-leaf-environment))
547	       (imported (make-leaf-environment))
548	       (env (make-eval-environment local imported)))
549	  (environment-define local 'a #t)
550	  (let* ((local-cell (environment-cell local 'a #f))
551		 (env-cell (environment-cell env 'a #f)))
552	    (eq? env-cell local-cell)))))
553
554    (with-test-prefix "defining symbols"
555
556      (pass-if "symbols are bound in local after define"
557	(let* ((local (make-leaf-environment))
558	       (imported (make-leaf-environment))
559	       (env (make-eval-environment local imported)))
560	  (environment-define env 'a #t)
561	  (environment-bound? local 'a)))
562
563      (pass-if "cells in local get rebound after define"
564	(let* ((local (make-leaf-environment))
565	       (imported (make-leaf-environment))
566	       (env (make-eval-environment local imported)))
567	  (environment-define env 'a #f)
568	  (let* ((old-cell (environment-cell local 'a #f)))
569	    (environment-define env 'a #f)
570	    (let* ((new-cell (environment-cell local 'a #f)))
571	      (not (eq? new-cell old-cell))))))
572
573      (pass-if "cells in imported get shadowed after define"
574	(let* ((local (make-leaf-environment))
575	       (imported (make-leaf-environment))
576	       (env (make-eval-environment local imported)))
577	  (environment-define imported 'a #f)
578	  (environment-define env 'a #t)
579	  (environment-ref local 'a))))
580
581    (let* ((local (make-leaf-environment))
582	   (imported (make-leaf-environment))
583	   (env (make-eval-environment local imported)))
584
585      (pass-if-exception "reference an unbound symbol"
586	exception:unbound-symbol
587	(environment-ref env 'b))
588
589      (pass-if-exception "set! an unbound symbol"
590	exception:unbound-symbol
591	(environment-set! env 'b #f))
592
593      (pass-if-exception "get a readable cell for an unbound symbol"
594	exception:unbound-symbol
595	(environment-cell env 'b #f))
596
597      (pass-if-exception "get a writable cell for an unbound symbol"
598	exception:unbound-symbol
599	(environment-cell env 'b #t))))
600
601  (with-test-prefix "eval-environment-set-local!"
602
603    (pass-if "documented?"
604      (documented? eval-environment-set-local!))
605
606    (pass-if "new binding becomes visible"
607      (let* ((old-local (make-leaf-environment))
608	     (new-local (make-leaf-environment))
609	     (imported (make-leaf-environment))
610	     (env (make-eval-environment old-local imported)))
611	(environment-bound? env 'a)
612	(environment-define new-local 'a #t)
613	(eval-environment-set-local! env new-local)
614	(environment-bound? env 'a)))
615
616    (pass-if "existing binding is replaced"
617      (let* ((old-local (make-leaf-environment))
618	     (new-local (make-leaf-environment))
619	     (imported (make-leaf-environment))
620	     (env (make-eval-environment old-local imported)))
621	(environment-define old-local 'a #f)
622	(environment-ref env 'a)
623	(environment-define new-local 'a #t)
624	(eval-environment-set-local! env new-local)
625	(environment-ref env 'a)))
626
627    (pass-if "undefined binding is removed"
628      (let* ((old-local (make-leaf-environment))
629	     (new-local (make-leaf-environment))
630	     (imported (make-leaf-environment))
631	     (env (make-eval-environment old-local imported)))
632	(environment-define old-local 'a #f)
633	(environment-ref env 'a)
634	(eval-environment-set-local! env new-local)
635	(not (environment-bound? env 'a))))
636
637    (pass-if "binding in imported remains shadowed"
638      (let* ((old-local (make-leaf-environment))
639	     (new-local (make-leaf-environment))
640	     (imported (make-leaf-environment))
641	     (env (make-eval-environment old-local imported)))
642	(environment-define imported 'a #f)
643	(environment-define old-local 'a #f)
644	(environment-ref env 'a)
645	(environment-define new-local 'a #t)
646	(eval-environment-set-local! env new-local)
647	(environment-ref env 'a)))
648
649    (pass-if "binding in imported gets shadowed"
650      (let* ((old-local (make-leaf-environment))
651	     (new-local (make-leaf-environment))
652	     (imported (make-leaf-environment))
653	     (env (make-eval-environment old-local imported)))
654	(environment-define imported 'a #f)
655	(environment-ref env 'a)
656	(environment-define new-local 'a #t)
657	(eval-environment-set-local! env new-local)
658	(environment-ref env 'a)))
659
660    (pass-if "binding in imported becomes visible"
661      (let* ((old-local (make-leaf-environment))
662	     (new-local (make-leaf-environment))
663	     (imported (make-leaf-environment))
664	     (env (make-eval-environment old-local imported)))
665	(environment-define imported 'a #t)
666	(environment-define old-local 'a #f)
667	(environment-ref env 'a)
668	(eval-environment-set-local! env new-local)
669	(environment-ref env 'a))))
670
671  (with-test-prefix "eval-environment-set-imported!"
672
673    (pass-if "documented?"
674      (documented? eval-environment-set-imported!))
675
676    (pass-if "new binding becomes visible"
677      (let* ((local (make-leaf-environment))
678	     (old-imported (make-leaf-environment))
679	     (new-imported (make-leaf-environment))
680	     (env (make-eval-environment local old-imported)))
681	(environment-bound? env 'a)
682	(environment-define new-imported 'a #t)
683	(eval-environment-set-imported! env new-imported)
684	(environment-bound? env 'a)))
685
686    (pass-if "existing binding is replaced"
687      (let* ((local (make-leaf-environment))
688	     (old-imported (make-leaf-environment))
689	     (new-imported (make-leaf-environment))
690	     (env (make-eval-environment local old-imported)))
691	(environment-define old-imported 'a #f)
692	(environment-ref env 'a)
693	(environment-define new-imported 'a #t)
694	(eval-environment-set-imported! env new-imported)
695	(environment-ref env 'a)))
696
697    (pass-if "undefined binding is removed"
698      (let* ((local (make-leaf-environment))
699	     (old-imported (make-leaf-environment))
700	     (new-imported (make-leaf-environment))
701	     (env (make-eval-environment local old-imported)))
702	(environment-define old-imported 'a #f)
703	(environment-ref env 'a)
704	(eval-environment-set-imported! env new-imported)
705	(not (environment-bound? env 'a))))
706
707    (pass-if "binding in imported remains shadowed"
708      (let* ((local (make-leaf-environment))
709	     (old-imported (make-leaf-environment))
710	     (new-imported (make-leaf-environment))
711	     (env (make-eval-environment local old-imported)))
712	(environment-define local 'a #t)
713	(environment-define old-imported 'a #f)
714	(environment-ref env 'a)
715	(environment-define new-imported 'a #t)
716	(eval-environment-set-imported! env new-imported)
717	(environment-ref env 'a)))
718
719    (pass-if "binding in imported gets shadowed"
720      (let* ((local (make-leaf-environment))
721	     (old-imported (make-leaf-environment))
722	     (new-imported (make-leaf-environment))
723	     (env (make-eval-environment local old-imported)))
724	(environment-define local 'a #t)
725	(environment-ref env 'a)
726	(environment-define new-imported 'a #f)
727	(eval-environment-set-imported! env new-imported)
728	(environment-ref env 'a))))
729
730  (with-test-prefix "undefine"
731
732    (pass-if "undefine an already undefined symbol"
733      (let* ((local (make-leaf-environment))
734	     (imported (make-leaf-environment))
735	     (env (make-eval-environment local imported)))
736	(environment-undefine env 'a)
737	#t))
738
739    (pass-if "undefine removes a binding from local"
740      (let* ((local (make-leaf-environment))
741	     (imported (make-leaf-environment))
742	     (env (make-eval-environment local imported)))
743	(environment-define local 'a #t)
744	(environment-undefine env 'a)
745	(not (environment-bound? local 'a))))
746
747    (pass-if "undefine does not influence imported"
748      (let* ((local (make-leaf-environment))
749	     (imported (make-leaf-environment))
750	     (env (make-eval-environment local imported)))
751	(environment-define imported 'a #t)
752	(environment-undefine env 'a)
753	(environment-bound? imported 'a)))
754
755    (pass-if "undefine an imported symbol does not undefine it"
756      (let* ((local (make-leaf-environment))
757	     (imported (make-leaf-environment))
758	     (env (make-eval-environment local imported)))
759	(environment-define imported 'a #t)
760	(environment-undefine env 'a)
761	(environment-bound? env 'a)))
762
763    (pass-if "undefine unshadows an imported symbol"
764      (let* ((local (make-leaf-environment))
765	     (imported (make-leaf-environment))
766	     (env (make-eval-environment local imported)))
767	(environment-define imported 'a #t)
768	(environment-define local 'a #f)
769	(environment-undefine env 'a)
770	(environment-ref env 'a))))
771
772  (with-test-prefix "fold"
773
774    (pass-if "empty environment"
775      (let* ((local (make-leaf-environment))
776	     (imported (make-leaf-environment))
777	     (env (make-eval-environment local imported)))
778	(eq? 'success (environment-fold env folder 'success))))
779
780    (pass-if "one symbol in local"
781      (let* ((local (make-leaf-environment))
782	     (imported (make-leaf-environment))
783	     (env (make-eval-environment local imported)))
784	(environment-define local 'a #t)
785	(equal? '((a . #t)) (environment-fold env folder '()))))
786
787    (pass-if "one symbol in imported"
788      (let* ((local (make-leaf-environment))
789	     (imported (make-leaf-environment))
790	     (env (make-eval-environment local imported)))
791	(environment-define imported 'a #t)
792	(equal? '((a . #t)) (environment-fold env folder '()))))
793
794    (pass-if "shadowed symbol"
795      (let* ((local (make-leaf-environment))
796	     (imported (make-leaf-environment))
797	     (env (make-eval-environment local imported)))
798	(environment-define local 'a #t)
799	(environment-define imported 'a #f)
800	(equal? '((a . #t)) (environment-fold env folder '()))))
801
802    (pass-if "one symbol each"
803      (let* ((local (make-leaf-environment))
804	     (imported (make-leaf-environment))
805	     (env (make-eval-environment local imported)))
806	(environment-define local 'a #t)
807	(environment-define imported 'b #f)
808	(let ((folded (environment-fold env folder '())))
809	  (or (equal? folded '((a . #t) (b . #f)))
810	      (equal? folded '((b . #f) (a . #t))))))))
811
812
813  (with-test-prefix "observe"
814
815    (pass-if "observe an environment"
816      (let* ((local (make-leaf-environment))
817	     (imported (make-leaf-environment))
818	     (env (make-eval-environment local imported)))
819	(environment-observe env (make-observer-func))
820	#t))
821
822    (pass-if "observe an environment twice"
823      (let* ((local (make-leaf-environment))
824	     (imported (make-leaf-environment))
825	     (env (make-eval-environment local imported))
826	     (observer-1 (environment-observe env (make-observer-func)))
827	     (observer-2 (environment-observe env (make-observer-func))))
828	(not (eq? observer-1 observer-2))))
829
830    (pass-if "definition of an undefined symbol"
831      (let* ((local (make-leaf-environment))
832	     (imported (make-leaf-environment))
833	     (env (make-eval-environment local imported))
834	     (func (make-observer-func)))
835	(environment-observe env func)
836	(environment-define env 'a 1)
837	(eqv? (func) 1)))
838
839    (pass-if "definition of an already defined symbol"
840      (let* ((local (make-leaf-environment))
841	     (imported (make-leaf-environment))
842	     (env (make-eval-environment local imported)))
843	(environment-define env 'a 1)
844	(let* ((func (make-observer-func)))
845	  (environment-observe env func)
846	  (environment-define env 'a 1)
847	  (eqv? (func) 1))))
848
849    (pass-if "set!ing of a defined symbol"
850      (let* ((local (make-leaf-environment))
851	     (imported (make-leaf-environment))
852	     (env (make-eval-environment local imported)))
853	(environment-define env 'a 1)
854	(let* ((func (make-observer-func)))
855	  (environment-observe env func)
856	  (environment-set! env 'a 1)
857	  (eqv? (func) 0))))
858
859    (pass-if "undefining a defined symbol"
860      (let* ((local (make-leaf-environment))
861	     (imported (make-leaf-environment))
862	     (env (make-eval-environment local imported)))
863	(environment-define env 'a 1)
864	(let* ((func (make-observer-func)))
865	  (environment-observe env func)
866	  (environment-undefine env 'a)
867	  (eqv? (func) 1))))
868
869    (pass-if "undefining an already undefined symbol"
870      (let* ((local (make-leaf-environment))
871	     (imported (make-leaf-environment))
872	     (env (make-eval-environment local imported))
873	     (func (make-observer-func)))
874	(environment-observe env func)
875	(environment-undefine env 'a)
876	(eqv? (func) 0)))
877
878    (pass-if "unobserve an active observer"
879      (let* ((local (make-leaf-environment))
880	     (imported (make-leaf-environment))
881	     (env (make-eval-environment local imported))
882	     (func (make-observer-func))
883	     (observer (environment-observe env func)))
884	(environment-unobserve observer)
885	(environment-define env 'a 1)
886	(eqv? (func) 0)))
887
888    (pass-if "unobserve an inactive observer"
889      (let* ((local (make-leaf-environment))
890	     (imported (make-leaf-environment))
891	     (env (make-eval-environment local imported))
892	     (func (make-observer-func))
893	     (observer (environment-observe env func)))
894	(environment-unobserve observer)
895	(environment-unobserve observer)
896	#t)))
897
898
899  (with-test-prefix "observe-weak"
900
901    (pass-if "observe an environment"
902      (let* ((local (make-leaf-environment))
903	     (imported (make-leaf-environment))
904	     (env (make-eval-environment local imported)))
905	(environment-observe-weak env (make-observer-func))
906	#t))
907
908    (pass-if "observe an environment twice"
909      (let* ((local (make-leaf-environment))
910	     (imported (make-leaf-environment))
911	     (env (make-eval-environment local imported))
912	     (observer-1 (environment-observe-weak env (make-observer-func)))
913	     (observer-2 (environment-observe-weak env (make-observer-func))))
914	(not (eq? observer-1 observer-2))))
915
916    (pass-if "definition of an undefined symbol"
917      (let* ((local (make-leaf-environment))
918	     (imported (make-leaf-environment))
919	     (env (make-eval-environment local imported))
920	     (func (make-observer-func)))
921	(environment-observe-weak env func)
922	(environment-define env 'a 1)
923	(eqv? (func) 1)))
924
925    (pass-if "definition of an already defined symbol"
926      (let* ((local (make-leaf-environment))
927	     (imported (make-leaf-environment))
928	     (env (make-eval-environment local imported)))
929	(environment-define env 'a 1)
930	(let* ((func (make-observer-func)))
931	  (environment-observe-weak env func)
932	  (environment-define env 'a 1)
933	  (eqv? (func) 1))))
934
935    (pass-if "set!ing of a defined symbol"
936      (let* ((local (make-leaf-environment))
937	     (imported (make-leaf-environment))
938	     (env (make-eval-environment local imported)))
939	(environment-define env 'a 1)
940	(let* ((func (make-observer-func)))
941	  (environment-observe-weak env func)
942	  (environment-set! env 'a 1)
943	  (eqv? (func) 0))))
944
945    (pass-if "undefining a defined symbol"
946      (let* ((local (make-leaf-environment))
947	     (imported (make-leaf-environment))
948	     (env (make-eval-environment local imported)))
949	(environment-define env 'a 1)
950	(let* ((func (make-observer-func)))
951	  (environment-observe-weak env func)
952	  (environment-undefine env 'a)
953	  (eqv? (func) 1))))
954
955    (pass-if "undefining an already undefined symbol"
956      (let* ((local (make-leaf-environment))
957	     (imported (make-leaf-environment))
958	     (env (make-eval-environment local imported))
959	     (func (make-observer-func)))
960	(environment-observe-weak env func)
961	(environment-undefine env 'a)
962	(eqv? (func) 0)))
963
964    (pass-if "unobserve an active observer"
965      (let* ((local (make-leaf-environment))
966	     (imported (make-leaf-environment))
967	     (env (make-eval-environment local imported))
968	     (func (make-observer-func))
969	     (observer (environment-observe-weak env func)))
970	(environment-unobserve observer)
971	(environment-define env 'a 1)
972	(eqv? (func) 0)))
973
974    (pass-if "unobserve an inactive observer"
975      (let* ((local (make-leaf-environment))
976	     (imported (make-leaf-environment))
977	     (env (make-eval-environment local imported))
978	     (func (make-observer-func))
979	     (observer (environment-observe-weak env func)))
980	(environment-unobserve observer)
981	(environment-unobserve observer)
982	#t))
983
984    (pass-if "weak observer gets collected"
985      (gc)
986      (let* ((local (make-leaf-environment))
987	     (imported (make-leaf-environment))
988	     (env (make-eval-environment local imported))
989	     (func (make-observer-func)))
990	(environment-observe-weak env func)
991	(gc)
992	(environment-define env 'a 1)
993	(if (not (eqv? (func) 0))
994	    (throw 'unresolved) ; note: conservative scanning
995	    #t))))
996
997
998  (with-test-prefix "erroneous observers"
999
1000    (pass-if "update continues after error"
1001      (let* ((local (make-leaf-environment))
1002	     (imported (make-leaf-environment))
1003	     (env (make-eval-environment local imported))
1004	     (func-1 (make-erroneous-observer-func))
1005	     (func-2 (make-erroneous-observer-func)))
1006	(environment-observe env func-1)
1007	(environment-observe env func-2)
1008	(catch #t
1009	  (lambda ()
1010	    (environment-define env 'a 1)
1011	    #f)
1012	  (lambda args
1013	    (and (eq? (func-1) 1)
1014		 (eq? (func-2) 1))))))))
1015
1016
1017;;;
1018;;; leaf-environment based import-environments
1019;;;
1020
1021(with-test-prefix "leaf-environment based import-environments"
1022
1023  (with-test-prefix "import-environment?"
1024
1025    (pass-if "documented?"
1026      (documented? import-environment?))
1027
1028    (pass-if "non-environment-object"
1029      (not (import-environment? #f)))
1030
1031    (pass-if "leaf-environment-object"
1032      (not (import-environment? (make-leaf-environment))))
1033
1034    (pass-if "eval-environment-object"
1035      (let* ((local (make-leaf-environment))
1036	     (imported (make-leaf-environment))
1037	     (env (make-eval-environment local imported)))
1038	(not (import-environment? (make-leaf-environment))))))
1039
1040
1041  (with-test-prefix "make-import-environment"
1042
1043    (pass-if "documented?"
1044      (documented? make-import-environment))))
1045
1046