basis/windows/com/com-tests.factor

   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 ;
   6 IN: windows.com.tests
   7
   8 COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
   9     HRESULT returnOK ( )
  10     HRESULT returnError ( ) ;
  11
  12 COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
  13     int getX ( )
  14     void setX ( int newX ) ;
  15
  16 COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
  17     int xPlus ( int y )
  18     int xMulAdd ( int mul, int add ) ;
  19
  20 COM-INTERFACE: ISelfReferential IUnknown {d4f45bf8-f720-4701-a09d-e8e341981121}
  21     ISelfReferential* selfReference ( ) ;
  22
  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
  27
  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
  33
  34 SYMBOL: +test-wrapper+
  35 SYMBOL: +guinea-pig-implementation+
  36 SYMBOL: +orig-wrapped-objects+
  37
  38 +wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
  39
  40 TUPLE: test-implementation x ;
  41 C: <test-implementation> test-implementation
  42
  43 [
  44     [
  45         {
  46             { IInherited {
  47                 [ drop S_OK ] ! ISimple::returnOK
  48                 [ drop E_FAIL ] ! ISimple::returnError
  49                 [ x>> ] ! IInherited::getX
  50                 [ >>x drop ] ! IInherited::setX
  51             } }
  52             { IUnrelated {
  53                 [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
  54                 [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
  55             } }
  56         } <com-wrapper>
  57         dup +test-wrapper+ set [
  58
  59             0 <test-implementation> swap com-wrap
  60             dup +guinea-pig-implementation+ set [
  61                 drop
  62
  63                 S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
  64                 E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
  65                 20 1array [
  66                     +guinea-pig-implementation+ get
  67                     [ 20 IInherited::setX ]
  68                     [ IInherited::getX ] bi
  69                 ] unit-test
  70                 420 1array [
  71                     +guinea-pig-implementation+ get
  72                     IUnrelated-iid com-query-interface
  73                     [ 20 20 IUnrelated::xMulAdd ] with-com-interface
  74                 ] unit-test
  75                 40 1array [
  76                     +guinea-pig-implementation+ get
  77                     IUnrelated-iid com-query-interface
  78                     [ 20 IUnrelated::xPlus ] with-com-interface
  79                 ] unit-test
  80
  81                 +guinea-pig-implementation+ get 1array [
  82                     +guinea-pig-implementation+ get com-add-ref
  83                 ] unit-test
  84
  85                 { } [ +guinea-pig-implementation+ get com-release ] unit-test
  86
  87                 +guinea-pig-implementation+ get 1array [
  88                     +guinea-pig-implementation+ get IUnknown-iid com-query-interface
  89                     dup com-release
  90                 ] unit-test
  91                 +guinea-pig-implementation+ get 1array [
  92                     +guinea-pig-implementation+ get ISimple-iid com-query-interface
  93                     dup com-release
  94                 ] unit-test
  95                 void* heap-size +guinea-pig-implementation+ get <displaced-alien>
  96                 +guinea-pig-implementation+ get
  97                 2array [
  98                     +guinea-pig-implementation+ get IUnrelated-iid com-query-interface
  99                     dup ISimple-iid com-query-interface
 100                     over com-release dup com-release
 101                 ] unit-test
 102             ] with-com-interface
 103         ] with-disposal
 104     ] with-compilation-unit
 105 ] with-destructors
 106
 107 ! Ensure that we freed +guinea-pig-implementation
 108 +orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test