Updating Windows I/O code

db4
U-SLAVA-DFB8FF805\Slava 2008-05-15 00:13:08 -05:00
parent 8f96e40c1c
commit 05466df1e0
9 changed files with 219 additions and 253 deletions

View File

@ -96,7 +96,7 @@ M: winnt link-info ( path -- info )
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing dup close-always
normalize-path open-existing &close-handle
"FILETIME" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
@ -112,7 +112,7 @@ M: winnt link-info ( path -- info )
#! timestamp order: creation access write
[
>r >r >r
normalize-path open-existing dup close-always
normalize-path open-existing &close-handle
r> r> r> (set-file-times)
] with-destructors ;
@ -128,6 +128,6 @@ M: winnt link-info ( path -- info )
M: winnt touch-file ( path -- )
[
normalize-path
maybe-create-file over close-always
maybe-create-file >r &close-handle r>
[ drop ] [ f now dup (set-file-times) ] if
] with-destructors ;

View File

@ -30,8 +30,8 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
: make-token-privileges ( name ? -- obj )
"TOKEN_PRIVILEGES" <c-object>
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
"LUID_AND_ATTRIBUTES" malloc-array
dup free-always over set-TOKEN_PRIVILEGES-Privileges
"LUID_AND_ATTRIBUTES" malloc-array &free
over set-TOKEN_PRIVILEGES-Privileges
swap [
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
@ -63,14 +63,12 @@ M: wince with-privileges
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r 0 open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
dup close-later
CreateFileMapping [ win32-error=0/f ] keep |close-handle
dup
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
dup close-later
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep |close-handle
] with-privileges ;
M: windows (mapped-file) ( path length -- mmap )
M: windows (mapped-file)
[
swap
GENERIC_WRITE GENERIC_READ bitor
@ -78,11 +76,11 @@ M: windows (mapped-file) ( path length -- mmap )
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
f \ mapped-file boa
] with-destructors ;
M: windows close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f
[ handle>> [ &close-handle drop ] each ]
[ address>> UnmapViewOfFile win32-error=0/f ]
bi
] with-destructors ;

View File

@ -14,11 +14,11 @@ TUPLE: io-callback port thread ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
"OVERLAPPED" malloc-object dup free-always ;
"OVERLAPPED" malloc-object &free ;
: make-overlapped ( port -- overlapped-ext )
>r (make-overlapped) r> port-handle win32-file-ptr
[ over set-OVERLAPPED-offset ] when* ;
>r (make-overlapped)
r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
: <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ;
@ -56,13 +56,22 @@ M: winnt add-completion ( handle -- )
io-hash get-global set-at
] "I/O" suspend 3drop ;
: wait-for-overlapped ( ms -- overlapped ? )
>r master-completion-port get-global
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[ save-callback ]
[ get-overlapped-result ]
[ nip pending-error ]
2tri ;
:: wait-for-overlapped ( ms -- overlapped ? )
master-completion-port get-global
r> INFINITE or ! timeout
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
[ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
[
ms INFINITE or ! timeout
GetQueuedCompletionStatus
] keep *void* swap zero? ;
: lookup-callback ( overlapped -- callback )
io-hash get-global delete-at* drop
@ -70,30 +79,23 @@ M: winnt add-completion ( handle -- )
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
GetLastError dup expected-io-error? [
2drop t
] [
dup eof? [
drop lookup-callback
dup port>> t >>eof drop
] [
(win32-error-string) swap lookup-callback
[ port>> set-port-error ] keep
] if thread>> resume f
GetLastError dup expected-io-error? [ 2drop f ] [
>r lookup-callback [ thread>> ] [ port>> ] bi r>
dup eof?
[ drop t >>eof drop ]
[ (win32-error-string) >>error drop ] if
thread>> resume t
] if
] [
lookup-callback
io-callback-thread resume f
thread>> resume t
] if ;
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
M: winnt cancel-io
handle>> handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- )
drain-overlapped ;
handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global

View File

@ -57,53 +57,39 @@ M: winnt open-append
>r (open-append) r> ;
: update-file-ptr ( n port -- )
port-handle
dup win32-file-ptr [
rot + swap set-win32-file-ptr
] [
2drop
] if* ;
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
: finish-flush ( overlapped port -- )
dup pending-error
tuck get-overlapped-result
dup pick update-file-ptr
swap buffer>> buffer-consume ;
: finish-flush ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
: (flush-output) ( port -- )
: ((wait-to-write)) ( port -- )
dup make-FileArgs
tuck setup-write WriteFile
dupd overlapped-error? [
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
>r lpOverlapped>> r>
[ twiddle-thumbs ] keep
[ finish-flush ] keep
dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
] [
2drop
] if ;
: flush-output ( port -- )
[ [ (flush-output) ] with-timeout ] with-destructors ;
M: winnt (wait-to-write)
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
M: winnt flush-port
dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
: finish-read ( overlapped port -- )
dup pending-error
tuck get-overlapped-result dup zero? [
drop t >>eof drop
: finish-read ( n port -- )
over zero? [
t >>eof 2drop
] [
dup pick buffer>> n>buffer
swap update-file-ptr
[ buffer>> n>buffer ] [ update-file-ptr ] bi
] if ;
: ((wait-to-read)) ( port -- )
dup make-FileArgs
tuck setup-read ReadFile
dupd overlapped-error? [
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
finish-read
>r lpOverlapped>> r>
[ twiddle-thumbs ] [ finish-read ] bi
] [ 2drop ] if ;
M: winnt (wait-to-read) ( port -- )

View File

@ -49,7 +49,7 @@ IN: io.windows.nt.launcher
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-always ;
CreateFile dup invalid-handle? &close-handle ;
: redirect-append ( default path access-mode create-mode -- handle )
>r >r path>> r> r>

View File

@ -19,7 +19,7 @@ IN: io.windows.nt.monitors
f
CreateFile
dup invalid-handle?
dup close-later
|close-handle
dup add-completion
f <win32-file> ;
@ -41,11 +41,7 @@ TUPLE: win32-monitor < monitor port ;
: read-changes ( port -- bytes )
[
dup begin-reading-changes
swap [ save-callback ] 2keep
check-closed ! we may have closed it...
dup eof>> [ "EOF??" throw ] when
get-overlapped-result
[ begin-reading-changes ] [ twiddle-thumbs ] bi
] with-destructors ;
: parse-action ( action -- changed )

View File

@ -47,7 +47,7 @@ IN: io.windows.nt.pipes
M: winnt (pipe) ( -- pipe )
[
unique-pipe-name
[ create-named-pipe dup close-later ]
[ open-other-end dup close-later ]
[ create-named-pipe |close-handle ]
[ open-other-end |close-handle ]
bi pipe boa
] with-destructors ;

View File

@ -30,114 +30,118 @@ TUPLE: ConnectEx-args port
s* name* namelen* lpSendBuffer* dwSendDataLength*
lpdwBytesSent* lpOverlapped* ptr* ;
: init-connect ( sockaddr size ConnectEx -- )
[ set-ConnectEx-args-namelen* ] keep
[ set-ConnectEx-args-name* ] keep
f over set-ConnectEx-args-lpSendBuffer*
0 over set-ConnectEx-args-dwSendDataLength*
f over set-ConnectEx-args-lpdwBytesSent*
(make-overlapped) swap set-ConnectEx-args-lpOverlapped* ;
: <ConnectEx-args> ( sockaddr size -- )
ConnectEx-args new
swap >>namelen*
swap >>name*
f >>lpSendBuffer*
0 >>dwSendDataLength*
f >>lpdwBytesSent*
(make-overlapped) >>lpOverlapped* ;
: (ConnectEx) ( ConnectEx -- )
\ ConnectEx-args >tuple*<
: call-ConnectEx ( ConnectEx -- )
ConnectEx-args >tuple*<
"int"
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
"stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ;
: connect-continuation ( overlapped port -- )
2dup save-callback
get-overlapped-result drop ;
: (wait-to-connect) ( client-out handle -- )
overlapped>> swap twiddle-thumbs drop ;
M: win32-socket wait-to-connect ( client-out handle -- )
[ overlapped>> swap connect-continuation ]
[ drop pending-error ]
2bi ;
: get-socket-name ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size
[ getsockname socket-error ] 2keep drop ;
M: win32-socket wait-to-connect ( client-out handle remote -- sockaddr )
[
[ drop (wait-to-connect) ]
[ get-socket-name nip ]
3bi
] keep parse-sockaddr ;
M: object ((client)) ( addrspec -- handle )
[
\ ConnectEx-args new
over make-sockaddr/size pick init-connect
over tcp-socket over set-ConnectEx-args-s*
dup ConnectEx-args-s* add-completion
dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
dup ConnectEx-args-s* INADDR_ANY roll bind-socket
dup (ConnectEx)
dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi <win32-socket>
] with-destructors ;
dup make-sockaddr/size <ConnectEx-args>
over tcp-socket >>s*
dup s*>> add-completion
dup s*>> get-ConnectEx-ptr >>ptr*
dup s*>> INADDR_ANY roll bind-socket
dup call-ConnectEx
dup [ s*>> ] [ lpOverlapped*>> ] bi <win32-socket> ;
TUPLE: AcceptEx-args port
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
: init-accept-buffer ( server-port AcceptEx -- )
>r server-port-addr sockaddr-type heap-size 16 +
dup dup 2 * malloc dup free-always r>
[ set-AcceptEx-args-lpOutputBuffer* ] keep
[ set-AcceptEx-args-dwLocalAddressLength* ] keep
set-AcceptEx-args-dwRemoteAddressLength* ;
swap addr>> sockaddr-type heap-size 16 +
[ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
drop ;
: init-accept ( server-port AcceptEx -- )
[ init-accept-buffer ] 2keep
[ set-AcceptEx-args-port ] 2keep
>r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep
dup AcceptEx-args-port server-port-addr tcp-socket
over set-AcceptEx-args-sAcceptSocket*
0 over set-AcceptEx-args-dwReceiveDataLength*
f over set-AcceptEx-args-lpdwBytesReceived*
(make-overlapped) swap set-AcceptEx-args-lpOverlapped* ;
: <AcceptEx-args> ( server-port -- AcceptEx )
AcceptEx-args new
2dup init-accept-buffer
over >>port
over handle>> handle>> >>sListenSocket*
over addr>> tcp-socket >>sAcceptSocket*
0 >>dwReceiveDataLength*
f >>lpdwBytesReceived*
(make-overlapped) >>lpOverlapped*
nip ;
: ((accept)) ( AcceptEx -- )
\ AcceptEx-args >tuple*<
: call-AcceptEx ( AcceptEx -- )
AcceptEx-args >tuple*<
AcceptEx drop
winsock-error-string [ throw ] when* ;
: make-accept-continuation ( AcceptEx -- )
dup AcceptEx-args-lpOverlapped*
swap AcceptEx-args-port save-callback ;
: check-accept-error ( AcceptEx -- )
dup AcceptEx-args-lpOverlapped*
swap AcceptEx-args-port get-overlapped-result drop ;
: extract-remote-host ( AcceptEx -- addrspec )
[
[ AcceptEx-args-lpOutputBuffer* ] keep
[ AcceptEx-args-dwReceiveDataLength* ] keep
[ AcceptEx-args-dwLocalAddressLength* ] keep
AcceptEx-args-dwRemoteAddressLength*
f <void*>
0 <int>
f <void*> [
0 <int> GetAcceptExSockaddrs
] keep *void*
] keep AcceptEx-args-port server-port-addr parse-sockaddr ;
{
[ lpOutputBuffer*>> ]
[ dwReceiveDataLength*>> ]
[ dwLocalAddressLength*>> ]
[ dwRemoteAddressLength*>> ]
} cleave
f <void*>
0 <int>
f <void*> [
0 <int> GetAcceptExSockaddrs
] keep *void* ;
: accept-continuation ( AcceptEx -- addrspec client )
[ make-accept-continuation ] keep
[ check-accept-error ] keep
[ extract-remote-host ] keep
! addrspec AcceptEx
[ AcceptEx-args-sAcceptSocket* add-completion ] keep
[ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi <win32-socket> ;
: finish-accept ( AcceptEx -- client sockaddr )
[ sAcceptSocket*>> add-completion ]
[ [ sAcceptSocket*>> ] [ lpOverlapped*>> ] bi <win32-socket> ]
[ extract-remote-host ]
tri ;
M: winnt (accept) ( server -- addrspec handle )
: wait-to-accept ( AcceptEx -- )
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ;
M: winnt (accept) ( server -- handle sockaddr )
[
[
\ AcceptEx-args new
[ init-accept ] keep
[ ((accept)) ] keep
[ accept-continuation ] keep
AcceptEx-args-port pending-error
<AcceptEx-args>
{
[ call-AcceptEx ]
[ wait-to-accept ]
[ finish-accept ]
[ port>> pending-error ]
} cleave
] with-timeout
] with-destructors ;
M: winnt (server) ( addrspec -- handle )
M: winnt (server) ( addrspec -- handle sockaddr )
[
SOCK_STREAM server-fd dup listen-on-socket
dup add-completion
f <win32-socket>
[ SOCK_STREAM server-fd ] keep
[
drop
[ listen-on-socket ]
[ add-completion ]
[ f <win32-socket> ]
tri
]
[ get-socket-name ]
2bi
] with-destructors ;
M: winnt (datagram) ( addrspec -- handle )
@ -152,53 +156,43 @@ TUPLE: WSARecvFrom-args port
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
: make-receive-buffer ( -- WSABUF )
"WSABUF" malloc-object dup free-always
"WSABUF" malloc-object &free
default-buffer-size get over set-WSABUF-len
default-buffer-size get malloc dup free-always over set-WSABUF-buf ;
default-buffer-size get malloc &free over set-WSABUF-buf ;
: init-WSARecvFrom ( datagram WSARecvFrom -- )
[ set-WSARecvFrom-args-port ] 2keep
[
>r handle>> handle>> r>
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
>r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
] keep
make-receive-buffer over set-WSARecvFrom-args-lpBuffers*
1 over set-WSARecvFrom-args-dwBufferCount*
0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
(make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ;
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom new
over >>port
over handle>> handle>> >>s*
swap addr>> sockaddr-type heap-size
[ malloc &free >>lpFrom* ]
[ malloc-int &free >>lpFromLen* ] bi
make-receive-buffer >>lpBuffers*
1 >>dwBufferCount*
0 malloc-int &free >>lpFlags*
0 malloc-int &free >>lpNumberOfBytesRecvd*
(make-overlapped) >>lpOverlapped* ;
: WSARecvFrom-continuation ( WSARecvFrom -- n )
dup WSARecvFrom-args-lpOverlapped*
swap WSARecvFrom-args-port [ save-callback ] 2keep
get-overlapped-result ;
: wait-to-receive ( WSARecvFrom -- n )
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
: call-WSARecvFrom ( WSARecvFrom -- )
\ WSARecvFrom-args >tuple*<
WSARecvFrom
socket-error* ;
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec )
[
WSARecvFrom-args-lpBuffers* WSABUF-buf
swap memory>byte-array
] keep
[ WSARecvFrom-args-lpFrom* ] keep
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
[ lpFrom*>> ]
bi ;
M: winnt receive ( datagram -- packet addrspec )
[
check-datagram-port
\ WSARecvFrom-args new
[ init-WSARecvFrom ] keep
[ call-WSARecvFrom ] keep
[ WSARecvFrom-continuation ] keep
[ WSARecvFrom-args-port pending-error ] keep
parse-WSARecvFrom
<WSARecvFrom-args>
{
[ call-WSARecvFrom ]
[ wait-to-receive ]
[ port>> pending-error ]
[ parse-WSARecvFrom ]
} cleave
] with-destructors ;
TUPLE: WSASendTo-args port
@ -206,49 +200,38 @@ TUPLE: WSASendTo-args port
dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
: make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object dup free-always
over malloc-byte-array dup free-always over set-WSABUF-buf
swap length over set-WSABUF-len ;
"WSABUF" malloc-object &free
[ >r malloc-byte-array &free r> set-WSABUF-buf ]
[ >r length r> set-WSABUF-len ]
[ nip ]
2tri ;
: init-WSASendTo ( packet addrspec datagram WSASendTo -- )
[ set-WSASendTo-args-port ] 2keep
[
>r port-handle win32-file-handle r> set-WSASendTo-args-s*
] keep
[
>r make-sockaddr/size >r
malloc-byte-array dup free-always
r> r>
[ set-WSASendTo-args-iToLen* ] keep
set-WSASendTo-args-lpTo*
] keep
[
>r make-send-buffer r> set-WSASendTo-args-lpBuffers*
] keep
1 over set-WSASendTo-args-dwBufferCount*
0 over set-WSASendTo-args-dwFlags*
0 <uint> over set-WSASendTo-args-lpNumberOfBytesSent*
(make-overlapped) swap set-WSASendTo-args-lpOverlapped* ;
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
over >>port
over handle>> handle>> >>s*
swap make-sockaddr/size
>r malloc-byte-array &free
r> [ >>lpTo* ] [ >>iToLen* ] bi*
swap make-send-buffer >>lpBuffers*
1 >>dwBufferCount*
0 >>dwFlags*
0 <uint> >>lpNumberOfBytesSent*
(make-overlapped) >>lpOverlapped* ;
: WSASendTo-continuation ( WSASendTo -- )
dup WSASendTo-args-lpOverlapped*
swap WSASendTo-args-port
[ save-callback ] 2keep
get-overlapped-result drop ;
: wait-to-send ( WSASendTo -- )
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ;
: call-WSASendTo ( WSASendTo -- )
\ WSASendTo-args >tuple*<
WSASendTo socket-error* ;
WSASendTo-args >tuple*< WSASendTo socket-error* ;
USE: io.sockets
M: winnt send ( packet addrspec datagram -- )
[
check-datagram-send
\ WSASendTo-args new
[ init-WSASendTo ] keep
[ call-WSASendTo ] keep
[ WSASendTo-continuation ] keep
WSASendTo-args-port pending-error
<WSASendTo-args>
[ call-WSASendTo ]
[ wait-to-send ]
[ port>> pending-error ]
tri
] with-destructors ;

View File

@ -8,8 +8,6 @@ windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
IN: io.windows
M: windows destruct-socket closesocket drop ;
TUPLE: win32-file handle ptr ;
C: <win32-file> win32-file
@ -41,7 +39,7 @@ M: win32-file init-handle ( handle -- )
drop ;
M: win32-file close-handle ( handle -- )
win32-file-handle close-handle ;
handle>> close-handle ;
M: alien close-handle ( handle -- )
CloseHandle drop ;
@ -51,7 +49,8 @@ M: alien close-handle ( handle -- )
[
>r >r share-mode security-attributes-inherit r> r>
CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup invalid-handle?
|close-handle
dup add-completion
] with-destructors ;
@ -101,26 +100,31 @@ TUPLE: FileArgs
C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep
[ buffer>> ] keep
[
buffer>> buffer-length
"DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ;
{
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
[ drop "DWORD" <c-object> ]
[ FileArgs-overlapped ]
} cleave <FileArgs> ;
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
[ FileArgs-hFile ] keep
[ FileArgs-lpBuffer buffer-end ] keep
[ FileArgs-lpBuffer buffer-capacity ] keep
[ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ;
{
[ hFile>> ]
[ lpBuffer>> buffer-end ]
[ lpBuffer>> buffer-capacity ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
[ FileArgs-hFile ] keep
[ FileArgs-lpBuffer buffer@ ] keep
[ FileArgs-lpBuffer buffer-length ] keep
[ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ;
{
[ hFile>> ]
[ lpBuffer>> buffer@ ]
[ lpBuffer>> buffer-length ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
M: windows (file-reader) ( path -- stream )
open-read <win32-file> <input-port> ;
@ -179,17 +183,14 @@ TUPLE: socket-destructor alien ;
C: <socket-destructor> socket-destructor
HOOK: destruct-socket io-backend ( obj -- )
M: socket-destructor dispose ( obj -- )
alien>> destruct-socket ;
alien>> closesocket drop ;
: close-socket-later ( handle -- )
<socket-destructor> <only-once> add-error-destructor ;
: |close-socket ( handle -- handle )
dup <socket-destructor> <only-once> |dispose drop ;
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket
dup close-socket-later
>r dup protocol-family r> open-socket |close-socket
dup rot make-sockaddr/size bind socket-error ;
USE: namespaces
@ -202,7 +203,7 @@ USE: namespaces
listen-backlog listen winsock-return-check ;
M: win32-socket dispose ( stream -- )
win32-file-handle closesocket drop ;
handle>> closesocket drop ;
M: windows addrinfo-error ( n -- )
winsock-return-check ;