namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien ;
+specialized-arrays.alien specialized-arrays.direct.alien
+windows.kernel32 ;
IN: windows.com.wrapper
-TUPLE: com-wrapper callbacks vtbls disposed ;
+TUPLE: com-wrapper < disposable callbacks vtbls ;
<PRIVATE
"windows.com.wrapper.callbacks" create-vocab drop
: (next-vtbl-counter) ( -- n )
- +vtbl-counter+ [ 1+ dup ] change ;
+ +vtbl-counter+ [ 1 + dup ] change ;
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
: (make-query-interface) ( interfaces -- quot )
(query-interface-cases)
'[
- swap 16 memory>byte-array
+ swap GUID memory>struct
_ case
[
"void*" heap-size * rot <displaced-alien> com-add-ref
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
_
- [ alien-unsigned-4 1+ dup ]
+ [ alien-unsigned-4 1 + dup ]
[ set-alien-unsigned-4 ]
2bi
] ;
length "void*" heap-size * '[
_
[ drop ]
- [ alien-unsigned-4 1- dup ]
+ [ alien-unsigned-4 1 - dup ]
[ set-alien-unsigned-4 ]
2tri
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
: compile-alien-callback ( word return parameters abi quot -- word )
'[ _ _ _ _ alien-callback ]
- [ [ (( -- alien )) define-declared ] pick slip ]
+ [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
with-compilation-unit ;
: (callback-word) ( function-name interface-name counter -- word )
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
- [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ]
+ [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
[ +live-wrappers+ get adjoin ] bi ;
: <com-wrapper> ( implementations -- wrapper )
- (make-callbacks) f f com-wrapper boa
+ com-wrapper new-disposable swap (make-callbacks) >>callbacks
dup allocate-wrapper ;
M: com-wrapper dispose*