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 : nmake-cmd ( -- args )
  11     { "nmake" "/f" "nmakefile" }
  12     target-cpu get name>> "." split "-" join suffix ;
  13
  14 : gnu-make-cmd ( -- args )
  15     gnu-make
  16     target-os get name>> target-cpu get name>> (platform)
  17     2array ;
  18
  19 : mason-child-make-cmd ( -- args )
  20     {
  21         { [ target-os get windows = ] [ nmake-cmd ] }
  22         [ gnu-make-cmd ]
  23     } cond ;
  24
  25 : make-mason-child-vm ( -- )
  26     "factor" [
  27         <process>
  28             mason-child-make-cmd >>command
  29             "../compile-log" >>stdout
  30             +stdout+ >>stderr
  31             +new-group+ >>group
  32         try-process
  33     ] with-directory ;
  34
  35 ! On windows, process launches relative to current process, ignoring
  36 ! current-directory variables. Must pass absolute-path of factor.com
  37 : mason-child-vm ( -- string )
  38     target-os get windows = [
  39         "./factor.com" absolute-path
  40     ] [
  41         "./factor"
  42     ] if ;
  43
  44 : mason-child-boot-cmd ( -- cmd )
  45     [
  46         mason-child-vm ,
  47         "-i=" target-boot-image-name append ,
  48         "-no-user-init" ,
  49         boot-flags get %
  50     ] { } make ;
  51
  52 : bootstrap-mason-child ( -- )
  53     "factor" [
  54         <process>
  55             mason-child-boot-cmd >>command
  56             +closed+ >>stdin
  57             "../boot-log" >>stdout
  58             +stdout+ >>stderr
  59             1 hours >>timeout
  60             +new-group+ >>group
  61         try-process
  62     ] with-directory ;
  63
  64 : mason-child-test-cmd ( -- cmd ) mason-child-vm "-run=mason.test" 2array ;
  65
  66 : test-mason-child ( -- )
  67     "factor" [
  68         <process>
  69             mason-child-test-cmd >>command
  70             +closed+ >>stdin
  71             "../test-log" >>stdout
  72             +stdout+ >>stderr
  73             4 hours >>timeout
  74             +new-group+ >>group
  75         try-process
  76     ] with-directory ;
  77
  78 : recover-else ( try catch else -- )
  79     [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
  80
  81 MACRO: recover-cond ( alist -- )
  82     dup { [ length 1 = ] [ first callable? ] } 1&&
  83     [ first ] [
  84         [ first first2 ] [ rest ] bi
  85         '[ _ _ [ _ recover-cond ] recover-else ]
  86     ] if ;
  87
  88 : build-child ( -- status )
  89     {
  90         { [ notify-make-vm make-mason-child-vm ] [ compile-failed ] }
  91         { [ notify-boot bootstrap-mason-child ] [ boot-failed ] }
  92         { [ notify-test test-mason-child ] [ test-failed ] }
  93         [ success ]
  94     } recover-cond ;