extra/mason/child/child.factor

   1 ! Copyright (C) 2008, 2011 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays calendar combinators
   4 combinators.short-circuit continuations fry io.directories
   5 io.launcher io.pathnames kernel macros make mason.config
   6 mason.notify mason.platform mason.report namespaces quotations
   7 sequences splitting system ;
   8 IN: mason.child
   9
  10 ! Make sure we call the build directory's factor.cmd
  11 : nmake-cmd ( -- args )
  12     "./build.cmd" absolute-path
  13     "latest"
  14     target-cpu get name>> "." split "-" join 3array ;
  15
  16 : gnu-make-cmd ( -- args )
  17     gnu-make
  18     target-os get name>> target-cpu get name>> (platform)
  19     2array ;
  20
  21 : mason-child-make-cmd ( -- args )
  22     {
  23         { [ target-os get windows = ] [ nmake-cmd ] }
  24         [ gnu-make-cmd ]
  25     } cond ;
  26
  27 : make-mason-child-vm ( -- )
  28     "factor" [
  29         <process>
  30             mason-child-make-cmd >>command
  31             "../compile-log" >>stdout
  32             +stdout+ >>stderr
  33             +new-group+ >>group
  34         try-process
  35     ] with-directory ;
  36
  37 ! On windows, process launches relative to current process, ignoring
  38 ! current-directory variables. Must pass absolute-path of factor.com
  39 : mason-child-vm ( -- string )
  40     target-os get windows = [
  41         "./factor.com" absolute-path
  42     ] [
  43         "./factor"
  44     ] if ;
  45
  46 : mason-child-boot-cmd ( -- cmd )
  47     [
  48         mason-child-vm ,
  49         "-i=" target-boot-image-name append ,
  50         "-no-user-init" ,
  51         boot-flags get %
  52     ] { } make ;
  53
  54 : bootstrap-mason-child ( -- )
  55     "factor" [
  56         <process>
  57             mason-child-boot-cmd >>command
  58             +closed+ >>stdin
  59             "../boot-log" >>stdout
  60             +stdout+ >>stderr
  61             1 hours >>timeout
  62             +new-group+ >>group
  63         try-process
  64     ] with-directory ;
  65
  66 : mason-child-test-cmd ( -- cmd ) mason-child-vm "-run=mason.test" 2array ;
  67
  68 : test-mason-child ( -- )
  69     "factor" [
  70         <process>
  71             mason-child-test-cmd >>command
  72             +closed+ >>stdin
  73             "../test-log" >>stdout
  74             +stdout+ >>stderr
  75             4 hours >>timeout
  76             +new-group+ >>group
  77         try-process
  78     ] with-directory ;
  79
  80 : recover-else ( try catch else -- )
  81     [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
  82
  83 MACRO: recover-cond ( alist -- quot )
  84     dup { [ length 1 = ] [ first callable? ] } 1&&
  85     [ first ] [
  86         [ first first2 ] [ rest ] bi
  87         '[ _ _ [ _ recover-cond ] recover-else ]
  88     ] if ;
  89
  90 : build-child ( -- status )
  91     {
  92         { [ notify-make-vm make-mason-child-vm ] [ compile-failed ] }
  93         { [ notify-boot bootstrap-mason-child ] [ boot-failed ] }
  94         { [ notify-test test-mason-child ] [ test-failed ] }
  95         [ success ]
  96     } recover-cond ;