Merge branch 'master' of http://dharmatech.onigirihouse.com/factor
Slava Pestov
commit
5bf2cbf4c6
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue