1 USING: tools.test concurrency.locks concurrency.count-downs
\r
2 concurrency.messaging concurrency.mailboxes locals kernel
\r
3 threads sequences calendar accessors ;
\r
4 IN: concurrency.locks.tests
\r
6 :: lock-test-0 ( -- v )
\r
7 [let | v [ V{ } clone ]
\r
8 c [ 2 <count-down> ] |
\r
16 ] "Lock test 1" spawn drop
\r
24 ] "Lock test 2" spawn drop
\r
30 :: lock-test-1 ( -- v )
\r
31 [let | v [ V{ } clone ]
\r
33 c [ 2 <count-down> ] |
\r
43 ] "Lock test 1" spawn drop
\r
53 ] "Lock test 2" spawn drop
\r
59 [ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
\r
60 [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
\r
63 <reentrant-lock> dup [
\r
70 [ ] [ <rw-lock> drop ] unit-test
\r
72 [ ] [ <rw-lock> [ ] with-read-lock ] unit-test
\r
74 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
\r
76 [ ] [ <rw-lock> [ ] with-write-lock ] unit-test
\r
78 [ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
\r
80 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
\r
82 :: rw-lock-test-1 ( -- v )
\r
83 [let | l [ <rw-lock> ]
\r
84 c [ 1 <count-down> ]
\r
85 c' [ 1 <count-down> ]
\r
86 c'' [ 4 <count-down> ]
\r
97 ] "R/W lock test 1" spawn drop
\r
107 ] "R/W lock test 2" spawn drop
\r
116 ] "R/W lock test 4" spawn drop
\r
124 ] "R/W lock test 5" spawn drop
\r
130 [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
\r
132 :: rw-lock-test-2 ( -- v )
\r
133 [let | l [ <rw-lock> ]
\r
134 c [ 1 <count-down> ]
\r
135 c' [ 2 <count-down> ]
\r
146 ] "R/W lock test 1" spawn drop
\r
154 ] "R/W lock test 2" spawn drop
\r
160 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
\r
162 ! Test lock timeouts
\r
163 :: lock-timeout-test ( -- v )
\r
164 [let | l [ <lock> ] |
\r
166 l [ 1 seconds sleep ] with-lock
\r
167 ] "Lock holder" spawn drop
\r
170 l 1/10 seconds [ ] with-lock-timeout
\r
171 ] "Lock timeout-er" spawn-linked drop
\r
176 [ lock-timeout-test ] [
\r
177 thread>> name>> "Lock timeout-er" =
\r
182 1 seconds [ ] with-write-lock-timeout
\r
189 1 seconds [ ] with-write-lock-timeout
\r
197 1 seconds [ ] with-read-lock-timeout
\r