1 USING: alien alien.c-types windows.com.syntax init
2 windows.com.syntax.private windows.com continuations kernel
3 namespaces windows.ole32 libc vocabs assocs accessors arrays
4 sequences quotations combinators math words compiler.units
5 destructors fry math.parser generalizations sets ;
6 IN: windows.com.wrapper
8 TUPLE: com-wrapper callbacks vtbls disposed ;
12 SYMBOL: +wrapped-objects+
13 +wrapped-objects+ get-global
14 [ H{ } +wrapped-objects+ set-global ]
17 SYMBOL: +live-wrappers+
18 +live-wrappers+ get-global
19 [ V{ } +live-wrappers+ set-global ]
22 SYMBOL: +vtbl-counter+
23 +vtbl-counter+ get-global
24 [ 0 +vtbl-counter+ set-global ]
27 "windows.com.wrapper.callbacks" create-vocab drop
29 : (next-vtbl-counter) ( -- n )
30 +vtbl-counter+ [ 1+ dup ] change ;
32 : com-unwrap ( wrapped -- object )
33 +wrapped-objects+ get-global at*
34 [ "invalid COM wrapping pointer" throw ] unless ;
36 : (free-wrapped-object) ( wrapped -- )
37 [ +wrapped-objects+ get-global delete-at ] keep
40 : (query-interface-cases) ( interfaces -- cases )
42 [ find-com-interface-definition family-tree [ iid>> ] map ] dip
43 1quotation [ 2array ] curry map
47 : (make-query-interface) ( interfaces -- quot )
48 (query-interface-cases)
50 swap 16 memory>byte-array
53 "void*" heap-size * rot <displaced-alien> com-add-ref
54 0 rot set-void*-nth S_OK
55 ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
58 : (make-add-ref) ( interfaces -- quot )
59 length "void*" heap-size * '[
60 _ swap <displaced-alien>
62 1+ [ 0 rot set-ulong-nth ] keep
65 : (make-release) ( interfaces -- quot )
66 length "void*" heap-size * '[
67 _ over <displaced-alien>
69 1- [ 0 rot set-ulong-nth ] keep
70 dup zero? [ swap (free-wrapped-object) ] [ nip ] if
73 : (make-iunknown-methods) ( interfaces -- quots )
74 [ (make-query-interface) ]
76 [ (make-release) ] tri
79 : (thunk) ( n -- quot )
82 [ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ]
85 : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
86 [ '[ _ '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
87 [ '[ _ [ swap 2array ] curry map ] ] bi bi*
90 : compile-alien-callback ( word return parameters abi quot -- word )
91 '[ _ _ _ _ alien-callback ]
92 [ [ (( -- alien )) define-declared ] pick slip ]
93 with-compilation-unit ;
95 : byte-array>malloc ( byte-array -- alien )
96 [ byte-length malloc ] [ over byte-array>memory ] bi ;
98 : (callback-word) ( function-name interface-name counter -- word )
99 [ "::" rot 3append "-callback-" ] dip number>string 3append
100 "windows.com.wrapper.callbacks" create ;
102 : (finish-thunk) ( param-count thunk quot -- thunked-quot )
103 [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ]
106 : (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
107 (thunk) (thunked-quots)
108 swap [ find-com-interface-definition family-tree-functions ]
109 keep (next-vtbl-counter) '[
111 [ name>> _ _ (callback-word) ]
118 first2 (finish-thunk)
120 "stdcall" swap compile-alien-callback
123 : (make-callbacks) ( implementations -- sequence )
124 dup [ first ] map (make-iunknown-methods)
125 [ >r >r first2 r> r> swap (make-interface-callbacks) ]
128 : (malloc-wrapped-object) ( wrapper -- wrapped-object )
129 vtbls>> length "void*" heap-size *
130 [ "ulong" heap-size + malloc ] keep
131 over <displaced-alien>
132 1 0 rot set-ulong-nth ;
134 : (callbacks>vtbl) ( callbacks -- vtbl )
135 [ execute ] map >c-void*-array byte-array>malloc ;
136 : (callbacks>vtbls) ( callbacks -- vtbls )
137 [ (callbacks>vtbl) ] map ;
139 : (allocate-wrapper) ( wrapper -- )
140 dup callbacks>> (callbacks>vtbls) >>vtbls
144 +live-wrappers+ get-global [ (allocate-wrapper) ] each
145 H{ } +wrapped-objects+ set-global ;
147 [ (init-hook) ] "windows.com.wrapper" add-init-hook
151 : allocate-wrapper ( wrapper -- )
152 [ (allocate-wrapper) ]
153 [ +live-wrappers+ get adjoin ] bi ;
155 : <com-wrapper> ( implementations -- wrapper )
156 (make-callbacks) f f com-wrapper boa
157 dup allocate-wrapper ;
159 M: com-wrapper dispose*
160 [ [ free ] each f ] change-vtbls
161 +live-wrappers+ get-global delete ;
163 : com-wrap ( object wrapper -- wrapped-object )
164 [ vtbls>> ] [ (malloc-wrapped-object) ] bi
165 [ [ set-void*-nth ] curry each-index ] keep
166 [ +wrapped-objects+ get-global set-at ] keep ;