diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index d83c789d36..520a5dff48 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -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" "FILETIME" "FILETIME" @@ -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 ; diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index b401ed5556..d9944b8510 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -30,8 +30,8 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES : make-token-privileges ( name ? -- obj ) "TOKEN_PRIVILEGES" 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 ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 99364f832d..bd2b03aad8 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -14,11 +14,11 @@ TUPLE: io-callback port thread ; C: 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* ; : ( 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 ! bytes f ! key f ! 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 set-global diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 2b3021a3f1..08926cb4f7 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -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 -- ) diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index c18523e68d..61ff65fe08 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -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> diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index ee8c6c60e1..88f082625e 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -19,7 +19,7 @@ IN: io.windows.nt.monitors f CreateFile dup invalid-handle? - dup close-later + |close-handle dup add-completion f ; @@ -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 ) diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 8a0fa05b74..3fd37d6bc3 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -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 ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 5baa0a31e5..657551cdac 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -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* ; +: ( 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 - ] with-destructors ; + dup make-sockaddr/size + 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 ; 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* ; +: ( 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 - 0 - f [ - 0 GetAcceptExSockaddrs - ] keep *void* - ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; + { + [ lpOutputBuffer*>> ] + [ dwReceiveDataLength*>> ] + [ dwLocalAddressLength*>> ] + [ dwRemoteAddressLength*>> ] + } cleave + f + 0 + f [ + 0 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 ; +: finish-accept ( AcceptEx -- client sockaddr ) + [ sAcceptSocket*>> add-completion ] + [ [ sAcceptSocket*>> ] [ lpOverlapped*>> ] bi ] + [ 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 + + { + [ 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 + [ SOCK_STREAM server-fd ] keep + [ + drop + [ listen-on-socket ] + [ add-completion ] + [ f ] + 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* ; +: ( 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 + + { + [ 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 over set-WSASendTo-args-lpNumberOfBytesSent* - (make-overlapped) swap set-WSASendTo-args-lpOverlapped* ; +: ( 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 >>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 + + [ call-WSASendTo ] + [ wait-to-send ] + [ port>> pending-error ] + tri ] with-destructors ; - diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 5c0a1c8ecf..5b205d0dca 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -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 @@ -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 : make-FileArgs ( port -- ) - [ port-handle win32-file-handle ] keep - [ buffer>> ] keep - [ - buffer>> buffer-length - "DWORD" - ] keep FileArgs-overlapped ; + { + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop "DWORD" ] + [ FileArgs-overlapped ] + } cleave ; : setup-read ( -- 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 ( -- 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 ; @@ -179,17 +183,14 @@ TUPLE: socket-destructor alien ; C: socket-destructor -HOOK: destruct-socket io-backend ( obj -- ) - M: socket-destructor dispose ( obj -- ) - alien>> destruct-socket ; + alien>> closesocket drop ; -: close-socket-later ( handle -- ) - add-error-destructor ; +: |close-socket ( handle -- handle ) + dup |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 ;