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

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