1 USING: accessors alien alien.c-types alien.data alien.syntax
2 arrays assocs classes.struct combinators
3 combinators.short-circuit destructors io io.backend
4 io.backend.windows io.buffers io.files.windows io.ports
5 io.streams.c io.streams.null io.timeouts kernel libc locals
6 math namespaces sequences system threads windows.errors
7 windows.handles windows.kernel32 ;
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-struct &free ;
20 : make-overlapped ( port -- overlapped-ext )
21 [ (make-overlapped) ] dip
22 handle>> ptr>> [ >>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 = ] } 1|| ;
41 : twiddle-thumbs ( overlapped port -- bytes-transferred )
44 [ self ] dip >c-ptr pending-overlapped get-global set-at
46 { [ dup integer? ] [ ] }
49 [ drop 0 ] [ n>win32-error-string throw ] if
54 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
55 nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
56 master-completion-port get-global
57 { int void* pointer: OVERLAPPED }
58 [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
59 :> ( error? bytes key overlapped )
60 bytes overlapped error? ;
62 : resume-callback ( result overlapped -- )
63 >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
65 : handle-overlapped ( nanos -- ? )
68 [ drop GetLastError 1array ] dip resume-callback t
70 ] [ resume-callback t ] if ;
72 M: win32-handle cancel-operation
73 [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
75 M: winnt io-multiplex ( nanos -- )
76 handle-overlapped [ 0 io-multiplex ] when ;
78 M: winnt init-io ( -- )
79 <master-completion-port> master-completion-port set-global
80 H{ } clone pending-overlapped set-global ;
82 ERROR: invalid-file-size n ;
84 : handle>file-size ( handle -- n )
85 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
87 ERROR: seek-before-start n ;
89 : set-seek-ptr ( n handle -- )
90 [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
92 M: winnt tell-handle ( handle -- n ) ptr>> ;
94 M: winnt seek-handle ( n seek-type handle -- )
96 { seek-absolute [ set-seek-ptr ] }
97 { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
98 { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
102 : file-error? ( n -- eof? )
105 { [ dup expected-io-error? ] [ drop f ] }
106 { [ dup eof? ] [ drop t ] }
107 [ n>win32-error-string throw ]
111 : wait-for-file ( FileArgs n port -- n )
113 [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
115 : update-file-ptr ( n port -- )
116 handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
118 : finish-write ( n port -- )
119 [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
121 M: winnt (wait-to-write)
123 [ make-FileArgs dup setup-write WriteFile ]
129 : finish-read ( n port -- )
130 [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
132 M: winnt (wait-to-read) ( port -- )
134 [ make-FileArgs dup setup-read ReadFile ]
140 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
145 [ null-reader null-writer null-writer set-stdio ] if ;