Refactor windows.com.wrapper to make better use of fry and cleave to show what is going on. Create named words for wrapper alien-callbacks so it is easy to see what code gets generated. Change com-query-interface to malloc the buffer for the returned interface pointer to avoid GC heisenbugs when calling into a com-wrapped factor object
Joe Groff
parent
fa71934d2c
commit
7bd7222b07
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types windows.com.syntax windows.ole32
|
||||
windows.types continuations kernel alien.syntax ;
|
||||
windows.types continuations kernel alien.syntax libc ;
|
||||
IN: windows.com
|
||||
|
||||
LIBRARY: ole32
|
||||
|
|
@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
|
|||
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
|
||||
|
||||
: com-query-interface ( interface iid -- interface' )
|
||||
f <void*>
|
||||
[ IUnknown::QueryInterface ole32-error ] keep
|
||||
*void* ;
|
||||
"void*" heap-size [
|
||||
[ IUnknown::QueryInterface ole32-error ] keep *void*
|
||||
] with-malloc ;
|
||||
|
||||
: com-add-ref ( interface -- interface )
|
||||
[ IUnknown::AddRef drop ] keep ; inline
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
USING: alien alien.c-types windows.com.syntax
|
||||
windows.com.syntax.private windows.com continuations kernel
|
||||
sequences.lib namespaces windows.ole32 libc
|
||||
sequences.lib namespaces windows.ole32 libc vocabs
|
||||
assocs accessors arrays sequences quotations combinators
|
||||
math combinators.lib words compiler.units destructors ;
|
||||
math combinators.lib words compiler.units destructors fry
|
||||
math.parser ;
|
||||
IN: windows.com.wrapper
|
||||
|
||||
TUPLE: com-wrapper vtbls freed? ;
|
||||
TUPLE: com-wrapper vtbls disposed ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -14,6 +15,16 @@ SYMBOL: +wrapped-objects+
|
|||
[ H{ } +wrapped-objects+ set-global ]
|
||||
unless
|
||||
|
||||
SYMBOL: +vtbl-counter+
|
||||
+vtbl-counter+ get-global
|
||||
[ 0 +vtbl-counter+ set-global ]
|
||||
unless
|
||||
|
||||
"windows.com.wrapper.callbacks" create-vocab drop
|
||||
|
||||
: (next-vtbl-counter) ( -- n )
|
||||
+vtbl-counter+ [ 1+ dup ] change ;
|
||||
|
||||
: com-unwrap ( wrapped -- object )
|
||||
+wrapped-objects+ get-global at*
|
||||
[ "invalid COM wrapping pointer" throw ] unless ;
|
||||
|
|
@ -22,34 +33,38 @@ unless
|
|||
[ +wrapped-objects+ get-global delete-at ] keep
|
||||
free ;
|
||||
|
||||
: (make-query-interface) ( interfaces -- quot )
|
||||
: (query-interface-cases) ( interfaces -- cases )
|
||||
[
|
||||
[ swap 16 memory>byte-array ] %
|
||||
[
|
||||
>r find-com-interface-definition family-tree
|
||||
r> 1quotation [ >r iid>> r> 2array ] curry map
|
||||
[ find-com-interface-definition family-tree [ iid>> ] map ] dip
|
||||
1quotation [ 2array ] curry map
|
||||
] map-index concat
|
||||
[ drop f ] suffix ,
|
||||
\ case ,
|
||||
"void*" heap-size
|
||||
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
|
||||
curry ,
|
||||
[ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
|
||||
\ if* ,
|
||||
] [ ] make ;
|
||||
[ drop f ] suffix ;
|
||||
|
||||
: (make-query-interface) ( interfaces -- quot )
|
||||
(query-interface-cases)
|
||||
'[
|
||||
swap 16 memory>byte-array
|
||||
, case
|
||||
[
|
||||
"void*" heap-size * rot <displaced-alien> com-add-ref
|
||||
0 rot set-void*-nth S_OK
|
||||
] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
|
||||
] ;
|
||||
|
||||
: (make-add-ref) ( interfaces -- quot )
|
||||
length "void*" heap-size * [ swap <displaced-alien>
|
||||
length "void*" heap-size * '[
|
||||
, swap <displaced-alien>
|
||||
0 over ulong-nth
|
||||
1+ [ 0 rot set-ulong-nth ] keep
|
||||
] curry ;
|
||||
] ;
|
||||
|
||||
: (make-release) ( interfaces -- quot )
|
||||
length "void*" heap-size * [ over <displaced-alien>
|
||||
length "void*" heap-size * '[
|
||||
, over <displaced-alien>
|
||||
0 over ulong-nth
|
||||
1- [ 0 rot set-ulong-nth ] keep
|
||||
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
|
||||
] curry ;
|
||||
] ;
|
||||
|
||||
: (make-iunknown-methods) ( interfaces -- quots )
|
||||
[ (make-query-interface) ]
|
||||
|
|
@ -60,32 +75,48 @@ unless
|
|||
: (thunk) ( n -- quot )
|
||||
dup 0 =
|
||||
[ drop [ ] ]
|
||||
[ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
|
||||
[ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
|
||||
if ;
|
||||
|
||||
: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
|
||||
[ [ swap 2array ] curry map swap ] keep
|
||||
[ com-unwrap ] compose [ swap 2array ] curry map append ;
|
||||
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
|
||||
[ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
|
||||
[ '[ , [ swap 2array ] curry map ] ] bi bi*
|
||||
swap append ;
|
||||
|
||||
: compile-alien-callback ( return parameters abi quot -- alien )
|
||||
: compile-alien-callback ( word return parameters abi quot -- alien )
|
||||
[ alien-callback ] 4 ncurry
|
||||
[ gensym [ swap (( -- alien )) define-declared ] keep ]
|
||||
[ [ (( -- alien )) define-declared ] pick slip ]
|
||||
with-compilation-unit
|
||||
execute ;
|
||||
|
||||
: (make-vtbl) ( interface-name quots iunknown-methods n -- )
|
||||
: (byte-array-to-malloced-buffer) ( byte-array -- alien )
|
||||
[ byte-length malloc ] [ over byte-array>memory ] bi ;
|
||||
|
||||
: (callback-word) ( function-name interface-name counter -- word )
|
||||
[ "::" rot 3append "-callback-" ] dip number>string 3append
|
||||
"windows.com.wrapper.callbacks" create ;
|
||||
|
||||
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
|
||||
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
|
||||
dip compose ;
|
||||
|
||||
: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
|
||||
(thunk) (thunked-quots)
|
||||
swap find-com-interface-definition family-tree-functions [
|
||||
[ return>> ] [ parameters>> [ first ] map ] bi
|
||||
dup length 1- roll [
|
||||
first dup empty?
|
||||
[ 2drop [ ] ]
|
||||
[ swap [ ndip ] 2curry ]
|
||||
if
|
||||
] [ second ] bi compose
|
||||
swap [ find-com-interface-definition family-tree-functions ]
|
||||
keep (next-vtbl-counter) '[
|
||||
swap [
|
||||
[ name>> , , (callback-word) ]
|
||||
[ return>> ] [
|
||||
parameters>>
|
||||
[ [ first ] map ]
|
||||
[ length ] bi
|
||||
] tri
|
||||
] [
|
||||
first2 (finish-thunk)
|
||||
] bi*
|
||||
"stdcall" swap compile-alien-callback
|
||||
] 2map >c-void*-array [ byte-length malloc ] keep
|
||||
over byte-array>memory ;
|
||||
] 2map >c-void*-array
|
||||
(byte-array-to-malloced-buffer) ;
|
||||
|
||||
: (make-vtbls) ( implementations -- vtbls )
|
||||
dup [ first ] map (make-iunknown-methods)
|
||||
|
|
@ -102,11 +133,10 @@ PRIVATE>
|
|||
: <com-wrapper> ( implementations -- wrapper )
|
||||
(make-vtbls) f com-wrapper boa ;
|
||||
|
||||
M: com-wrapper dispose
|
||||
t >>freed?
|
||||
M: com-wrapper dispose*
|
||||
vtbls>> [ free ] each ;
|
||||
|
||||
: com-wrap ( object wrapper -- wrapped-object )
|
||||
dup (malloc-wrapped-object) >r vtbls>> r>
|
||||
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
|
||||
[ [ set-void*-nth ] curry each-index ] keep
|
||||
[ +wrapped-objects+ get-global set-at ] keep ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue