Merge erg@factorcode.org:/git/erg

Conflicts:

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

core/bootstrap/stage2.factor

@@ -48,7 +48,11 @@ IN: bootstrap.stage2
 
         "Compiling remaining words..." print flush
 
-        all-words [ compiled? not ] subset recompile-hook get call
+        "bootstrap.compiler" vocab [
+            vocabs [
+                words "compile" "compiler" lookup execute
+            ] each
+        ] when
     ] with-compiler-errors
 
     f error set-global

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
@@ -205,3 +205,36 @@ DEFER: generic-then-not-generic-test-2
 [ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
 
 [ 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
+
+[ 4 ] [ foldable-test-2 ] unit-test
+
+DEFER: flushable-test-2
+
+[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
+
+[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
+
+[ V{ } ] [ flushable-test-2 ] unit-test
+
+[ ] [ "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/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/math/math-docs.factor

@@ -209,7 +209,7 @@ HELP: bitxor
 
 HELP: shift
 { $values { "x" integer } { "n" integer } { "y" integer } }
-{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
+{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
 { $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ;
 
 HELP: bitnot

core/optimizer/backend/backend.factor

@@ -17,17 +17,17 @@ SYMBOL: optimizer-changed
 
 GENERIC: optimize-node* ( node -- node/t changed? )
 
-: ?union ( hash/f hash -- hash )
+: ?union ( assoc/f assoc -- hash )
     over [ union ] [ nip ] if ;
 
-: add-node-literals ( hash node -- )
+: add-node-literals ( assoc node -- )
     over assoc-empty? [
         2drop
     ] [
         [ node-literals ?union ] keep set-node-literals
     ] if ;
 
-: add-node-classes ( hash node -- )
+: add-node-classes ( assoc node -- )
     over assoc-empty? [
         2drop
     ] [
@@ -324,6 +324,7 @@ M: #dispatch optimize-node*
     ] if ;
 
 : flush-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
     dup node-out-d length f <repetition> inline-literals ;
 
 : partial-eval? ( #call -- ? )
@@ -337,9 +338,9 @@ M: #dispatch optimize-node*
     dup node-in-d [ node-literal ] with map ;
 
 : partial-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
     dup literal-in-d over node-param 1quotation
-    [ with-datastack ] catch
+    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
-    [ 3drop t ] [ inline-literals ] if ;
 
 : define-identities ( words identities -- )
     [ "identities" set-word-prop ] curry each ;

core/parser/parser-docs.factor

@@ -44,8 +44,7 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
 "If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
 { $list
     { "If there are no words having this name at all, an error is thrown and parsing stops." }
-    { "If there is exactly one vocabulary having a word with this name, the vocabulary is automatically added to the search path. This behavior is intended for interactive use and exploratory programming only, and production code should contain full " { $link POSTPONE: USING: } " declarations." }
+    { "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
-    { "If there is more than one vocabulary which contains a word with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
 }
 "When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
 

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-tests.factor

@@ -175,3 +175,14 @@ SYMBOL: quot-uses-b
 
 [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
 [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
+
+! Regressions
+[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test
+[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
+[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
+[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
+
+[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test
+[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
+[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
+[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test

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 ;
 
@@ -127,7 +146,7 @@ SYMBOL: changed-words
 : reset-word ( word -- )
     {
         "unannotated-def"
-        "parsing" "inline" "foldable"
+        "parsing" "inline" "foldable" "flushable"
         "predicating"
         "reading" "writing"
         "constructing"
@@ -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>
+        [ display ] <slate>
-    { 600 600 } over set-slate-dim
+        { 600 600 } over set-slate-dim
-    "Golden Section" open-window
+        "Golden Section" open-window
-] with-ui ;
+    ] with-ui ;
 
-MAIN: golden-section-window
+MAIN: golden-section-window

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

@@ -1,5 +1,5 @@
 USING: io io.buffers io.backend help.markup help.syntax kernel
-strings sbufs ;
+strings sbufs words ;
 IN: io.nonblocking
 
 ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
@@ -40,7 +40,7 @@ $nl
     { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
     { { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
     { { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
-    { { $link port-type } " - a symbol identifying the port's intended purpose. Can be " { $link input } ", " { $link output } ", " { $link closed } ", or any other symbol" }
+    { { $link port-type } " - a symbol identifying the port's intended purpose" }
     { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
 } } ;
 
@@ -55,7 +55,7 @@ HELP: init-handle
 { $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
 
 HELP: <port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "port" "a new " { $link port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
 { $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
 $low-level-note ;
 

extra/io/nonblocking/nonblocking.factor

@@ -12,38 +12,36 @@ SYMBOL: default-buffer-size
 ! Common delegate of native stream readers and writers
 TUPLE: port handle error timeout cutoff type eof? ;
 
-SYMBOL: input
-SYMBOL: output
 SYMBOL: closed
 
-PREDICATE: port input-port port-type input eq? ;
+PREDICATE: port input-port port-type input-port eq? ;
-PREDICATE: port output-port port-type output eq? ;
+PREDICATE: port output-port port-type output-port eq? ;
 
 GENERIC: init-handle ( handle -- )
 GENERIC: close-handle ( handle -- )
 
-: <port> ( handle buffer -- port )
+: <port> ( handle buffer type -- port )
-    over init-handle
+    pick init-handle
     0 0 {
         set-port-handle
         set-delegate
+        set-port-type
         set-port-timeout
         set-port-cutoff
     } port construct ;
 
-: <buffered-port> ( handle -- port )
+: <buffered-port> ( handle type -- port )
-    default-buffer-size get <buffer> <port> ;
+    default-buffer-size get <buffer> swap <port> ;
 
 : <reader> ( handle -- stream )
-    <buffered-port> input over set-port-type <line-reader> ;
+    input-port <buffered-port> <line-reader> ;
 
 : <writer> ( handle -- stream )
-    <buffered-port> output over set-port-type <plain-writer> ;
+    output-port <buffered-port> <plain-writer> ;
 
 : handle>duplex-stream ( in-handle out-handle -- stream )
     <writer>
-    [ >r <reader> r> <duplex-stream> ]
+    [ >r <reader> r> <duplex-stream> ] [ ] [ stream-close ]
-    [ ] [ stream-close ]
     cleanup ;
 
 : touch-port ( port -- )
@@ -162,7 +160,7 @@ M: output-port stream-flush ( port -- )
 M: port stream-close
     dup port-type closed eq? [
         dup port-type >r closed over set-port-type r>
-        output eq? [ dup port-flush ] when
+        output-port eq? [ dup port-flush ] when
         dup port-handle close-handle
         dup delegate [ buffer-free ] when*
         f over set-delegate
@@ -170,8 +168,8 @@ M: port stream-close
 
 TUPLE: server-port addr client ;
 
-: <server-port> ( port addr -- server )
+: <server-port> ( handle addr -- server )
-    server-port pick set-port-type
+    >r f server-port <port> r>
     { set-delegate set-server-port-addr }
     server-port construct ;
 
@@ -180,8 +178,8 @@ TUPLE: server-port addr client ;
 
 TUPLE: datagram-port addr packet packet-addr ;
 
-: <datagram-port> ( port addr -- datagram )
+: <datagram-port> ( handle addr -- datagram )
-    datagram-port pick set-port-type
+    >r f datagram-port <port> r>
     { set-delegate set-datagram-port-addr }
     datagram-port construct ;
 

extra/io/sniffer/bsd/bsd.factor

@@ -83,7 +83,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
         ] keep
         dupd sniffer-spec-ifname ioctl-sniffer-fd
         dup make-ioctl-buffer
-        <port> input over set-port-type <line-reader>
+        input-port <port> <line-reader>
         \ sniffer construct-delegate
     ] with-destructors ;
 

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

@@ -7,19 +7,60 @@ continuations system libc qualified namespaces ;
 QUALIFIED: io
 IN: io.unix.backend
 
-! Multiplexer protocol
+MIXIN: unix-io
-SYMBOL: unix-io-backend
 
-HOOK: init-unix-io unix-io-backend ( -- )
+! I/O tasks
-HOOK: register-io-task unix-io-backend ( task -- )
+TUPLE: io-task port callbacks ;
-HOOK: unregister-io-task unix-io-backend ( task -- )
-HOOK: unix-io-multiplex unix-io-backend ( timeval -- )
 
-TUPLE: unix-io ;
+: io-task-fd io-task-port port-handle ;
 
-! Global variables
+: <io-task> ( port continuation class -- task )
-SYMBOL: read-tasks
+    >r 1vector io-task construct-boa r> construct-delegate ;
-SYMBOL: write-tasks
+    inline
+
+TUPLE: input-task ;
+
+: <input-task> ( port continuation class -- task )
+    >r input-task <io-task> r> construct-delegate ; inline
+
+TUPLE: output-task ;
+
+: <output-task> ( port continuation class -- task )
+    >r output-task <io-task> r> construct-delegate ; inline
+
+GENERIC: do-io-task ( task -- ? )
+GENERIC: io-task-container ( mx task -- hashtable )
+
+! I/O multiplexers
+TUPLE: mx fd reads writes ;
+
+M: input-task io-task-container drop mx-reads ;
+
+M: output-task io-task-container drop mx-writes ;
+
+: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
+
+: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
+
+GENERIC: register-io-task ( task mx -- )
+GENERIC: unregister-io-task ( task mx -- )
+GENERIC: wait-for-events ( ms mx -- )
+
+: fd/container ( task mx -- task fd container )
+    over io-task-container >r dup io-task-fd r> ; inline
+
+: check-io-task ( task mx -- )
+    fd/container key? nip [
+        "Cannot perform multiple reads from the same port" throw
+    ] when ;
+
+M: mx register-io-task ( task mx -- )
+    2dup check-io-task fd/container set-at ;
+
+: add-io-task ( task -- ) mx get-global register-io-task ;
+
+M: mx unregister-io-task ( task mx -- )
+    fd/container delete-at drop ;
 
 ! Some general stuff
 : file-mode OCT: 0666 ;
@@ -52,43 +93,15 @@ M: integer close-handle ( fd -- )
     err_no dup ignorable-error?
     [ 2drop f ] [ strerror swap report-error t ] if ;
 
-! Associates a port with a list of continuations waiting on the
+: pop-callbacks ( mx task -- )
-! port to finish I/O
+    dup rot unregister-io-task
-TUPLE: io-task port callbacks ;
-
-: <io-task> ( port continuation class -- task )
-    >r 1vector io-task construct-boa r> construct-delegate ;
-    inline
-
-! Multiplexer
-GENERIC: do-io-task ( task -- ? )
-GENERIC: task-container ( task -- vector )
-
-: io-task-fd io-task-port port-handle ;
-
-: check-io-task ( task -- )
-    dup io-task-fd swap task-container at [
-        "Cannot perform multiple reads from the same port" throw
-    ] when ;
-
-: add-io-task ( task -- )
-    dup check-io-task
-    dup register-io-task
-    dup io-task-fd over task-container set-at ;
-
-: remove-io-task ( task -- )
-    dup io-task-fd over task-container delete-at
-    unregister-io-task ;
-
-: pop-callbacks ( task -- )
-    dup remove-io-task
     io-task-callbacks [ schedule-thread ] each ;
 
-: handle-fd ( task -- )
+: handle-io-task ( mx task -- )
     dup io-task-port touch-port
-    dup do-io-task [ pop-callbacks ] [ drop ] if ;
+    dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
 
-: handle-timeout ( task -- )
+: handle-timeout ( mx task -- )
     "Timeout" over io-task-port report-error pop-callbacks ;
 
 ! Readers
@@ -113,15 +126,12 @@ GENERIC: task-container ( task -- vector )
 TUPLE: read-task ;
 
 : <read-task> ( port continuation -- task )
-    read-task <io-task> ;
+    read-task <input-task> ;
 
 M: read-task do-io-task
     io-task-port dup refill
     [ [ reader-eof ] [ drop ] if ] keep ;
 
-M: read-task task-container
-    drop read-tasks get-global ;
-
 M: input-port (wait-to-read)
     [ <read-task> add-io-task stop ] callcc0 pending-error ;
 
@@ -133,19 +143,16 @@ M: input-port (wait-to-read)
 TUPLE: write-task ;
 
 : <write-task> ( port continuation -- task )
-    write-task <io-task> ;
+    write-task <output-task> ;
 
 M: write-task do-io-task
     io-task-port dup buffer-empty? over port-error or
     [ 0 swap buffer-reset t ] [ write-step ] if ;
 
-M: write-task task-container
-    drop write-tasks get-global ;
-
 : add-write-io-task ( port continuation -- )
-    over port-handle write-tasks get-global at
+    over port-handle mx get-global mx-writes at*
     [ io-task-callbacks push drop ]
-    [ <write-task> add-io-task ] if* ;
+    [ drop <write-task> add-io-task ] if ;
 
 : (wait-to-write) ( port -- )
     [ add-write-io-task stop ] callcc0 drop ;
@@ -154,16 +161,26 @@ M: port port-flush ( port -- )
     dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
 
 M: unix-io io-multiplex ( ms -- )
-    unix-io-multiplex ;
+    mx get-global wait-for-events ;
-
-M: unix-io init-io ( -- )
-    H{ } clone read-tasks set-global
-    H{ } clone write-tasks set-global
-    init-unix-io ;
 
 M: unix-io init-stdio ( -- )
     0 1 handle>duplex-stream io:stdio set-global
     2 <writer> io:stderr set-global ;
 
+! mx io-task for embedding an fd-based mx inside another mx
+TUPLE: mx-port mx ;
+
+: <mx-port> ( mx -- port )
+    dup mx-fd f mx-port <port>
+    { set-mx-port-mx set-delegate } mx-port construct ;
+
+TUPLE: mx-task ;
+
+: <mx-task> ( port -- task )
+    f io-task construct-boa mx-task construct-delegate ;
+
+M: mx-task do-io-task
+    io-task-port mx-port-mx 0 swap wait-for-events f ;
+
 : multiplexer-error ( n -- )
     0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;

extra/io/unix/backend/kqueue/kqueue.factor

@@ -1,106 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel io.nonblocking io.unix.backend
-io.unix.sockets sequences assocs unix unix.kqueue math
-namespaces classes combinators ;
-IN: io.unix.backend.kqueue
-
-TUPLE: unix-kqueue-io ;
-
-! Global variables
-SYMBOL: kqueue-fd
-SYMBOL: kqueue-added
-SYMBOL: kqueue-deleted
-SYMBOL: kqueue-events
-
-: max-events ( -- n )
-    #! We read up to 256 events at a time. This is an arbitrary
-    #! constant...
-    256 ; inline
-
-M: unix-kqueue-io init-unix-io ( -- )
-    H{ } clone kqueue-added set-global
-    H{ } clone kqueue-deleted set-global
-    max-events "kevent" <c-array> kqueue-events set-global
-    kqueue dup io-error kqueue-fd set-global ;
-
-M: unix-kqueue-io register-io-task ( task -- )
-    dup io-task-fd kqueue-added get-global key? [ drop ] [
-        dup io-task-fd kqueue-deleted get-global key? [
-            io-task-fd kqueue-deleted get-global delete-at
-        ] [
-            dup io-task-fd kqueue-added get-global set-at
-        ] if
-    ] if ;
-
-M: unix-kqueue-io unregister-io-task ( task -- )
-    dup io-task-fd kqueue-deleted get-global key? [ drop ] [
-        dup io-task-fd kqueue-added get-global key? [
-            io-task-fd kqueue-added get-global delete-at
-        ] [
-            dup io-task-fd kqueue-deleted get-global set-at
-        ] if
-    ] if ;
-
-: io-task-filter ( task -- n )
-    class {
-        { read-task    [ EVFILT_READ  ] }
-        { accept-task  [ EVFILT_READ  ] }
-        { receive-task [ EVFILT_READ  ] }
-        { write-task   [ EVFILT_WRITE ] }
-        { connect-task [ EVFILT_WRITE ] }
-        { send-task    [ EVFILT_WRITE ] }
-    } case ;
-
-: make-kevent ( task -- event )
-    "kevent" <c-object>
-    over io-task-fd over set-kevent-ident
-    swap io-task-filter over set-kevent-filter ;
-
-: make-add-kevent ( task -- event )
-    make-kevent
-    EV_ADD over set-kevent-flags ;
-
-: make-delete-kevent ( task -- event )
-    make-kevent
-    EV_DELETE over set-kevent-flags ;
-
-: kqueue-additions ( -- kevents )
-    kqueue-added get-global
-    dup clear-assoc values
-    [ make-add-kevent ] map ;
-
-: kqueue-deletions ( -- kevents )
-    kqueue-deleted get-global
-    dup clear-assoc values
-    [ make-delete-kevent ] map ;
-
-: kqueue-changelist ( -- byte-array n )
-    kqueue-additions kqueue-deletions append
-    dup concat f like swap length ;
-
-: kqueue-eventlist ( -- byte-array n )
-    kqueue-events get-global max-events ;
-
-: do-kevent ( timespec -- n )
-    >r
-    kqueue-fd get-global
-    kqueue-changelist
-    kqueue-eventlist
-    r> kevent dup multiplexer-error ;
-
-: kevent-task ( kevent -- task )
-    dup kevent-ident swap kevent-filter {
-        { [ dup EVFILT_READ = ] [ read-tasks ] }
-        { [ dup EVFILT_WRITE = ] [ write-tasks ] }
-    } cond nip get at ;
-
-: handle-kevents ( n eventlist -- )
-    [ kevent-nth kevent-task handle-fd ] curry each ;
-
-M: unix-kqueue-io unix-io-multiplex ( ms -- )
-    make-timespec
-    do-kevent
-    kqueue-events get-global handle-kevents ;
-
-T{ unix-kqueue-io } unix-io-backend set-global

extra/io/unix/backend/select/select.factor

@@ -1,52 +0,0 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel io.nonblocking io.unix.backend
-bit-arrays sequences assocs unix math namespaces structs ;
-IN: io.unix.backend.select
-
-TUPLE: unix-select-io ;
-
-! Global variables
-SYMBOL: read-fdset
-SYMBOL: write-fdset
-
-M: unix-select-io init-unix-io ( -- )
-    FD_SETSIZE 8 * <bit-array> read-fdset set-global
-    FD_SETSIZE 8 * <bit-array> write-fdset set-global ;
-
-: handle-fdset ( fdset tasks -- )
-    swap [
-        swap dup io-task-port timeout? [
-            nip handle-timeout
-        ] [
-            tuck io-task-fd swap nth
-            [ handle-fd ] [ drop ] if
-        ] if drop
-    ] curry assoc-each ;
-
-: init-fdset ( fdset tasks -- )
-    swap dup clear-bits
-    [ >r drop t swap r> set-nth ] curry assoc-each ;
-
-: read-fdset/tasks
-    read-fdset get-global read-tasks get-global ;
-
-: write-fdset/tasks
-    write-fdset get-global write-tasks get-global ;
-
-: init-fdsets ( -- read write except )
-    read-fdset/tasks dupd init-fdset
-    write-fdset/tasks dupd init-fdset
-    f ;
-
-M: unix-select-io register-io-task ( task -- ) drop ;
-
-M: unix-select-io unregister-io-task ( task -- ) drop ;
-
-M: unix-select-io unix-io-multiplex ( timeval -- )
-    make-timeval >r FD_SETSIZE init-fdsets r>
-    select multiplexer-error
-    read-fdset/tasks handle-fdset
-    write-fdset/tasks handle-fdset ;
-
-T{ unix-select-io } unix-io-backend set-global

extra/io/unix/bsd/bsd.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Slava Pestov.
+! 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
+;
+
+! 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
+! notification and process exit notification.
+
+! kqueue is buggy with files and ptys so we can't use it as the
+! main multiplexer.
+
+TUPLE: bsd-io ;
+
+INSTANCE: bsd-io unix-io
+
+M: bsd-io init-io ( -- )
+    <select-mx> mx set-global
+    <kqueue-mx> kqueue-mx set-global
+    kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
+    2dup mx get-global mx-reads set-at
+    mx get-global mx-writes set-at ;
+
+M: bsd-io register-process ( process -- )
+    process-handle kqueue-mx get-global add-pid-task ;
+
+T{ bsd-io } set-io-backend

extra/io/unix/epoll/epoll.factor

@@ -0,0 +1,62 @@
+! 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 unix.linux.epoll math
+namespaces structs ;
+IN: io.unix.epoll
+
+TUPLE: epoll-mx events ;
+
+: max-events ( -- n )
+    #! We read up to 256 events at a time. This is an arbitrary
+    #! constant...
+    256 ; inline
+
+: <epoll-mx> ( -- mx )
+    epoll-mx construct-mx
+    max-events epoll_create dup io-error over set-mx-fd
+    max-events "epoll-event" <c-array> over set-epoll-mx-events ;
+
+GENERIC: io-task-events ( task -- n )
+
+M: input-task io-task-events drop EPOLLIN ;
+
+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
+    swap io-task-fd over set-epoll-event-fd ;
+
+: do-epoll-ctl ( task mx what -- )
+    >r mx-fd r> rot dup io-task-fd swap make-event
+    epoll_ctl io-error ;
+
+M: epoll-mx register-io-task ( task mx -- )
+    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-event ( mx timeout -- n )
+    >r { mx-fd epoll-mx-events } get-slots max-events
+    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-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 epoll-event-nth handle-event
+    ] with each ;
+
+M: epoll-mx wait-for-events ( ms mx -- )
+    dup rot wait-event handle-events ;

extra/io/unix/kqueue/kqueue.factor

@@ -0,0 +1,78 @@
+! Copyright (C) 2008 Slava Pestov.
+! 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 ;
+IN: io.unix.kqueue
+
+TUPLE: kqueue-mx events ;
+
+: max-events ( -- n )
+    #! We read up to 256 events at a time. This is an arbitrary
+    #! constant...
+    256 ; inline
+
+: <kqueue-mx> ( -- mx )
+    kqueue-mx construct-mx
+    kqueue dup io-error over set-mx-fd
+    max-events "kevent" <c-array> over set-kqueue-mx-events ;
+
+GENERIC: io-task-filter ( task -- n )
+
+M: input-task io-task-filter drop EVFILT_READ ;
+
+M: output-task io-task-filter drop EVFILT_WRITE ;
+
+: make-kevent ( task flags -- event )
+    "kevent" <c-object>
+    tuck set-kevent-flags
+    over io-task-fd over set-kevent-ident
+    swap io-task-filter over set-kevent-filter ;
+
+: register-kevent ( kevent mx -- )
+    mx-fd swap 1 f 0 f kevent io-error ;
+
+M: kqueue-mx register-io-task ( task mx -- )
+    over EV_ADD make-kevent over register-kevent
+    delegate register-io-task ;
+
+M: kqueue-mx unregister-io-task ( task mx -- )
+    2dup delegate unregister-io-task
+    swap EV_DELETE make-kevent swap register-kevent ;
+
+: wait-kevent ( mx timespec -- n )
+    >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
+    dup multiplexer-error ;
+
+: kevent-read-task ( mx fd -- )
+    over mx-reads at handle-io-task ;
+
+: kevent-write-task ( mx fd -- )
+    over mx-reads at handle-io-task ;
+
+: kevent-proc-task ( mx pid -- )
+    dup (wait-for-pid) swap find-process
+    dup [ notify-exit ] [ 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 ] }
+    } cond ;
+
+: handle-kevents ( mx n -- )
+    [ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
+
+M: kqueue-mx wait-for-events ( ms mx -- )
+    swap make-timespec dupd wait-kevent handle-kevents ;
+
+: make-proc-kevent ( pid -- kevent )
+    "kevent" <c-object>
+    tuck set-kevent-ident
+    EV_ADD over set-kevent-flags
+    EVFILT_PROC over set-kevent-filter
+    NOTE_EXIT over set-kevent-fflags ;
+
+: add-pid-task ( pid mx -- )
+    swap make-proc-kevent swap register-kevent ;

extra/io/unix/launcher/launcher.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.launcher io.unix.backend io.nonblocking
+USING: io io.backend io.launcher io.unix.backend io.nonblocking
-sequences kernel namespaces math system alien.c-types
+sequences kernel namespaces math system alien.c-types debugger
-debugger continuations arrays assocs combinators unix.process
+continuations arrays assocs combinators unix.process
 parser-combinators memoize promises strings ;
 IN: io.unix.launcher
 
@@ -42,31 +42,18 @@ MEMO: 'arguments' ( -- parser )
 : assoc>env ( assoc -- env )
     [ "=" swap 3append ] { } assoc>map ;
 
-: (spawn-process) ( -- )
+: spawn-process ( -- )
     [
-        pass-environment? [
+        get-arguments
-	    get-arguments get-environment assoc>env exec-args-with-env
+        pass-environment?
-        ] [
+        [ get-environment assoc>env exec-args-with-env ]
-	    get-arguments exec-args-with-path
+        [ exec-args-with-path ] if
-        ] if io-error
+        io-error
     ] [ error. :c flush ] recover 1 exit ;
 
-: wait-for-process ( pid -- )
+M: unix-io run-process* ( desc -- pid )
-    0 <int> 0 waitpid drop ;
-
-: spawn-process ( -- pid )
-    [ (spawn-process) ] [ ] with-fork ;
-
-: spawn-detached ( -- )
-    [ spawn-process 0 exit ] [ ] with-fork wait-for-process ;
-
-M: unix-io run-process* ( desc -- )
     [
-        +detached+ get [
+        [ spawn-process ] [ ] with-fork <process>
-            spawn-detached
-        ] [
-            spawn-process wait-for-process
-        ] if
     ] with-descriptor ;
 
 : open-pipe ( -- pair )
@@ -80,20 +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 ;
-
-: <pipe-stream> ( in out pid -- stream )
-    pipe-stream construct-boa
-    -rot handle>duplex-stream over set-delegate ;
-
-M: pipe-stream stream-close
-    dup delegate stream-close
-    pipe-stream-pid wait-for-process ;
 
 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

@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: io.unix.linux
+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 ( -- )
+    <select-mx> mx set-global
+    start-wait-thread ;
+
+T{ linux-io } set-io-backend

extra/io/unix/select/select.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2004, 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 ;
+IN: io.unix.select
+
+TUPLE: select-mx read-fdset write-fdset ;
+
+! Factor's bit-arrays are an array of bytes, OS X expects
+! FD_SET to be an array of cells, so we have to account for
+! byte order differences on big endian platforms
+: little-endian? 1 <int> *char 1 = ; foldable
+
+: munge ( i -- i' )
+    little-endian? [ BIN: 11000 bitxor ] unless ; inline
+
+: <select-mx> ( -- mx )
+    select-mx construct-mx
+    FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
+    FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
+
+: handle-fd ( fd task fdset mx -- )
+    roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ;
+
+: handle-fdset ( tasks fdset mx -- )
+    [ handle-fd ] 2curry assoc-each ;
+
+: init-fdset ( tasks fdset -- )
+    dup clear-bits
+    [ >r drop t swap munge r> set-nth ] curry assoc-each ;
+
+: read-fdset/tasks
+    { mx-reads select-mx-read-fdset } get-slots ;
+
+: write-fdset/tasks
+    { mx-writes select-mx-write-fdset } get-slots ;
+
+: init-fdsets ( mx -- read write except )
+    [ read-fdset/tasks tuck init-fdset ] keep
+    write-fdset/tasks tuck init-fdset
+    f ;
+
+M: select-mx wait-for-events ( ms mx -- )
+    swap >r FD_SETSIZE over init-fdsets r> make-timeval
+    select multiplexer-error
+    dup read-fdset/tasks pick handle-fdset
+    dup write-fdset/tasks rot handle-fdset ;

extra/io/unix/sockets/sockets.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov, Ivan Tikhonov.
+! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
 ! See http://factorcode.org/license.txt for BSD license.
 
 ! We need to fiddle with the exact search order here, since
@@ -34,14 +34,12 @@ M: unix-io addrinfo-error ( n -- )
 TUPLE: connect-task ;
 
 : <connect-task> ( port continuation -- task )
-    connect-task <io-task> ;
+    connect-task <output-task> ;
 
 M: connect-task do-io-task
     io-task-port dup port-handle f 0 write
     0 < [ defer-error ] [ drop t ] if ;
 
-M: connect-task task-container drop write-tasks get-global ;
-
 : wait-to-connect ( port -- )
     [ <connect-task> add-io-task stop ] callcc0 drop ;
 
@@ -68,9 +66,7 @@ USE: unix
 TUPLE: accept-task ;
 
 : <accept-task> ( port continuation  -- task )
-    accept-task <io-task> ;
+    accept-task <input-task> ;
-
-M: accept-task task-container drop read-tasks get ;
 
 : accept-sockaddr ( port -- fd sockaddr )
     dup port-handle swap server-port-addr sockaddr-type
@@ -101,7 +97,6 @@ M: unix-io <server> ( addrspec -- stream )
     [
         SOCK_STREAM server-fd
         dup 10 listen zero? [ dup close (io-error) ] unless
-        f <port>
     ] keep <server-port> ;
 
 M: unix-io accept ( server -- client )
@@ -113,7 +108,7 @@ M: unix-io accept ( server -- client )
 
 ! Datagram sockets - UDP and Unix domain
 M: unix-io <datagram>
-    [ SOCK_DGRAM server-fd f <port> ] keep <datagram-port> ;
+    [ SOCK_DGRAM server-fd ] keep <datagram-port> ;
 
 SYMBOL: receive-buffer
 
@@ -139,7 +134,7 @@ packet-size <byte-array> receive-buffer set-global
 TUPLE: receive-task ;
 
 : <receive-task> ( stream continuation  -- task )
-    receive-task <io-task> ;
+    receive-task <input-task> ;
 
 M: receive-task do-io-task
     io-task-port
@@ -152,8 +147,6 @@ M: receive-task do-io-task
         2drop defer-error
     ] if ;
 
-M: receive-task task-container drop read-tasks get ;
-
 : wait-receive ( stream -- )
     [ <receive-task> add-io-task stop ] callcc0 drop ;
 
@@ -170,7 +163,7 @@ M: unix-io receive ( datagram -- packet addrspec )
 TUPLE: send-task packet sockaddr len ;
 
 : <send-task> ( packet sockaddr len stream continuation -- task )
-    send-task <io-task> [
+    send-task <output-task> [
         {
             set-send-task-packet
             set-send-task-sockaddr
@@ -185,8 +178,6 @@ M: send-task do-io-task
     [ send-task-len do-send ] keep
     swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
 
-M: send-task task-container drop write-tasks get ;
-
 : wait-send ( packet sockaddr len stream -- )
     [ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
 

extra/io/unix/unix.factor

@@ -3,10 +3,8 @@ io.unix.launcher io.unix.mmap io.backend combinators namespaces
 system vocabs.loader ;
 
 {
-    ! kqueue is a work in progress
+    { [ bsd? ] [ "io.unix.bsd" ] }
-    ! { [ macosx? ] [ "io.unix.backend.kqueue" ] }
+    { [ macosx? ] [ "io.unix.bsd" ] }
-    ! { [ bsd? ] [ "io.unix.backend.kqueue" ] }
+    { [ linux? ] [ "io.unix.linux" ] }
-    { [ unix? ] [ "io.unix.backend.select" ] }
+    { [ solaris? ] [ "io.unix.solaris" ] }
 } cond require
-
-T{ unix-io } io-backend set-global

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/ce/sockets/sockets.factor

@@ -38,7 +38,7 @@ M: windows-ce-io <server> ( addrspec -- duplex-stream )
     [
         windows.winsock:SOCK_STREAM server-fd
         dup listen-on-socket
-        <win32-socket> f <port>
+        <win32-socket>
     ] keep <server-port> ;
 
 M: windows-ce-io accept ( server -- client )
@@ -58,7 +58,7 @@ M: windows-ce-io accept ( server -- client )
 
 M: windows-ce-io <datagram> ( addrspec -- datagram )
     [
-        windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
+        windows.winsock:SOCK_DGRAM server-fd <win32-socket>
     ] keep <datagram-port> ;
 
 : packet-size 65536 ; inline

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,29 +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 [
+        lookup-callback
-            io-callback-continuation
+        io-callback-continuation schedule-thread f
-        ] [
-            "unhandled io event" print flush f
-        ] if*
     ] if ;
 
+: drain-overlapped ( timeout -- )
+    handle-overlapped [ 0 drain-overlapped ] unless ;
+
 : maybe-expire ( io-callbck -- )
     io-callback-port
     dup timeout? [
@@ -148,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/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/nt/sockets/sockets.factor

@@ -149,7 +149,7 @@ M: windows-nt-io <server> ( addrspec -- server )
         [
             SOCK_STREAM server-fd dup listen-on-socket
             dup add-completion
-            <win32-socket> f <port>
+            <win32-socket>
         ] keep <server-port>
     ] with-destructors ;
 
@@ -158,7 +158,7 @@ M: windows-nt-io <datagram> ( addrspec -- datagram )
         [
             SOCK_DGRAM server-fd
             dup add-completion
-            <win32-socket> f <port>
+            <win32-socket>
         ] keep <datagram-port>
     ] with-destructors ;
 

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

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: unix.linux.epoll
+USING: alien.syntax math ;
+
+FUNCTION: int epoll_create ( int size ) ;
+
+FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
+
+C-STRUCT: epoll-event
+    { "uint" "events" }
+    { "uint" "fd" }
+    { "uint" "padding" } ;
+
+FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
+
+: EPOLL_CTL_ADD 1 ; inline ! Add a file decriptor to the interface.
+: EPOLL_CTL_DEL 2 ; inline ! Remove a file decriptor from the interface.
+: EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure.
+
+: EPOLLIN     HEX: 001 ; inline
+: EPOLLPRI    HEX: 002 ; inline
+: EPOLLOUT    HEX: 004 ; inline
+: EPOLLRDNORM HEX: 040 ; inline
+: EPOLLRDBAND HEX: 080 ; inline
+: EPOLLWRNORM HEX: 100 ; inline
+: EPOLLWRBAND HEX: 200 ; inline
+: EPOLLMSG    HEX: 400 ; inline
+: EPOLLERR    HEX: 008 ; inline
+: EPOLLHUP    HEX: 010 ; inline
+: EPOLLET     31 2^    ; inline

extra/unix/process/process.factor

@@ -1,53 +1,35 @@
-
+USING: kernel alien.c-types sequences math unix
-USING: kernel alien.c-types sequences math unix combinators.cleave ;
+combinators.cleave vectors kernel namespaces continuations
+threads assocs vectors ;
 
 IN: unix.process
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Low-level Unix process launching utilities. These are used
+! to implement io.launcher on Unix. User code should use
+! io.launcher instead.
 
 : >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : exec ( pathname argv -- int )
-  [ malloc-char-string ] [ >argv ] bi* execv ;
+    [ malloc-char-string ] [ >argv ] bi* execv ;
 
 : exec-with-path ( filename argv -- int )
-  [ malloc-char-string ] [ >argv ] bi* execvp ;
+    [ malloc-char-string ] [ >argv ] bi* execvp ;
 
 : exec-with-env ( filename argv envp -- int )
-  [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
+    [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: exec-args ( seq -- int )
+    [ first ] [ ] bi exec ;
 
-: exec-args           ( seq -- int ) [ first ] [ ] bi exec ;
+: exec-args-with-path ( seq -- int )
-: exec-args-with-path ( seq -- int ) [ first ] [ ] bi exec-with-path ;
+    [ first ] [ ] bi exec-with-path ;
 
-: exec-args-with-env  ( seq seq -- int ) >r [ first ] [ ] bi r> exec-with-env ;
+: exec-args-with-env  ( seq seq -- int )
+    >r [ first ] [ ] bi r> exec-with-env ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: with-fork ( child parent -- )
+    fork dup zero? -roll swap curry if ; inline
 
-: with-fork ( child parent -- ) fork dup zero? -roll swap curry if ; inline
+: wait-for-pid ( pid -- status )
-
+    0 <int> [ 0 waitpid drop ] keep *int ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: kernel alien.c-types namespaces continuations threads assocs unix
-       combinators.cleave ;
-
-SYMBOL: pid-wait
-
-! KEY | VALUE
-! -----------
-! pid | continuation
-
-: init-pid-wait ( -- ) H{ } clone pid-wait set-global ;
-
-: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ;
-
-: wait-loop ( -- )
-  -1 0 <int> tuck WNOHANG waitpid               ! &status return
-  [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
-  dup [ schedule-thread-with ] [ 2drop ] if
-  250 sleep wait-loop ;
-
-: start-wait-loop ( -- ) init-pid-wait [ 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 ;