core/compiler/test/templates.factor

   1 ! Black box testing of templater optimization
   2
   3 USING: arrays compiler kernel kernel.private math
   4 hashtables.private math.private math.ratios.private namespaces
   5 sequences sequences.private tools.test namespaces.private
   6 slots.private combinators.private ;
   7 IN: temporary
   8
   9 ! Oops!
  10 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test
  11 [ "hi" ] [ [ "hi" ] compile-1 ] unit-test
  12
  13 [ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-1 ] unit-test
  14
  15 [ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
  16 [ 0 ] [ 3 [ tag ] compile-1 ] unit-test
  17 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test
  18
  19 [ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
  20
  21 [ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test
  22
  23 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
  24
  25 [ { 1 2 3 } { 1 4 3 } 3 3 ]
  26 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-1 ]
  27 unit-test
  28
  29 [ { 1 2 3 } { 1 4 3 } 8 8 ]
  30 [ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]
  31 unit-test
  32
  33 ! Test literals in either side of a shuffle
  34 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
  35
  36 [ 2 ] [ 1 2 [ swap fixnum/i ] compile-1 ] unit-test
  37
  38 : foo ;
  39
  40 [ 4 4 ]
  41 [ 1/2 [ tag [ foo ] keep ] compile-1 ]
  42 unit-test
  43
  44 [ 1 2 2 ]
  45 [ 1/2 [ dup 1 slot swap 2 slot [ foo ] keep ] compile-1 ]
  46 unit-test
  47
  48 [ 41 5 4 ] [
  49     5/4 4/5 [
  50         dup ratio? [
  51             over ratio? [
  52                 2dup 2>fraction >r * swap r> * swap
  53                 + -rot denominator swap denominator
  54             ] [
  55                 2drop f f f
  56             ] if
  57         ] [
  58             2drop f f f
  59         ] if
  60     ] compile-1
  61 ] unit-test
  62
  63 : jxyz
  64     over bignum? [
  65         dup ratio? [
  66             [ >fraction ] 2apply swapd
  67             >r 2array swap r> 2array swap
  68         ] when
  69     ] when ;
  70
  71 \ jxyz compile
  72
  73 [ { 1 2 } { 1 1 } ] [ 1 >bignum 1/2 jxyz ] unit-test
  74
  75 [ 3 ]
  76 [
  77     global [ 3 \ foo set ] bind
  78     \ foo [ global >n get ndrop ] compile-1
  79 ] unit-test
  80
  81 : blech drop ;
  82
  83 [ 3 ]
  84 [
  85     global [ 3 \ foo set ] bind
  86     \ foo [ global [ get ] swap blech call ] compile-1
  87 ] unit-test
  88
  89 [ 3 ]
  90 [
  91     global [ 3 \ foo set ] bind
  92     \ foo [ global [ get ] swap >n call ndrop ] compile-1
  93 ] unit-test
  94
  95 [ 3 ]
  96 [
  97     global [ 3 \ foo set ] bind
  98     \ foo [ global [ get ] bind ] compile-1
  99 ] unit-test
 100
 101 [ 12 13 ] [
 102     -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-1
 103 ] unit-test
 104
 105 [ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-1 ] unit-test
 106
 107 [ 12 13 ] [
 108     -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-1
 109 ] unit-test
 110
 111 [ 2 ] [
 112     SBUF" " [ 2 slot 2 [ slot ] keep ] compile-1 nip
 113 ] unit-test
 114
 115 ! Test slow shuffles
 116 [ 3 1 2 3 4 5 6 7 8 9 ] [
 117     1 2 3 4 5 6 7 8 9
 118     [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
 119     compile-1
 120 ] unit-test
 121
 122 [ 2 2 2 2 2 2 2 2 2 2 1 ] [
 123     1 2
 124     [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-1
 125 ] unit-test
 126
 127 [ ] [ [ 9 [ ] times ] compile-1 ] unit-test
 128
 129 [ ] [
 130     [
 131         [ 200 dup [ 200 3array ] curry map drop ] times
 132     ] compile-quot drop
 133 ] unit-test
 134
 135
 136 ! Test how dispatch handles the end of a basic block
 137 : try-breaking-dispatch
 138     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 139
 140 : try-breaking-dispatch-2
 141     1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
 142
 143 [ t ] [
 144     10000000 [ drop try-breaking-dispatch-2 ] all?
 145 ] unit-test
 146
 147 ! Regression
 148 : (broken) ( x -- y ) ;
 149
 150 [ 2.0 { 2.0 0.0 } ] [
 151     2.0 1.0
 152     [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-1
 153 ] unit-test
 154
 155 ! Regression
 156 : hellish-bug-1 2drop ;
 157
 158 : hellish-bug-2 ( i array x -- x )
 159     2dup 1 slot eq? [ 2drop ] [
 160         2dup array-nth tombstone? [
 161             [
 162                 [ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
 163                 pick 2dup hellish-bug-1 3drop
 164             ] 2keep
 165         ] unless >r 2 fixnum+fast r> hellish-bug-2
 166     ] if ; inline
 167
 168 : hellish-bug-3 ( hash array -- )
 169     0 swap hellish-bug-2 drop ;
 170
 171 [ ] [
 172     H{ { 1 2 } { 3 4 } } dup hash-array
 173     [ 0 swap hellish-bug-2 drop ] compile-1
 174 ] unit-test
 175
 176 ! Regression
 177 : foox
 178     dup not
 179     [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
 180
 181 [ 3 ] [ f foox ] unit-test
 182
 183 TUPLE: my-tuple ;
 184
 185 [ 4 ] [ T{ my-tuple } foox ] unit-test
 186
 187 [ 5 ] [ "hi" foox ] unit-test