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

core/bootstrap/primitives.factor

@@ -78,6 +78,7 @@ call
     "strings"
     "strings.private"
     "system"
+    "system.private"
     "threads.private"
     "tools.profiler.private"
     "tuples"
@@ -646,7 +647,8 @@ builtins get num-tags get tail f union-class define-class
     { "innermost-frame-scan" "kernel.private" }
     { "set-innermost-frame-quot" "kernel.private" }
     { "call-clear" "kernel" }
-    { "(os-envs)" "system" }
+    { "(os-envs)" "system.private" }
+    { "(set-os-envs)" "system.private" }
     { "resize-byte-array" "byte-arrays" }
     { "resize-bit-array" "bit-arrays" }
     { "resize-float-array" "float-arrays" }

core/inference/known-words/known-words.factor

@@ -10,7 +10,8 @@ namespaces.private parser prettyprint quotations
 quotations.private sbufs sbufs.private sequences
 sequences.private slots.private strings strings.private system
 threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector compiler.units ;
+words words.private assocs inspector compiler.units
+system.private ;
 IN: inference.known-words
 
 ! Shuffle words
@@ -597,6 +598,8 @@ set-primitive-effect
 
 \ (os-envs) { } { array } <effect> set-primitive-effect
 
+\ (set-os-envs) { array } { } <effect> set-primitive-effect
+
 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
 
 \ dll-valid? { object } { object } <effect> set-primitive-effect

core/system/system-tests.factor

@@ -1,6 +1,17 @@
-USING: math tools.test system prettyprint ;
+USING: math tools.test system prettyprint namespaces kernel ;
 IN: system.tests
 
 [ t ] [ cell integer? ] unit-test
 [ t ] [ bootstrap-cell integer? ] unit-test
-[ ] [ os-envs . ] unit-test
+
+wince? [
+    [ ] [ os-envs . ] unit-test
+] unless
+
+unix? [
+    [ ] [ os-envs "envs" set ] unit-test
+    [ ] [ { { "A" "B" } } set-os-envs ] unit-test
+    [ "B" ] [ "A" os-env ] unit-test
+    [ ] [ "envs" get set-os-envs ] unit-test
+    [ t ] [ os-envs "envs" get = ] unit-test
+] when

core/system/system.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: system
 USING: kernel kernel.private sequences math namespaces
-splitting assocs ;
+splitting assocs system.private ;
 
 : cell ( -- n ) 7 getenv ; foldable
 
@@ -59,3 +59,6 @@ splitting assocs ;
 
 : os-envs ( -- assoc )
     (os-envs) [ "=" split1 ] H{ } map>assoc ;
+
+: set-os-envs ( assoc -- )
+    [ "=" swap 3append ] { } assoc>map (set-os-envs) ;

extra/editors/jedit/jedit.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions io kernel math
 namespaces parser prettyprint sequences strings words
-editors io.files io.sockets io.streams.string io.binary
+editors io.files io.sockets io.streams.byte-array io.binary
-math.parser io.encodings.ascii ;
+math.parser io.encodings.ascii io.encodings.binary
+io.encodings.utf8 ;
 IN: editors.jedit
 
 : jedit-server-info ( -- port auth )
@@ -14,17 +15,17 @@ IN: editors.jedit
     ] with-file-reader ;
 
 : make-jedit-request ( files -- code )
-    [
+    utf8 [
         "EditServer.handleClient(false,false,false," write
         cwd pprint
         "," write
         "new String[] {" write
         [ pprint "," write ] each
         "null});\n" write
-    ] with-string-writer ;
+    ] with-byte-writer ;
 
 : send-jedit-request ( request -- )
-    jedit-server-info swap "localhost" swap <inet> <client> [
+    jedit-server-info "localhost" rot <inet> binary <client> [
         4 >be write
         dup length 2 >be write
         write

extra/io/launcher/launcher-docs.factor

@@ -4,102 +4,71 @@ USING: help.markup help.syntax quotations kernel io math
 calendar ;
 IN: io.launcher
 
-HELP: +command+
+ARTICLE: "io.launcher.command" "Specifying a command"
-{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
+"The " { $snippet "command" } " slot of a " { $link process } " can contain either a string or a sequence of strings. In the first case, the string is processed in an operating system-specific manner. In the second case, the first element is a program name and the remaining elements are passed to the program as command-line arguments." ;
 
-HELP: +arguments+
+ARTICLE: "io.launcher.detached" "Running processes in the background"
-{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ;
+"By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:"
+{ $subsection run-detached } ;
 
-HELP: +detached+
+ARTICLE: "io.launcher.environment" "Setting environment variables"
-{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
+"The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific."
 $nl
-"Default value is " { $link f } "." }
+"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:"
-{ $notes "Cannot be used with " { $link <process-stream> } "." }
+{ $subsection +prepend-environment+ }
-{ $see-also run-detached } ;
+{ $subsection +replace-environment+ }
+{ $subsection +append-environment+ }
+"The default value is " { $link +append-environment+ } "." ;
 
-HELP: +environment+
+ARTICLE: "io.launcher.redirection" "Input/output redirection"
-{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key."
+"On all operating systems except for Windows CE, the default input/output/error streams can be redirected."
 $nl
-"Default value is an empty association." } ;
+"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:"
-
+{ $list
-HELP: +environment-mode+
+    { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
-{ $description "Launch descriptor key. Must equal of the following:"
+    { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link <process-stream> } " pipe" }
-    { $list
+    { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" }
-        { $link +prepend-environment+ }
+    { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" }
-        { $link +replace-environment+ }
+    { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" }
-        { $link +append-environment+ }
+    { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
-    }
-"Default value is " { $link +append-environment+ } "."
-} ;
-
-HELP: +stdin+
-{ $description "Launch descriptor key. Must equal one of the following:"
-    { $list
-        { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
-        { { $link +inherit+ } " - standard input is inherited from the current process" }
-        { { $link +closed+ } " - standard input is closed" }
-        { "a path name - standard input is read from the given file, which must exist" }
-        { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
-    }
-} ;
-
-HELP: +stdout+
-{ $description "Launch descriptor key. Must equal one of the following:"
-    { $list
-        { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
-        { { $link +inherit+ } " - standard output is inherited from the current process" }
-        { { $link +closed+ } " - standard output is closed" }
-        { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
-        { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
-    }
-} ;
-
-HELP: +stderr+
-{ $description "Launch descriptor key. Must equal one of the following:"
-    { $list
-        { { $link f } " - standard error is inherited from the current process" }
-        { { $link +inherit+ } " - same as above" }
-        { { $link +stdout+ } " - standard error is merged with standard output" }
-        { { $link +closed+ } " - standard error is closed" }
-        { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
-        { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
-    }
 } ;
 
 HELP: +closed+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
 
 HELP: +inherit+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
+
+HELP: +stdout+
+{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ;
 
 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."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"If this value is set, the child process environment consists of the value of the " { $snippet "environment" } " slot together with the current environment, with entries from the current environment taking precedence."
 $nl
 "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ;
 
 HELP: +replace-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the value of the " { $snippet "environment" } " slot."
 $nl
 "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ;
 
 HELP: +append-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the current environment together with the value of the " { $snippet "environment" } " key, with entries from the " { $snippet "environment" } " key taking precedence."
 $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
-HELP: +timeout+
+ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
-{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+{ $description "The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." } ;
-
-HELP: default-descriptor
-{ $description "Association storing default values for launch descriptor keys." } ;
-
-HELP: with-descriptor
-{ $values { "desc" "a launch descriptor" } { "quot" quotation } } 
-{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ;
 
 HELP: get-environment
-{ $values { "env" "an association" } }
+{ $values { "process" process } { "env" "an association" } }
-{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
+{ $description "Combines the current environment with the value of the " { $snippet "environment" } " slot of the " { $link process } " using the " { $snippet "environment-mode" } " slot." } ;
 
 HELP: current-process-handle
 { $values { "handle" "a process handle" } }
@@ -110,20 +79,16 @@ HELP: run-process*
 { $contract "Launches a process using the launch descriptor." }
 { $notes "User code should call " { $link run-process } " instead." } ;
 
-HELP: >descriptor
-{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
-{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
-
 HELP: run-process
 { $values { "desc" "a launch descriptor" } { "process" process } }
-{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
 { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
 
 HELP: run-detached
 { $values { "desc" "a launch descriptor" } { "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 "io.launcher.descriptors" } " for details." }
+{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
 { $notes
-    "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
+    "This word is functionally identical to passing a " { $link process } " to " { $link run-process } " having the " { $snippet "detached" } " slot set."
     $nl
     "The output value can be passed to " { $link wait-for-process } " to get an exit code."
 } ;
@@ -147,11 +112,11 @@ HELP: kill-process*
 { $notes "User code should call " { $link kill-process } " intead." } ;
 
 HELP: process
-{ $class-description "A class representing an active or finished process."
+{ $class-description "A class representing a process. Instances are created by calling " { $link <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."
+HELP: <process>
-$nl
+{ $values { "process" process } }
-"Processes can be passed to " { $link wait-for-process } "." } ;
+{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-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." } ;
@@ -161,8 +126,7 @@ HELP: <process-stream>
   { "desc" "a launch descriptor" }
   { "encoding" "an encoding descriptor" }
   { "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 of the given encoding." }
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
-{ $notes "Closing the stream will block until the process exits." } ;
 
 HELP: with-process-stream
 { $values
@@ -176,41 +140,40 @@ HELP: wait-for-process
 { $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.descriptors" "Launch descriptors"
-"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
-{ $list
+$nl
-    { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
+"Strings and string arrays are wrapped in a new empty " { $link process } " with the " { $snippet "command" } " slot set. This covers basic use-cases where no launch parameters need to be set."
-    { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
+$nl
-    { "associations can be passed in, which allows finer control over launch parameters" }
+"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ;
-}
-"The associations can contain the following keys:"
-{ $subsection +command+ }
-{ $subsection +arguments+ }
-{ $subsection +detached+ }
-{ $subsection +environment+ }
-{ $subsection +environment-mode+ }
-{ $subsection +timeout+ }
-{ $subsection +stdin+ }
-{ $subsection +stdout+ }
-{ $subsection +stderr+ } ;
 
-ARTICLE: "io.launcher" "Launching OS processes"
+ARTICLE: "io.launcher.lifecycle" "The process lifecycle"
-"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+"A freshly instantiated " { $link process } " represents a set of launch parameters. Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
-{ $subsection "io.launcher.descriptors" }
+{ $link process-started? }
-"The following words are used to launch processes:"
+"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running."
+{ $link process-running? }
+"It is possible to wait for a process to exit:"
+{ $link wait-for-process }
+"A running process can also be killed:"
+{ $link kill-process } ;
+
+ARTICLE: "io.launcher.launch" "Launching processes"
+"Launching processes:"
 { $subsection run-process }
-{ $subsection run-detached }
 { $subsection try-process }
-"Stopping processes:"
-{ $subsection kill-process }
-"Finding the current process handle:"
-{ $subsection current-process-handle }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
-{ $subsection with-process-stream }
+{ $subsection with-process-stream } ;
-"A class representing an active or finished process:"
+
-{ $subsection process }
+ARTICLE: "io.launcher" "Operating system processes"
-"Waiting for a process to end, or getting the exit code of a finished process:"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
-{ $subsection wait-for-process }
+{ $subsection "io.launcher.descriptors" }
-"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
+{ $subsection "io.launcher.launch" }
+"Advanced topics:"
+{ $subsection "io.launcher.lifecycle" }
+{ $subsection "io.launcher.command" }
+{ $subsection "io.launcher.detached" }
+{ $subsection "io.launcher.environment" }
+{ $subsection "io.launcher.redirection" }
+{ $subsection "io.launcher.timeouts" } ;
 
 ABOUT: "io.launcher"

extra/io/launcher/launcher.factor

@@ -3,68 +3,71 @@
 USING: io io.backend io.timeouts system kernel namespaces
 strings hashtables sequences assocs combinators vocabs.loader
 init threads continuations math io.encodings io.streams.duplex
-io.nonblocking ;
+io.nonblocking new-slots accessors ;
 IN: io.launcher
 
+
+TUPLE: process
+
+command
+detached
+
+environment
+environment-mode
+
+stdin
+stdout
+stderr
+
+timeout
+
+handle status
+killed ;
+
+SYMBOL: +closed+
+SYMBOL: +inherit+
+SYMBOL: +stdout+
+
+SYMBOL: +prepend-environment+
+SYMBOL: +replace-environment+
+SYMBOL: +append-environment+
+
+: <process> ( -- process )
+    process construct-empty
+    H{ } clone >>environment
+    +append-environment+ >>environment-mode ;
+
+: process-started? ( process -- ? )
+    dup handle>> swap status>> or ;
+
+: process-running? ( process -- ? )
+    process-handle >boolean ;
+
 ! Non-blocking process exit notification facility
 SYMBOL: processes
 
 [ H{ } clone processes set-global ] "io.launcher" add-init-hook
 
-TUPLE: process handle status killed? timeout ;
-
 HOOK: register-process io-backend ( process -- )
 
 M: object register-process drop ;
 
-: <process> ( handle -- process )
+: process-started ( process handle -- )
-    f f f process construct-boa
+    >>handle
     V{ } clone over processes get set-at
-    dup register-process ;
+    register-process ;
 
 M: process equal? 2drop f ;
 
 M: process hashcode* process-handle hashcode* ;
 
-: process-running? ( process -- ? ) process-status not ;
+: pass-environment? ( process -- ? )
+    dup environment>> assoc-empty? not
+    swap environment-mode>> +replace-environment+ eq? or ;
 
-SYMBOL: +command+
+: get-environment ( process -- env )
-SYMBOL: +arguments+
+    dup environment>>
-SYMBOL: +detached+
+    swap environment-mode>> {
-SYMBOL: +environment+
-SYMBOL: +environment-mode+
-SYMBOL: +stdin+
-SYMBOL: +stdout+
-SYMBOL: +stderr+
-
-SYMBOL: +timeout+
-
-SYMBOL: +prepend-environment+
-SYMBOL: +replace-environment+
-SYMBOL: +append-environment+
-
-SYMBOL: +closed+
-SYMBOL: +inherit+
-
-: default-descriptor
-    H{
-        { +command+ f }
-        { +arguments+ f }
-        { +detached+ f }
-        { +environment+ H{ } }
-        { +environment-mode+ +append-environment+ }
-    } ;
-
-: with-descriptor ( desc quot -- )
-    default-descriptor [ >r clone r> bind ] bind ; inline
-
-: pass-environment? ( -- ? )
-    +environment+ get assoc-empty? not
-    +environment-mode+ get +replace-environment+ eq? or ;
-
-: get-environment ( -- env )
-    +environment+ get
-    +environment-mode+ get {
         { +prepend-environment+ [ os-envs union ] }
         { +append-environment+ [ os-envs swap union ] }
         { +replace-environment+ [ ] }
@@ -73,78 +76,81 @@ SYMBOL: +inherit+
 : string-array? ( obj -- ? )
     dup sequence? [ [ string? ] all? ] [ drop f ] if ;
 
-: >descriptor ( desc -- desc )
+GENERIC: >process ( obj -- process )
-    {
+
-        { [ dup string? ] [ +command+ associate ] }
+M: process >process
-        { [ dup string-array? ] [ +arguments+ associate ] }
+    dup process-started? [
-        { [ dup assoc? ] [ >hashtable ] }
+        "Process has already been started once" throw
-    } cond ;
+    ] when
+    clone ;
+
+M: object >process <process> swap >>command ;
 
 HOOK: current-process-handle io-backend ( -- handle )
 
-HOOK: run-process* io-backend ( desc -- handle )
+HOOK: run-process* io-backend ( process -- handle )
 
 : wait-for-process ( process -- status )
     [
-        dup process-handle
+        dup handle>>
         [
             dup [ processes get at push ] curry
             "process" suspend drop
         ] when
-        dup process-killed?
+        dup killed>>
-        [ "Process was killed" throw ] [ process-status ] if
+        [ "Process was killed" throw ] [ status>> ] if
     ] with-timeout ;
 
-: run-process ( desc -- process )
-    >descriptor
-    dup run-process*
-    +timeout+ pick at [ over set-timeout ] when*
-    +detached+ rot at [ dup wait-for-process drop ] unless ;
-
 : run-detached ( desc -- process )
-    >descriptor H{ { +detached+ t } } union run-process ;
+    >process
+    dup dup run-process* process-started
+    dup timeout>> [ over set-timeout ] when* ;
+
+: run-process ( desc -- process )
+    run-detached
+    dup detached>> [ dup wait-for-process drop ] unless ;
 
 TUPLE: process-failed code ;
 
 : process-failed ( code -- * )
     \ process-failed construct-boa throw ;
 
-: try-process ( desc -- )
+: try-process ( command/process -- )
     run-process wait-for-process dup zero?
     [ drop ] [ process-failed ] if ;
 
 HOOK: kill-process* io-backend ( handle -- )
 
 : kill-process ( process -- )
-    t over set-process-killed?
+    t >>killed
-    process-handle [ kill-process* ] when* ;
+    handle>> [ kill-process* ] when* ;
 
-M: process timeout process-timeout ;
+M: process timeout timeout>> ;
 
 M: process set-timeout set-process-timeout ;
 
 M: process timed-out kill-process ;
 
-HOOK: (process-stream) io-backend ( desc -- in out process )
+HOOK: (process-stream) io-backend ( process -- handle in out )
 
 TUPLE: process-stream process ;
 
 : <process-stream> ( desc encoding -- stream )
-    swap >descriptor
+    >r >process dup dup (process-stream)
-    [ (process-stream) >r rot <encoder-duplex> r> ] keep
+    >r >r process-started process-stream construct-boa
-    +timeout+ swap at [ over set-timeout ] when*
+    r> r> <reader&writer> r> <encoder-duplex>
-    { set-delegate set-process-stream-process }
+    over set-delegate ;
-    process-stream construct ;
 
 : with-process-stream ( desc quot -- status )
     swap <process-stream>
     [ swap with-stream ] keep
-    process-stream-process wait-for-process ; inline
+    process>> wait-for-process ; inline
 
-: notify-exit ( status process -- )
+: notify-exit ( process status -- )
-    [ set-process-status ] keep
+    >>status
     [ processes get delete-at* drop [ resume ] each ] keep
-    f swap set-process-handle ;
+    f >>handle
+    drop ;
 
 GENERIC: underlying-handle ( stream -- handle )
 

extra/io/unix/kqueue/kqueue.factor

@@ -54,7 +54,7 @@ M: kqueue-mx unregister-io-task ( task mx -- )
 
 : kevent-proc-task ( pid -- )
     dup wait-for-pid swap find-process
-    dup [ notify-exit ] [ 2drop ] if ;
+    dup [ swap notify-exit ] [ 2drop ] if ;
 
 : handle-kevent ( mx kevent -- )
     dup kevent-ident swap kevent-filter {

extra/io/unix/launcher/launcher-tests.factor

@@ -1,6 +1,7 @@
 IN: io.unix.launcher.tests
 USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.ascii ;
+continuations math io.encodings.ascii io.encodings.latin1
+accessors kernel sequences ;
 
 [ ] [
     [ "launcher-test-1" temp-file delete-file ] ignore-errors
@@ -20,10 +21,10 @@ continuations math io.encodings.ascii ;
 ] unit-test
 
 [ ] [
-    [
+    <process>
-        "echo Hello" +command+ set
+        "echo Hello" >>command
-        "launcher-test-1" temp-file +stdout+ set
+        "launcher-test-1" temp-file >>stdout
-    ] { } make-assoc try-process
+    try-process
 ] unit-test
 
 [ "Hello\n" ] [
@@ -34,12 +35,12 @@ continuations math io.encodings.ascii ;
 ] unit-test
 
 [ "" ] [
-    [
+    <process>
         "cat"
         "launcher-test-1" temp-file
-        2array +arguments+ set
+        2array >>command
-        +inherit+ +stdout+ set
+        +inherit+ >>stdout
-    ] { } make-assoc ascii <process-stream> contents
+    ascii <process-stream> contents
 ] unit-test
 
 [ ] [
@@ -47,11 +48,11 @@ continuations math io.encodings.ascii ;
 ] unit-test
 
 [ ] [
-    [
+    <process>
-        "cat" +command+ set
+        "cat" >>command
-        +closed+ +stdin+ set
+        +closed+ >>stdin
-        "launcher-test-1" temp-file +stdout+ set
+        "launcher-test-1" temp-file >>stdout
-    ] { } make-assoc try-process
+    try-process
 ] unit-test
 
 [ "" ] [
@@ -64,10 +65,10 @@ continuations math io.encodings.ascii ;
 [ ] [
     2 [
         "launcher-test-1" temp-file ascii <file-appender> [
-            [
+            <process>
-                +stdout+ set
+                swap >>stdout
-                "echo Hello" +command+ set
+                "echo Hello" >>command
-            ] { } make-assoc try-process
+            try-process
         ] with-disposal
     ] times
 ] unit-test
@@ -78,3 +79,19 @@ continuations math io.encodings.ascii ;
     2array
     ascii <process-stream> contents
 ] unit-test
+
+[ t ] [
+    <process>
+        "env" >>command
+        { { "A" "B" } } >>environment
+    latin1 <process-stream> lines
+    "A=B" swap member?
+] unit-test
+
+[ { "A=B" } ] [
+    <process>
+        "env" >>command
+        { { "A" "B" } } >>environment
+        +replace-environment+ >>environment-mode
+    latin1 <process-stream> lines
+] unit-test

extra/io/unix/launcher/launcher.factor

@@ -4,14 +4,14 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
 io.unix.files io.nonblocking sequences kernel namespaces math
 system alien.c-types debugger continuations arrays assocs
 combinators unix.process strings threads unix
-io.unix.launcher.parser io.encodings.latin1 ;
+io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
 IN: io.unix.launcher
 
 ! Search unix first
 USE: unix
 
-: get-arguments ( -- seq )
+: get-arguments ( process -- seq )
-    +command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
+    command>> dup string? [ tokenize-command ] when ;
 
 : assoc>env ( assoc -- env )
     [ "=" swap 3append ] { } assoc>map ;
@@ -44,28 +44,27 @@ USE: unix
 
 : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
 
-: setup-redirection ( -- )
+: setup-redirection ( process -- process )
-    +stdin+ get ?closed read-flags 0 redirect
+    dup stdin>> ?closed read-flags 0 redirect
-    +stdout+ get ?closed write-flags 1 redirect
+    dup stdout>> ?closed write-flags 1 redirect
-    +stderr+ get dup +stdout+ eq?
+    dup stderr>> dup +stdout+ eq?
     [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
 
-: spawn-process ( -- )
+: spawn-process ( process -- * )
     [
         setup-redirection
-        get-arguments
+        dup pass-environment? [
-        pass-environment?
+            dup get-environment set-os-envs
-        [ get-environment assoc>env exec-args-with-env ]
+        ] when
-        [ exec-args-with-path ] if
+
-        io-error
+        get-arguments exec-args-with-path
-    ] [ error. :c flush ] recover 1 exit ;
+        (io-error)
+    ] [ 255 exit ] recover ;
 
 M: unix-io current-process-handle ( -- handle ) getpid ;
 
-M: unix-io run-process* ( desc -- pid )
+M: unix-io run-process* ( process -- pid )
-    [
+    [ spawn-process ] curry [ ] with-fork ;
-        [ spawn-process ] [ ] with-fork <process>
-    ] with-descriptor ;
 
 M: unix-io kill-process* ( pid -- )
     SIGTERM kill io-error ;
@@ -78,21 +77,15 @@ M: unix-io kill-process* ( pid -- )
     2dup first close second close
     >r first 0 dup2 drop r> second 1 dup2 drop ;
 
-: spawn-process-stream ( -- in out pid )
-    open-pipe open-pipe [
-        setup-stdio-pipe
-        spawn-process
-    ] [
-        -rot 2dup second close first close
-    ] with-fork first swap second rot <process> ;
-
 M: unix-io (process-stream)
-    [
+    >r open-pipe open-pipe r>
-        spawn-process-stream >r <reader&writer> r>
+    [ >r setup-stdio-pipe r> spawn-process ] curry
-    ] with-descriptor ;
+    [ -rot 2dup second close first close ]
+    with-fork
+    first swap second ;
 
 : find-process ( handle -- process )
-    processes get swap [ nip swap process-handle = ] curry
+    processes get swap [ nip swap handle>> = ] curry
     assoc-find 2drop ;
 
 ! Inefficient process wait polling, used on Linux and Solaris.
@@ -103,7 +96,7 @@ M: unix-io (process-stream)
         2drop t
     ] [
         find-process dup [
-            >r *int WEXITSTATUS r> notify-exit f
+            swap *int WEXITSTATUS notify-exit f
         ] [
             2drop f
         ] if

extra/io/windows/launcher/launcher.factor

@@ -130,7 +130,7 @@ M: windows-io kill-process* ( handle -- )
 : process-exited ( process -- )
     dup process-handle exit-code
     over process-handle dispose-process
-    swap notify-exit ;
+    notify-exit ;
 
 : wait-for-processes ( processes -- ? )
     keys dup

extra/tools/deploy/backend/backend.factor

@@ -6,7 +6,7 @@ continuations math definitions mirrors splitting parser classes
 inspector layouts vocabs.loader prettyprint.config prettyprint
 debugger io.streams.c io.streams.duplex io.files io.backend
 quotations io.launcher words.private tools.deploy.config
-bootstrap.image io.encodings.utf8 ;
+bootstrap.image io.encodings.utf8 accessors ;
 IN: tools.deploy.backend
 
 : (copy-lines) ( stream -- )
@@ -17,11 +17,11 @@ IN: tools.deploy.backend
     [ (copy-lines) ] with-disposal ;
 
 : run-with-output ( arguments -- )
-    [
+    <process>
-        +arguments+ set
+        swap >>command
-        +stdout+ +stderr+ set
+        +stdout+ >>stderr
-    ] H{ } make-assoc utf8 <process-stream>
+        +closed+ >>stdin
-    dup duplex-stream-out dispose
+    utf8 <process-stream>
     dup copy-lines
     process-stream-process wait-for-process zero? [
         "Deployment failed" throw

extra/tools/disassembler/disassembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io words alien kernel math.parser alien.syntax
 io.launcher system assocs arrays sequences namespaces qualified
-system math generator.fixup io.encodings.ascii ;
+system math generator.fixup io.encodings.ascii accessors ;
 IN: tools.disassembler
 
 : in-file "gdb-in.txt" temp-file ;
@@ -23,11 +23,11 @@ M: pair make-disassemble-cmd
     ] with-file-writer ;
 
 : run-gdb ( -- lines )
-    [
+    <process>
-        +closed+ +stdin+ set
+        +closed+ >>stdin
-        out-file +stdout+ set
+        out-file >>stdout
-        [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set
+        [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
-    ] { } make-assoc try-process
+    try-process
     out-file ascii file-lines ;
 
 : tabs>spaces ( str -- str' )

vm/os-unix.c

@@ -117,6 +117,29 @@ DEFINE_PRIMITIVE(os_envs)
 	dpush(result);
 }
 
+DEFINE_PRIMITIVE(set_os_envs)
+{
+	F_ARRAY *array = untag_array(dpop());
+	CELL size = array_capacity(array);
+
+	/* Memory leak */
+	char **env = calloc(size + 1,sizeof(CELL));
+
+	CELL i;
+	for(i = 0; i < size; i++)
+	{
+		F_STRING *string = untag_string(array_nth(array,i));
+		CELL length = to_fixnum(string->length);
+
+		char *chars = malloc(length + 1);
+		char_string_to_memory(string,chars);
+		chars[length] = '\0';
+		env[i] = chars;
+	}
+
+	environ = env;
+}
+
 F_SEGMENT *alloc_segment(CELL size)
 {
 	int pagesize = getpagesize();

vm/os-windows.c

@@ -233,3 +233,8 @@ void sleep_millis(DWORD msec)
 {
 	Sleep(msec);
 }
+
+DECLARE_PRIMITIVE(set_os_envs)
+{
+	not_implemented_error();
+}

vm/primitives.c

@@ -186,6 +186,7 @@ void *primitives[] = {
 	primitive_set_innermost_stack_frame_quot,
 	primitive_call_clear,
 	primitive_os_envs,
+	primitive_set_os_envs,
 	primitive_resize_byte_array,
 	primitive_resize_bit_array,
 	primitive_resize_float_array,

vm/run.h

@@ -249,6 +249,7 @@ DECLARE_PRIMITIVE(setenv);
 DECLARE_PRIMITIVE(exit);
 DECLARE_PRIMITIVE(os_env);
 DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_envs);
 DECLARE_PRIMITIVE(eq);
 DECLARE_PRIMITIVE(millis);
 DECLARE_PRIMITIVE(sleep);