stack-checker.alien: generate a declaration for input parameter types
							parent
							
								
									fd1aad71bd
								
							
						
					
					
						commit
						723d780703
					
				| 
						 | 
				
			
			@ -526,3 +526,18 @@ USING: alien alien.c-types ;
 | 
			
		|||
    [ int { } cdecl [ 2 2 + ] alien-callback ]
 | 
			
		||||
    { + } inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ double { double double } cdecl [ + ] alien-callback ]
 | 
			
		||||
    \ + inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ f ] [
 | 
			
		||||
    [ double { double double } cdecl [ + ] alien-callback ]
 | 
			
		||||
    \ float+ inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ f ] [
 | 
			
		||||
    [ char { char char } cdecl [ + ] alien-callback ]
 | 
			
		||||
    \ fixnum+fast inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -6,6 +6,7 @@ alien.private alien.c-types fry quotations strings
 | 
			
		|||
stack-checker.backend stack-checker.errors stack-checker.visitor
 | 
			
		||||
stack-checker.dependencies stack-checker.state
 | 
			
		||||
compiler.utilities effects ;
 | 
			
		||||
FROM: kernel.private => declare ;
 | 
			
		||||
IN: stack-checker.alien
 | 
			
		||||
 | 
			
		||||
TUPLE: alien-node-params
 | 
			
		||||
| 
						 | 
				
			
			@ -113,13 +114,16 @@ TUPLE: alien-callback-params < alien-node-params xt ;
 | 
			
		|||
: callback-return-quot ( ctype -- quot )
 | 
			
		||||
    return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ;
 | 
			
		||||
 | 
			
		||||
: callback-prep-quot ( params -- quot )
 | 
			
		||||
    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 | 
			
		||||
: callback-parameter-quot ( params -- quot )
 | 
			
		||||
    parameters>> [ c-type ] map
 | 
			
		||||
    [ [ c-type-class ] map '[ _ declare ] ]
 | 
			
		||||
    [ [ c-type-boxer-quot ] map spread>quot ]
 | 
			
		||||
    bi append ;
 | 
			
		||||
 | 
			
		||||
GENERIC: wrap-callback-quot ( params quot -- quot' )
 | 
			
		||||
 | 
			
		||||
M: callable wrap-callback-quot
 | 
			
		||||
    swap [ callback-prep-quot ] [ callback-return-quot ] bi surround
 | 
			
		||||
    swap [ callback-parameter-quot ] [ callback-return-quot ] bi surround
 | 
			
		||||
    yield-hook get
 | 
			
		||||
    '[ _ _ do-callback ]
 | 
			
		||||
    >quotation ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue