basis/windows/com/wrapper/wrapper.factor

   1 USING: alien alien.c-types alien.accessors windows.com.syntax
   2 init windows.com.syntax.private windows.com continuations kernel
   3 namespaces windows.ole32 libc vocabs assocs accessors arrays
   4 sequences quotations combinators math words compiler.units
   5 destructors fry math.parser generalizations sets
   6 specialized-arrays windows.kernel32 classes.struct ;
   7 SPECIALIZED-ARRAY: void*
   8 IN: windows.com.wrapper
   9
  10 TUPLE: com-wrapper < disposable callbacks vtbls ;
  11
  12 <PRIVATE
  13
  14 SYMBOL: +wrapped-objects+
  15 +wrapped-objects+ get-global
  16 [ H{ } +wrapped-objects+ set-global ]
  17 unless
  18
  19 SYMBOL: +live-wrappers+
  20 +live-wrappers+ get-global
  21 [ V{ } +live-wrappers+ set-global ]
  22 unless
  23
  24 SYMBOL: +vtbl-counter+
  25 +vtbl-counter+ get-global
  26 [ 0 +vtbl-counter+ set-global ]
  27 unless
  28
  29 "windows.com.wrapper.callbacks" create-vocab drop
  30
  31 : (next-vtbl-counter) ( -- n )
  32     +vtbl-counter+ [ 1 + dup ] change ;
  33
  34 : com-unwrap ( wrapped -- object )
  35     +wrapped-objects+ get-global at*
  36     [ "invalid COM wrapping pointer" throw ] unless ;
  37
  38 : (free-wrapped-object) ( wrapped -- )
  39     [ +wrapped-objects+ get-global delete-at ] keep
  40     free ;
  41
  42 : (query-interface-cases) ( interfaces -- cases )
  43     [
  44         [ find-com-interface-definition family-tree [ iid>> ] map ] dip
  45         1quotation [ 2array ] curry map
  46     ] map-index concat
  47     [ drop f ] suffix ;
  48
  49 : (make-query-interface) ( interfaces -- quot )
  50     (query-interface-cases)
  51     '[
  52         swap GUID memory>struct
  53         _ case
  54         [
  55             "void*" heap-size * rot <displaced-alien> com-add-ref
  56             swap 0 set-alien-cell S_OK
  57         ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
  58     ] ;
  59
  60 : (make-add-ref) ( interfaces -- quot )
  61     length "void*" heap-size * '[
  62         _
  63         [ alien-unsigned-4 1 + dup ]
  64         [ set-alien-unsigned-4 ]
  65         2bi
  66     ] ;
  67
  68 : (make-release) ( interfaces -- quot )
  69     length "void*" heap-size * '[
  70         _
  71         [ drop ]
  72         [ alien-unsigned-4 1 - dup ]
  73         [ set-alien-unsigned-4 ]
  74         2tri
  75         dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
  76     ] ;
  77
  78 : (make-iunknown-methods) ( interfaces -- quots )
  79     [ (make-query-interface) ]
  80     [ (make-add-ref) ]
  81     [ (make-release) ] tri
  82     3array ;
  83
  84 : (thunk) ( n -- quot )
  85     dup 0 =
  86     [ drop [ ] ]
  87     [ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ]
  88     if ;
  89
  90 : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
  91     [ '[ @ com-unwrap ] [ swap 2array ] curry map ]
  92     [                   [ swap 2array ] curry map ] bi-curry bi*
  93     prepend ;
  94
  95 : compile-alien-callback ( word return parameters abi quot -- word )
  96     '[ _ _ _ _ alien-callback ]
  97     [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
  98     with-compilation-unit ;
  99
 100 : (callback-word) ( function-name interface-name counter -- word )
 101     [ "::" rot 3append "-callback-" ] dip number>string 3append
 102     "windows.com.wrapper.callbacks" create ;
 103
 104 : (finish-thunk) ( param-count thunk quot -- thunked-quot )
 105     [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
 106     dip compose ;
 107
 108 : (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
 109     (thunk) (thunked-quots)
 110     swap [ find-com-interface-definition family-tree-functions ]
 111     keep (next-vtbl-counter) '[
 112         swap [
 113             [ name>> _ _ (callback-word) ]
 114             [ return>> ] [
 115                 parameters>>
 116                 [ [ first ] map ]
 117                 [ length ] bi
 118             ] tri
 119         ] [
 120             first2 (finish-thunk)
 121         ] bi*
 122         "stdcall" swap compile-alien-callback
 123     ] 2map ;
 124
 125 : (make-callbacks) ( implementations -- sequence )
 126     dup [ first ] map (make-iunknown-methods)
 127     [ [ first2 ] 2dip swap (make-interface-callbacks) ]
 128     curry map-index ;
 129
 130 : (malloc-wrapped-object) ( wrapper -- wrapped-object )
 131     vtbls>> length "void*" heap-size *
 132     [ "ulong" heap-size + malloc ] keep
 133     [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
 134
 135 : (callbacks>vtbl) ( callbacks -- vtbl )
 136     [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ;
 137 : (callbacks>vtbls) ( callbacks -- vtbls )
 138     [ (callbacks>vtbl) ] map ;
 139
 140 : (allocate-wrapper) ( wrapper -- )
 141     dup callbacks>> (callbacks>vtbls) >>vtbls
 142     f >>disposed drop ;
 143
 144 : (init-hook) ( -- )
 145     +live-wrappers+ get-global [ (allocate-wrapper) ] each
 146     H{ } +wrapped-objects+ set-global ;
 147
 148 [ (init-hook) ] "windows.com.wrapper" add-init-hook
 149
 150 PRIVATE>
 151
 152 : allocate-wrapper ( wrapper -- )
 153     [ (allocate-wrapper) ]
 154     [ +live-wrappers+ get adjoin ] bi ;
 155
 156 : <com-wrapper> ( implementations -- wrapper )
 157     com-wrapper new-disposable swap (make-callbacks) >>callbacks
 158     dup allocate-wrapper ;
 159
 160 M: com-wrapper dispose*
 161     [ [ free ] each f ] change-vtbls
 162     +live-wrappers+ get-global delete ;
 163
 164 : com-wrap ( object wrapper -- wrapped-object )
 165     [ vtbls>> ] [ (malloc-wrapped-object) ] bi
 166     [ over length <direct-void*-array> 0 swap copy ] keep
 167     [ +wrapped-objects+ get-global set-at ] keep ;