Merge branch 'master' into jamshred

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/inference/transforms/transforms.factor

@@ -74,7 +74,7 @@ M: pair (bitfield-quot) ( spec -- quot )
         dup tuple-size [ <tuple> ] 2curry
         swap infer-quot
     ] [
-        \ construct-empty declared-infer
+        \ construct-empty 1 1 <effect> make-call-node
     ] if
 ] "infer" set-word-prop
 

core/io/backend/backend.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: init kernel system ;
+USING: init kernel system namespaces ;
 IN: io.backend
 
 SYMBOL: io-backend
@@ -21,3 +21,6 @@ M: object normalize-pathname ;
 
 [ init-io embedded? [ init-stdio ] unless ]
 "io.backend" add-init-hook
+
+: set-io-backend ( backend -- )
+    io-backend set-global init-io init-stdio ;

core/io/io-docs.factor

@@ -29,7 +29,6 @@ ARTICLE: "stdio" "The default stream"
 "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
 { $subsection stdio }
 "Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
-{ $subsection close }
 { $subsection read1 }
 { $subsection read }
 { $subsection read-until }
@@ -178,10 +177,6 @@ $io-error ;
 HELP: stdio
 { $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
 
-HELP: close
-{ $contract "Closes the " { $link stdio } " stream." } 
-$io-error ;
-
 HELP: readln
 { $values { "str/f" "a string or " { $link f } } }
 { $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }

core/io/io.factor

@@ -38,8 +38,6 @@ SYMBOL: stdio
 ! Default error stream
 SYMBOL: stderr
 
-: close ( -- ) stdio get stream-close ;
-
 : readln ( -- str/f ) stdio get stream-readln ;
 : read1 ( -- ch/f ) stdio get stream-read1 ;
 : read ( n -- str/f ) stdio get stream-read ;
@@ -56,7 +54,9 @@ SYMBOL: stderr
     stdio swap with-variable ; inline
 
 : with-stream ( stream quot -- )
-    swap [ [ close ] [ ] cleanup ] with-stream* ; inline
+    swap [
+        [ stdio get stream-close ] [ ] cleanup
+    ] with-stream* ; inline
 
 : tabular-output ( style quot -- )
     swap >r { } make r> stdio get stream-write-table ; inline

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/bootstrap/io/io.factor

@@ -10,6 +10,3 @@ IN: bootstrap.io
         { [ wince? ] [ "windows.ce" ] }
     } cond append require
 ] when
-
-init-io
-init-stdio

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/golden-section/golden-section.factor

@@ -1,28 +1,25 @@
-USING: kernel namespaces math math.constants math.functions
+USING: kernel namespaces math math.constants math.functions arrays sequences
-arrays sequences opengl opengl.gl opengl.glu ui ui.render
+    opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
-ui.gadgets ui.gadgets.theme ui.gadgets.slate colors ;
+    ui.gadgets.slate colors ;
 IN: golden-section
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 ! To run:
-! 
+! "golden-section" run
-! "demos.golden-section" run
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : disk ( quadric radius center -- )
-glPushMatrix
+    glPushMatrix
-gl-translate
+    gl-translate
-dup 0 glScalef
+    dup 0 glScalef
-0 1 10 10 gluDisk
+    0 1 10 10 gluDisk
-glPopMatrix ;
+    glPopMatrix ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: phi ( -- phi ) 5 sqrt 1 + 2 / 1 - ;
+: omega ( i -- omega ) phi 1- * 2 * pi * ;
-
-: omega ( i -- omega ) phi * 2 * pi * ;
 
 : x ( i -- x ) dup omega cos * 0.5 * ;
 
@@ -35,10 +32,10 @@ glPopMatrix ;
 : color ( i -- color ) 360.0 / dup 0.25 1 4array ;
 
 : rim ( quadric i -- )
-black gl-color dup radius 1.5 * swap center disk ;
+    black gl-color dup radius 1.5 * swap center disk ;
 
 : inner ( quadric i -- )
-dup color gl-color dup radius swap center disk ;
+    dup color gl-color dup radius swap center disk ;
 
 : dot ( quadric i -- ) 2dup rim inner ;
 
@@ -47,21 +44,21 @@ dup color gl-color dup radius swap center disk ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : with-quadric ( quot -- )
-gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
+    gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
 
 : display ( -- )
-GL_PROJECTION glMatrixMode
+    GL_PROJECTION glMatrixMode
-glLoadIdentity
+    glLoadIdentity
--400 400 -400 400 -1 1 glOrtho
+    -400 400 -400 400 -1 1 glOrtho
-GL_MODELVIEW glMatrixMode
+    GL_MODELVIEW glMatrixMode
-glLoadIdentity
+    glLoadIdentity
-[ golden-section ] with-quadric ;
+    [ golden-section ] with-quadric ;
 
 : golden-section-window ( -- )
-[
+    [
         [ display ] <slate>
         { 600 600 } over set-slate-dim
         "Golden Section" open-window
-] with-ui ;
+    ] with-ui ;
 
 MAIN: golden-section-window

extra/hexdump/hexdump.factor

@@ -1,4 +1,6 @@
-USING: arrays io io.streams.string kernel math math.parser namespaces prettyprint sequences splitting strings ;
+USING: arrays combinators.lib io io.streams.string
+kernel math math.parser namespaces prettyprint
+sequences splitting strings ;
 IN: hexdump
 
 <PRIVATE
@@ -6,12 +8,16 @@ IN: hexdump
 : header. ( len -- )
     "Length: " write dup unparse write ", " write >hex write "h" write nl ;
 
-: offset. ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+: offset. ( lineno -- )
-: h-pad. ( digit -- ) >hex 2 CHAR: 0 pad-left write ;
+    16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+
+: h-pad. ( digit -- )
+    >hex 2 CHAR: 0 pad-left write ;
+
 : line. ( str n -- )
     offset.
     dup [ h-pad. " " write ] each
-    16 over length - "   " <array> concat write
+    16 over length - 3 * CHAR: \s <string> write
     [ dup printable? [ drop CHAR: . ] unless write1 ] each
     nl ;
 
@@ -19,9 +25,8 @@ PRIVATE>
 : hexdump ( seq -- str )
     [
         dup length header.
-        16 <sliced-groups> dup length [ line. ] 2each
+        16 <sliced-groups> [ line. ] each-index
     ] string-out ;
 
 : hexdump. ( seq -- )
     hexdump write ;
-

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+
@@ -31,6 +31,36 @@ HELP: +environment-mode+
 "Default value is " { $link append-environment } "."
 } ;
 
+HELP: +stdin+
+{ $description "Launch descriptor key. Must equal one of the following:"
+    { $list
+        { { $link f } " - standard input is inherited" }
+        { { $link +closed+ } " - standard input is closed" }
+        { "a path name - standard input is read from the given file, which must exist" }
+    }
+} ;
+
+HELP: +stdout+
+{ $description "Launch descriptor key. Must equal one of the following:"
+    { $list
+        { { $link f } " - standard output is inherited" }
+        { { $link +closed+ } " - standard output is closed" }
+        { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
+    }
+} ;
+
+HELP: +stderr+
+{ $description "Launch descriptor key. Must equal one of the following:"
+    { $list
+        { { $link f } " - standard error is inherited" }
+        { { $link +closed+ } " - standard error is closed" }
+        { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
+    }
+} ;
+
+HELP: +closed+
+{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+
 HELP: prepend-environment
 { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
 $nl
@@ -58,7 +88,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 +103,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."
@@ -105,9 +154,19 @@ $nl
 { $subsection +detached+ }
 { $subsection +environment+ }
 { $subsection +environment-mode+ }
+"Redirecting standard input and output to files:"
+{ $subsection +stdin+ }
+{ $subsection +stdout+ }
+{ $subsection +stderr+ }
 "The following words are used to launch processes:"
 { $subsection run-process }
 { $subsection run-detached }
-{ $subsection <process-stream> } ;
+"Redirecting standard input and output to a pipe:"
+{ $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,14 +1,39 @@
-! 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+
 SYMBOL: +environment+
 SYMBOL: +environment-mode+
+SYMBOL: +stdin+
+SYMBOL: +stdout+
+SYMBOL: +stderr+
+SYMBOL: +closed+
 
 SYMBOL: prepend-environment
 SYMBOL: replace-environment
@@ -42,17 +67,38 @@ GENERIC: >descriptor ( obj -- desc )
 
 M: string >descriptor +command+ associate ;
 M: sequence >descriptor +arguments+ associate ;
-M: assoc >descriptor ;
+M: assoc >descriptor >hashtable ;
 
-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
+    [
+        prepare-resolve-host
         "addrinfo" <c-object>
-    r> [ AI_PASSIVE over set-addrinfo-flags ] when
+        [ set-addrinfo-flags ] keep
         PF_UNSPEC over set-addrinfo-family
         IPPROTO_TCP over set-addrinfo-protocol
         f <void*> [ getaddrinfo addrinfo-error ] keep *void*
         [ parse-addrinfo-list ] keep
-    freeaddrinfo ;
+        freeaddrinfo
+    ] with-scope ;
 
 M: object host-name ( -- name )
     256 <byte-array> dup dup length gethostname

extra/io/unix/bsd/bsd.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.unix.bsd
 USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
-io.unix.launcher namespaces kernel assocs threads continuations
+io.launcher io.unix.launcher namespaces kernel assocs threads 
-;
+continuations ;
 
 ! On *BSD and Mac OS X, we use select() for the top-level
 ! multiplexer, and we hang a kqueue off of it but file change
@@ -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 } io-backend set-global
+T{ bsd-io } set-io-backend

extra/io/unix/epoll/epoll.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel io.nonblocking io.unix.backend
-bit-arrays sequences assocs unix math namespaces structs ;
+bit-arrays sequences assocs unix unix.linux.epoll math
+namespaces structs ;
 IN: io.unix.epoll
 
 TUPLE: epoll-mx events ;
@@ -18,40 +19,44 @@ TUPLE: epoll-mx events ;
 
 GENERIC: io-task-events ( task -- n )
 
-M: input-task drop EPOLLIN ;
+M: input-task io-task-events drop EPOLLIN ;
 
-M: output-task drop EPOLLOUT ;
+M: output-task io-task-events drop EPOLLOUT ;
 
 : make-event ( task -- event )
     "epoll-event" <c-object>
     over io-task-events over set-epoll-event-events
-    over io-task-fd over set-epoll-fd ;
+    swap io-task-fd over set-epoll-event-fd ;
 
 : do-epoll-ctl ( task mx what -- )
-    >r >r make-event r> mx-fd r> pick event-data *int roll
+    >r mx-fd r> rot dup io-task-fd swap make-event
     epoll_ctl io-error ;
 
 M: epoll-mx register-io-task ( task mx -- )
-    EPOLL_CTL_ADD do-epoll-ctl ;
+    2dup EPOLL_CTL_ADD do-epoll-ctl 
+    delegate register-io-task ;
 
 M: epoll-mx unregister-io-task ( task mx -- )
+    2dup delegate unregister-io-task
     EPOLL_CTL_DEL do-epoll-ctl ;
 
-: wait-kevent ( mx timeout -- n )
+: wait-event ( mx timeout -- n )
-    >r mx-fd epoll-mx-events max-events r> epoll_wait
+    >r { mx-fd epoll-mx-events } get-slots max-events
-    dup multiplexer-error ;
+    r> epoll_wait dup multiplexer-error ;
 
 : epoll-read-task ( mx fd -- )
     over mx-reads at* [ handle-io-task ] [ 2drop ] if ;
 
 : epoll-write-task ( mx fd -- )
-    over mx-reads at* [ handle-io-task ] [ 2drop ] if ;
+    over mx-writes at* [ handle-io-task ] [ 2drop ] if ;
 
 : handle-event ( mx kevent -- )
     epoll-event-fd 2dup epoll-read-task epoll-write-task ;
 
 : handle-events ( mx n -- )
-    [ over epoll-mx-events kevent-nth handle-kevent ] with each ;
+    [
+        over epoll-mx-events epoll-event-nth handle-event
+    ] with each ;
 
 M: epoll-mx wait-for-events ( ms mx -- )
-    dup rot wait-kevent handle-kevents ;
+    dup rot wait-event handle-events ;

extra/io/unix/files/files.factor

@@ -4,13 +4,15 @@ USING: io.backend io.nonblocking io.unix.backend io.files io
 unix kernel math continuations ;
 IN: io.unix.files
 
+: read-flags O_RDONLY ; inline
+
 : open-read ( path -- fd )
     O_RDONLY file-mode open dup io-error ;
 
 M: unix-io <file-reader> ( path -- stream )
     open-read <reader> ;
 
-: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ;
+: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; inline
 
 : open-write ( path -- fd )
     write-flags file-mode open dup io-error ;
@@ -18,7 +20,7 @@ M: unix-io <file-reader> ( path -- stream )
 M: unix-io <file-writer> ( path -- stream )
     open-write <writer> ;
 
-: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ;
+: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; inline
 
 : open-append ( path -- fd )
     append-flags file-mode open dup io-error

extra/io/unix/kqueue/kqueue.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel io.nonblocking io.unix.backend
 sequences assocs unix unix.kqueue unix.process math namespaces
-combinators threads vectors ;
+combinators threads vectors io.launcher io.unix.launcher ;
 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 )
@@ -51,16 +50,15 @@ M: kqueue-mx unregister-io-task ( task mx -- )
 : kevent-write-task ( mx fd -- )
     over mx-reads at handle-io-task ;
 
-: kevent-proc-task ( mx pid -- )
+: kevent-proc-task ( 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 {
         { [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
         { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
-        { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+        { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
     } cond ;
 
 : handle-kevents ( mx n -- )
@@ -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

@@ -1,18 +1,15 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.backend io.launcher io.unix.backend io.nonblocking
+USING: io io.backend io.launcher io.unix.backend io.unix.files
-sequences kernel namespaces math system alien.c-types debugger
+io.nonblocking sequences kernel namespaces math system
-continuations arrays assocs combinators unix.process
+ alien.c-types debugger continuations arrays assocs 
-parser-combinators memoize promises strings ;
+combinators unix.process parser-combinators memoize 
+promises strings threads ;
 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,8 +43,25 @@ MEMO: 'arguments' ( -- parser )
 : assoc>env ( assoc -- env )
     [ "=" swap 3append ] { } assoc>map ;
 
-: (spawn-process) ( -- )
+: (redirect) ( path mode fd -- )
+    >r file-mode open dup io-error dup
+    r> dup2 io-error close ;
+
+: redirect ( obj mode fd -- )
+    {
+        { [ pick not ] [ 3drop ] }
+        { [ pick +closed+ eq? ] [ close 2drop ] }
+        { [ pick string? ] [ (redirect) ] }
+    } cond ;
+
+: setup-redirection ( -- )
+    +stdin+ get read-flags 0 redirect
+    +stdout+ get write-flags 1 redirect
+    +stderr+ get write-flags 2 redirect ;
+
+: spawn-process ( -- )
     [
+        setup-redirection
         get-arguments
         pass-environment?
         [ get-environment assoc>env exec-args-with-env ]
@@ -55,20 +69,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 +85,36 @@ 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 )
+    processes get swap [ nip swap process-handle = ] curry
+    assoc-find 2drop ;
+
+! 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 0 <= [
+        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

@@ -1,17 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.unix.linux
-USING: io.unix.backend io.unix.select namespaces kernel assocs ;
+USING: io.backend io.unix.backend io.unix.launcher io.unix.select
+namespaces kernel assocs unix.process ;
 
 TUPLE: linux-io ;
 
 INSTANCE: linux-io unix-io
 
 M: linux-io init-io ( -- )
-    start-wait-loop
+    <select-mx> mx set-global
-    <epoll-mx> mx set-global ;
+    start-wait-thread ;
 
-M: linux-io wait-for-pid ( pid -- status )
+T{ linux-io } set-io-backend
-    [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ;
-
-T{ linux-io } io-backend set-global

extra/io/unix/unix.factor

@@ -5,6 +5,6 @@ system vocabs.loader ;
 {
     { [ bsd? ] [ "io.unix.bsd" ] }
     { [ macosx? ] [ "io.unix.bsd" ] }
-    { [ linux? ] [ "io.unix.backend.linux" ] }
+    { [ linux? ] [ "io.unix.linux" ] }
-    { [ solaris? ] [ "io.unix.backend.solaris" ] }
+    { [ solaris? ] [ "io.unix.solaris" ] }
 } cond require

extra/io/windows/ce/ce.factor

@@ -3,4 +3,4 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
 namespaces io.windows.mmap ;
 IN: io.windows.ce
 
-T{ windows-ce-io } io-backend set-global
+T{ windows-ce-io } set-io-backend

extra/io/windows/launcher/launcher.factor

@@ -1,9 +1,10 @@
-! 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
+io.windows io.windows.pipes libc io.nonblocking
-math windows.kernel32 windows namespaces io.launcher kernel
+io.streams.duplex windows.types math windows.kernel32 windows
-sequences windows.errors assocs splitting system ;
+namespaces io.launcher kernel sequences windows.errors assocs
+splitting system threads init strings combinators io.backend ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args
@@ -19,24 +20,17 @@ 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
     "STARTUPINFO" <c-object>
     "STARTUPINFO" heap-size over set-STARTUPINFO-cb
     "PROCESS_INFORMATION" <c-object>
+    TRUE
     {
-        set-CreateProcess-args-bInheritHandles
         set-CreateProcess-args-dwCreateFlags
         set-CreateProcess-args-lpStartupInfo
         set-CreateProcess-args-lpProcessInformation
+        set-CreateProcess-args-bInheritHandles
     } \ CreateProcess-args construct ;
 
 : call-CreateProcess ( CreateProcess-args -- )
@@ -93,10 +87,58 @@ TUPLE: CreateProcess-args
         over set-CreateProcess-args-lpEnvironment
     ] when ;
 
-: wait-for-process ( args -- )
+: (redirect) ( path access-mode create-mode -- handle )
-    CreateProcess-args-lpProcessInformation
+    >r >r
-    PROCESS_INFORMATION-hProcess INFINITE
+    normalize-pathname
-    WaitForSingleObject drop ;
+    r> ! access-mode
+    share-mode
+    security-attributes-inherit
+    r> ! create-mode
+    FILE_ATTRIBUTE_NORMAL ! flags and attributes
+    f ! template file
+    CreateFile dup invalid-handle? dup close-later ;
+
+: redirect ( obj access-mode create-mode -- handle )
+    {
+        { [ pick not ] [ 3drop f ] }
+        { [ pick +closed+ eq? ] [ 3drop t ] }
+        { [ pick string? ] [ (redirect) ] }
+    } cond ;
+
+: ?closed or dup t eq? [ drop f ] when ;
+
+: inherited-stdout ( args -- handle )
+    CreateProcess-args-stdout-pipe
+    [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
+
+: redirect-stdout ( args -- handle )
+    +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
+    swap inherited-stdout ?closed ;
+
+: inherited-stderr ( args -- handle )
+    drop STD_ERROR_HANDLE GetStdHandle ;
+
+: redirect-stderr ( args -- handle )
+    +stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect
+    swap inherited-stderr ?closed ;
+
+: inherited-stdin ( args -- handle )
+    CreateProcess-args-stdin-pipe
+    [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
+
+: redirect-stdin ( args -- handle )
+    +stdin+ get GENERIC_READ OPEN_EXISTING redirect
+    swap inherited-stdin ?closed ;
+
+: fill-startup-info
+    dup CreateProcess-args-lpStartupInfo
+    STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
+
+    over redirect-stdout over set-STARTUPINFO-hStdOutput
+    over redirect-stderr over set-STARTUPINFO-hStdError
+    over redirect-stdin over set-STARTUPINFO-hStdInput
+
+    drop ;
 
 : make-CreateProcess-args ( -- args )
     default-CreateProcess-args
@@ -104,10 +146,46 @@ TUPLE: CreateProcess-args
     fill-dwCreateFlags
     fill-lpEnvironment ;
 
-M: windows-io run-process* ( desc -- )
+M: windows-io run-process* ( desc -- handle )
     [
-        make-CreateProcess-args
+        [
+            make-CreateProcess-args fill-startup-info
             dup call-CreateProcess
-        +detached+ get [ dup wait-for-process ] unless
+            CreateProcess-args-lpProcessInformation <process>
-        dispose-CreateProcess-args
+        ] with-descriptor
-    ] with-descriptor ;
+    ] with-destructors ;
+
+: 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

@@ -4,7 +4,7 @@ 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 ;
+io.windows.launcher io.windows.pipes ;
 IN: io.windows.nt.launcher
 
 ! The below code is based on the example given in
@@ -30,22 +30,10 @@ IN: io.windows.nt.launcher
     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
@@ -59,6 +47,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/io/windows/nt/nt.factor

@@ -9,4 +9,4 @@ USE: io.windows.mmap
 USE: io.backend
 USE: namespaces
 
-T{ windows-nt-io } io-backend set-global
+T{ windows-nt-io } set-io-backend

extra/io/windows/pipes/pipes.factor

@@ -3,19 +3,11 @@
 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
+IN: io.windows.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

extra/io/windows/windows.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.nonblocking io.sockets io.binary
 io.sockets.impl windows.errors strings io.streams.duplex kernel
 math namespaces sequences windows windows.kernel32
-windows.shell32 windows.winsock splitting ;
+windows.shell32 windows.types windows.winsock splitting ;
 IN: io.windows
 
 TUPLE: windows-nt-io ;
@@ -34,6 +34,14 @@ M: windows-io normalize-directory ( string -- string )
     FILE_SHARE_READ FILE_SHARE_WRITE bitor
     FILE_SHARE_DELETE bitor ; foldable
 
+: 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
+
 M: win32-file init-handle ( handle -- )
     drop ;
 

extra/math/constants/constants-docs.factor

@@ -4,6 +4,8 @@ IN: math.constants
 ARTICLE: "math-constants" "Constants"
 "Standard mathematical constants:"
 { $subsection e }
+{ $subsection gamma }
+{ $subsection phi }
 { $subsection pi }
 "Various limits:"
 { $subsection most-positive-fixnum }
@@ -15,6 +17,13 @@ ABOUT: "math-constants"
 HELP: e
 { $values { "e" "base of natural logarithm" } } ;
 
+HELP: gamma
+{ $values { "gamma" "Euler-Mascheroni constant" } }
+{ $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ;
+
+HELP: phi
+{ $values { "phi" "golden ratio" } } ;
+
 HELP: pi
 { $values { "pi" "circumference of circle with diameter 1" } } ;
 

extra/math/constants/constants.factor

@@ -3,5 +3,7 @@
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
+: gamma ( -- gamma ) 0.57721566490153286060 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
+: phi ( -- phi ) 1.61803398874989484820 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

extra/math/miller-rabin/miller-rabin-tests.factor

@@ -1,4 +1,5 @@
-USING: math.miller-rabin kernel math namespaces tools.test ;
+USING: math.miller-rabin tools.test ;
+IN: temporary
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
 [ t ] [ 2 miller-rabin ] unit-test
@@ -7,4 +8,3 @@ USING: math.miller-rabin kernel math namespaces tools.test ;
 [ t ] [ 37 miller-rabin ] unit-test
 [ 101 ] [ 100 next-prime ] unit-test
 [ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
-

extra/math/miller-rabin/summary.txt

@@ -0,0 +1 @@
+Miller-Rabin probabilistic primality test

extra/math/text/english/english.factor

@@ -12,10 +12,10 @@ IN: math.text.english
     "Seventeen" "Eighteen" "Nineteen" } nth ;
 
 : tens ( n -- str )
-    { "" "" "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
+    { f f "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
 
 : scale-numbers ( n -- str )  ! up to 10^99
-    { "" "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
+    { f "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
     "Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion"
     "Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion"
     "Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion"
@@ -45,7 +45,7 @@ SYMBOL: and-needed?
 
 : tens-place ( n -- str )
     100 mod dup 20 >= [
-        10 /mod >r tens r>
+        10 /mod [ tens ] dip
         dup zero? [ drop ] [ "-" swap small-numbers 3append ] if
     ] [
         dup zero? [ drop "" ] [ small-numbers ] if
@@ -97,3 +97,4 @@ PRIVATE>
     ] [
         [ (number>text) ] with-scope
     ] if ;
+

extra/math/text/summary.txt

@@ -0,0 +1 @@
+Convert integers to text in multiple languages

extra/project-euler/002/002.factor

@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences shuffle ;
 IN: project-euler.002
 
 ! http://projecteuler.net/index.php?section=problems&id=2
@@ -22,12 +22,12 @@ IN: project-euler.002
 <PRIVATE
 
 : (fib-upto) ( seq n limit -- seq )
-    2dup <= [ >r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ;
+    2dup <= [ [ over push dup 2 tail* sum ] dip (fib-upto) ] [ 2drop ] if ;
 
 PRIVATE>
 
 : fib-upto ( n -- seq )
-    { 0 } 1 rot (fib-upto) ;
+    V{ 0 } clone 1 rot (fib-upto) ;
 
 : euler002 ( -- answer )
     1000000 fib-upto [ even? ] subset sum ;
@@ -35,4 +35,18 @@ PRIVATE>
 ! [ euler002 ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials
 
-MAIN: euler002
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+: fib-upto* ( n -- seq )
+    0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
+    1 head-slice* { 0 1 } swap append ;
+
+: euler002a ( -- answer )
+    1000000 fib-upto* [ even? ] subset sum ;
+
+! [ euler002a ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler002a

extra/project-euler/023/023.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables kernel math math.ranges project-euler.common sequences
     sorting ;

extra/project-euler/024/024.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.parser math.ranges namespaces sequences ;
 IN: project-euler.024

extra/project-euler/025/025.factor

@@ -1,7 +1,7 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math math.functions math.parser math.ranges memoize
+USING: alien.syntax kernel math math.constants math.functions math.parser
-    project-euler.common sequences ;
+    math.ranges memoize project-euler.common sequences ;
 IN: project-euler.025
 
 ! http://projecteuler.net/index.php?section=problems&id=25
@@ -67,9 +67,6 @@ PRIVATE>
 
 <PRIVATE
 
-: phi ( -- phi )
-    5 sqrt 1+ 2 / ;
-
 : digit-fib* ( n -- term )
     1- 5 log10 2 / + phi log10 / ceiling >integer ;
 

extra/project-euler/026/026.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.functions math.primes math.ranges sequences ;
 IN: project-euler.026

extra/project-euler/027/027.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.primes project-euler.common sequences ;
 IN: project-euler.027

extra/project-euler/028/028.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.lib kernel math math.ranges ;
 IN: project-euler.028

extra/project-euler/029/029.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables kernel math.functions math.ranges project-euler.common
     sequences ;

extra/project-euler/030/030.factor

@@ -0,0 +1,46 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math math.functions project-euler.common sequences ;
+IN: project-euler.030
+
+! http://projecteuler.net/index.php?section=problems&id=30
+
+! DESCRIPTION
+! -----------
+
+! Surprisingly there are only three numbers that can be written as the sum of
+! fourth powers of their digits:
+
+!     1634 = 1^4 + 6^4 + 3^4 + 4^4
+!     8208 = 8^4 + 2^4 + 0^4 + 8^4
+!     9474 = 9^4 + 4^4 + 7^4 + 4^4
+
+!     As 1 = 1^4 is not a sum it is not included.
+
+! The sum of these numbers is 1634 + 8208 + 9474 = 19316.
+
+! Find the sum of all the numbers that can be written as the sum of fifth
+! powers of their digits.
+
+
+! SOLUTION
+! --------
+
+! if n is the number of digits
+! n * 9^5 = 10^n  when n ≈ 5.513
+! 10^5.513 ≈ 325537
+
+<PRIVATE
+
+: sum-fifth-powers ( n -- sum )
+    number>digits [ 5 ^ ] sigma ;
+
+PRIVATE>
+
+: euler030 ( -- answer )
+    325537 [ dup sum-fifth-powers = ] subset sum 1- ;
+
+! [ euler030 ] 100 ave-time
+! 2537 ms run / 125 ms GC ave time - 100 trials
+
+MAIN: euler030

extra/project-euler/031/031.factor

@@ -0,0 +1,63 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math ;
+IN: project-euler.031
+
+! http://projecteuler.net/index.php?section=problems&id=31
+
+! DESCRIPTION
+! -----------
+
+! In England the currency is made up of pound, £, and pence, p, and there are
+! eight coins in general circulation:
+
+!     1p, 2p, 5p, 10p, 20p, 50p, £1 (100p) and £2 (200p).
+
+! It is possible to make £2 in the following way:
+
+!     1×£1 + 1×50p + 2×20p + 1×5p + 1×2p + 3×1p
+
+! How many different ways can £2 be made using any number of coins?
+
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: 1p ( m -- n )
+    drop 1 ;
+
+: 2p ( m -- n )
+    dup 0 >= [ [ 2 - 2p ] keep 1p + ] [ drop 0 ] if ;
+
+: 5p ( m -- n )
+    dup 0 >= [ [ 5 - 5p ] keep 2p + ] [ drop 0 ] if ;
+
+: 10p ( m -- n )
+    dup 0 >= [ [ 10 - 10p ] keep 5p + ] [ drop 0 ] if ;
+
+: 20p ( m -- n )
+    dup 0 >= [ [ 20 - 20p ] keep 10p + ] [ drop 0 ] if ;
+
+: 50p ( m -- n )
+    dup 0 >= [ [ 50 - 50p ] keep 20p + ] [ drop 0 ] if ;
+
+: 100p ( m -- n )
+    dup 0 >= [ [ 100 - 100p ] keep 50p + ] [ drop 0 ] if ;
+
+: 200p ( m -- n )
+    dup 0 >= [ [ 200 - 200p ] keep 100p + ] [ drop 0 ] if ;
+
+PRIVATE>
+
+: euler031 ( -- answer )
+    200 200p ;
+
+! [ euler031 ] 100 ave-time
+! 4 ms run / 0 ms GC ave time - 100 trials
+
+! TODO: generalize to eliminate duplication; use a sequence to specify denominations?
+
+MAIN: euler031

extra/project-euler/032/032.factor

@@ -0,0 +1,81 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib hashtables kernel math math.combinatorics math.parser
+    math.ranges project-euler.common project-euler.024 sequences sorting ;
+IN: project-euler.032
+
+! http://projecteuler.net/index.php?section=problems&id=32
+
+! DESCRIPTION
+! -----------
+
+! The product 7254 is unusual, as the identity, 39 × 186 = 7254, containing
+! multiplicand, multiplier, and product is 1 through 9 pandigital.
+
+! Find the sum of all products whose multiplicand/multiplier/product identity
+! can be written as a 1 through 9 pandigital.
+
+! HINT: Some products can be obtained in more than one way so be sure to only
+! include it once in your sum.
+
+
+! SOLUTION
+! --------
+
+! Generate all pandigital numbers and then check if they fit the identity
+
+<PRIVATE
+
+: source-032 ( -- seq )
+    9 factorial [ 9 permutation [ 1+ ] map 10 swap digits>integer ] map ;
+
+: 1and4 ( n -- ? )
+    number>string 1 cut-slice 4 cut-slice
+    [ 10 string>integer ] 3apply [ * ] dip = ;
+
+: 2and3 ( n -- ? )
+    number>string 2 cut-slice 3 cut-slice
+    [ 10 string>integer ] 3apply [ * ] dip = ;
+
+: valid? ( n -- ? )
+    dup 1and4 swap 2and3 or ;
+
+: products ( seq -- m )
+    [ number>string 4 tail* 10 string>integer ] map ;
+
+PRIVATE>
+
+: euler032 ( -- answer )
+    source-032 [ valid? ] subset products prune sum ;
+
+! [ euler032 ] 10 ave-time
+! 27609 ms run / 2484 ms GC ave time - 10 trials
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! Generate all reasonable multiplicand/multiplier pairs, then multiply and see
+! if the equation is pandigital
+
+<PRIVATE
+
+: source-032a ( -- seq )
+    50 [1,b] 2000 [1,b] cartesian-product ;
+
+: pandigital? ( n -- ? )
+    number>string natural-sort "123456789" = ;
+
+! multiplicand/multiplier/product
+: mmp ( pair -- n )
+    first2 2dup * [ number>string ] 3apply 3append 10 string>integer ;
+
+PRIVATE>
+
+: euler032a ( -- answer )
+    source-032a [ mmp ] map [ pandigital? ] subset products prune sum ;
+
+! [ euler032a ] 100 ave-time
+! 5978 ms run / 327 ms GC ave time - 100 trials
+
+MAIN: euler032a

extra/project-euler/common/common.factor

@@ -11,7 +11,7 @@ IN: project-euler.common
 ! collect-consecutive - #8, #11
 ! log10 - #25, #134
 ! max-path - #18, #67
-! number>digits - #16, #20
+! number>digits - #16, #20, #30
 ! propagate-all - #18, #67
 ! sum-proper-divisors - #21
 ! tau* - #12

extra/project-euler/project-euler.factor

@@ -9,8 +9,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs
     project-euler.017 project-euler.018 project-euler.019 project-euler.020
     project-euler.021 project-euler.022 project-euler.023 project-euler.024
     project-euler.025 project-euler.026 project-euler.027 project-euler.028
-    project-euler.029 project-euler.067 project-euler.134 project-euler.169
+    project-euler.029 project-euler.030 project-euler.067 project-euler.134
-    project-euler.173 project-euler.175 ;
+    project-euler.169 project-euler.173 project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

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/tools/test/test-docs.factor

@@ -6,7 +6,7 @@ ARTICLE: "tools.test" "Unit testing"
 $nl
 "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
 $nl
-"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } " -tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
+"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
 $nl
 "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:"
 { $subsection unit-test }

extra/unix/linux/epoll/epoll.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: unix.linux.epoll
-USING: alien.syntax ;
+USING: alien.syntax math ;
 
 FUNCTION: int epoll_create ( int size ) ;
 
@@ -9,7 +9,8 @@ FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
 
 C-STRUCT: epoll-event
     { "uint" "events" }
-    { "uint" "fd" } ;
+    { "uint" "fd" }
+    { "uint" "padding" } ;
 
 FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
 

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/unix/unix.factor

@@ -13,7 +13,7 @@ TYPEDEF: longlong quad_t
 TYPEDEF: uint gid_t
 TYPEDEF: uint in_addr_t
 TYPEDEF: uint ino_t
-TYPEDEF: uint pid_t
+TYPEDEF: int pid_t
 TYPEDEF: uint socklen_t
 TYPEDEF: uint time_t
 TYPEDEF: uint uid_t

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 ;