Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-12-03 09:33:54 -06:00
commit 1cf1b5fb3c
34 changed files with 25 additions and 18 deletions

1
basis/io/windows/nt/privileges/privileges.factor Normal file → Executable file
View File

@ -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 ;

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
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 ;

View File

@ -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 ;