2008-03-01 17:00:45 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: concurrency.flags.tests
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 04:28:45 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								USING: tools.test concurrency.flags concurrency.combinators
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-19 02:50:05 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								kernel threads locals accessors calendar ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-30 19:28:15 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								:: flag-test-1 ( -- val )
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [let | f [ <flag> ] |
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ f raise-flag ] "Flag test" spawn drop
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f lower-flag
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 06:47:14 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f value>>
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ f ] [ flag-test-1 ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								:: flag-test-2 ( -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [let | f [ <flag> ] |
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-19 02:50:05 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f lower-flag
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 06:47:14 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f value>>
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ f ] [ flag-test-2 ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-30 19:28:15 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								:: flag-test-3 ( -- val )
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [let | f [ <flag> ] |
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f raise-flag
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 06:47:14 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f value>>
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ t ] [ flag-test-3 ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-30 19:28:15 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								:: flag-test-4 ( -- val )
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [let | f [ <flag> ] |
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ f raise-flag ] "Flag test" spawn drop
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f wait-for-flag
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 06:47:14 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f value>>
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ t ] [ flag-test-4 ] unit-test
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-30 19:28:15 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								:: flag-test-5 ( -- val )
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [let | f [ <flag> ] |
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-19 02:50:05 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f wait-for-flag
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 06:47:14 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        f value>>
							 | 
						
					
						
							
								
									
										
										
										
											2008-02-29 20:10:30 -05:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ t ] [ flag-test-5 ] unit-test
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 04:28:45 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[ ] [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    { 1 2 } <flag>
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-19 02:50:05 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-07 04:28:45 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ [ wait-for-flag drop ] curry parallel-each ] bi
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								] unit-test
							 |