Merge branch 'master' of git://factorcode.org/git/factor
commit
1cf1b5fb3c
|
@ -42,7 +42,6 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
|||
[ lookup-privilege ] dip
|
||||
[
|
||||
TOKEN_PRIVILEGES-Privileges
|
||||
[ 0 ] dip LUID_AND_ATTRIBUTES-nth
|
||||
set-LUID_AND_ATTRIBUTES-Luid
|
||||
] keep ;
|
||||
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
USING: alien alien.c-types windows.com.syntax init
|
||||
windows.com.syntax.private windows.com continuations kernel
|
||||
USING: alien alien.c-types alien.accessors 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 sets ;
|
||||
destructors fry math.parser generalizations sets
|
||||
specialized-arrays.alien specialized-arrays.direct.alien ;
|
||||
IN: windows.com.wrapper
|
||||
|
||||
TUPLE: com-wrapper callbacks vtbls disposed ;
|
||||
|
@ -51,23 +52,26 @@ unless
|
|||
_ case
|
||||
[
|
||||
"void*" heap-size * rot <displaced-alien> com-add-ref
|
||||
0 rot set-void*-nth S_OK
|
||||
] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
|
||||
swap 0 set-alien-cell S_OK
|
||||
] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
|
||||
] ;
|
||||
|
||||
: (make-add-ref) ( interfaces -- quot )
|
||||
length "void*" heap-size * '[
|
||||
_ swap <displaced-alien>
|
||||
0 over ulong-nth
|
||||
1+ [ 0 rot set-ulong-nth ] keep
|
||||
_
|
||||
[ alien-unsigned-4 1+ dup ]
|
||||
[ set-alien-unsigned-4 ]
|
||||
2bi
|
||||
] ;
|
||||
|
||||
: (make-release) ( interfaces -- quot )
|
||||
length "void*" heap-size * '[
|
||||
_ over <displaced-alien>
|
||||
0 over ulong-nth
|
||||
1- [ 0 rot set-ulong-nth ] keep
|
||||
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
|
||||
_
|
||||
[ drop ]
|
||||
[ alien-unsigned-4 1- dup ]
|
||||
[ set-alien-unsigned-4 ]
|
||||
2tri
|
||||
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
|
||||
] ;
|
||||
|
||||
: (make-iunknown-methods) ( interfaces -- quots )
|
||||
|
@ -125,8 +129,7 @@ unless
|
|||
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
|
||||
vtbls>> length "void*" heap-size *
|
||||
[ "ulong" heap-size + malloc ] keep
|
||||
over <displaced-alien>
|
||||
1 0 rot set-ulong-nth ;
|
||||
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
|
||||
|
||||
: (callbacks>vtbl) ( callbacks -- vtbl )
|
||||
[ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
|
||||
|
@ -159,5 +162,5 @@ M: com-wrapper dispose*
|
|||
|
||||
: com-wrap ( object wrapper -- wrapped-object )
|
||||
[ 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 ;
|
||||
|
|
|
@ -6,8 +6,10 @@ USING: kernel alien.c-types combinators namespaces make arrays
|
|||
vars colors self self.slots
|
||||
random-weighted colors.hsv cfdg.gl accessors
|
||||
ui.gadgets.handler ui.gestures assocs ui.gadgets macros
|
||||
qualified speicalized-arrays.double ;
|
||||
qualified specialized-arrays.double ;
|
||||
|
||||
QUALIFIED: syntax
|
||||
|
||||
IN: cfdg
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
@ -53,7 +55,10 @@ VAR: color-stack
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
|
||||
! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
|
||||
|
||||
: double-nth* ( c-array indices -- seq )
|
||||
swap byte-array>double-array [ nth ] curry map ;
|
||||
|
||||
: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;
|
||||
|
Loading…
Reference in New Issue