Merge erg@factorcode.org:/git/erg

core/compiler/compiler.factor

@@ -7,21 +7,6 @@ optimizer definitions math compiler.errors threads graphs
 generic ;
 IN: compiler
 
-SYMBOL: compiled-crossref
-
-compiled-crossref global [ H{ } assoc-like ] change-at
-
-: compiled-xref ( word dependencies -- )
-    2dup "compiled-uses" set-word-prop
-    compiled-crossref get add-vertex* ;
-
-: compiled-unxref ( word -- )
-    dup "compiled-uses" word-prop
-    compiled-crossref get remove-vertex* ;
-
-: compiled-usage ( word -- assoc )
-    compiled-crossref get at ;
-
 : compiled-usages ( words -- seq )
     [ [ dup ] H{ } map>assoc dup ] keep [
         compiled-usage [ nip +inlined+ eq? ] assoc-subset update
@@ -41,7 +26,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
     >r dupd save-effect r>
     f pick compiler-error
     over compiled-unxref
-    compiled-xref ;
+    over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
 
 : compile-succeeded ( word -- effect dependencies )
     [

core/compiler/test/redefine.factor

@@ -1,6 +1,6 @@
 USING: compiler definitions generic assocs inference math
 namespaces parser tools.test words kernel sequences arrays io
-effects tools.test.inference compiler.units ;
+effects tools.test.inference compiler.units inference.state ;
 IN: temporary
 
 DEFER: x-1
@@ -206,12 +206,15 @@ DEFER: generic-then-not-generic-test-2
 
 [ 4 ] [ generic-then-not-generic-test-2 ] unit-test
 
+DEFER: foldable-test-1
 DEFER: foldable-test-2
 
 [ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
 
 [ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
 
+[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
+
 [ 3 ] [ foldable-test-2 ] unit-test
 
 [ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
@@ -229,3 +232,9 @@ DEFER: flushable-test-2
 [ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
 
 [ V{ 3 } ] [ flushable-test-2 ] unit-test
+
+: ax ;
+: bx ax ;
+[ \ bx forget ] with-compilation-unit
+
+[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test

core/dlists/dlists.factor

@@ -78,7 +78,8 @@ PRIVATE>
 
 : pop-front ( dlist -- obj )
     dup dlist-front [
-        dlist-node-next
+        dup dlist-node-next
+        f rot set-dlist-node-next
         f over set-prev-when
         swap set-dlist-front
     ] 2keep dlist-node-obj
@@ -87,13 +88,13 @@ PRIVATE>
 : pop-front* ( dlist -- ) pop-front drop ;
 
 : pop-back ( dlist -- obj )
-    [
+    dup dlist-back [
-        dlist-back dup dlist-node-prev f over set-next-when
+        dup dlist-node-prev
-    ] keep
+        f rot set-dlist-node-prev
-    [ set-dlist-back ] keep
+        f over set-next-when
-    [ normalize-front ] keep
+        swap set-dlist-back
-    dec-length
+    ] 2keep dlist-node-obj
-    dlist-node-obj ;
+    swap [ normalize-front ] keep dec-length ;
 
 : pop-back* ( dlist -- ) pop-back drop ;
 

core/prettyprint/prettyprint-docs.factor

@@ -1,6 +1,6 @@
 USING: prettyprint.backend prettyprint.config
-prettyprint.sections help.markup help.syntax io kernel words
+prettyprint.sections prettyprint.private help.markup help.syntax
-definitions quotations strings ;
+io kernel words definitions quotations strings ;
 IN: prettyprint
 
 ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"

core/prettyprint/prettyprint.factor

@@ -86,14 +86,14 @@ combinators quotations ;
 : .s ( -- ) datastack stack. ;
 : .r ( -- ) retainstack stack. ;
 
+<PRIVATE
+
 SYMBOL: ->
 
 \ ->
 { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
 "word-style" set-word-prop
 
-<PRIVATE
-
 ! This code is ugly and could probably be simplified
 : remove-step-into
     building get dup empty? [

core/words/words.factor

@@ -87,6 +87,25 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ;
 M: word uses ( word -- seq )
     word-def quot-uses keys ;
 
+SYMBOL: compiled-crossref
+
+compiled-crossref global [ H{ } assoc-like ] change-at
+
+: compiled-xref ( word dependencies -- )
+    2dup "compiled-uses" set-word-prop
+    compiled-crossref get add-vertex* ;
+
+: compiled-unxref ( word -- )
+    dup "compiled-uses" word-prop
+    compiled-crossref get remove-vertex* ;
+
+: delete-compiled-xref ( word -- )
+    dup compiled-unxref
+    compiled-crossref get delete-at ;
+
+: compiled-usage ( word -- assoc )
+    compiled-crossref get at ;
+
 M: word redefined* ( word -- )
     { "inferred-effect" "base-case" "no-effect" } reset-props ;
 
@@ -187,6 +206,7 @@ M: word (forget-word)
 
 : forget-word ( word -- )
     dup delete-xref
+    dup delete-compiled-xref
     (forget-word) ;
 
 M: word forget* forget-word ;

extra/calendar/windows/windows.factor

@@ -1,5 +1,5 @@
-USING: alien alien.c-types kernel math
+USING: calendar.backend namespaces alien.c-types
-windows windows.kernel32 namespaces ;
+windows windows.kernel32 kernel math ;
 IN: calendar.windows
 
 TUPLE: windows-calendar ;
@@ -11,37 +11,3 @@ M: windows-calendar gmt-offset ( -- float )
     [ GetTimeZoneInformation win32-error=0/f ] keep
     [ TIME_ZONE_INFORMATION-Bias ] keep
     TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ;
-
-: >64bit ( lo hi -- n )
-    32 shift bitor ;
-
-: windows-1601 ( -- timestamp )
-    1601 1 1 0 0 0 0 <timestamp> ;
-
-: FILETIME>windows-time ( FILETIME -- n )
-    [ FILETIME-dwLowDateTime ] keep
-    FILETIME-dwHighDateTime >64bit ;
-
-: windows-time>timestamp ( n -- timestamp )
-    10000000 /i seconds windows-1601 swap +dt ;
-
-: windows-time ( -- n )
-    "FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
-    FILETIME>windows-time ;
-
-: timestamp>windows-time ( timestamp -- n )
-    #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
-    >gmt windows-1601 timestamp- >bignum 10000000 * ;
-
-: windows-time>FILETIME ( n -- FILETIME )
-    "FILETIME" <c-object>
-    [
-        [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
-        >r -32 shift r> set-FILETIME-dwHighDateTime
-    ] keep ;
-
-: timestamp>FILETIME ( timestamp -- FILETIME/f )
-    [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
-
-: FILETIME>timestamp ( FILETIME -- timestamp/f )
-    FILETIME>windows-time windows-time>timestamp ;

extra/cocoa/messages/messages.factor

@@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot )
     super-message-senders message-senders ? get at
     [ slip execute ] 2curry ;
 
-: send ( args... receiver selector -- return... ) f (send) ; inline
+: send ( receiver args... selector -- return... ) f (send) ; inline
 
 \ send soft "break-after" set-word-prop
 
-: super-send ( args... receiver selector -- return... ) t (send) ; inline
+: super-send ( receiver args... selector -- return... ) t (send) ; inline
 
 \ super-send soft "break-after" set-word-prop
 

extra/editors/editpadpro/editpadpro.factor

@@ -10,6 +10,8 @@ IN: editors.editpadpro
     ] unless* ;
 
 : editpadpro ( file line -- )
-    [ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
+    [
+        editpadpro-path , "/l" swap number>string append , ,
+    ] { } make run-detached drop ;
 
 [ editpadpro ] edit-hook set-global

extra/editors/editplus/editplus.factor

@@ -9,7 +9,7 @@ IN: editors.editplus
 
 : editplus ( file line -- )
     [
-        editplus-path % " -cursor " % # " " % %
+        editplus-path , "-cursor" , number>string , ,
-    ] "" make run-detached ;
+    ] { } make run-detached drop ;
 
 [ editplus ] edit-hook set-global

extra/editors/emacs/emacs.factor

@@ -4,8 +4,11 @@ IN: editors.emacs
 
 : emacsclient ( file line -- )
     [
-        "emacsclient --no-wait +" % # " " % %
+        "emacsclient" ,
-    ] "" make run-process ;
+        "--no-wait" ,
+        "+" swap number>string append ,
+        ,
+    ] { } make run-process drop ;
 
 : emacs ( word -- )
     where first2 emacsclient ;

extra/editors/emeditor/emeditor.factor

@@ -9,8 +9,7 @@ IN: editors.emeditor
 
 : emeditor ( file line -- )
     [
-        emeditor-path % " /l " % #
+        emeditor-path , "/l" , number>string , ,
-        " " % "\"" % % "\"" %
+    ] { } make run-detached drop ;
-    ] "" make run-detached ;
 
 [ emeditor ] edit-hook set-global

extra/editors/notepadpp/notepadpp.factor

@@ -9,7 +9,8 @@ IN: editors.notepadpp
 
 : notepadpp ( file line -- )
     [
-        notepadpp-path % " -n" % # " " % %
+        notepadpp-path ,
-    ] "" make run-detached ;
+        "-n" swap number>string append , ,
+    ] "" make run-detached drop ;
 
 [ notepadpp ] edit-hook set-global

extra/editors/scite/scite.factor

@@ -18,14 +18,13 @@ SYMBOL: scite-path
 
 : scite-command ( file line -- cmd )
   swap
-  [ scite-path get %
+  [
-    " \"" %
+    scite-path get ,
-    %
+    ,
-    "\" -goto:" %
+    "-goto:" swap number>string append ,
-    #
+  ] { } make ;
-  ] "" make ;
 
 : scite-location ( file line -- )
-  scite-command run-detached ;
+  scite-command run-detached drop ;
 
 [ scite-location ] edit-hook set-global

extra/editors/ted-notepad/ted-notepad.factor

@@ -9,8 +9,7 @@ IN: editors.ted-notepad
 
 : ted-notepad ( file line -- )
     [
-        ted-notepad-path % " /l" % #
+        ted-notepad-path , "/l" swap number>string append , ,
-        " " % %
+    ] { } make run-detached drop ;
-    ] "" make run-detached ;
 
 [ ted-notepad ] edit-hook set-global

extra/editors/textmate/textmate.factor

@@ -4,6 +4,7 @@ namespaces prettyprint editors ;
 IN: editors.textmate
 
 : textmate-location ( file line -- )
-    [ "mate -a -l " % # " " % unparse % ] "" make run-process ;
+    [ "mate" , "-a" , "-l" , number>string , , ] { } make
+    run-process drop ;
 
 [ textmate-location ] edit-hook set-global

extra/editors/ultraedit/ultraedit.factor

@@ -10,8 +10,8 @@ IN: editors.ultraedit
 
 : ultraedit ( file line -- )
     [
-        ultraedit-path % " " % swap % "/" % # "/1" %
+        ultraedit-path , [ % "/" % # "/1" % ] "" make ,
-    ] "" make run-detached ;
+    ] { } make run-detached drop ;
 
 
 [ ultraedit ] edit-hook set-global

extra/editors/vim/vim.factor

@@ -10,13 +10,15 @@ HOOK: vim-command vim-editor
 
 TUPLE: vim ;
 
-M: vim vim-command ( file line -- string )
+M: vim vim-command ( file line -- array )
-    [ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ;
+    [
+        vim-path get , swap , "+" swap number>string append ,
+    ] { } make ;
 
 : vim-location ( file line -- )
     vim-command
     vim-detach get-global
-    [ run-detached ] [ run-process ] if ;
+    [ run-detached ] [ run-process ] if drop ;
 
 "vim" vim-path set-global
 [ vim-location ] edit-hook set-global

extra/editors/wordpad/wordpad.factor

@@ -8,8 +8,6 @@ IN: editors.wordpad
     ] unless* ;
 
 : wordpad ( file line -- )
-    [
+    drop wordpad-path swap 2array run-detached drop ;
-        wordpad-path % drop " " % "\"" % % "\"" %
-    ] "" make run-detached ;
 
 [ wordpad ] edit-hook set-global

extra/io/launcher/launcher-docs.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations kernel ;
+USING: help.markup help.syntax quotations kernel io math ;
 IN: io.launcher
 
 HELP: +command+
@@ -58,7 +58,7 @@ HELP: get-environment
 { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
 
 HELP: run-process*
-{ $values { "desc" "a launch descriptor" } }
+{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
 { $contract "Launches a process using the launch descriptor." }
 { $notes "User code should call " { $link run-process } " instead." } ;
 
@@ -73,22 +73,41 @@ HELP: >descriptor
 } ;
 
 HELP: run-process
-{ $values { "obj" object } }
+{ $values { "obj" object } { "process" process } }
-{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ;
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
+{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
 
 HELP: run-detached
-{ $values { "obj" object } }
+{ $values { "obj" object } { "process" process } }
 { $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
 { $notes
     "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
+    $nl
+    "The output value can be passed to " { $link wait-for-process } " to get an exit code."
 } ;
 
+HELP: process
+{ $class-description "A class representing an active or finished process."
+$nl
+"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances."
+$nl
+"Processes can be passed to " { $link wait-for-process } "." } ;
+
+HELP: process-stream
+{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
+
 HELP: <process-stream>
 { $values { "obj" object } { "stream" "a bidirectional stream" } }
 { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
 { $notes "Closing the stream will block until the process exits." } ;
 
-{ run-process run-detached <process-stream> } related-words
+HELP: with-process-stream
+{ $values { "obj" object } { "quot" quotation } { "process" process } }
+{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
+
+HELP: wait-for-process
+{ $values { "process" process } { "status" integer } }
+{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
 
 ARTICLE: "io.launcher" "Launching OS processes"
 "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
@@ -108,6 +127,11 @@ $nl
 "The following words are used to launch processes:"
 { $subsection run-process }
 { $subsection run-detached }
-{ $subsection <process-stream> } ;
+{ $subsection <process-stream> }
+{ $subsection with-process-stream }
+"A class representing an active or finished process:"
+{ $subsection process }
+"Waiting for a process to end, or getting the exit code of a finished process:"
+{ $subsection wait-for-process } ;
 
 ABOUT: "io.launcher"

extra/io/launcher/launcher.factor

@@ -1,9 +1,30 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend system kernel namespaces strings hashtables
+USING: io io.backend system kernel namespaces strings hashtables
-sequences assocs combinators vocabs.loader ;
+sequences assocs combinators vocabs.loader init threads
+continuations ;
 IN: io.launcher
 
+! Non-blocking process exit notification facility
+SYMBOL: processes
+
+[ H{ } clone processes set-global ] "io.launcher" add-init-hook
+
+TUPLE: process handle status ;
+
+HOOK: register-process io-backend ( process -- )
+
+M: object register-process drop ;
+
+: <process> ( handle -- process )
+    f process construct-boa
+    V{ } clone over processes get set-at
+    dup register-process ;
+
+M: process equal? 2drop f ;
+
+M: process hashcode* process-handle hashcode* ;
+
 SYMBOL: +command+
 SYMBOL: +arguments+
 SYMBOL: +detached+
@@ -44,15 +65,36 @@ M: string >descriptor +command+ associate ;
 M: sequence >descriptor +arguments+ associate ;
 M: assoc >descriptor ;
 
-HOOK: run-process* io-backend ( desc -- )
+HOOK: run-process* io-backend ( desc -- handle )
 
-: run-process ( obj -- )
+: wait-for-process ( process -- status )
-    >descriptor run-process* ;
+    dup process-handle [
+        dup [ processes get at push stop ] curry callcc0
+    ] when process-status ;
 
-: run-detached ( obj -- )
+: run-process ( obj -- process )
-    >descriptor H{ { +detached+ t } } union run-process* ;
+    >descriptor
+    dup run-process*
+    +detached+ rot at [ dup wait-for-process drop ] unless ;
 
-HOOK: process-stream* io-backend ( desc -- stream )
+: run-detached ( obj -- process )
+    >descriptor H{ { +detached+ t } } union run-process ;
+
+HOOK: process-stream* io-backend ( desc -- stream process )
+
+TUPLE: process-stream process ;
 
 : <process-stream> ( obj -- stream )
-    >descriptor process-stream* ;
+    >descriptor process-stream*
+    { set-delegate set-process-stream-process }
+    process-stream construct ;
+
+: with-process-stream ( obj quot -- process )
+    swap <process-stream>
+    [ swap with-stream ] keep
+    process-stream-process ; inline
+
+: notify-exit ( status process -- )
+    [ set-process-status ] keep
+    [ processes get delete-at* drop [ schedule-thread ] each ] keep
+    f swap set-process-handle ;

extra/io/sockets/impl/impl.factor

@@ -51,10 +51,13 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
     "0.0.0.0" or
     rot inet-pton *uint over set-sockaddr-in-addr ;
 
+SYMBOL: port-override
+
+: (port) port-override get [ ] [ ] ?if ;
+
 M: inet4 parse-sockaddr
     >r dup sockaddr-in-addr <uint> r> inet-ntop
-    swap sockaddr-in-port ntohs <inet4> ;
+    swap sockaddr-in-port ntohs (port) <inet4> ;
-
 
 M: inet6 inet-ntop ( data addrspec -- str )
     drop 16 memory>string 2 <groups> [ be> >hex ] map ":" join ;
@@ -80,7 +83,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr )
 
 M: inet6 parse-sockaddr
     >r dup sockaddr-in6-addr r> inet-ntop
-    swap sockaddr-in6-port ntohs <inet6> ;
+    swap sockaddr-in6-port ntohs (port) <inet6> ;
 
 : addrspec-of-family ( af -- addrspec )
     {
@@ -102,15 +105,28 @@ M: f parse-sockaddr nip ;
     [ dup addrinfo-next swap addrinfo>addrspec ]
     [ ] unfold nip [ ] subset ;
 
+: prepare-resolve-host ( host serv passive? -- host' serv' flags )
+    #! If the port is a number, we resolve for 'http' then
+    #! change it later. This is a workaround for a FreeBSD
+    #! getaddrinfo() limitation -- on Windows, Linux and Mac,
+    #! we can convert a number to a string and pass that as the
+    #! service name, but on FreeBSD this gives us an unknown
+    #! service error.
+    >r
+    dup integer? [ port-override set "http" ] when
+    r> AI_PASSIVE 0 ? ;
+
 M: object resolve-host ( host serv passive? -- seq )
-    >r dup integer? [ number>string ] when
+    [
-    "addrinfo" <c-object>
+        prepare-resolve-host
-    r> [ AI_PASSIVE over set-addrinfo-flags ] when
+        "addrinfo" <c-object>
-    PF_UNSPEC over set-addrinfo-family
+        [ set-addrinfo-flags ] keep
-    IPPROTO_TCP over set-addrinfo-protocol
+        PF_UNSPEC over set-addrinfo-family
-    f <void*> [ getaddrinfo addrinfo-error ] keep *void*
+        IPPROTO_TCP over set-addrinfo-protocol
-    [ parse-addrinfo-list ] keep
+        f <void*> [ getaddrinfo addrinfo-error ] keep *void*
-    freeaddrinfo ;
+        [ parse-addrinfo-list ] keep
+        freeaddrinfo
+    ] with-scope ;
 
 M: object host-name ( -- name )
     256 <byte-array> dup dup length gethostname

extra/io/unix/bsd/bsd.factor

@@ -23,7 +23,7 @@ M: bsd-io init-io ( -- )
     2dup mx get-global mx-reads set-at
     mx get-global mx-writes set-at ;
 
-M: bsd-io wait-for-process ( pid -- status )
+M: bsd-io register-process ( process -- )
-    [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ;
+    process-handle kqueue-mx get-global add-pid-task ;
 
 T{ bsd-io } set-io-backend

extra/io/unix/kqueue/kqueue.factor

@@ -5,7 +5,7 @@ sequences assocs unix unix.kqueue unix.process math namespaces
 combinators threads vectors ;
 IN: io.unix.kqueue
 
-TUPLE: kqueue-mx events processes ;
+TUPLE: kqueue-mx events ;
 
 : max-events ( -- n )
     #! We read up to 256 events at a time. This is an arbitrary
@@ -15,7 +15,6 @@ TUPLE: kqueue-mx events processes ;
 : <kqueue-mx> ( -- mx )
     kqueue-mx construct-mx
     kqueue dup io-error over set-mx-fd
-    H{ } clone over set-kqueue-mx-processes
     max-events "kevent" <c-array> over set-kqueue-mx-events ;
 
 GENERIC: io-task-filter ( task -- n )
@@ -52,9 +51,8 @@ M: kqueue-mx unregister-io-task ( task mx -- )
     over mx-reads at handle-io-task ;
 
 : kevent-proc-task ( mx pid -- )
-    dup (wait-for-pid) spin kqueue-mx-processes delete-at* [
+    dup (wait-for-pid) swap find-process
-        [ schedule-thread-with ] with each
+    dup [ notify-exit ] [ 2drop ] if ;
-    ] [ 2drop ] if ;
 
 : handle-kevent ( mx kevent -- )
     dup kevent-ident swap kevent-filter {
@@ -76,11 +74,5 @@ M: kqueue-mx wait-for-events ( ms mx -- )
     EVFILT_PROC over set-kevent-filter
     NOTE_EXIT over set-kevent-fflags ;
 
-: add-pid-task ( continuation pid mx -- )
+: add-pid-task ( pid mx -- )
-    2dup kqueue-mx-processes at* [
+    swap make-proc-kevent swap register-kevent ;
-        2nip push
-    ] [
-        drop
-        over make-proc-kevent over register-kevent
-        >r >r 1vector r> r> kqueue-mx-processes set-at
-    ] if ;

extra/io/unix/launcher/launcher.factor

@@ -9,10 +9,6 @@ IN: io.unix.launcher
 ! Search unix first
 USE: unix
 
-HOOK: wait-for-process io-backend ( pid -- status )
-
-M: unix-io wait-for-process ( pid -- status ) wait-for-pid ;
-
 ! Our command line parser. Supported syntax:
 ! foo bar baz -- simple tokens
 ! foo\ bar -- escaping the space
@@ -46,7 +42,7 @@ MEMO: 'arguments' ( -- parser )
 : assoc>env ( assoc -- env )
     [ "=" swap 3append ] { } assoc>map ;
 
-: (spawn-process) ( -- )
+: spawn-process ( -- )
     [
         get-arguments
         pass-environment?
@@ -55,20 +51,9 @@ MEMO: 'arguments' ( -- parser )
         io-error
     ] [ error. :c flush ] recover 1 exit ;
 
-: spawn-process ( -- pid )
+M: unix-io run-process* ( desc -- pid )
-    [ (spawn-process) ] [ ] with-fork ;
-
-: spawn-detached ( -- )
-    [ spawn-process 0 exit ] [ ] with-fork
-    wait-for-process drop ;
-
-M: unix-io run-process* ( desc -- )
     [
-        +detached+ get [
+        [ spawn-process ] [ ] with-fork <process>
-            spawn-detached
-        ] [
-            spawn-process wait-for-process drop
-        ] if
     ] with-descriptor ;
 
 : open-pipe ( -- pair )
@@ -82,21 +67,35 @@ M: unix-io run-process* ( desc -- )
 : spawn-process-stream ( -- in out pid )
     open-pipe open-pipe [
         setup-stdio-pipe
-        (spawn-process)
+        spawn-process
     ] [
         -rot 2dup second close first close
-    ] with-fork first swap second rot ;
+    ] with-fork first swap second rot <process> ;
-
-TUPLE: pipe-stream pid status ;
-
-: <pipe-stream> ( in out pid -- stream )
-    f pipe-stream construct-boa
-    -rot handle>duplex-stream over set-delegate ;
-
-M: pipe-stream stream-close
-    dup delegate stream-close
-    dup pipe-stream-pid wait-for-process
-    swap set-pipe-stream-status ;
 
 M: unix-io process-stream*
-    [ spawn-process-stream <pipe-stream> ] with-descriptor ;
+    [
+        spawn-process-stream >r handle>duplex-stream r>
+    ] with-descriptor ;
+
+: find-process ( handle -- process )
+    f process construct-boa processes get at ;
+
+! Inefficient process wait polling, used on Linux and Solaris.
+! On BSD and Mac OS X, we use kqueue() which scales better.
+: wait-for-processes ( -- ? )
+    -1 0 <int> tuck WNOHANG waitpid
+    dup zero? [
+        2drop t
+    ] [
+        find-process dup [
+            >r *uint r> notify-exit f
+        ] [
+            2drop f
+        ] if
+    ] if ;
+
+: wait-loop ( -- )
+    wait-for-processes [ 250 sleep ] when wait-loop ;
+
+: start-wait-thread ( -- )
+    [ wait-loop ] in-thread ;

extra/io/unix/linux/linux.factor

@@ -10,9 +10,6 @@ INSTANCE: linux-io unix-io
 
 M: linux-io init-io ( -- )
     <select-mx> mx set-global
-    start-wait-loop ;
+    start-wait-thread ;
-
-M: linux-io wait-for-process ( pid -- status )
-    wait-for-pid ;
 
 T{ linux-io } set-io-backend

extra/io/windows/launcher/launcher.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2008 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 ;
+sequences windows.errors assocs splitting system threads init ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args
@@ -19,13 +19,6 @@ TUPLE: CreateProcess-args
        lpProcessInformation
        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* ;
-
 : default-CreateProcess-args ( -- obj )
     0
     0
@@ -93,21 +86,50 @@ TUPLE: CreateProcess-args
         over set-CreateProcess-args-lpEnvironment
     ] when ;
 
-: wait-for-process ( args -- )
-    CreateProcess-args-lpProcessInformation
-    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 -- )
+M: windows-io run-process* ( desc -- handle )
     [
         make-CreateProcess-args
         dup call-CreateProcess
-        +detached+ get [ dup wait-for-process ] unless
+        CreateProcess-args-lpProcessInformation <process>
-        dispose-CreateProcess-args
     ] with-descriptor ;
+
+: dispose-process ( process-information -- )
+    #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
+    #! with CloseHandle when they are no longer needed."
+    dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
+    PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
+
+: exit-code ( process -- n )
+    PROCESS_INFORMATION-hProcess
+    0 <ulong> [ GetExitCodeProcess ] keep *ulong
+    swap win32-error=0/f ;
+
+: process-exited ( process -- )
+    dup process-handle exit-code
+    over process-handle dispose-process
+    swap notify-exit ;
+
+: wait-for-processes ( processes -- ? )
+    keys dup
+    [ process-handle PROCESS_INFORMATION-hProcess ] map
+    dup length swap >c-void*-array 0 0
+    WaitForMultipleObjects
+    dup HEX: ffffffff = [ win32-error ] when
+    dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
+
+: wait-loop ( -- )
+    processes get dup assoc-empty?
+    [ drop t ] [ wait-for-processes ] if
+    [ 250 sleep ] when
+    wait-loop ;
+
+: start-wait-thread ( -- )
+    [ wait-loop ] in-thread ;
+
+[ start-wait-thread ] "io.windows.launcher" add-init-hook

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

@@ -116,25 +116,27 @@ M: windows-nt-io add-completion ( handle -- )
 : lookup-callback ( GetQueuedCompletion-args -- callback )
     io-hash get-global delete-at* drop ;
 
-: wait-for-io ( timeout -- continuation/f )
+: handle-overlapped ( timeout -- ? )
     wait-for-overlapped [
         GetLastError dup expected-io-error? [
-            2drop f
+            2drop t
         ] [
             dup eof? [
                 drop lookup-callback
                 dup io-callback-port t swap set-port-eof?
-                io-callback-continuation
             ] [
                 (win32-error-string) swap lookup-callback
                 [ io-callback-port set-port-error ] keep
-                io-callback-continuation
+            ] if io-callback-continuation schedule-thread f
-            ] if
         ] if
     ] [
-        lookup-callback io-callback-continuation
+        lookup-callback
+        io-callback-continuation schedule-thread f
     ] if ;
 
+: drain-overlapped ( timeout -- )
+    handle-overlapped [ 0 drain-overlapped ] unless ;
+
 : maybe-expire ( io-callbck -- )
     io-callback-port
     dup timeout? [
@@ -144,10 +146,10 @@ M: windows-nt-io add-completion ( handle -- )
     ] if ;
 
 : cancel-timeout ( -- )
-    io-hash get-global values [ maybe-expire ] each ;
+    io-hash get-global [ nip maybe-expire ] assoc-each ;
 
 M: windows-nt-io io-multiplex ( ms -- )
-    cancel-timeout wait-for-io [ schedule-thread ] when* ;
+    cancel-timeout drain-overlapped ;
 
 M: windows-nt-io init-io ( -- )
     <master-completion-port> master-completion-port set-global

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

@@ -59,6 +59,6 @@ M: windows-io process-stream*
             dup CreateProcess-args-stdout-pipe pipe-in
             over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
 
-            swap dispose-CreateProcess-args
+            swap CreateProcess-args-lpProcessInformation <process>
         ] with-destructors
     ] with-descriptor ;

extra/tools/deploy/macosx/macosx.factor

@@ -8,10 +8,10 @@ QUALIFIED: unix
 IN: tools.deploy.macosx
 
 : touch ( path -- )
-    { "touch" } swap add run-process ;
+    { "touch" } swap add run-process drop ;
 
 : rm ( path -- )
-    { "rm" "-rf" } swap add run-process ;
+    { "rm" "-rf" } swap add run-process drop ;
 
 : bundle-dir ( -- dir )
     vm parent-directory parent-directory ;

extra/unix/process/process.factor

@@ -31,25 +31,5 @@ IN: unix.process
 : with-fork ( child parent -- )
     fork dup zero? -roll swap curry if ; inline
 
-! Lame polling strategy for getting process exit codes. On
-! BSD, we use kqueue which is more efficient.
-
-SYMBOL: pid-wait
-
-: (wait-for-pid) ( pid -- status )
-    0 <int> [ 0 waitpid drop ] keep *int ;
-
 : wait-for-pid ( pid -- status )
-    [ pid-wait get-global [ ?push ] change-at stop ] curry
+    0 <int> [ 0 waitpid drop ] keep *int ;
-    callcc1 ;
-
-: wait-loop ( -- )
-    -1 0 <int> tuck WNOHANG waitpid               ! &status return
-    [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
-    [ schedule-thread-with ] with each
-    250 sleep
-    wait-loop ;
-
-: start-wait-loop ( -- )
-    H{ } clone pid-wait set-global
-    [ wait-loop ] in-thread ;

extra/windows/kernel32/kernel32.factor

@@ -898,7 +898,7 @@ FUNCTION: HANDLE GetCurrentThread ( ) ;
 ! FUNCTION: GetEnvironmentStringsW
 ! FUNCTION: GetEnvironmentVariableA
 ! FUNCTION: GetEnvironmentVariableW
-! FUNCTION: GetExitCodeProcess
+FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ;
 ! FUNCTION: GetExitCodeThread
 ! FUNCTION: GetExpandedNameA
 ! FUNCTION: GetExpandedNameW
@@ -1496,7 +1496,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I
 ! FUNCTION: VirtualUnlock
 ! FUNCTION: WaitCommEvent
 ! FUNCTION: WaitForDebugEvent
-! FUNCTION: WaitForMultipleObjects
+FUNCTION: DWORD WaitForMultipleObjects ( DWORD nCount, HANDLE* lpHandles, BOOL bWaitAll, DWORD dwMilliseconds ) ;
 ! FUNCTION: WaitForMultipleObjectsEx
 FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ;
 ! FUNCTION: WaitForSingleObjectEx

extra/windows/time/time.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types kernel math windows windows.kernel32
+namespaces calendar.backend ;
+IN: windows.time
+
+: >64bit ( lo hi -- n )
+    32 shift bitor ;
+
+: windows-1601 ( -- timestamp )
+    1601 1 1 0 0 0 0 <timestamp> ;
+
+: FILETIME>windows-time ( FILETIME -- n )
+    [ FILETIME-dwLowDateTime ] keep
+    FILETIME-dwHighDateTime >64bit ;
+
+: windows-time>timestamp ( n -- timestamp )
+    10000000 /i seconds windows-1601 swap +dt ;
+
+: windows-time ( -- n )
+    "FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
+    FILETIME>windows-time ;
+
+: timestamp>windows-time ( timestamp -- n )
+    #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
+    >gmt windows-1601 timestamp- >bignum 10000000 * ;
+
+: windows-time>FILETIME ( n -- FILETIME )
+    "FILETIME" <c-object>
+    [
+        [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
+        >r -32 shift r> set-FILETIME-dwHighDateTime
+    ] keep ;
+
+: timestamp>FILETIME ( timestamp -- FILETIME/f )
+    [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
+
+: FILETIME>timestamp ( FILETIME -- timestamp/f )
+    FILETIME>windows-time windows-time>timestamp ;