basis/windows/com/wrapper/wrapper.factor

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