diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor old mode 100644 new mode 100755 index 4833a7412a..4202ed4c56 --- a/extra/windows/com/com.factor +++ b/extra/windows/com/com.factor @@ -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 - [ 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 diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 972a75ecb9..6d6aa078e8 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -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 ; byte-array ] % + [ find-com-interface-definition family-tree [ iid>> ] map ] dip + 1quotation [ 2array ] curry map + ] map-index concat + [ drop f ] suffix ; + +: (make-query-interface) ( interfaces -- quot ) + (query-interface-cases) + '[ + swap 16 memory>byte-array + , case [ - >r find-com-interface-definition family-tree - r> 1quotation [ >r iid>> r> 2array ] curry map - ] map-index concat - [ drop f ] suffix , - \ case , - "void*" heap-size - [ * rot com-add-ref 0 rot set-void*-nth S_OK ] - curry , - [ nip f 0 rot set-void*-nth E_NOINTERFACE ] , - \ if* , - ] [ ] make ; + "void*" heap-size * rot 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 + length "void*" heap-size * '[ + , swap 0 over ulong-nth 1+ [ 0 rot set-ulong-nth ] keep - ] curry ; + ] ; : (make-release) ( interfaces -- quot ) - length "void*" heap-size * [ over + length "void*" heap-size * '[ + , over 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 ] curry ] + [ "void*" heap-size neg * '[ , swap ] ] 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> : ( 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 ;