diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor old mode 100644 new mode 100755 index 6741732cc4..7231bb6402 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2007 Slava Pestov, Doug Coleman +! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers generic sbufs system io.streams.lines io.streams.plain io.streams.duplex -continuations debugger classes byte-arrays ; +continuations debugger classes byte-arrays namespaces ; -: default-buffer-size 64 1024 * ; inline +SYMBOL: default-buffer-size +64 1024 * default-buffer-size set-global ! Common delegate of native stream readers and writers TUPLE: port handle error timeout cutoff type eof? ; @@ -18,6 +19,7 @@ PREDICATE: port input-port port-type input eq? ; PREDICATE: port output-port port-type output eq? ; GENERIC: init-handle ( handle -- ) +GENERIC: close-handle ( handle -- ) : ( handle buffer -- port ) over init-handle @@ -29,7 +31,7 @@ GENERIC: init-handle ( handle -- ) } port construct ; : ( handle -- port ) - default-buffer-size ; + default-buffer-size get ; : ( handle -- stream ) input over set-port-type ; @@ -150,6 +152,20 @@ M: output-port stream-write1 M: output-port stream-write over length over wait-to-write >buffer ; +GENERIC: port-flush ( port -- ) + +M: output-port stream-flush ( port -- ) + dup port-flush pending-error ; + +M: port stream-close + dup port-type closed eq? [ + dup port-type >r closed over set-port-type r> + output eq? [ dup port-flush ] when + dup port-handle close-handle + dup delegate [ buffer-free ] when* + f over set-delegate + ] unless drop ; + TUPLE: server-port addr client ; : ( port addr -- server ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100644 new mode 100755 index a0d8658661..486fe46866 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -34,6 +34,9 @@ M: integer init-handle ( fd -- ) #! 1 are closed). F_SETFL O_NONBLOCK fcntl drop ; +M: integer close-handle ( fd -- ) + close ; + : report-error ( error port -- ) [ "Error on fd " % dup port-handle # ": " % swap % ] "" make swap set-port-error ; @@ -168,21 +171,9 @@ M: write-task task-container drop write-tasks get-global ; : (wait-to-write) ( port -- ) [ swap add-write-io-task stop ] callcc0 drop ; -: port-flush ( port -- ) +M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -M: output-port stream-flush - dup port-flush pending-error ; - -M: port stream-close - dup port-type closed eq? [ - dup port-type >r closed over set-port-type r> - output eq? [ dup port-flush ] when - dup port-handle close - dup delegate [ buffer-free ] when* - f over set-delegate - ] unless drop ; - USE: io M: unix-io init-io ( -- ) diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index f367296ea7..37eb161ff8 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,5 +1,6 @@ USING: io.nonblocking io.windows threads.private kernel -io.backend windows.winsock windows ; +io.backend windows.winsock windows.kernel32 windows +io.streams.duplex io namespaces alien.syntax system combinators ; IN: io.windows.ce.backend : port-errored ( port -- ) @@ -20,3 +21,22 @@ M: windows-ce-io flush-output ( port -- ) M: windows-ce-io init-io ( -- ) init-winsock ; + +LIBRARY: libc +FUNCTION: void* _getstdfilex int fd ; +FUNCTION: void* _fileno void* file ; + +M: windows-ce-io init-stdio ( -- ) + #! We support Windows NT too, to make this I/O backend + #! easier to debug. + 4096 default-buffer-size [ + winnt? [ + STD_INPUT_HANDLE GetStdHandle + STD_OUTPUT_HANDLE GetStdHandle + ] [ + 0 _getstdfilex _fileno + 1 _getstdfilex _fileno + ] if + >r f + r> f + ] with-variable stdio set ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index ea00b0248c..277641a78a 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -14,23 +14,15 @@ M: win32-file wince-read drop dup make-FileArgs dup setup-read ReadFile zero? [ drop port-errored ] [ - FileArgs-lpNumberOfBytesRet *uint dup zero? [ - drop - t swap set-port-eof? - ] [ - swap n>buffer - ] if + FileArgs-lpNumberOfBytesRet *uint dup zero? + [ drop t swap set-port-eof? ] [ swap n>buffer ] if ] if ; M: win32-file wince-write ( port port-handle -- ) drop dup make-FileArgs dup setup-write WriteFile zero? [ drop port-errored ] [ - FileArgs-lpNumberOfBytesRet *uint ! *DWORD - over delegate [ buffer-consume ] keep - buffer-length 0 > [ - flush-output - ] [ - drop - ] if + FileArgs-lpNumberOfBytesRet *uint + over buffer-consume + port-flush ] if ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index e592d75ae0..8fd1bc5fea 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -1,7 +1,8 @@ USING: alien alien.c-types combinators io io.backend io.buffers io.nonblocking io.sockets io.sockets.impl io.windows kernel libc math namespaces prettyprint qualified sequences strings threads -threads.private windows windows.kernel32 io.windows.ce.backend ; +threads.private windows windows.kernel32 io.windows.ce.backend +byte-arrays ; QUALIFIED: windows.winsock IN: io.windows.ce @@ -19,7 +20,7 @@ C: WSAArgs : make-WSAArgs ( port -- ) [ port-handle win32-file-handle ] keep - delegate 1 "DWORD" f f f ; + 1 "DWORD" f f f ; : setup-WSARecv ( -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine ) [ WSAArgs-s ] keep @@ -49,9 +50,9 @@ C: WSAArgs ! ] if ; M: win32-socket wince-read ( port port-handle -- ) - win32-file-handle over - delegate [ buffer-end ] keep buffer-capacity 0 - windows.winsock:recv dup windows.winsock:SOCKET_ERROR = [ + win32-file-handle over buffer-end pick buffer-capacity 0 + windows.winsock:recv + dup windows.winsock:SOCKET_ERROR = [ drop port-errored ] [ dup zero? [ @@ -91,18 +92,10 @@ M: win32-socket wince-read ( port port-handle -- ) ! ] if ; M: win32-socket wince-write ( port port-handle -- ) - win32-file-handle over - delegate [ buffer@ ] keep - buffer-length 0 windows.winsock:send dup windows.winsock:SOCKET_ERROR = [ - drop port-errored - ] [ - over delegate [ buffer-consume ] keep - buffer-length 0 > [ - flush-output - ] [ - drop - ] if - ] if ; + win32-file-handle over buffer@ pick buffer-length 0 + windows.winsock:send + dup windows.winsock:SOCKET_ERROR = + [ drop port-errored ] [ over buffer-consume port-flush ] if ; : do-connect ( addrspec -- socket ) [ tcp-socket dup ] keep @@ -123,12 +116,11 @@ M: windows-ce-io ( addrspec -- duplex-stream ) M: windows-ce-io accept ( server -- client ) dup check-server-port [ - [ touch-port ] keep - [ port-handle win32-file-handle ] keep - server-port-addr sockaddr-type heap-size - [ "char" ] keep [ - - f 0 + dup touch-port + dup port-handle win32-file-handle + swap server-port-addr sockaddr-type heap-size + dup [ + swap f 0 windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET = [ windows.winsock:winsock-error ] when ] keep @@ -143,10 +135,10 @@ M: windows-ce-io ( addrspec -- datagram ) M: windows-ce-io receive ( datagram -- packet addrspec ) dup check-datagram-port [ - port-handle delegate win32-file-handle + port-handle win32-file-handle "WSABUF" - default-buffer-size over windows.winsock:set-WSABUF-len - default-buffer-size "char" over windows.winsock:set-WSABUF-buf + default-buffer-size get over windows.winsock:set-WSABUF-len + default-buffer-size get over windows.winsock:set-WSABUF-buf [ 1 0 [ @@ -167,7 +159,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec ) M: windows-ce-io send ( packet addrspec datagram -- ) 3dup check-datagram-send - delegate port-handle delegate win32-file-handle + port-handle win32-file-handle rot dup length "WSABUF" [ windows.winsock:set-WSABUF-len ] keep [ windows.winsock:set-WSABUF-buf ] keep diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index a67aa96ce8..037253db11 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -83,8 +83,8 @@ C: pipe PIPE_ACCESS_DUPLEX FILE_FLAG_OVERLAPPED bitor PIPE_TYPE_BYTE PIPE_READMODE_BYTE PIPE_NOWAIT bitor bitor PIPE_UNLIMITED_INSTANCES - default-buffer-size - default-buffer-size + default-buffer-size get + default-buffer-size get 0 security-attributes-inherit CreateNamedPipe dup invalid-handle? ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 0cbdabfa1e..16e01b6103 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,13 +1,10 @@ -USING: alien alien.c-types arrays assocs combinators continuations -destructors io io.backend io.nonblocking io.windows libc -kernel math namespaces sequences threads tuples.lib windows -windows.errors windows.kernel32 prettyprint strings splitting -io.files windows.winsock ; +USING: alien alien.c-types arrays assocs combinators +continuations destructors io io.backend io.nonblocking +io.windows libc kernel math namespaces sequences threads +tuples.lib windows windows.errors windows.kernel32 strings +splitting io.files windows.winsock ; IN: io.windows.nt.backend -: .. global [ . flush ] bind ; -: .S global [ .s flush ] bind ; - : unicode-prefix ( -- seq ) "\\\\?\\" ; inline @@ -51,6 +48,12 @@ C: io-callback >r (make-overlapped) r> port-handle win32-file-ptr [ over set-OVERLAPPED-offset ] when* ; +: port-overlapped ( port -- overlapped ) + port-handle win32-file-overlapped ; + +: set-port-overlapped ( overlapped port -- ) + port-handle set-win32-file-overlapped ; + : completion-port ( handle existing -- handle ) f 1 CreateIoCompletionPort dup win32-error=0/f ; @@ -75,7 +78,7 @@ C: GetOverlappedResult-args : (save-callback) ( io-callback -- ) dup io-callback-port port-handle win32-file-overlapped - \ io-hash get-global set-at ; + io-hash get-global set-at ; : save-callback ( port -- ) [ @@ -95,7 +98,7 @@ C: GetQueuedCompletionStatusParams : lookup-callback ( GetQueuedCompletion-args -- callback ) GetQueuedCompletionStatusParams-lpOverlapped* *void* - \ io-hash get-global delete-at* drop ; + io-hash get-global delete-at* drop ; : wait-for-io ( timeout -- continuation/f ) wait-for-overlapped @@ -125,19 +128,17 @@ C: GetQueuedCompletionStatusParams drop ] if ; -: cancel-timedout ( -- ) +: cancel-timeout ( -- ) io-hash get-global values [ maybe-expire ] each ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timedout - [ wait-for-io ] [ global [ "error: " write . flush ] bind drop f ] recover - [ schedule-thread ] when* ; + cancel-timeout wait-for-io [ schedule-thread ] when* ; M: windows-nt-io init-io ( -- ) #! Should only be called on startup. Calling this at any #! other time can have unintended consequences. global [ master-completion-port \ master-completion-port set - H{ } clone \ io-hash set + H{ } clone io-hash set init-winsock ] bind ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor old mode 100644 new mode 100755 index 791b03ab5e..530bc14c3a --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -17,26 +17,24 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) 2drop ] if* ; -DEFER: (flush-output) : finish-flush ( port -- ) dup pending-error dup get-overlapped-result - [ over update-file-ptr ] keep - over delegate [ buffer-consume ] keep - buffer-length 0 > [ - (flush-output) - ] [ - drop - ] if ; + dup pick update-file-ptr + swap buffer-consume ; + +: save-overlapped-and-callback ( fileargs port -- ) + swap FileArgs-lpOverlapped over set-port-overlapped + save-callback ; : (flush-output) ( port -- ) dup touch-port dup make-FileArgs - [ setup-write WriteFile ] keep - >r dupd overlapped-error? r> swap [ - FileArgs-lpOverlapped over set-port-overlapped - dup save-callback - finish-flush + tuck setup-write WriteFile + dupd overlapped-error? [ + [ save-overlapped-and-callback ] keep + [ finish-flush ] keep + dup buffer-empty? [ drop ] [ (flush-output) ] if ] [ 2drop ] if ; @@ -49,17 +47,16 @@ M: windows-nt-io flush-output ( port -- ) dup get-overlapped-result dup zero? [ drop t swap set-port-eof? ] [ - [ over n>buffer ] keep + dup pick n>buffer swap update-file-ptr ] if ; : ((wait-to-read)) ( port -- ) dup touch-port dup make-FileArgs - [ setup-read ReadFile ] keep - >r dupd overlapped-error? r> swap [ - FileArgs-lpOverlapped over set-port-overlapped - dup save-callback + tuck setup-read ReadFile + dupd overlapped-error? [ + [ save-overlapped-and-callback ] keep finish-read ] [ 2drop diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 1b6288eb1d..74538ac06a 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -178,7 +178,7 @@ TUPLE: WSARecvFrom-args port ] keep "WSABUF" malloc-object dup free-always 2dup swap set-WSARecvFrom-args-lpBuffers* - default-buffer-size [ malloc dup free-always ] keep + default-buffer-size get [ malloc dup free-always ] keep pick set-WSABUF-len swap set-WSABUF-buf 1 over set-WSARecvFrom-args-dwBufferCount* @@ -256,6 +256,8 @@ TUPLE: WSASendTo-args port \ WSASendTo-args >tuple*< WSASendTo socket-error* ; +USE: io.sockets + M: windows-nt-io send ( packet addrspec datagram -- ) [ 3dup check-datagram-send diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor old mode 100644 new mode 100755 index 8d6d7cb6f2..894874a60b --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -31,12 +31,6 @@ TUPLE: win32-file handle ptr overlapped ; { set-win32-file-handle set-win32-file-ptr } \ win32-file construct ; -: set-port-overlapped ( overlapped port -- ) - port-handle set-win32-file-overlapped ; - -: port-overlapped ( port -- overlapped ) - port-handle win32-file-overlapped ; - HOOK: CreateFile-flags io-backend ( -- DWORD ) HOOK: flush-output io-backend ( port -- ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) @@ -48,7 +42,14 @@ M: windows-io normalize-directory ( string -- string ) : share-mode ( -- fixnum ) FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline -M: win32-file init-handle ( handle -- ) drop ; +M: win32-file init-handle ( handle -- ) + drop ; + +M: win32-file close-handle ( handle -- ) + win32-file-handle CloseHandle drop ; + +M: port port-flush + dup buffer-empty? [ dup flush-output ] unless drop ; ! Clean up resources (open handle) if add-completion fails : open-file ( path access-mode create-mode -- handle ) @@ -101,27 +102,6 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: output-port stream-flush ( port -- ) - dup buffer-empty? [ - dup flush-output - ] unless pending-error ; - -M: port stream-close ( port -- ) - dup port-type closed = [ - drop - ] [ - ! For duplex-streams, we call CloseHandle twice on the same handle - [ dup port-type output = [ stream-flush ] [ drop ] if ] keep - [ closed swap set-port-type ] keep - [ port-handle win32-file-handle CloseHandle drop ] keep - USE: namespaces - [ delegate [ buffer-free ] [ - global [ "delegate was empty!!" print flush ] bind - USE: windows.winsock.private - ] if* ] keep - f swap set-delegate - ] if ; - M: windows-io ( path -- stream ) open-read ;