125 lines
3.4 KiB
Factor
125 lines
3.4 KiB
Factor
USING: alien alien.c-types arrays assocs combinators
|
|
continuations destructors io io.backend io.ports io.timeouts
|
|
io.windows io.windows.files io.files io.buffers io.streams.c
|
|
libc kernel math namespaces sequences threads windows
|
|
windows.errors windows.kernel32 strings splitting qualified
|
|
ascii system accessors locals ;
|
|
QUALIFIED: windows.winsock
|
|
IN: io.windows.nt.backend
|
|
|
|
! Global variable with assoc mapping overlapped to threads
|
|
SYMBOL: pending-overlapped
|
|
|
|
TUPLE: io-callback port thread ;
|
|
|
|
C: <io-callback> io-callback
|
|
|
|
: (make-overlapped) ( -- overlapped-ext )
|
|
"OVERLAPPED" malloc-object &free ;
|
|
|
|
: make-overlapped ( port -- overlapped-ext )
|
|
>r (make-overlapped)
|
|
r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
|
|
|
|
: <completion-port> ( handle existing -- handle )
|
|
f 1 CreateIoCompletionPort dup win32-error=0/f ;
|
|
|
|
SYMBOL: master-completion-port
|
|
|
|
: <master-completion-port> ( -- handle )
|
|
INVALID_HANDLE_VALUE f <completion-port> ;
|
|
|
|
M: winnt add-completion ( win32-handle -- )
|
|
handle>> master-completion-port get-global <completion-port> drop ;
|
|
|
|
: eof? ( error -- ? )
|
|
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
|
|
|
|
: twiddle-thumbs ( overlapped port -- bytes-transferred )
|
|
[
|
|
drop
|
|
[ pending-overlapped get-global set-at ] curry "I/O" suspend
|
|
{
|
|
{ [ dup integer? ] [ ] }
|
|
{ [ dup array? ] [
|
|
first dup eof?
|
|
[ drop 0 ] [ (win32-error-string) throw ] if
|
|
] }
|
|
} cond
|
|
] with-timeout ;
|
|
|
|
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
|
|
master-completion-port get-global
|
|
0 <int> [ ! bytes
|
|
f <void*> ! key
|
|
f <void*> [ ! overlapped
|
|
ms INFINITE or ! timeout
|
|
GetQueuedCompletionStatus zero?
|
|
] keep *void*
|
|
] keep *int spin ;
|
|
|
|
: resume-callback ( result overlapped -- )
|
|
pending-overlapped get-global delete-at* drop resume-with ;
|
|
|
|
: handle-overlapped ( timeout -- ? )
|
|
wait-for-overlapped [
|
|
dup [
|
|
>r drop GetLastError 1array r> resume-callback t
|
|
] [
|
|
2drop f
|
|
] if
|
|
] [
|
|
resume-callback t
|
|
] if ;
|
|
|
|
M: win32-handle cancel-operation
|
|
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
|
|
|
|
M: winnt io-multiplex ( ms -- )
|
|
handle-overlapped [ 0 io-multiplex ] when ;
|
|
|
|
M: winnt init-io ( -- )
|
|
<master-completion-port> master-completion-port set-global
|
|
H{ } clone pending-overlapped set-global
|
|
windows.winsock:init-winsock ;
|
|
|
|
: file-error? ( n -- eof? )
|
|
zero? [
|
|
GetLastError {
|
|
{ [ dup expected-io-error? ] [ drop f ] }
|
|
{ [ dup eof? ] [ drop t ] }
|
|
[ (win32-error-string) throw ]
|
|
} cond
|
|
] [ f ] if ;
|
|
|
|
: wait-for-file ( FileArgs n port -- n )
|
|
swap file-error?
|
|
[ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
|
|
|
|
: update-file-ptr ( n port -- )
|
|
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
|
|
|
|
: finish-write ( n port -- )
|
|
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
|
|
|
|
M: winnt (wait-to-write)
|
|
[
|
|
[ make-FileArgs dup setup-write WriteFile ]
|
|
[ wait-for-file ]
|
|
[ finish-write ]
|
|
tri
|
|
] with-destructors ;
|
|
|
|
: finish-read ( n port -- )
|
|
[ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
|
|
|
|
M: winnt (wait-to-read) ( port -- )
|
|
[
|
|
[ make-FileArgs dup setup-read ReadFile ]
|
|
[ wait-for-file ]
|
|
[ finish-read ]
|
|
tri
|
|
] with-destructors ;
|
|
|
|
M: winnt (init-stdio) init-c-stdio ;
|