extra/mason/child/child.factor

   1 ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays calendar combinators.short-circuit fry
   4 continuations debugger io.directories io.files io.launcher
   5 io.pathnames io.encodings.ascii kernel make mason.common mason.config
   6 mason.platform mason.report mason.notify namespaces sequences
   7 quotations macros ;
   8 IN: mason.child
   9
  10 : make-cmd ( -- args )
  11     gnu-make platform 2array ;
  12
  13 : make-vm ( -- )
  14     "factor" [
  15         <process>
  16             make-cmd >>command
  17             "../compile-log" >>stdout
  18             +stdout+ >>stderr
  19         try-process
  20     ] with-directory ;
  21
  22 : builds-factor-image ( -- img )
  23     builds/factor boot-image-name append-path ;
  24
  25 : copy-image ( -- )
  26     builds-factor-image "." copy-file-into
  27     builds-factor-image "factor" copy-file-into ;
  28
  29 : factor-vm ( -- string )
  30     target-os get "winnt" = "./factor.com" "./factor" ? ;
  31
  32 : boot-cmd ( -- cmd )
  33     [
  34         factor-vm ,
  35         "-i=" boot-image-name append ,
  36         "-no-user-init" ,
  37         target-cpu get { "x86.32" "x86.64" } member? [ "-sse-version=30" , ] when
  38     ] { } make ;
  39
  40 : boot ( -- )
  41     "factor" [
  42         <process>
  43             boot-cmd >>command
  44             +closed+ >>stdin
  45             "../boot-log" >>stdout
  46             +stdout+ >>stderr
  47             1 hours >>timeout
  48         try-process
  49     ] with-directory ;
  50
  51 : test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
  52
  53 : test ( -- )
  54     "factor" [
  55         <process>
  56             test-cmd >>command
  57             +closed+ >>stdin
  58             "../test-log" >>stdout
  59             +stdout+ >>stderr
  60             4 hours >>timeout
  61         try-process
  62     ] with-directory ;
  63
  64 : recover-else ( try catch else -- )
  65     [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
  66
  67 MACRO: recover-cond ( alist -- )
  68     dup { [ length 1 = ] [ first callable? ] } 1&&
  69     [ first ] [
  70         [ first first2 ] [ rest ] bi
  71         '[ _ _ [ _ recover-cond ] recover-else ]
  72     ] if ;
  73
  74 : build-child ( -- status )
  75     copy-image
  76     {
  77         { [ notify-make-vm make-vm ] [ compile-failed ] }
  78         { [ notify-boot boot ] [ boot-failed ] }
  79         { [ notify-test test ] [ test-failed ] }
  80         [ success ]
  81     } recover-cond ;