Merge branch 'master' of http://dharmatech.onigirihouse.com/factor

extra/builder/builder.factor

@@ -0,0 +1,113 @@
+
+USING: kernel io io.files io.launcher
+       system namespaces sequences splitting math.parser
+       unix prettyprint tools.time calendar bake vars ;
+
+IN: builder
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+  now `{ ,[ dup timestamp-year   ]
+      	 ,[ dup timestamp-month	 ]
+	 ,[ dup timestamp-day	 ]
+	 ,[ dup timestamp-hour	 ]
+	 ,[     timestamp-minute ] }
+  [ number>string 2 CHAR: 0 pad-left ] map "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-recipients
+
+: quote ( str -- str ) "'" swap "'" 3append ;
+
+: email-file ( subject file -- )
+  `{
+     "cat"       ,
+     "| mutt -s" ,[ quote ]
+     "-x"        %[ builder-recipients get ]
+   }
+   " " join system drop ;
+  
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ;
+
+: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: stamp
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: build ( -- )
+
+datestamp >stamp
+
+"/builds/factor" cd
+"git pull git://factorcode.org/git/factor.git" system
+0 =
+[ ]
+[
+  "builder: git pull" "/dev/null" email-file
+  "builder: git pull" throw
+]
+if
+
+"/builds/" stamp> append make-directory
+"/builds/" stamp> append cd
+"git clone /builds/factor" system drop
+
+"factor" cd
+
+{ "/usr/bin/git" "show" } <process-stream>
+[ readln ] with-stream
+" " split second
+"../git-id" <file-writer> [ print ] with-stream
+
+"make clean" system drop
+
+"make " target " > ../compile-log" 3append system
+0 =
+[ ]
+[
+  "builder: vm compile" "../compile-log" email-file
+  "builder: vm compile" throw
+] if
+
+"wget http://factorcode.org/images/latest/" boot-image append system
+0 =
+[ ]
+[
+  "builder: image download" "/dev/null" email-file
+  "builder: image download" throw
+] if
+
+[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ]
+benchmark nip
+"../boot-time" <file-writer> [ . ] with-stream
+0 =
+[ ]
+[
+  "builder: bootstrap" "../boot-log" email-file
+  "builder: bootstrap" throw
+] if
+
+[
+  "./factor -e='USE: tools.browser load-everything' > ../load-everything-log"
+  system
+] benchmark nip
+"../load-everything-time" <file-writer> [ . ] with-stream
+0 =
+[ ]
+[
+  "builder: load-everything" "../load-everything-log" email-file
+  "builder: load-everything" throw
+] if
+
+;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: build

extra/io/launcher/launcher-docs.factor

@@ -93,7 +93,7 @@ HELP: run-process*
 { $notes "User code should call " { $link run-process } " instead." } ;
 
 HELP: >descriptor
-{ $values { "obj" object } { "desc" "a launch descriptor" } }
+{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
 { $description "Creates a launch descriptor from an object, which must be one of the following:"
     { $list
         { "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
@@ -103,12 +103,12 @@ HELP: >descriptor
 } ;
 
 HELP: run-process
-{ $values { "obj" object } { "process" 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 >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 } { "process" process } }
+{ $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 >descriptor } " for details." }
 { $notes
     "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
@@ -127,12 +127,17 @@ 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" } }
+{ $values
+  { "desc" "a launch 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." }
 { $notes "Closing the stream will block until the process exits." } ;
 
 HELP: with-process-stream
-{ $values { "obj" object } { "quot" quotation } { "process" process } }
+{ $values
+  { "desc" "a launch descriptor" }
+  { "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

extra/io/launcher/launcher.factor

@@ -63,7 +63,7 @@ SYMBOL: append-environment
         { replace-environment [ ] }
     } case ;
 
-GENERIC: >descriptor ( obj -- desc )
+GENERIC: >descriptor ( desc -- desc )
 
 M: string >descriptor +command+ associate ;
 M: sequence >descriptor +arguments+ associate ;
@@ -76,24 +76,24 @@ HOOK: run-process* io-backend ( desc -- handle )
         dup [ processes get at push stop ] curry callcc0
     ] when process-status ;
 
-: run-process ( obj -- process )
+: run-process ( desc -- process )
     >descriptor
     dup run-process*
     +detached+ rot at [ dup wait-for-process drop ] unless ;
 
-: run-detached ( obj -- process )
+: run-detached ( desc -- process )
     >descriptor H{ { +detached+ t } } union run-process ;
 
 HOOK: process-stream* io-backend ( desc -- stream process )
 
 TUPLE: process-stream process ;
 
-: <process-stream> ( obj -- stream )
+: <process-stream> ( desc -- stream )
     >descriptor process-stream*
     { set-delegate set-process-stream-process }
     process-stream construct ;
 
-: with-process-stream ( obj quot -- process )
+: with-process-stream ( desc quot -- process )
     swap <process-stream>
     [ swap with-stream ] keep
     process-stream-process ; inline