102 lines
3.7 KiB
Factor
102 lines
3.7 KiB
Factor
USING: kernel windows.com windows.com.syntax windows.ole32
|
|
alien alien.syntax tools.test libc alien.c-types
|
|
namespaces arrays continuations accessors math windows.com.wrapper
|
|
windows.com.wrapper.private destructors effects ;
|
|
IN: windows.com.tests
|
|
|
|
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
|
|
HRESULT returnOK ( )
|
|
HRESULT returnError ( ) ;
|
|
|
|
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
|
|
int getX ( )
|
|
void setX ( int newX ) ;
|
|
|
|
COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
|
|
int xPlus ( int y )
|
|
int xMulAdd ( int mul, int add ) ;
|
|
|
|
{ GUID: {216fb341-0eb2-44b1-8edb-60b76e353abc} } [ ISimple-iid ] unit-test
|
|
{ GUID: {9620ecec-8438-423b-bb14-86f835aa40dd} } [ IInherited-iid ] unit-test
|
|
{ GUID: {00000000-0000-0000-C000-000000000046} } [ IUnknown-iid ] unit-test
|
|
{ GUID: {b06ac3f4-30e4-406b-a7cd-c29cead4552c} } [ IUnrelated-iid ] unit-test
|
|
|
|
{ (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test
|
|
{ (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test
|
|
{ (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test
|
|
{ (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test
|
|
{ (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test
|
|
|
|
SYMBOL: +test-wrapper+
|
|
SYMBOL: +guinea-pig-implementation+
|
|
SYMBOL: +orig-wrapped-objects+
|
|
|
|
+wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
|
|
|
|
TUPLE: test-implementation x ;
|
|
C: <test-implementation> test-implementation
|
|
|
|
{
|
|
{ IInherited {
|
|
[ drop S_OK ] ! ISimple::returnOK
|
|
[ drop E_FAIL ] ! ISimple::returnError
|
|
[ x>> ] ! IInherited::getX
|
|
[ >>x drop ] ! IInherited::setX
|
|
} }
|
|
{ IUnrelated {
|
|
[ swap x>> + ] ! IUnrelated::xPlus
|
|
[ spin x>> * + ] ! IUnrelated::xMulAdd
|
|
} }
|
|
} <com-wrapper>
|
|
dup +test-wrapper+ set [
|
|
|
|
0 <test-implementation> swap com-wrap
|
|
dup +guinea-pig-implementation+ set [ drop
|
|
|
|
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
|
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
|
20 1array [
|
|
+guinea-pig-implementation+ get
|
|
[ 20 IInherited::setX ]
|
|
[ IInherited::getX ] bi
|
|
] unit-test
|
|
420 1array [
|
|
+guinea-pig-implementation+ get
|
|
IUnrelated-iid com-query-interface
|
|
[ 20 20 IUnrelated::xMulAdd ] with-com-interface
|
|
] unit-test
|
|
40 1array [
|
|
+guinea-pig-implementation+ get
|
|
IUnrelated-iid com-query-interface
|
|
[ 20 IUnrelated::xPlus ] with-com-interface
|
|
] unit-test
|
|
|
|
+guinea-pig-implementation+ get 1array [
|
|
+guinea-pig-implementation+ get com-add-ref
|
|
] unit-test
|
|
|
|
{ } [ +guinea-pig-implementation+ get com-release ] unit-test
|
|
|
|
+guinea-pig-implementation+ get 1array [
|
|
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
|
|
dup com-release
|
|
] unit-test
|
|
+guinea-pig-implementation+ get 1array [
|
|
+guinea-pig-implementation+ get ISimple-iid com-query-interface
|
|
dup com-release
|
|
] unit-test
|
|
void* heap-size +guinea-pig-implementation+ get <displaced-alien>
|
|
+guinea-pig-implementation+ get
|
|
2array [
|
|
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
|
|
dup ISimple-iid com-query-interface
|
|
over com-release dup com-release
|
|
] unit-test
|
|
|
|
] with-com-interface
|
|
|
|
] with-disposal
|
|
|
|
! Ensure that we freed +guinea-pig-implementation
|
|
+orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test
|