Windows IO fixes and <process-stream> work

extra/io/launcher/launcher.factor

@@ -59,3 +59,4 @@ HOOK: process-stream* io-backend ( desc -- stream )
 
 USE-IF: unix? io.unix.launcher
 USE-IF: windows? io.windows.launcher
+USE-IF: winnt? io.windows.nt.launcher

extra/io/windows/ce/backend/backend.factor

@@ -13,7 +13,7 @@ M: windows-ce-io add-completion ( port -- ) drop ;
 GENERIC: wince-read ( port port-handle -- )
 
 M: input-port (wait-to-read) ( port -- )
-    dup port-handle wince-read ;
+    dup dup port-handle wince-read pending-error ;
 
 GENERIC: wince-write ( port port-handle -- )
 
@@ -41,7 +41,5 @@ M: windows-ce-io init-stdio ( -- )
         ] [
             0 _getstdfilex _fileno
             1 _getstdfilex _fileno
-        ] if
+        ] if <win32-duplex-stream>
-        >r f <win32-file> <reader>
+    ] with-variable stdio set ;
-        r> f <win32-file> <writer>
-    ] with-variable <duplex-stream> stdio set ;

extra/io/windows/ce/files/files.factor

@@ -10,12 +10,16 @@ IN: windows.ce.files
 M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
 M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
 
+: finish-read ( port status bytes-ret -- )
+    swap [ drop port-errored ] [ swap n>buffer ] if ;
+
 M: win32-file wince-read
-    drop dup make-FileArgs dup setup-read ReadFile zero? [
+    drop
-        drop port-errored
+    dup make-FileArgs dup setup-read ReadFile zero?
+    swap FileArgs-lpNumberOfBytesRet *uint dup zero? [
+        2drop t swap set-port-eof?
     ] [
-        FileArgs-lpNumberOfBytesRet *uint dup zero?
+        finish-read
-        [ drop t swap set-port-eof? ] [ swap n>buffer ] if
     ] if ;
 
 M: win32-file wince-write ( port port-handle -- )

extra/io/windows/launcher/launcher.factor

@@ -1,11 +1,11 @@
+! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system ;
 IN: io.windows.launcher
 
-! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
-
 TUPLE: CreateProcess-args
        lpApplicationName
        lpCommandLine
@@ -20,6 +20,8 @@ TUPLE: CreateProcess-args
        stdout-pipe stdin-pipe ;
 
 : dispose-CreateProcess-args ( args -- )
+    #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
+    #! with CloseHandle when they are no longer needed."
     CreateProcess-args-lpProcessInformation dup
     PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
     PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
@@ -75,7 +77,7 @@ TUPLE: CreateProcess-args
 : fill-dwCreateFlags
     0
     pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
-    +detached+ get [ DETACHED_PROCESS bitor ] when
+    +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when
     over set-CreateProcess-args-dwCreateFlags ;
 
 : fill-lpEnvironment
@@ -93,137 +95,16 @@ TUPLE: CreateProcess-args
     PROCESS_INFORMATION-hProcess INFINITE
     WaitForSingleObject drop ;
 
+: make-CreateProcess-args ( -- args )
+    default-CreateProcess-args
+    wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+    fill-dwCreateFlags
+    fill-lpEnvironment ;
+
 M: windows-io run-process* ( desc -- )
     [
-        default-CreateProcess-args
+        make-CreateProcess-args
-        wince? [
-            fill-lpApplicationName
-        ] [
-            fill-lpCommandLine
-        ] if
-        fill-dwCreateFlags
-        fill-lpEnvironment
         dup call-CreateProcess
         +detached+ get [ dup wait-for-process ] unless
         dispose-CreateProcess-args
     ] with-descriptor ;
-
-! : default-security-attributes ( -- obj )
-!     "SECURITY_ATTRIBUTES" <c-object>
-!     "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
-!
-! : security-attributes-inherit ( -- obj )
-!     default-security-attributes
-!     TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ;
-!
-! : set-inherit ( handle ? -- )
-!     >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
-!
-! ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
-!
-! TUPLE: pipe hRead hWrite ;
-!
-! C: <pipe> pipe
-!
-! : factor-pipe-name
-!     "\\\\.\\pipe\\Factor" ;
-!
-! : create-named-pipe ( str -- handle )
-!     PIPE_ACCESS_DUPLEX FILE_FLAG_OVERLAPPED bitor
-!     PIPE_TYPE_BYTE PIPE_READMODE_BYTE PIPE_NOWAIT bitor bitor
-!     PIPE_UNLIMITED_INSTANCES
-!     default-buffer-size get
-!     default-buffer-size get
-!     0
-!     security-attributes-inherit
-!     CreateNamedPipe dup invalid-handle? ;
-!
-! : ERROR_PIPE_CONNECT 535 ; inline
-!
-! : pipe-connect-error? ( n -- ? )
-!     ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
-!
-! clear "ls" <process-stream> contents
-! M: windows-nt-io <process-stream> ( command -- stream )
-!     [
-!         [
-!             default-CreateProcess-args
-!             fill-lpCommandLine
-!             TRUE over set-CreateProcess-args-bInheritHandles
-!
-!             dup CreateProcess-args-lpStartupInfo
-!             STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
-!
-!             factor-pipe-name create-named-pipe
-!             global [ "Named pipe: " write dup . ] bind
-!             dup t set-inherit
-!             [ add-completion ] keep
-!
-!             ! CreateFile
-!             ! factor-pipe-name open-pipe-r/w
-!             factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
-!             0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
-!             CreateFile
-!             global [ "Created File: " write dup . ] bind
-!             dup invalid-handle? dup close-later
-!             dup add-completion
-!
-!             swap (make-overlapped) ConnectNamedPipe zero? [
-!                 GetLastError pipe-connect-error? [
-!                     win32-error-string throw
-!                 ] when
-!             ] when
-!             dup t set-inherit
-!
-!             ! ERROR_PIPE_CONNECTED
-!             [ pick set-CreateProcess-args-stdin-pipe ] keep
-!             global [ "Setting the stdios to: " write dup . ] bind
-!             [ over set-STARTUPINFO-hStdOutput ] keep
-!             [ over set-STARTUPINFO-hStdInput ] keep
-!             swap set-STARTUPINFO-hStdError
-!             !
-!             [ call-CreateProcess ] keep
-!             [ CreateProcess-args-stdin-pipe f <win32-file> dup handle>duplex-stream ] keep
-!             drop ! TODO: close handles instead of drop
-!         ] with-destructors
-!     ] with-descriptor ;
-!
-! : create-pipe ( -- pipe )
-!     "HANDLE" <c-object>
-!     "HANDLE" <c-object>
-!     [
-!         security-attributes-inherit
-!         0
-!         CreatePipe win32-error=0/f
-!     ] 2keep
-!     [ *void* dup close-later ] 2apply <pipe> ;
-!
-! M: windows-ce-io process-stream*
-!     [
-!         default-CreateProcess-args
-!         TRUE over set-CreateProcess-args-bInheritHandles
-!
-!         create-pipe  ! for child's STDOUT
-!         dup pipe-hRead f set-inherit
-!         over set-CreateProcess-args-stdout-pipe
-!
-!         create-pipe  ! for child's STDIN
-!         dup pipe-hWrite f set-inherit
-!         over set-CreateProcess-args-stdin-pipe
-!
-!         dup CreateProcess-args-lpStartupInfo
-!         STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
-!
-!         over CreateProcess-args-stdout-pipe
-!             pipe-hWrite over set-STARTUPINFO-hStdOutput
-!         over CreateProcess-args-stdout-pipe
-!             pipe-hWrite over set-STARTUPINFO-hStdError
-!         over CreateProcess-args-stdin-pipe
-!             pipe-hRead swap set-STARTUPINFO-hStdInput
-!
-!         [ call-CreateProcess ] keep
-!         [ CreateProcess-args-stdin-pipe pipe-hRead f <win32-file> <reader> ] keep
-!         [ CreateProcess-args-stdout-pipe pipe-hWrite f <win32-file> <writer> <duplex-stream> ] keep
-!         drop ! TODO: close handles instead of drop
-!     ] with-destructors ;
-!

extra/io/windows/mmap/mmap.factor

@@ -78,7 +78,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
         PAGE_READWRITE SEC_COMMIT bitor
         FILE_MAP_ALL_ACCESS mmap-open
         -rot 2array
-        \ mapped-file construct-boa
+        f \ mapped-file construct-boa
     ] with-destructors ;
 
 M: windows-io (close-mapped-file) ( mapped-file -- )

extra/io/windows/nt/backend/backend.factor

@@ -42,7 +42,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
 
 SYMBOL: io-hash
 
-TUPLE: io-callback port continuation ;
+TUPLE: io-callback continuation port ;
+
 C: <io-callback> io-callback
 
 : (make-overlapped) ( -- overlapped-ext )
@@ -74,53 +75,55 @@ SYMBOL: master-completion-port
 M: windows-nt-io add-completion ( handle -- )
     master-completion-port get-global <completion-port> drop ;
 
-TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ;
+: eof? ( error -- ? )
+    dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
 
-C: <GetOverlappedResult-args> GetOverlappedResult-args
+: overlapped-error? ( port n -- ? )
+    zero? [
+        GetLastError {
+            { [ dup expected-io-error? ] [ 2drop t ] }
+            { [ dup eof? ] [ drop t swap set-port-eof? f ] }
+            { [ t ] [ (win32-error-string) throw ] }
+        } cond
+    ] [
+        drop t
+    ] if ;
 
-: get-overlapped-result ( port -- n )
+: get-overlapped-result ( port -- bytes-transferred )
-    [
+    dup
-        port-handle dup win32-file-handle
+    port-handle
-        swap win32-file-overlapped 0 <int> 0
+    dup win32-file-handle
-    ] keep <GetOverlappedResult-args> [
+    swap win32-file-overlapped
-        \ GetOverlappedResult-args >tuple<
+    0 <uint> [
-        >r GetOverlappedResult r> swap overlapped-error? drop
+        0
-    ] keep GetOverlappedResult-args-lpNumberOfBytesTransferred* *int ;
+        GetOverlappedResult overlapped-error? drop
-
+    ] keep *uint ;
-: (save-callback) ( io-callback -- )
-    dup io-callback-port port-handle win32-file-overlapped
-    io-hash get-global set-at ;
 
 : save-callback ( port -- )
     [
-        <io-callback> (save-callback) stop
+        [ <io-callback> ] keep port-handle win32-file-overlapped
-    ] callcc0 drop ;
+        io-hash get-global set-at stop
+    ] curry callcc0 ;
 
-TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ;
+: wait-for-overlapped ( ms -- overlapped ? )
-
+    >r master-completion-port get-global r> ! port ms
-C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
+    0 <int> ! bytes
-
+    f <void*> ! key
-: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret )
+    f <void*> ! overlapped
-    >r master-completion-port get-global 0 <int> 0 <int> 0 <int>
+    [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
-    r> <GetQueuedCompletionStatusParams> [
-        GetQueuedCompletionStatusParams >tuple*<
-        GetQueuedCompletionStatus
-    ] keep swap ;
 
 : lookup-callback ( GetQueuedCompletion-args -- callback )
-    GetQueuedCompletionStatusParams-lpOverlapped* *void*
     io-hash get-global delete-at* drop ;
 
 : wait-for-io ( timeout -- continuation/f )
-    wait-for-overlapped
+    wait-for-overlapped [
-    zero? [
+        GetLastError dup expected-io-error? [
-        GetLastError dup (expected-io-error?) [
             2drop f
         ] [
-            dup ERROR_HANDLE_EOF = [
+            dup eof? [
-                drop lookup-callback [
+                drop lookup-callback
-                    io-callback-port t swap set-port-eof?
+                dup io-callback-port t swap set-port-eof?
-                ] keep io-callback-continuation
+                io-callback-continuation
             ] [
                 (win32-error-string) swap lookup-callback
                 [ io-callback-port set-port-error ] keep
@@ -146,10 +149,6 @@ M: windows-nt-io io-multiplex ( ms -- )
     cancel-timeout wait-for-io [ schedule-thread ] when* ;
 
 M: windows-nt-io init-io ( -- )
-    #! Should only be called on startup. Calling this at any
+    <master-completion-port> master-completion-port set-global
-    #! other time can have unintended consequences.
+    H{ } clone io-hash set-global
-    global [
+    windows.winsock:init-winsock ;
-        <master-completion-port> master-completion-port set
-        H{ } clone io-hash set
-        windows.winsock:init-winsock
-    ] bind ;

extra/io/windows/nt/launcher/launcher.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays continuations destructors io
+io.windows libc io.nonblocking io.streams.duplex windows.types
+math windows.kernel32 windows namespaces io.launcher kernel
+sequences windows.errors assocs splitting system
+io.windows.launcher io.windows.nt.pipes ;
+IN: io.windows.nt.launcher
+
+! The below code is based on the example given in
+! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
+
+: set-inherit ( handle ? -- )
+    >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
+
+: add-pipe-dtors ( pipe -- )
+    dup
+    pipe-in close-later
+    pipe-out close-later ;
+
+: fill-stdout-pipe
+    <unique-incoming-pipe>
+    dup add-pipe-dtors
+    dup pipe-in f set-inherit
+    over set-CreateProcess-args-stdout-pipe ;
+
+: fill-stdin-pipe
+    <unique-outgoing-pipe>
+    dup add-pipe-dtors
+    dup pipe-out f set-inherit
+    over set-CreateProcess-args-stdin-pipe ;
+
+: fill-startup-info
+    dup CreateProcess-args-lpStartupInfo
+    STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
+
+    over CreateProcess-args-stdout-pipe
+        pipe-out over set-STARTUPINFO-hStdOutput
+    over CreateProcess-args-stdout-pipe
+        pipe-out over set-STARTUPINFO-hStdError
+    over CreateProcess-args-stdin-pipe
+        pipe-in swap set-STARTUPINFO-hStdInput ;
+
+M: windows-io process-stream*
+    [
+        [
+            make-CreateProcess-args
+            TRUE over set-CreateProcess-args-bInheritHandles
+
+            fill-stdout-pipe
+            fill-stdin-pipe
+            fill-startup-info
+
+            dup call-CreateProcess
+
+            dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
+            dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
+
+            dup CreateProcess-args-stdout-pipe pipe-in
+            over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
+
+            swap dispose-CreateProcess-args
+        ] with-destructors
+    ] with-descriptor ;

extra/io/windows/nt/pipes/pipes.factor

@@ -0,0 +1,72 @@
+! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays destructors io io.windows libc
+windows.types math windows.kernel32 windows namespaces kernel
+sequences windows.errors assocs math.parser system random ;
+IN: io.windows.nt.pipes
+
+: default-security-attributes ( -- obj )
+    "SECURITY_ATTRIBUTES" <c-object>
+    "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
+
+: security-attributes-inherit ( -- obj )
+    default-security-attributes
+    TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
+
+: create-named-pipe ( name mode -- handle )
+    FILE_FLAG_OVERLAPPED bitor
+    PIPE_TYPE_BYTE
+    1
+    4096
+    4096
+    0
+    security-attributes-inherit
+    CreateNamedPipe
+    dup win32-error=0/f
+    dup add-completion ;
+
+: open-other-end ( name mode -- handle )
+    FILE_SHARE_READ FILE_SHARE_WRITE bitor
+    security-attributes-inherit
+    OPEN_EXISTING
+    FILE_FLAG_OVERLAPPED
+    f
+    CreateFile
+    dup win32-error=0/f
+    dup add-completion ;
+
+TUPLE: pipe in out ;
+
+: <pipe> ( name in-mode out-mode -- pipe )
+    [
+        >r over >r create-named-pipe dup close-later
+        r> r> open-other-end dup close-later
+        pipe construct-boa
+    ] with-destructors ;
+
+: close-pipe ( pipe -- )
+    dup
+    pipe-in CloseHandle drop
+    pipe-out CloseHandle drop ;
+
+: <incoming-pipe> ( name -- pipe )
+    PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
+
+: <outgoing-pipe> ( name -- pipe )
+    PIPE_ACCESS_DUPLEX GENERIC_READ <pipe> ;
+
+: unique-pipe-name ( -- string )
+    [
+        "\\\\.\\pipe\\factor-" %
+        pipe counter #
+        "-" %
+        (random) #
+        "-" %
+        millis #
+    ] "" make ;
+
+: <unique-incoming-pipe> ( -- pipe )
+    unique-pipe-name <incoming-pipe> ;
+
+: <unique-outgoing-pipe> ( -- pipe )
+    unique-pipe-name <outgoing-pipe> ;

extra/io/windows/windows.factor

@@ -20,6 +20,9 @@ TUPLE: win32-file handle ptr overlapped ;
 : <win32-file> ( handle ptr -- obj )
     f win32-file construct-boa ;
 
+: <win32-duplex-stream> ( in out -- stream )
+    >r f <win32-file> r> f <win32-file> handle>duplex-stream ;
+
 HOOK: CreateFile-flags io-backend ( -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )