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

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 <void*>
+    "void*" heap-size [
-    [ IUnknown::QueryInterface ole32-error ] keep
+        [ IUnknown::QueryInterface ole32-error ] keep *void*
-    *void* ;
+    ] with-malloc ;
 
 : com-add-ref ( interface -- interface )
      [ IUnknown::AddRef drop ] keep ; inline

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 ;
 
 <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 ] %
+        [ find-com-interface-definition family-tree [ iid>> ] map ] dip
-        [
+        1quotation [ 2array ] curry map
-            >r find-com-interface-definition family-tree
-            r> 1quotation [ >r iid>> r> 2array ] curry map
     ] map-index concat
-        [ drop f ] suffix ,
+    [ drop f ] suffix ;
-        \ case ,
+
-        "void*" heap-size
+: (make-query-interface) ( interfaces -- quot )
-        [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
+    (query-interface-cases) 
-        curry ,
+    '[
-        [ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
+        swap 16 memory>byte-array
-        \ if* ,
+        , case
-    ] [ ] make ;
+        [
+            "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' )
+: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
-    [ [ swap 2array ] curry map swap ] keep
+    [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
-    [ com-unwrap ] compose [ swap 2array ] curry map append ;
+    [ '[ ,                   [ 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 [
+    swap [ find-com-interface-definition family-tree-functions ]
-        [ return>> ] [ parameters>> [ first ] map ] bi
+    keep (next-vtbl-counter) '[
-        dup length 1- roll [
+        swap [
-            first dup empty?
+            [ name>> , , (callback-word) ]
-            [ 2drop [ ] ]
+            [ return>> ] [
-            [ swap [ ndip ] 2curry ]
+                parameters>>
-            if
+                [ [ first ] map ]
-        ] [ second ] bi compose
+                [ length ] bi
+            ] tri
+        ] [
+            first2 (finish-thunk)
+        ] bi*
         "stdcall" swap compile-alien-callback
-    ] 2map >c-void*-array [ byte-length malloc ] keep
+    ] 2map >c-void*-array
-    over byte-array>memory ;
+    (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
+M: com-wrapper dispose*
-    t >>freed?
     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 ;