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