Refactor curry/compose a bit for upcoming frontend changes
							parent
							
								
									a881ce01ae
								
							
						
					
					
						commit
						9e685d7ac4
					
				| 
						 | 
				
			
			@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts
 | 
			
		|||
classes classes.builtin classes.tuple classes.tuple.private
 | 
			
		||||
kernel.private vocabs vocabs.loader source-files definitions
 | 
			
		||||
slots classes.union classes.intersection classes.predicate
 | 
			
		||||
compiler.units bootstrap.image.private io.files accessors combinators ;
 | 
			
		||||
compiler.units bootstrap.image.private io.files accessors
 | 
			
		||||
combinators ;
 | 
			
		||||
IN: bootstrap.primitives
 | 
			
		||||
 | 
			
		||||
"Creating primitives and basic runtime structures..." print flush
 | 
			
		||||
| 
						 | 
				
			
			@ -310,9 +311,12 @@ tuple
 | 
			
		|||
} prepare-slots define-tuple-class
 | 
			
		||||
 | 
			
		||||
"curry" "kernel" lookup
 | 
			
		||||
[ f "inline" set-word-prop ]
 | 
			
		||||
[ ]
 | 
			
		||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
 | 
			
		||||
{
 | 
			
		||||
    [ f "inline" set-word-prop ]
 | 
			
		||||
    [ make-flushable ]
 | 
			
		||||
    [ ]
 | 
			
		||||
    [ tuple-layout [ <tuple-boa> ] curry ] tri
 | 
			
		||||
} cleave
 | 
			
		||||
(( obj quot -- curry )) define-declared
 | 
			
		||||
 | 
			
		||||
"compose" "kernel" create
 | 
			
		||||
| 
						 | 
				
			
			@ -323,9 +327,12 @@ tuple
 | 
			
		|||
} prepare-slots define-tuple-class
 | 
			
		||||
 | 
			
		||||
"compose" "kernel" lookup
 | 
			
		||||
[ f "inline" set-word-prop ]
 | 
			
		||||
[ ]
 | 
			
		||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
 | 
			
		||||
{
 | 
			
		||||
    [ f "inline" set-word-prop ]
 | 
			
		||||
    [ make-flushable ]
 | 
			
		||||
    [ ]
 | 
			
		||||
    [ tuple-layout [ <tuple-boa> ] curry ] tri
 | 
			
		||||
} cleave
 | 
			
		||||
(( quot1 quot2 -- compose )) define-declared
 | 
			
		||||
 | 
			
		||||
! Sub-primitive words
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private
 | 
			
		|||
slots.private ;
 | 
			
		||||
IN: quotations
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
: uncurry dup 3 slot swap 4 slot ; inline
 | 
			
		||||
 | 
			
		||||
: uncompose dup 3 slot swap 4 slot ; inline
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
M: quotation call (call) ;
 | 
			
		||||
 | 
			
		||||
M: curry call dup 3 slot swap 4 slot call ;
 | 
			
		||||
M: curry call uncurry call ;
 | 
			
		||||
 | 
			
		||||
M: compose call dup 3 slot swap 4 slot slip call ;
 | 
			
		||||
M: compose call uncompose slip call ;
 | 
			
		||||
 | 
			
		||||
M: wrapper equal?
 | 
			
		||||
    over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue