steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/io/windows/files/files.factor
View File

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

18
extra/io/windows/mmap/mmap.factor
View File

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

44
extra/io/windows/nt/backend/backend.factor
View File

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

44
extra/io/windows/nt/files/files.factor
View File

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

2
extra/io/windows/nt/launcher/launcher.factor
View File

@ -49,7 +49,7 @@ IN: io.windows.nt.launcher
create-mode create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file 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 ) : redirect-append ( default path access-mode create-mode -- handle )
>r >r path>> r> r> >r >r path>> r> r>

8
extra/io/windows/nt/monitors/monitors.factor
View File

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

4
extra/io/windows/nt/pipes/pipes.factor
View File

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

289
extra/io/windows/nt/sockets/sockets.factor
View File

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

57
extra/io/windows/windows.factor
View File

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