steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Update windows.com.wrapper for specialized-arrays changes

db4
U-SLAVA-DFB8FF805\Slava 2008-12-03 09:12:57 -06:00
parent 0a2ef55dc6
commit cc34ead754
1 changed files with 18 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
basis/windows/com/wrapper/wrapper.factor Normal file → Executable file
View File

@ -1,8 +1,9 @@
USING: alien alien.c-types windows.com.syntax init USING: alien alien.c-types alien.accessors windows.com.syntax
windows.com.syntax.private windows.com continuations kernel init windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets ; destructors fry math.parser generalizations sets
specialized-arrays.alien specialized-arrays.direct.alien ;
IN: windows.com.wrapper IN: windows.com.wrapper
TUPLE: com-wrapper callbacks vtbls disposed ; TUPLE: com-wrapper callbacks vtbls disposed ;
@ -51,23 +52,26 @@ unless
_ case _ case
[ [
"void*" heap-size * rot <displaced-alien> com-add-ref "void*" heap-size * rot <displaced-alien> com-add-ref
0 rot set-void*-nth S_OK swap 0 set-alien-cell S_OK
] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if* ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
] ; ] ;
: (make-add-ref) ( interfaces -- quot ) : (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[ length "void*" heap-size * '[
_ swap <displaced-alien> _
0 over ulong-nth [ alien-unsigned-4 1+ dup ]
1+ [ 0 rot set-ulong-nth ] keep [ set-alien-unsigned-4 ]
2bi
] ; ] ;
: (make-release) ( interfaces -- quot ) : (make-release) ( interfaces -- quot )
length "void*" heap-size * '[ length "void*" heap-size * '[
_ over <displaced-alien> _
0 over ulong-nth [ drop ]
1- [ 0 rot set-ulong-nth ] keep [ alien-unsigned-4 1- dup ]
dup zero? [ swap (free-wrapped-object) ] [ nip ] if [ set-alien-unsigned-4 ]
2tri
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
] ; ] ;
: (make-iunknown-methods) ( interfaces -- quots ) : (make-iunknown-methods) ( interfaces -- quots )
@ -125,8 +129,7 @@ unless
: (malloc-wrapped-object) ( wrapper -- wrapped-object ) : (malloc-wrapped-object) ( wrapper -- wrapped-object )
vtbls>> length "void*" heap-size * vtbls>> length "void*" heap-size *
[ "ulong" heap-size + malloc ] keep [ "ulong" heap-size + malloc ] keep
over <displaced-alien> [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
1 0 rot set-ulong-nth ;
: (callbacks>vtbl) ( callbacks -- vtbl ) : (callbacks>vtbl) ( callbacks -- vtbl )
[ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
@ -159,5 +162,5 @@ M: com-wrapper dispose*
: com-wrap ( object wrapper -- wrapped-object ) : com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi [ vtbls>> ] [ (malloc-wrapped-object) ] bi
[ [ set-void*-nth ] curry each-index ] keep [ over length <direct-void*-array> 0 swap copy ] keep
[ +wrapped-objects+ get-global set-at ] keep ; [ +wrapped-objects+ get-global set-at ] keep ;