} cond
] with-timeout ;
-:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? )
+:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
master-completion-port get-global
0 <int> :> bytes
f <void*> :> key
f <void*> :> overlapped
- usec [ 1000 /i ] [ INFINITE ] if* :> timeout
+ nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error?
bytes *int
: resume-callback ( result overlapped -- )
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
-: handle-overlapped ( us -- ? )
+: handle-overlapped ( nanos -- ? )
wait-for-overlapped [
[
[ drop GetLastError 1array ] dip resume-callback t
M: win32-handle cancel-operation
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
-M: winnt io-multiplex ( us -- )
+M: winnt io-multiplex ( nanos -- )
handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )
USING: kernel windows.com windows.com.syntax windows.ole32
-alien alien.syntax tools.test libc alien.c-types
+alien alien.syntax tools.test libc alien.c-types
namespaces arrays continuations accessors math windows.com.wrapper
-windows.com.wrapper.private destructors effects ;
+windows.com.wrapper.private destructors effects compiler.units ;
IN: windows.com.tests
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+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 {
- [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
- [ [ x>> ] [ * ] [ + ] tri* ] ! 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
+C: <test-implementation> test-implementation
+
+[
+ {
+ { IInherited {
+ [ drop S_OK ] ! ISimple::returnOK
+ [ drop E_FAIL ] ! ISimple::returnError
+ [ x>> ] ! IInherited::getX
+ [ >>x drop ] ! IInherited::setX
+ } }
+ { IUnrelated {
+ [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
+ [ [ x>> ] [ * ] [ + ] tri* ] ! 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
+] with-compilation-unit
! Ensure that we freed +guinea-pig-implementation
+orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test