-USING: alien alien.c-types windows.com.syntax
+USING: alien alien.c-types windows.com.syntax init
 windows.com.syntax.private windows.com continuations kernel
 namespaces windows.ole32 libc vocabs assocs accessors arrays
 sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations ;
+destructors fry math.parser generalizations sets ;
 IN: windows.com.wrapper
 
-TUPLE: com-wrapper vtbls disposed ;
+TUPLE: com-wrapper callbacks vtbls disposed ;
 
 <PRIVATE
 
 SYMBOL: +wrapped-objects+
 +wrapped-objects+ get-global
 [ H{ } +wrapped-objects+ set-global ]
+unless
+
+SYMBOL: +live-wrappers+
++live-wrappers+ get-global
+[ V{ } +live-wrappers+ set-global ]
 unless
 
 SYMBOL: +vtbl-counter+

            first2 (finish-thunk)
        ] bi*
        "stdcall" swap compile-alien-callback
    ] 2map >c-void*-array
    (byte-array-to-malloced-buffer) ;

: (make-vtbls) ( implementations -- vtbls )
    dup [ first ] map (make-iunknown-methods)
    [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;

: (malloc-wrapped-object) ( wrapper -- wrapped-object )
    vtbls>> length "void*" heap-size *

    over <displaced-alien>
    1 0 rot set-ulong-nth ;

: (callbacks>vtbl) ( callbacks -- vtbl )
    [ execute ] map >c-void*-array byte-array>malloc ;
: (callbacks>vtbls) ( callbacks -- vtbls )
    [ (callbacks>vtbl) ] map ;

: (allocate-wrapper) ( wrapper -- )
    dup callbacks>> (callbacks>vtbls) >>vtbls
    f >>disposed drop ;

: (init-hook) ( -- )
    +live-wrappers+ get-global [ (allocate-wrapper) ] each
    H{ } +wrapped-objects+ set-global ;

[ (init-hook) ] "windows.com.wrapper" add-init-hook

PRIVATE>

: allocate-wrapper ( wrapper -- )
    [ (allocate-wrapper) ]
    [ +live-wrappers+ get adjoin ] bi ;

: <com-wrapper> ( implementations -- wrapper )
    (make-callbacks) f f com-wrapper boa
    dup allocate-wrapper ;

M: com-wrapper dispose*
    [ [ free ] each f ] change-vtbls
    +live-wrappers+ get-global delete ;

: com-wrap ( object wrapper -- wrapped-object )
    [ vtbls>> ] [ (malloc-wrapped-object) ] bi
