-USING: tools.test concurrency.locks concurrency.count-downs\r
-concurrency.messaging concurrency.mailboxes locals kernel\r
-threads sequences calendar accessors ;\r
-IN: concurrency.locks.tests\r
-\r
-:: lock-test-0 ( -- v )\r
- V{ } clone :> v\r
- 2 <count-down> :> c\r
-\r
- [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v ;\r
-\r
-:: lock-test-1 ( -- v )\r
- V{ } clone :> v\r
- <lock> :> l\r
- 2 <count-down> :> c\r
-\r
- [\r
- l [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- l [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v ;\r
-\r
-[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test\r
-[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test\r
-\r
-[ 3 ] [\r
- <reentrant-lock> dup [\r
- [\r
- 3\r
- ] with-lock\r
- ] with-lock\r
-] unit-test\r
-\r
-[ ] [ <rw-lock> drop ] unit-test\r
-\r
-[ ] [ <rw-lock> [ ] with-read-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> [ ] with-write-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test\r
-\r
-:: rw-lock-test-1 ( -- v )\r
- <rw-lock> :> l\r
- 1 <count-down> :> c\r
- 1 <count-down> :> c'\r
- 4 <count-down> :> c''\r
- V{ } clone :> v\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- yield\r
- 3 v push\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 4 v push\r
- 1 seconds sleep\r
- 5 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 2 v push\r
- c' count-down\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 4" spawn drop\r
-\r
- [\r
- c' await\r
- l [\r
- 6 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 5" spawn drop\r
-\r
- c'' await\r
- v ;\r
-\r
-[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test\r
-\r
-:: rw-lock-test-2 ( -- v )\r
- <rw-lock> :> l\r
- 1 <count-down> :> c\r
- 2 <count-down> :> c'\r
- V{ } clone :> v\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- 1 seconds sleep\r
- 2 v push\r
- ] with-write-lock\r
- c' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 3 v push\r
- ] with-read-lock\r
- c' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- c' await\r
- v ;\r
-\r
-[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test\r
-\r
-! Test lock timeouts\r
-:: lock-timeout-test ( -- v )\r
- <lock> :> l\r
-\r
- [\r
- l [ 1 seconds sleep ] with-lock\r
- ] "Lock holder" spawn drop\r
-\r
- [\r
- l 1/10 seconds [ ] with-lock-timeout\r
- ] "Lock timeout-er" spawn-linked drop\r
-\r
- receive ;\r
-\r
-[ lock-timeout-test ] [\r
- thread>> name>> "Lock timeout-er" =\r
-] must-fail-with\r
-\r
-[\r
- <rw-lock> dup [\r
- 1 seconds [ ] with-write-lock-timeout\r
- ] with-read-lock\r
-] must-fail\r
-\r
-[\r
- <rw-lock> dup [\r
- dup [\r
- 1 seconds [ ] with-write-lock-timeout\r
- ] with-read-lock\r
- ] with-write-lock\r
-] must-fail\r
-\r
-[ ] [\r
- <rw-lock> dup [\r
- dup [\r
- 1 seconds [ ] with-read-lock-timeout\r
- ] with-read-lock\r
- ] with-write-lock\r
-] unit-test\r
+USING: tools.test concurrency.locks concurrency.count-downs
+concurrency.messaging concurrency.mailboxes locals kernel
+threads sequences calendar accessors ;
+IN: concurrency.locks.tests
+
+:: lock-test-0 ( -- v )
+ V{ } clone :> v
+ 2 <count-down> :> c
+
+ [
+ yield
+ 1 v push
+ yield
+ 2 v push
+ c count-down
+ ] "Lock test 1" spawn drop
+
+ [
+ yield
+ 3 v push
+ yield
+ 4 v push
+ c count-down
+ ] "Lock test 2" spawn drop
+
+ c await
+ v ;
+
+:: lock-test-1 ( -- v )
+ V{ } clone :> v
+ <lock> :> l
+ 2 <count-down> :> c
+
+ [
+ l [
+ yield
+ 1 v push
+ yield
+ 2 v push
+ ] with-lock
+ c count-down
+ ] "Lock test 1" spawn drop
+
+ [
+ l [
+ yield
+ 3 v push
+ yield
+ 4 v push
+ ] with-lock
+ c count-down
+ ] "Lock test 2" spawn drop
+
+ c await
+ v ;
+
+[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
+[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
+
+[ 3 ] [
+ <reentrant-lock> dup [
+ [
+ 3
+ ] with-lock
+ ] with-lock
+] unit-test
+
+[ ] [ <rw-lock> drop ] unit-test
+
+[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
+
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
+
+[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
+
+[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
+
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
+
+:: rw-lock-test-1 ( -- v )
+ <rw-lock> :> l
+ 1 <count-down> :> c
+ 1 <count-down> :> c'
+ 4 <count-down> :> c''
+ V{ } clone :> v
+
+ [
+ l [
+ 1 v push
+ c count-down
+ yield
+ 3 v push
+ ] with-read-lock
+ c'' count-down
+ ] "R/W lock test 1" spawn drop
+
+ [
+ c await
+ l [
+ 4 v push
+ 1 seconds sleep
+ 5 v push
+ ] with-write-lock
+ c'' count-down
+ ] "R/W lock test 2" spawn drop
+
+ [
+ c await
+ l [
+ 2 v push
+ c' count-down
+ ] with-read-lock
+ c'' count-down
+ ] "R/W lock test 4" spawn drop
+
+ [
+ c' await
+ l [
+ 6 v push
+ ] with-write-lock
+ c'' count-down
+ ] "R/W lock test 5" spawn drop
+
+ c'' await
+ v ;
+
+[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
+
+:: rw-lock-test-2 ( -- v )
+ <rw-lock> :> l
+ 1 <count-down> :> c
+ 2 <count-down> :> c'
+ V{ } clone :> v
+
+ [
+ l [
+ 1 v push
+ c count-down
+ 1 seconds sleep
+ 2 v push
+ ] with-write-lock
+ c' count-down
+ ] "R/W lock test 1" spawn drop
+
+ [
+ c await
+ l [
+ 3 v push
+ ] with-read-lock
+ c' count-down
+ ] "R/W lock test 2" spawn drop
+
+ c' await
+ v ;
+
+[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
+
+! Test lock timeouts
+:: lock-timeout-test ( -- v )
+ <lock> :> l
+
+ [
+ l [ 1 seconds sleep ] with-lock
+ ] "Lock holder" spawn drop
+
+ [
+ l 1/10 seconds [ ] with-lock-timeout
+ ] "Lock timeout-er" spawn-linked drop
+
+ receive ;
+
+[ lock-timeout-test ] [
+ thread>> name>> "Lock timeout-er" =
+] must-fail-with
+
+[
+ <rw-lock> dup [
+ 1 seconds [ ] with-write-lock-timeout
+ ] with-read-lock
+] must-fail
+
+[
+ <rw-lock> dup [
+ dup [
+ 1 seconds [ ] with-write-lock-timeout
+ ] with-read-lock
+ ] with-write-lock
+] must-fail
+
+[ ] [
+ <rw-lock> dup [
+ dup [
+ 1 seconds [ ] with-read-lock-timeout
+ ] with-read-lock
+ ] with-write-lock
+] unit-test
projects / factor.git / blobdiff