1 USING: kernel windows.com windows.com.syntax windows.ole32
2 windows.types alien alien.data alien.syntax tools.test libc
3 alien.c-types namespaces arrays continuations accessors math
4 windows.com.wrapper windows.com.wrapper.private destructors
5 effects compiler.units ;
8 COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
10 HRESULT returnError ( ) ;
12 COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
14 void setX ( int newX ) ;
16 COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
18 int xMulAdd ( int mul, int add ) ;
20 COM-INTERFACE: ISelfReferential IUnknown {d4f45bf8-f720-4701-a09d-e8e341981121}
21 ISelfReferential* selfReference ( ) ;
23 { GUID: {216fb341-0eb2-44b1-8edb-60b76e353abc} } [ ISimple-iid ] unit-test
24 { GUID: {9620ecec-8438-423b-bb14-86f835aa40dd} } [ IInherited-iid ] unit-test
25 { GUID: {00000000-0000-0000-C000-000000000046} } [ IUnknown-iid ] unit-test
26 { GUID: {b06ac3f4-30e4-406b-a7cd-c29cead4552c} } [ IUnrelated-iid ] unit-test
28 { (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test
29 { (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test
30 { (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test
31 { (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test
32 { (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test
34 SYMBOL: +test-wrapper+
35 SYMBOL: +guinea-pig-implementation+
36 SYMBOL: +orig-wrapped-objects+
38 +wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
40 TUPLE: test-implementation x ;
41 C: <test-implementation> test-implementation
46 [ drop S_OK ] ! ISimple::returnOK
47 [ drop E_FAIL ] ! ISimple::returnError
48 [ x>> ] ! IInherited::getX
49 [ >>x drop ] ! IInherited::setX
52 [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
53 [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
56 dup +test-wrapper+ set [
58 0 <test-implementation> swap com-wrap
59 dup +guinea-pig-implementation+ set [ drop
61 S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
62 E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
64 +guinea-pig-implementation+ get
65 [ 20 IInherited::setX ]
66 [ IInherited::getX ] bi
69 +guinea-pig-implementation+ get
70 IUnrelated-iid com-query-interface
71 [ 20 20 IUnrelated::xMulAdd ] with-com-interface
74 +guinea-pig-implementation+ get
75 IUnrelated-iid com-query-interface
76 [ 20 IUnrelated::xPlus ] with-com-interface
79 +guinea-pig-implementation+ get 1array [
80 +guinea-pig-implementation+ get com-add-ref
83 { } [ +guinea-pig-implementation+ get com-release ] unit-test
85 +guinea-pig-implementation+ get 1array [
86 +guinea-pig-implementation+ get IUnknown-iid com-query-interface
89 +guinea-pig-implementation+ get 1array [
90 +guinea-pig-implementation+ get ISimple-iid com-query-interface
93 void* heap-size +guinea-pig-implementation+ get <displaced-alien>
94 +guinea-pig-implementation+ get
96 +guinea-pig-implementation+ get IUnrelated-iid com-query-interface
97 dup ISimple-iid com-query-interface
98 over com-release dup com-release
104 ] with-compilation-unit
106 ! Ensure that we freed +guinea-pig-implementation
107 +orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test