1 USING: alien alien.c-types arrays assocs combinators continuations
2 destructors io io.backend io.ports io.timeouts io.backend.windows
3 io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
4 io.streams.c io.streams.null libc kernel math namespaces sequences
5 threads windows windows.errors windows.kernel32 strings splitting
6 ascii system accessors locals classes.struct ;
7 QUALIFIED: windows.winsock
8 IN: io.backend.windows.nt
10 ! Global variable with assoc mapping overlapped to threads
11 SYMBOL: pending-overlapped
13 TUPLE: io-callback port thread ;
15 C: <io-callback> io-callback
17 : (make-overlapped) ( -- overlapped-ext )
18 "OVERLAPPED" malloc-object &free ;
20 : make-overlapped ( port -- overlapped-ext )
21 [ (make-overlapped) ] dip
22 handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
24 M: winnt FileArgs-overlapped ( port -- overlapped )
27 : <completion-port> ( handle existing -- handle )
28 f 1 CreateIoCompletionPort dup win32-error=0/f ;
30 SYMBOL: master-completion-port
32 : <master-completion-port> ( -- handle )
33 INVALID_HANDLE_VALUE f <completion-port> ;
35 M: winnt add-completion ( win32-handle -- )
36 handle>> master-completion-port get-global <completion-port> drop ;
39 [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
41 : twiddle-thumbs ( overlapped port -- bytes-transferred )
44 [ pending-overlapped get-global set-at ] curry "I/O" suspend
46 { [ dup integer? ] [ ] }
49 [ drop 0 ] [ n>win32-error-string throw ] if
54 :: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
55 master-completion-port get-global
58 f <void*> [ ! overlapped
59 us [ 1000 /i ] [ INFINITE ] if* ! timeout
60 GetQueuedCompletionStatus zero?
64 : resume-callback ( result overlapped -- )
65 pending-overlapped get-global delete-at* drop resume-with ;
67 : handle-overlapped ( us -- ? )
70 [ drop GetLastError 1array ] dip resume-callback t
72 ] [ resume-callback t ] if ;
74 M: win32-handle cancel-operation
75 [ check-disposed ] [ handle>> CancelIo drop ] bi ;
77 M: winnt io-multiplex ( us -- )
78 handle-overlapped [ 0 io-multiplex ] when ;
80 M: winnt init-io ( -- )
81 <master-completion-port> master-completion-port set-global
82 H{ } clone pending-overlapped set-global
83 windows.winsock:init-winsock ;
85 ERROR: invalid-file-size n ;
87 : handle>file-size ( handle -- n )
88 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
90 ERROR: seek-before-start n ;
92 : set-seek-ptr ( n handle -- )
93 [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
95 M: winnt seek-handle ( n seek-type handle -- )
97 { seek-absolute [ set-seek-ptr ] }
98 { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
99 { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
103 : file-error? ( n -- eof? )
106 { [ dup expected-io-error? ] [ drop f ] }
107 { [ dup eof? ] [ drop t ] }
108 [ n>win32-error-string throw ]
112 : wait-for-file ( FileArgs n port -- n )
114 [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
116 : update-file-ptr ( n port -- )
117 handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
119 : finish-write ( n port -- )
120 [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
122 M: winnt (wait-to-write)
124 [ make-FileArgs dup setup-write WriteFile ]
130 : finish-read ( n port -- )
131 [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
133 M: winnt (wait-to-read) ( port -- )
135 [ make-FileArgs dup setup-read ReadFile ]
141 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
146 [ null-reader null-writer null-writer set-stdio ] if ;