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