Merge branch 'master' of git://factorcode.org/git/factor

core/alien/compiler/compiler.factor

@@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
 inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators ;
+kernel.private threads continuations.private libc combinators
+init ;
 IN: alien.compiler
 
 ! Common protocol for alien-invoke/alien-callback/alien-indirect
@@ -301,7 +302,7 @@ M: alien-indirect generate-node
 ! this hashtable, they will all be blown away by code GC, beware
 SYMBOL: callbacks
 
-H{ } clone callbacks set-global
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
 
 : register-callback ( word -- ) dup callbacks get set-at ;
 

core/combinators/combinators.factor

@@ -38,9 +38,7 @@ TUPLE: no-case ;
     pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
 
 M: sequence hashcode*
-    [
+    [ sequence-hashcode ] recursive-hashcode ;
-        0 -rot [ hashcode* bitxor ] curry* each
-    ] recursive-hashcode ;
 
 : alist>quot ( default assoc -- quot )
     [ rot \ if 3array append [ ] like ] assoc-each ;

core/io/streams/lines/lines-tests.factor

@@ -41,6 +41,14 @@ unit-test
      4 swap stream-read
 ] unit-test
 
+[
+    "1234"
+] [
+     "Hello world\r\n1234" <string-reader>
+     dup stream-readln drop
+     4 swap stream-read-partial
+] unit-test
+
 [
     CHAR: 1
 ] [

core/io/streams/lines/lines.factor

@@ -32,15 +32,26 @@ M: line-reader stream-readln ( stream -- str )
     "\r\n" over delegate stream-read-until handle-readln ;
 
 : fix-read ( stream string -- string )
-    "\n" ?head [ swap stream-read1 [ add ] when* ] [ nip ] if ;
+    over line-reader-cr [
+        over cr-
+        "\n" ?head [
+            swap stream-read1 [ add ] when*
+        ] [ nip ] if
+    ] [ nip ] if ;
 
 M: line-reader stream-read
-    tuck delegate stream-read
+    tuck delegate stream-read fix-read ;
-    over line-reader-cr [ over cr- fix-read ] [ nip ] if ;
+
+M: line-reader stream-read-partial
+    tuck delegate stream-read-partial fix-read ;
 
 : fix-read1 ( stream char -- char )
-    dup CHAR: \n = [ drop stream-read1 ] [ nip ] if ;
+    over line-reader-cr [
+        over cr-
+        dup CHAR: \n = [
+            drop stream-read1
+        ] [ nip ] if
+    ] [ nip ] if ;
 
 M: line-reader stream-read1 ( stream -- char )
-    dup delegate stream-read1
+    dup delegate stream-read1 fix-read1 ;
-    over line-reader-cr [ over cr- fix-read1 ] [ nip ] if ;

core/sequences/sequences.factor

@@ -44,7 +44,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 TUPLE: bounds-error index seq ;
 
 : bounds-error ( n seq -- * )
-    \ bounds-error construct-boa throw ;
+    die \ bounds-error construct-boa throw ;
 
 : bounds-check ( n seq -- n seq )
     2dup bounds-check? [ bounds-error ] unless ; inline
@@ -666,3 +666,8 @@ PRIVATE>
 
 : infimum ( seq -- n ) dup first [ min ] reduce ;
 : supremum ( seq -- n ) dup first [ max ] reduce ;
+
+: sequence-hashcode ( n seq -- x )
+    0 -rot [
+        hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
+    ] curry* each ; inline

core/strings/strings.factor

@@ -13,8 +13,7 @@ IN: strings
 : reset-string-hashcode f swap set-string-hashcode ; inline
 
 : rehash-string ( str -- )
-    dup 0 [ swap 31 fixnum*fast fixnum+fast ] reduce
+    1 over sequence-hashcode swap set-string-hashcode ; inline
-    swap set-string-hashcode ; inline
 
 PRIVATE>
 

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,75 @@
+! 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
+
+! This code is based on
+! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
+
+: 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-tests.factor

@@ -1,16 +0,0 @@
-USING: io.files kernel tools.test ;
-IN: temporary
-
-[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
-! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
-[ "c:" ] [ "c:" parent-directory ] unit-test
-[ "Z:" ] [ "Z:" parent-directory ] unit-test
-[ t ] [ "c:\\" root-directory? ] unit-test
-[ t ] [ "Z:\\" root-directory? ] unit-test
-[ f ] [ "c:\\foo" root-directory? ] unit-test
-[ f ] [ "." root-directory? ] unit-test
-[ f ] [ ".." root-directory? ] unit-test

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

extra/tools/deploy/shaker/shaker.factor

@@ -24,7 +24,6 @@ IN: tools.deploy.shaker
         "Stripping debugger" show
         "resource:extra/tools/deploy/shaker/strip-debugger.factor"
         run-file
-        do-parse-hook
     ] when ;
 
 : strip-libc ( -- )
@@ -32,7 +31,6 @@ IN: tools.deploy.shaker
         "Stripping manual memory management debug code" show
         "resource:extra/tools/deploy/shaker/strip-libc.factor"
         run-file
-        do-parse-hook
     ] when ;
 
 : strip-cocoa ( -- )
@@ -40,7 +38,6 @@ IN: tools.deploy.shaker
         "Stripping unused Cocoa methods" show
         "resource:extra/tools/deploy/shaker/strip-cocoa.factor"
         run-file
-        do-parse-hook
     ] when ;
 
 : strip-assoc ( retained-keys assoc -- newassoc )
@@ -116,7 +113,6 @@ SYMBOL: deploy-vocab
 
         strip-dictionary? [
             {
-                builtins
                 dictionary
                 inspector-hook
                 lexer-factory
@@ -142,6 +138,10 @@ SYMBOL: deploy-vocab
             "c-types" "alien.c-types" lookup ,
         ] when
 
+        native-io? [
+            "default-buffer-size" "io.nonblocking" lookup ,
+        ] when
+
         deploy-ui? get [
             "ui" child-vocabs
             "cocoa" child-vocabs
@@ -152,10 +152,11 @@ SYMBOL: deploy-vocab
         ] when
     ] { } make dup . ;
 
-: strip ( -- )
+: strip ( hook -- )
-    strip-libc
+    >r strip-libc
     strip-cocoa
     strip-debugger
+    r> [ call ] when*
     strip-init-hooks
     deploy-vocab get vocab-main set-boot-quot*
     retained-props >r
@@ -168,10 +169,9 @@ SYMBOL: deploy-vocab
     [
         [
             deploy-vocab set
-            parse-hook get >r
+            parse-hook get
             parse-hook off
             deploy-vocab get require
-            r> [ call ] when*
             strip
             finish-deploy
         ] [

extra/ui/gadgets/editors/editors-tests.factor

@@ -1,7 +1,7 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
 definitions namespaces ui.gadgets
 ui.gadgets.grids prettyprint documents ui.gestures
-tools.test.inference tools.test.ui ;
+tools.test.inference tools.test.ui models ;
 
 [ "foo bar" ] [
     <editor> "editor" set
@@ -31,3 +31,9 @@ tools.test.inference tools.test.ui ;
 ] unit-test
 
 { 0 1 } [ <editor> ] unit-test-effect
+
+"hello" <model> <field> "field" set
+
+"field" get [
+    [ "hello" ] [ "field" get field-model model-value ] unit-test
+] with-grafted-gadget

extra/ui/gadgets/gadgets.factor

@@ -70,8 +70,12 @@ M: gadget model-changed 2drop ;
     >r <gadget> r> construct-delegate ; inline
 
 : activate-control ( gadget -- )
-    dup gadget-model dup [ 2dup add-connection ] when drop
+    dup gadget-model dup [
-    dup gadget-model swap model-changed ;
+        2dup add-connection
+        swap model-changed
+    ] [
+        2drop
+    ] if ;
 
 : deactivate-control ( gadget -- )
     dup gadget-model dup [ 2dup remove-connection ] when 2drop ;

extra/ui/windows/windows.factor

@@ -280,10 +280,13 @@ SYMBOL: hWnd
     mouse-captured? [ release-capture ] when
     prepare-mouse send-button-up ;
 
+: make-TRACKMOUSEEVENT ( hWnd -- alien )
+    "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
+    "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+
 : handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
     2nip
-    over "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
+    over make-TRACKMOUSEEVENT
-    "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize
     TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
     0 over set-TRACKMOUSEEVENT-dwHoverTime
     TrackMouseEvent drop
@@ -387,10 +390,10 @@ SYMBOL: hWnd
     dup SetForegroundWindow drop
     SetFocus drop ;
 
-: init-win32-ui
+: init-win32-ui ( -- )
     "MSG" <c-object> msg-obj set
     "Factor-window" malloc-u16-string class-name-ptr set-global
-    register-wndclassex
+    register-wndclassex drop
     GetDoubleClickTime double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )

extra/windows/errors/errors.factor

@@ -3,6 +3,7 @@ IN: windows.errors
 
 : ERROR_SUCCESS 0 ; inline
 : ERROR_HANDLE_EOF 38 ; inline
+: ERROR_BROKEN_PIPE 109 ; inline
 : ERROR_IO_INCOMPLETE 996 ; inline
 : ERROR_IO_PENDING 997 ; inline
 

extra/windows/windows.factor

@@ -39,30 +39,21 @@ FUNCTION: void* error_message ( DWORD id ) ;
         win32-error-string throw
     ] when ;
 
-: (expected-io-error?) ( error-code -- ? )
+: expected-io-errors
     ERROR_SUCCESS
     ERROR_IO_INCOMPLETE
     ERROR_IO_PENDING
-    WAIT_TIMEOUT 4array member? ;
+    WAIT_TIMEOUT 4array ; foldable
 
-: expected-io-error? ( error-code -- )
+: expected-io-error? ( error-code -- ? )
-    dup (expected-io-error?) [
+    expected-io-errors member? ;
+
+: expected-io-error ( error-code -- )
+    dup expected-io-error? [
         drop
     ] [
         (win32-error-string) throw
     ] if ;
 
 : io-error ( return-value -- )
-    { 0 f } member? [ GetLastError expected-io-error? ] when ;
+    { 0 f } member? [ GetLastError expected-io-error ] when ;
-
-: overlapped-error? ( port n -- ? )
-    zero? [
-        GetLastError
-        {
-            { [ dup (expected-io-error?) ] [ 2drop t ] }
-            { [ dup ERROR_HANDLE_EOF = ] [ drop t swap set-port-eof? f ] }
-            { [ t ] [ (win32-error-string) throw ] }
-        } cond
-    ] [
-        drop t
-    ] if ;