| 
									
										
										
										
											2009-01-16 15:12:10 -05:00
										 |  |  | ! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov. | 
					
						
							| 
									
										
										
										
											2008-09-28 01:40:41 -04:00
										 |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2009-01-16 15:12:10 -05:00
										 |  |  | USING: accessors kernel parser words sequences quotations | 
					
						
							|  |  |  | combinators.short-circuit definitions ;
 | 
					
						
							| 
									
										
										
										
											2008-05-06 21:59:37 -04:00
										 |  |  | IN: values | 
					
						
							| 
									
										
										
										
											2008-04-30 20:39:54 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-09-28 01:40:41 -04:00
										 |  |  | ! Mutating literals in word definitions is not really allowed, | 
					
						
							|  |  |  | ! and the deploy tool takes advantage of this fact to perform | 
					
						
							|  |  |  | ! some aggressive stripping and compression. However, this | 
					
						
							|  |  |  | ! breaks a naive implementation of values. We need to do two | 
					
						
							|  |  |  | ! things: | 
					
						
							|  |  |  | ! 1) Store the value in a subclass of identity-tuple, so that | 
					
						
							|  |  |  | ! two quotations from different value words are never equal. | 
					
						
							|  |  |  | ! This avoids bogus merging of values. | 
					
						
							|  |  |  | ! 2) Set the "no-def-strip" word-prop, so that the shaker leaves | 
					
						
							|  |  |  | ! the def>> slot alone, allowing us to introspect it. Otherwise, | 
					
						
							|  |  |  | ! it will get set to [ ] and we would lose access to the | 
					
						
							|  |  |  | ! value-holder. | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | <PRIVATE
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | TUPLE: value-holder < identity-tuple obj ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | PRIVATE>
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-01-16 15:12:10 -05:00
										 |  |  | PREDICATE: value-word < word | 
					
						
							|  |  |  |     def>> { | 
					
						
							|  |  |  |         [ length 2 = ] | 
					
						
							|  |  |  |         [ first value-holder? ] | 
					
						
							|  |  |  |         [ second \ obj>> = ] | 
					
						
							|  |  |  |     } 1&& ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-03-21 02:27:50 -04:00
										 |  |  | SYNTAX: VALUE: | 
					
						
							| 
									
										
										
										
											2008-09-28 01:40:41 -04:00
										 |  |  |     CREATE-WORD | 
					
						
							|  |  |  |     dup t "no-def-strip" set-word-prop | 
					
						
							|  |  |  |     T{ value-holder } clone [ obj>> ] curry
 | 
					
						
							| 
									
										
										
										
											2009-03-21 02:27:50 -04:00
										 |  |  |     (( -- value )) define-declared ;
 | 
					
						
							| 
									
										
										
										
											2008-04-30 20:39:54 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-01-16 15:12:10 -05:00
										 |  |  | M: value-word definer drop \ VALUE: f ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | M: value-word definition drop f ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-04-30 20:39:54 -04:00
										 |  |  | : set-value ( value word -- )
 | 
					
						
							| 
									
										
										
										
											2008-09-28 01:40:41 -04:00
										 |  |  |     def>> first (>>obj) ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-03-21 02:27:50 -04:00
										 |  |  | SYNTAX: to: | 
					
						
							| 
									
										
										
										
											2009-10-28 14:38:27 -04:00
										 |  |  |     scan-word literalize suffix!
 | 
					
						
							|  |  |  |     \ set-value suffix! ;
 | 
					
						
							| 
									
										
										
										
											2008-05-06 21:59:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : get-value ( word -- value )
 | 
					
						
							| 
									
										
										
										
											2008-09-28 01:40:41 -04:00
										 |  |  |     def>> first obj>> ;
 | 
					
						
							| 
									
										
										
										
											2008-05-06 21:59:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : change-value ( word quot -- )
 | 
					
						
							| 
									
										
										
										
											2008-09-28 01:40:41 -04:00
										 |  |  |     [ [ get-value ] dip call ] [ drop ] 2bi set-value ; inline
 |