Updating Windows I/O code
U-SLAVA-DFB8FF805\Slava
parent
8f96e40c1c
commit
05466df1e0
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue