1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences accessors combinators math namespaces
4 init sets words assocs alien.libraries alien alien.private
5 alien.c-types fry stack-checker.backend
6 stack-checker.errors stack-checker.visitor
7 stack-checker.dependencies ;
8 IN: stack-checker.alien
10 TUPLE: alien-node-params return parameters abi in-d out-d ;
12 TUPLE: alien-invoke-params < alien-node-params library function ;
14 TUPLE: alien-indirect-params < alien-node-params ;
16 TUPLE: alien-assembly-params < alien-node-params quot ;
18 TUPLE: alien-callback-params < alien-node-params quot xt ;
20 : param-prep-quot ( params -- quot )
21 parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
23 : alien-stack ( params extra -- )
24 over parameters>> length + consume-d >>in-d
25 dup return>> void? 0 1 ? produce-d >>out-d
28 : return-prep-quot ( params -- quot )
29 return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
31 : infer-return ( params -- )
32 return-prep-quot infer-quot-here ;
34 : pop-return ( params -- params )
35 pop-literal [ depends-on-c-type ] [ nip >>return ] bi ;
37 : pop-library ( params -- params )
38 pop-literal nip >>library ;
40 : pop-function ( params -- params )
41 pop-literal nip >>function ;
43 : pop-params ( params -- params )
44 pop-literal [ [ depends-on-c-type ] each ] [ nip >>parameters ] bi ;
46 : pop-abi ( params -- params )
47 pop-literal nip >>abi ;
49 : pop-quot ( params -- params )
50 pop-literal nip >>quot ;
52 : infer-alien-invoke ( -- )
53 alien-invoke-params new
54 ! Compile-time parameters
60 dup library>> library-abi >>abi
61 ! Quotation which coerces parameters to required types
62 dup param-prep-quot infer-quot-here
63 ! Magic #: consume exactly the number of inputs
67 ! Quotation which coerces return value to required type
70 : infer-alien-indirect ( -- )
71 alien-indirect-params new
72 ! Compile-time parameters
76 ! Coerce parameters to required types
77 dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
78 ! Magic #: consume the function pointer, too
82 ! Quotation which coerces return value to required type
85 : infer-alien-assembly ( -- )
86 alien-assembly-params new
87 ! Compile-time parameters
92 ! Quotation which coerces parameters to required types
93 dup param-prep-quot infer-quot-here
94 ! Magic #: consume exactly the number of inputs
98 ! Quotation which coerces return value to required type
101 : callback-xt ( word -- alien )
102 callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
104 : callback-bottom ( params -- )
105 xt>> '[ _ callback-xt ] infer-quot-here ;
107 : infer-alien-callback ( -- )
108 alien-callback-params new
113 "( callback )" <uninterned-word> >>xt