basis/compiler/cfg/builder/builder-tests.factor

   1 IN: compiler.cfg.builder.tests
   2 USING: tools.test kernel sequences words sequences.private fry
   3 prettyprint alien alien.accessors math.private compiler.tree.builder
   4 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
   5 compiler.cfg.predecessors compiler.cfg.checker arrays locals
   6 byte-arrays kernel.private math slots.private ;
   7
   8 ! Just ensure that various CFGs build correctly.
   9 : unit-test-cfg ( quot -- )
  10     '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ;
  11
  12 {
  13     [ ]
  14     [ dup ]
  15     [ swap ]
  16     [ [ ] dip ]
  17     [ fixnum+ ]
  18     [ fixnum+fast ]
  19     [ 3 fixnum+fast ]
  20     [ fixnum*fast ]
  21     [ 3 fixnum*fast ]
  22     [ 3 swap fixnum*fast ]
  23     [ fixnum-shift-fast ]
  24     [ 10 fixnum-shift-fast ]
  25     [ -10 fixnum-shift-fast ]
  26     [ 0 fixnum-shift-fast ]
  27     [ 10 swap fixnum-shift-fast ]
  28     [ -10 swap fixnum-shift-fast ]
  29     [ 0 swap fixnum-shift-fast ]
  30     [ fixnum-bitnot ]
  31     [ eq? ]
  32     [ "hi" eq? ]
  33     [ fixnum< ]
  34     [ 5 fixnum< ]
  35     [ float+ ]
  36     [ 3.0 float+ ]
  37     [ float<= ]
  38     [ fixnum>bignum ]
  39     [ bignum>fixnum ]
  40     [ fixnum>float ]
  41     [ float>fixnum ]
  42     [ 3 f <array> ]
  43     [ [ 1 ] [ 2 ] if ]
  44     [ fixnum< [ 1 ] [ 2 ] if ]
  45     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
  46     [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
  47     [ [ t ] loop ]
  48     [ [ dup ] loop ]
  49     [ [ 2 ] [ 3 throw ] if 4 ]
  50     [ "int" f "malloc" { "int" } alien-invoke ]
  51     [ "int" { "int" } "cdecl" alien-indirect ]
  52     [ "int" { "int" } "cdecl" [ ] alien-callback ]
  53     [ swap - + * ]
  54     [ swap slot ]
  55 } [
  56     unit-test-cfg
  57 ] each
  58
  59 : test-1 ( -- ) test-1 ;
  60 : test-2 ( -- ) 3 . test-2 ;
  61 : test-3 ( a -- b ) dup [ test-3 ] when ;
  62
  63 {
  64     test-1
  65     test-2
  66     test-3
  67 } [ unit-test-cfg ] each
  68
  69 {
  70     byte-array
  71     simple-alien
  72     alien
  73     POSTPONE: f
  74 } [| class |
  75     {
  76         alien-signed-1
  77         alien-signed-2
  78         alien-signed-4
  79         alien-unsigned-1
  80         alien-unsigned-2
  81         alien-unsigned-4
  82         alien-cell
  83         alien-float
  84         alien-double
  85     } [| word |
  86         { class } word '[ _ declare 10 _ execute ] unit-test-cfg
  87         { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
  88     ] each
  89
  90     {
  91         set-alien-signed-1
  92         set-alien-signed-2
  93         set-alien-signed-4
  94         set-alien-unsigned-1
  95         set-alien-unsigned-2
  96         set-alien-unsigned-4
  97     } [| word |
  98         { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
  99         { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
 100     ] each
 101
 102     { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
 103     { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
 104
 105     { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
 106     { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
 107
 108     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
 109     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 110 ] each