2008-04-17 06:16:28 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								USING: namespaces io tools.test threads kernel
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-27 04:16:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								concurrency.combinators concurrency.promises locals math
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-14 10:10:13 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								words calendar sequences ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-01 17:00:45 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: threads.tests
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-18 06:07:40 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								3 "x" set
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-09 18:14:26 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ 2 "x" set ] "Test" spawn drop
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-18 06:07:40 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ 2 ] [ yield "x" get ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ ] [ [ flush ] "flush test" spawn drop flush ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								yield
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ ] [ 0.3 sleep ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ "hey" sleep ] must-fail
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ 3 ] [
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-19 15:38:02 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ 3 swap resume-with ] "Test suspend" suspend
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-18 06:07:40 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								] unit-test
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-16 03:44:17 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ f ] [ f get-global ] unit-test
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-17 06:16:28 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								{ { 0 3 6 9 12 15 18 21 24 27 } } [
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-14 10:10:13 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    10 iota [
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-17 06:16:28 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        0 "i" tset
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								            "i" [ yield 3 + ] tchange
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ] times yield
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        "i" tget
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] parallel-map
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								] unit-test
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-27 04:16:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2009-04-17 15:44:08 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								:: spawn-namespace-test ( -- ? )
							 | 
						
					
						
							
								
									
										
										
										
											2009-10-27 22:50:31 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    <promise> :> p gensym :> g
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        g "x" set
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ "x" get p fulfill ] "B" spawn drop
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] with-scope
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    p ?promise g eq? ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-27 04:16:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ t ] [ spawn-namespace-test ] unit-test
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-29 19:44:44 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ "a" [ 1 1 + ] spawn 100 sleep ] must-fail
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-06 06:02:16 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ ] [ 0.1 seconds sleep ] unit-test
							 |