1 USING: alien alien.c-types alien.accessors windows.com.syntax
2 init 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 specialized-arrays.alien specialized-arrays.direct.alien
7 windows.kernel32 classes.struct ;
8 IN: windows.com.wrapper
10 TUPLE: com-wrapper < disposable callbacks vtbls ;
14 SYMBOL: +wrapped-objects+
15 +wrapped-objects+ get-global
16 [ H{ } +wrapped-objects+ set-global ]
19 SYMBOL: +live-wrappers+
20 +live-wrappers+ get-global
21 [ V{ } +live-wrappers+ set-global ]
24 SYMBOL: +vtbl-counter+
25 +vtbl-counter+ get-global
26 [ 0 +vtbl-counter+ set-global ]
29 "windows.com.wrapper.callbacks" create-vocab drop
31 : (next-vtbl-counter) ( -- n )
32 +vtbl-counter+ [ 1 + dup ] change ;
34 : com-unwrap ( wrapped -- object )
35 +wrapped-objects+ get-global at*
36 [ "invalid COM wrapping pointer" throw ] unless ;
38 : (free-wrapped-object) ( wrapped -- )
39 [ +wrapped-objects+ get-global delete-at ] keep
42 : (query-interface-cases) ( interfaces -- cases )
44 [ find-com-interface-definition family-tree [ iid>> ] map ] dip
45 1quotation [ 2array ] curry map
49 : (make-query-interface) ( interfaces -- quot )
50 (query-interface-cases)
52 swap GUID memory>struct
55 "void*" heap-size * rot <displaced-alien> com-add-ref
56 swap 0 set-alien-cell S_OK
57 ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
60 : (make-add-ref) ( interfaces -- quot )
61 length "void*" heap-size * '[
63 [ alien-unsigned-4 1 + dup ]
64 [ set-alien-unsigned-4 ]
68 : (make-release) ( interfaces -- quot )
69 length "void*" heap-size * '[
72 [ alien-unsigned-4 1 - dup ]
73 [ set-alien-unsigned-4 ]
75 dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
78 : (make-iunknown-methods) ( interfaces -- quots )
79 [ (make-query-interface) ]
81 [ (make-release) ] tri
84 : (thunk) ( n -- quot )
87 [ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ]
90 : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
91 [ '[ @ com-unwrap ] [ swap 2array ] curry map ]
92 [ [ swap 2array ] curry map ] bi-curry bi*
95 : compile-alien-callback ( word return parameters abi quot -- word )
96 '[ _ _ _ _ alien-callback ]
97 [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
98 with-compilation-unit ;
100 : (callback-word) ( function-name interface-name counter -- word )
101 [ "::" rot 3append "-callback-" ] dip number>string 3append
102 "windows.com.wrapper.callbacks" create ;
104 : (finish-thunk) ( param-count thunk quot -- thunked-quot )
105 [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
108 : (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
109 (thunk) (thunked-quots)
110 swap [ find-com-interface-definition family-tree-functions ]
111 keep (next-vtbl-counter) '[
113 [ name>> _ _ (callback-word) ]
120 first2 (finish-thunk)
122 "stdcall" swap compile-alien-callback
125 : (make-callbacks) ( implementations -- sequence )
126 dup [ first ] map (make-iunknown-methods)
127 [ [ first2 ] 2dip swap (make-interface-callbacks) ]
130 : (malloc-wrapped-object) ( wrapper -- wrapped-object )
131 vtbls>> length "void*" heap-size *
132 [ "ulong" heap-size + malloc ] keep
133 [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
135 : (callbacks>vtbl) ( callbacks -- vtbl )
136 [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ;
137 : (callbacks>vtbls) ( callbacks -- vtbls )
138 [ (callbacks>vtbl) ] map ;
140 : (allocate-wrapper) ( wrapper -- )
141 dup callbacks>> (callbacks>vtbls) >>vtbls
145 +live-wrappers+ get-global [ (allocate-wrapper) ] each
146 H{ } +wrapped-objects+ set-global ;
148 [ (init-hook) ] "windows.com.wrapper" add-init-hook
152 : allocate-wrapper ( wrapper -- )
153 [ (allocate-wrapper) ]
154 [ +live-wrappers+ get adjoin ] bi ;
156 : <com-wrapper> ( implementations -- wrapper )
157 com-wrapper new-disposable swap (make-callbacks) >>callbacks
158 dup allocate-wrapper ;
160 M: com-wrapper dispose*
161 [ [ free ] each f ] change-vtbls
162 +live-wrappers+ get-global delete ;
164 : com-wrap ( object wrapper -- wrapped-object )
165 [ vtbls>> ] [ (malloc-wrapped-object) ] bi
166 [ over length <direct-void*-array> 0 swap copy ] keep
167 [ +wrapped-objects+ get-global set-at ] keep ;