| 
									
										
										
										
											2010-03-18 05:06:00 -04:00
										 |  |  | ! Copyright (C) 2003, 2010 Slava Pestov. | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2015-08-15 19:31:21 -04:00
										 |  |  | USING: accessors arrays assocs hashtables kernel kernel.private | 
					
						
							|  |  |  | math sequences vectors ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | IN: namespaces | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | <PRIVATE
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | TUPLE: global-hashtable | 
					
						
							|  |  |  |     { boxes hashtable read-only } ;
 | 
					
						
							|  |  |  | TUPLE: global-box value ;
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | : (box-at) ( key globals -- box )
 | 
					
						
							| 
									
										
										
										
											2015-08-14 22:51:29 -04:00
										 |  |  |     boxes>> [ drop f global-box boa ] cache ; foldable
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | : box-at ( key globals -- box )
 | 
					
						
							|  |  |  |     (box-at) { global-box } declare ; inline
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | M: global-hashtable at* | 
					
						
							| 
									
										
										
										
											2012-07-20 18:09:06 -04:00
										 |  |  |     boxes>> at* [ | 
					
						
							| 
									
										
										
										
											2015-08-13 20:46:40 -04:00
										 |  |  |         { global-box } declare value>> t
 | 
					
						
							| 
									
										
										
										
											2012-07-20 18:09:06 -04:00
										 |  |  |     ] [ drop f f ] if ; inline
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | M: global-hashtable set-at | 
					
						
							|  |  |  |     box-at value<< ; inline
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | M: global-hashtable delete-at | 
					
						
							|  |  |  |     box-at f swap value<< ; inline
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | : (get-namestack) ( -- namestack )
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  |     CONTEXT-OBJ-NAMESTACK context-object { vector } declare ; inline
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:46:40 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | : (set-namestack) ( namestack -- )
 | 
					
						
							|  |  |  |     CONTEXT-OBJ-NAMESTACK set-context-object ; inline
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:46:40 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | : >n ( namespace -- ) (get-namestack) push ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : ndrop ( -- ) (get-namestack) pop* ;
 | 
					
						
							| 
									
										
										
										
											2011-11-26 23:20:55 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | PRIVATE>
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:46:40 -04:00
										 |  |  | : global ( -- g )
 | 
					
						
							|  |  |  |     OBJ-GLOBAL special-object { global-hashtable } declare ; foldable
 | 
					
						
							| 
									
										
										
										
											2011-11-27 13:43:23 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | : namespace ( -- namespace ) (get-namestack) last ; inline
 | 
					
						
							|  |  |  | : get-namestack ( -- namestack ) (get-namestack) clone ;
 | 
					
						
							|  |  |  | : set-namestack ( namestack -- ) >vector (set-namestack) ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | : init-namespaces ( -- ) global 1array set-namestack ;
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-07-20 18:09:06 -04:00
										 |  |  | : get-global ( variable -- value ) global box-at value>> ; inline
 | 
					
						
							| 
									
										
										
										
											2011-10-13 20:21:59 -04:00
										 |  |  | : set-global ( value variable -- ) global set-at ; inline
 | 
					
						
							| 
									
										
										
										
											2012-07-20 18:09:06 -04:00
										 |  |  | : change-global ( variable quot -- )
 | 
					
						
							|  |  |  |     [ [ get-global ] keep ] dip dip set-global ; inline
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | : counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; inline
 | 
					
						
							|  |  |  | : initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : get ( variable -- value ) (get-namestack) assoc-stack ; inline
 | 
					
						
							|  |  |  | : set ( value variable -- ) namespace set-at ;
 | 
					
						
							|  |  |  | : change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
 | 
					
						
							|  |  |  | : on ( variable -- ) t swap set ; inline
 | 
					
						
							|  |  |  | : off ( variable -- ) f swap set ; inline
 | 
					
						
							| 
									
										
										
										
											2011-10-29 04:01:59 -04:00
										 |  |  | : toggle ( variable -- ) [ not ] change ; inline
 | 
					
						
							| 
									
										
										
										
											2011-10-13 20:21:59 -04:00
										 |  |  | : +@ ( n variable -- ) [ 0 or + ] change ; inline
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | : inc ( variable -- ) 1 swap +@ ; inline
 | 
					
						
							|  |  |  | : dec ( variable -- ) -1 swap +@ ; inline
 | 
					
						
							| 
									
										
										
										
											2015-08-13 20:53:07 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-07-19 03:02:47 -04:00
										 |  |  | : with-variables ( ns quot -- ) swap >n call ndrop ; inline
 | 
					
						
							|  |  |  | : with-scope ( quot -- ) 5 <hashtable> swap with-variables ; inline
 | 
					
						
							|  |  |  | : with-variable ( value key quot -- ) [ associate ] dip with-variables ; inline
 | 
					
						
							|  |  |  | : with-global ( quot -- ) [ global ] dip with-variables ; inline
 |