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

   1 USING: tools.test kernel sequences words sequences.private fry
   2 prettyprint alien alien.accessors math.private compiler.tree.builder
   3 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
   4 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
   5 compiler.cfg arrays locals byte-arrays kernel.private math
   6 slots.private vectors sbufs strings math.partial-dispatch
   7 strings.private ;
   8 IN: compiler.cfg.builder.tests
   9
  10 ! Just ensure that various CFGs build correctly.
  11 : unit-test-cfg ( quot -- )
  12     '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
  13
  14 : blahblah ( nodes -- ? )
  15     { fixnum } declare [
  16         dup 3 bitand 1 = [ drop t ] [
  17             dup 3 bitand 2 = [
  18                 blahblah
  19             ] [ drop f ] if
  20         ] if
  21     ] any? ; inline recursive
  22
  23 : more? ( x -- ? ) ;
  24
  25 : test-case-1 ( -- ? ) f ;
  26
  27 : test-case-2 ( -- )
  28     test-case-1 [ test-case-2 ] [ ] if ; inline recursive
  29
  30 {
  31     [ ]
  32     [ dup ]
  33     [ swap ]
  34     [ [ ] dip ]
  35     [ fixnum+ ]
  36     [ fixnum+fast ]
  37     [ 3 fixnum+fast ]
  38     [ fixnum*fast ]
  39     [ 3 fixnum*fast ]
  40     [ 3 swap fixnum*fast ]
  41     [ fixnum-shift-fast ]
  42     [ 10 fixnum-shift-fast ]
  43     [ -10 fixnum-shift-fast ]
  44     [ 0 fixnum-shift-fast ]
  45     [ 10 swap fixnum-shift-fast ]
  46     [ -10 swap fixnum-shift-fast ]
  47     [ 0 swap fixnum-shift-fast ]
  48     [ fixnum-bitnot ]
  49     [ eq? ]
  50     [ "hi" eq? ]
  51     [ fixnum< ]
  52     [ 5 fixnum< ]
  53     [ float+ ]
  54     [ 3.0 float+ ]
  55     [ float<= ]
  56     [ fixnum>bignum ]
  57     [ bignum>fixnum ]
  58     [ fixnum>float ]
  59     [ float>fixnum ]
  60     [ 3 f <array> ]
  61     [ [ 1 ] [ 2 ] if ]
  62     [ fixnum< [ 1 ] [ 2 ] if ]
  63     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
  64     [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
  65     [ [ t ] loop ]
  66     [ [ dup ] loop ]
  67     [ [ 2 ] [ 3 throw ] if 4 ]
  68     [ "int" f "malloc" { "int" } alien-invoke ]
  69     [ "int" { "int" } "cdecl" alien-indirect ]
  70     [ "int" { "int" } "cdecl" [ ] alien-callback ]
  71     [ swap - + * ]
  72     [ swap slot ]
  73     [ blahblah ]
  74     [ 1000 [ dup [ reverse ] when ] times ]
  75     [ 1array ]
  76     [ 1 2 ? ]
  77     [ { array } declare [ ] map ]
  78     [ { array } declare dup 1 slot [ 1 slot ] when ]
  79     [ [ dup more? ] [ dup ] produce ]
  80     [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
  81     [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
  82     [
  83         { fixnum sbuf } declare 2dup 3 slot fixnum> [
  84             over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
  85         ] [ ] if
  86     ]
  87     [ [ 2 fixnum* ] when 3 ]
  88     [ [ 2 fixnum+ ] when 3 ]
  89     [ [ 2 fixnum- ] when 3 ]
  90     [ 10000 [ ] times ]
  91     [
  92         over integer? [
  93             over dup 16 <-integer-fixnum
  94             [ 0 >=-integer-fixnum ] [ drop f ] if [
  95                 nip dup
  96                 [ ] [ ] if
  97             ] [ 2drop f ] if
  98         ] [ 2drop f ] if
  99     ]
 100     [
 101         pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
 102         set-string-nth-fast
 103     ]
 104 } [
 105     unit-test-cfg
 106 ] each
 107
 108 : test-1 ( -- ) test-1 ;
 109 : test-2 ( -- ) 3 . test-2 ;
 110 : test-3 ( a -- b ) dup [ test-3 ] when ;
 111
 112 {
 113     test-1
 114     test-2
 115     test-3
 116 } [ unit-test-cfg ] each
 117
 118 {
 119     byte-array
 120     simple-alien
 121     alien
 122     POSTPONE: f
 123 } [| class |
 124     {
 125         alien-signed-1
 126         alien-signed-2
 127         alien-signed-4
 128         alien-unsigned-1
 129         alien-unsigned-2
 130         alien-unsigned-4
 131         alien-cell
 132         alien-float
 133         alien-double
 134     } [| word |
 135         { class } word '[ _ declare 10 _ execute ] unit-test-cfg
 136         { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
 137     ] each
 138
 139     {
 140         set-alien-signed-1
 141         set-alien-signed-2
 142         set-alien-signed-4
 143         set-alien-unsigned-1
 144         set-alien-unsigned-2
 145         set-alien-unsigned-4
 146     } [| word |
 147         { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
 148         { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
 149     ] each
 150
 151     { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
 152     { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
 153
 154     { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
 155     { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
 156
 157     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
 158     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 159 ] each