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     ] { } make ;
  38
  39 : boot ( -- )
  40     "factor" [
  41         <process>
  42             boot-cmd >>command
  43             +closed+ >>stdin
  44             "../boot-log" >>stdout
  45             +stdout+ >>stderr
  46             1 hours >>timeout
  47         try-process
  48     ] with-directory ;
  49
  50 : test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
  51
  52 : test ( -- )
  53     "factor" [
  54         <process>
  55             test-cmd >>command
  56             +closed+ >>stdin
  57             "../test-log" >>stdout
  58             +stdout+ >>stderr
  59             4 hours >>timeout
  60         try-process
  61     ] with-directory ;
  62
  63 : recover-else ( try catch else -- )
  64     [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
  65
  66 MACRO: recover-cond ( alist -- )
  67     dup { [ length 1 = ] [ first callable? ] } 1&&
  68     [ first ] [
  69         [ first first2 ] [ rest ] bi
  70         '[ _ _ [ _ recover-cond ] recover-else ]
  71     ] if ;
  72
  73 : build-child ( -- status )
  74     copy-image
  75     {
  76         { [ notify-make-vm make-vm ] [ compile-failed ] }
  77         { [ notify-boot boot ] [ boot-failed ] }
  78         { [ notify-test test ] [ test-failed ] }
  79         [ success ]
  80     } recover-cond ;