1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences accessors combinators math namespaces
4 init sets words alien.libraries
6 stack-checker.backend stack-checker.errors stack-checker.visitor ;
7 IN: stack-checker.alien
9 TUPLE: alien-node-params return parameters abi in-d out-d ;
11 TUPLE: alien-invoke-params < alien-node-params library function ;
13 TUPLE: alien-indirect-params < alien-node-params ;
15 TUPLE: alien-callback-params < alien-node-params quot xt ;
17 : param-prep-quot ( node -- quot )
18 parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
20 : alien-stack ( params extra -- )
21 over parameters>> length + consume-d >>in-d
22 dup return>> void? 0 1 ? produce-d >>out-d
25 : return-prep-quot ( node -- quot )
26 return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
28 : infer-alien-invoke ( -- )
29 alien-invoke-params new
30 ! Compile-time parameters
31 pop-literal nip >>parameters
32 pop-literal nip >>function
33 pop-literal nip >>library
34 pop-literal nip >>return
35 ! Quotation which coerces parameters to required types
36 dup param-prep-quot infer-quot-here
38 dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
39 ! Magic #: consume exactly the number of inputs
43 ! Quotation which coerces return value to required type
44 return-prep-quot infer-quot-here ;
46 : infer-alien-indirect ( -- )
47 alien-indirect-params new
48 ! Compile-time parameters
50 pop-literal nip >>parameters
51 pop-literal nip >>return
52 ! Quotation which coerces parameters to required types
53 dup param-prep-quot [ dip ] curry infer-quot-here
54 ! Magic #: consume the function pointer, too
58 ! Quotation which coerces return value to required type
59 return-prep-quot infer-quot-here ;
61 : register-callback ( word -- ) callbacks get conjoin ;
63 : callback-bottom ( params -- )
64 xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
67 : infer-alien-callback ( -- )
68 alien-callback-params new
69 pop-literal nip >>quot
71 pop-literal nip >>parameters
72 pop-literal nip >>return