basis/windows/com/wrapper/wrapper.factor

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