source: project/release/4/environments/branches/rewrite/tests/run.scm @ 25666

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

environments rewrite: add test suite

File size: 4.0 KB
Line 
1(use test srfi-1 lolevel)
2(load-relative "../environments")
3(import environments)
4
5(test-group "environment-remove!"
6  (define env
7    (environment-copy (scheme-report-environment 5) #t '(display)))
8  (test-assert (environment-has-binding? env 'display))
9  (environment-remove! env '(display))
10  (test-assert (not (environment-has-binding? env 'display))))
11
12(test-group "environment-symbols"
13  (define env (make-environment #t))
14  (environment-extend! env 'foo 1)
15  (environment-extend! env 'bar 2)
16  (test-assert (lset= eq? '(foo bar) (environment-symbols env))))
17
18
19(test-group "interaction-environment?"
20  (test-assert (interaction-environment? (interaction-environment)))
21  (test-assert (not (interaction-environment? (scheme-report-environment 5)))))
22
23(test-assert (environment-empty? (make-environment #t)))
24
25(test-group "environment-extendable?"
26  (test-assert (environment-extendable? (make-environment #t)))
27  (test-assert (not (environment-extendable? (make-environment #f)))))
28
29(test-group "environment-ref"
30  (define env (scheme-report-environment 5))
31  (test display (environment-ref env 'display))
32  (test-error (environment-ref env 'asdasd))
33  (test-error (environment-ref env 'if)))
34
35(test-group "environment-set!"
36  (test-group "extendable"
37    (define env (make-environment #t))
38    (test-assert (not (environment-has-binding? env 'foo)))
39    (environment-set! env 'foo 123)
40    (test 123 (environment-ref env 'foo)))
41  (test-group "not extandable"
42    (define env (make-environment #f))
43    (test-error (environment-set! env 'foo 123))
44    (test-assert (not (environment-has-binding? env 'foo)))))
45
46(test-group "environment-extend!"
47  (test-group "extendable"
48    (define env (make-environment #t))
49    (test-assert (not (environment-has-binding? env 'foo)))
50    (environment-extend! env 'foo 123)
51    (test 123 (environment-ref env 'foo)))
52  (test-group "not extandable"
53    (define env (make-environment #f))
54    (environment-extend! env 'foo 123)
55    (test-assert (environment-has-binding? env 'foo))))
56
57(test-group "environment-includes?"
58  (test-assert (environment-includes? (scheme-report-environment 5) '+))
59  (test-assert (not (environment-includes? (scheme-report-environment 5) 'lol)))
60  ;; this doesn't correspond to the original egg's behavior (contrary to the documentation)
61  ;; (test-assert (environment-includes? (interaction-environment) 'lol))
62  ;; (test-assert (environment-includes? (interaction-environment) 'print))
63  )
64
65(test-group "environment-has-binding?"
66  (test-assert (environment-has-binding? (scheme-report-environment 5) '+))
67  (test-assert (not (environment-has-binding? (scheme-report-environment 5) 'lol)))
68  ;; doesn't work
69  ;; (test-assert (not (environment-has-binding? (interaction-environment) 'lol)))
70  ;; (test-assert (environment-has-binding? (interaction-environment) 'print))
71  )
72
73(test-group "environment-for-each"
74  (define env (environment-copy (scheme-report-environment 5) #t '(+ - * /)))
75  (define res '())
76  (environment-for-each
77   env
78   (lambda (sym proc)
79     (set! res (cons (cons sym proc) res))))
80  (test 4 (length res))
81  (test + (alist-ref '+ res))
82  (test - (alist-ref '- res))
83  (test * (alist-ref '* res))
84  (test / (alist-ref '/ res)))
85
86(test-group "copy, extend, gc"
87  (test-error (environment-copy (module-environment 'scheme) #t '(asdasd)))
88
89  (define env
90    (environment-copy (module-environment 'scheme)))
91
92  (test 456 (eval '(cadr (list 123 456)) env))
93  (test 'foo (eval ''foo env))
94  (test-assert (eval '(if #t #t #f) env))
95 
96  (environment-extend! env 'bar "hey")
97  (define bar (make-weak-locative (environment-ref env 'bar)))
98  (test "hey" (locative->object bar))
99  (test "hey" (eval 'bar env))
100
101  (environment-remove! env '(bar))
102
103  ;; we need a few GCs for that to work in compiled mode
104  (let loop ((i 10))
105    (unless (zero? i)
106      (gc #t)
107      (loop (- i 1))))
108
109  (test-assert (not (locative->object bar)))
110  (test-error (eval 'bar env))
111  (set! env (environment-copy (module-environment 'srfi-1) #t '()))
112  (gc #t)
113
114  (test-error (eval '(cadr bar) env)))
115
Note: See TracBrowser for help on using the repository browser.