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

eradicate string C types from windows.com.*

db4
Joe Groff 2009-09-30 16:17:50 -05:00
parent e0f3b72c65
commit f83698948f
2 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/windows/com/com-tests.factor
View File

@ -37,13 +37,13 @@ TUPLE: test-implementation x ;
C: <test-implementation> test-implementation C: <test-implementation> test-implementation
{ {
{ "IInherited" { { IInherited {
[ drop S_OK ] ! ISimple::returnOK [ drop S_OK ] ! ISimple::returnOK
[ drop E_FAIL ] ! ISimple::returnError [ drop E_FAIL ] ! ISimple::returnError
[ x>> ] ! IInherited::getX [ x>> ] ! IInherited::getX
[ >>x drop ] ! IInherited::setX [ >>x drop ] ! IInherited::setX
} } } }
{ "IUnrelated" { { IUnrelated {
[ swap x>> + ] ! IUnrelated::xPlus [ swap x>> + ] ! IUnrelated::xPlus
[ spin x>> * + ] ! IUnrelated::xMulAdd [ spin x>> * + ] ! IUnrelated::xMulAdd
} } } }
@ -85,7 +85,7 @@ dup +test-wrapper+ set [
+guinea-pig-implementation+ get ISimple-iid com-query-interface +guinea-pig-implementation+ get ISimple-iid com-query-interface
dup com-release dup com-release
] unit-test ] unit-test
"void*" heap-size +guinea-pig-implementation+ get <displaced-alien> void* heap-size +guinea-pig-implementation+ get <displaced-alien>
+guinea-pig-implementation+ get +guinea-pig-implementation+ get
2array [ 2array [
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface +guinea-pig-implementation+ get IUnrelated-iid com-query-interface

18
basis/windows/com/wrapper/wrapper.factor
View File

@ -52,13 +52,13 @@ unless
swap GUID memory>struct swap GUID memory>struct
_ case _ case
[ [
"void*" heap-size * rot <displaced-alien> com-add-ref void* heap-size * rot <displaced-alien> com-add-ref
swap 0 set-alien-cell S_OK swap 0 set-alien-cell S_OK
] [ nip f swap 0 set-alien-cell 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 * '[
_ _
[ alien-unsigned-4 1 + dup ] [ alien-unsigned-4 1 + dup ]
[ set-alien-unsigned-4 ] [ set-alien-unsigned-4 ]
@ -66,7 +66,7 @@ unless
] ; ] ;
: (make-release) ( interfaces -- quot ) : (make-release) ( interfaces -- quot )
length "void*" heap-size * '[ length void* heap-size * '[
_ _
[ drop ] [ drop ]
[ alien-unsigned-4 1 - dup ] [ alien-unsigned-4 1 - dup ]
@ -84,7 +84,7 @@ unless
: (thunk) ( n -- quot ) : (thunk) ( n -- quot )
dup 0 = dup 0 =
[ drop [ ] ] [ drop [ ] ]
[ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ] [ void* heap-size neg * '[ _ swap <displaced-alien> ] ]
if ; if ;
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s ) : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
@ -97,15 +97,15 @@ unless
[ [ (( -- alien )) define-declared ] pick [ call ] dip ] [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
with-compilation-unit ; with-compilation-unit ;
: (callback-word) ( function-name interface-name counter -- word ) : (callback-word) ( function-name interface counter -- word )
[ "::" rot 3append "-callback-" ] dip number>string 3append [ name>> "::" rot 3append "-callback-" ] dip number>string 3append
"windows.com.wrapper.callbacks" create ; "windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot ) : (finish-thunk) ( param-count thunk quot -- thunked-quot )
[ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ] [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
dip compose ; dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) : (make-interface-callbacks) ( interface quots iunknown-methods n -- words )
(thunk) (thunked-quots) (thunk) (thunked-quots)
swap [ find-com-interface-definition family-tree-functions ] swap [ find-com-interface-definition family-tree-functions ]
keep (next-vtbl-counter) '[ keep (next-vtbl-counter) '[
@ -128,8 +128,8 @@ unless
curry map-index ; curry map-index ;
: (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
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl ) : (callbacks>vtbl) ( callbacks -- vtbl )