Windows I/O cleanups, fix accept on CE

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 -- )
 
 : <port> ( handle buffer -- port )
     over init-handle
@@ -29,7 +31,7 @@ GENERIC: init-handle ( handle -- )
     } port construct ;
 
 : <buffered-port> ( handle -- port )
-    default-buffer-size <buffer> <port> ;
+    default-buffer-size get <buffer> <port> ;
 
 : <reader> ( handle -- stream )
     <buffered-port> input over set-port-type <line-reader> ;
@@ -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 ;
 
 : <server-port> ( port addr -- server )

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 <write-task> 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 ( -- )

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 <win32-file> <reader>
+        r> f <win32-file> <writer>
+    ] with-variable <duplex-stream> stdio set ;

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 ;

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> WSAArgs
 
 : make-WSAArgs ( port -- <WSARecv> )
     [ port-handle win32-file-handle ] keep
-    delegate 1 "DWORD" <c-object> f f f <WSAArgs> ;
+    1 "DWORD" <c-object> f f f <WSAArgs> ;
 
 : setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
     [ WSAArgs-s ] keep
@@ -49,9 +50,9 @@ C: <WSAArgs> 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 <server> ( 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" <c-array> ] keep [
-            <int>
-            f 0
+        dup touch-port
+        dup port-handle win32-file-handle
+        swap server-port-addr sockaddr-type heap-size
+        dup <byte-array> [
+            swap <int> f 0
             windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET =
             [ windows.winsock:winsock-error ] when
         ] keep
@@ -143,10 +135,10 @@ M: windows-ce-io <datagram> ( 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" <c-object>
-        default-buffer-size over windows.winsock:set-WSABUF-len
-        default-buffer-size "char" <c-array> over windows.winsock:set-WSABUF-buf
+        default-buffer-size get over windows.winsock:set-WSABUF-len
+        default-buffer-size get <byte-array> over windows.winsock:set-WSABUF-buf
         [
             1
             0 <uint> [
@@ -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" <c-object>
     [ windows.winsock:set-WSABUF-len ] keep
     [ windows.winsock:set-WSABUF-buf ] keep

extra/io/windows/launcher/launcher.factor

@@ -83,8 +83,8 @@ C: <pipe> 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? ;

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> 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> 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> 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> 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 ;

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

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

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
     [ 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 <file-reader> ( path -- stream )
     open-read <win32-file> <reader> ;