core/kernel/kernel-tests.factor

   1 USING: accessors alien alien.accessors arrays assocs byte-arrays
   2 continuations debugger grouping io.streams.string kernel
   3 kernel.private literals locals.backend math memory namespaces
   4 prettyprint sequences sequences.private tools.test words ;
   5 IN: kernel.tests
   6
   7 { 0 } [ f size ] unit-test
   8 { t } [ [ \ = \ = ] all-equal? ] unit-test
   9
  10 {
  11     {
  12         { 1 2 0 }
  13         { 1 2 1 }
  14         { 1 2 2 }
  15         { 1 2 3 }
  16         { 1 2 4 }
  17         { 1 2 5 }
  18         { 1 2 6 }
  19         { 1 2 7 }
  20         { 1 2 8 }
  21         { 1 2 9 }
  22     }
  23 } [ 1 2 10 <iota> [ 3array ] 2with map ] unit-test
  24
  25
  26 ! Don't leak extra roots if error is thrown
  27 { } [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test
  28
  29 [ -1 f <array> ] must-fail
  30 { } [ 1000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test ! Travis CI fails
  31
  32 ! Make sure we report the correct error on stack underflow
  33 [ clear drop ] [
  34     2 head ${ KERNEL-ERROR ERROR-DATASTACK-UNDERFLOW } =
  35 ] must-fail-with
  36
  37 { } [ :c ] unit-test
  38
  39 [
  40     3 [ { } set-retainstack ] dip ]
  41     [ 2 head ${ KERNEL-ERROR ERROR-RETAINSTACK-UNDERFLOW } =
  42 ] must-fail-with
  43
  44 { } [ :c ] unit-test
  45
  46 : overflow-d ( -- ) 3 overflow-d ;
  47
  48 : (overflow-d-alt) ( -- n ) 3 ;
  49
  50 : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
  51
  52 : overflow-r ( -- ) 3 load-local overflow-r ;
  53
  54 <<
  55 { overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
  56 [ t "no-compile" set-word-prop ] each
  57 >>
  58
  59 [ overflow-d ] [
  60     2 head ${ KERNEL-ERROR ERROR-DATASTACK-OVERFLOW } =
  61 ] must-fail-with
  62
  63 { } [ :c ] unit-test
  64
  65 [ overflow-d-alt ] [
  66     2 head ${ KERNEL-ERROR ERROR-DATASTACK-OVERFLOW } =
  67 ] must-fail-with
  68
  69 { } [ [ :c ] with-string-writer drop ] unit-test
  70
  71 [ overflow-r ] [
  72     2 head ${ KERNEL-ERROR ERROR-RETAINSTACK-OVERFLOW } =
  73 ] must-fail-with
  74
  75 { } [ :c ] unit-test
  76
  77 [ -7 <byte-array> ] must-fail
  78
  79 { 3 } [ t 3 and ] unit-test
  80 { f } [ f 3 and ] unit-test
  81 { f } [ 3 f and ] unit-test
  82 { 4 } [ 4 6 or ] unit-test
  83 { 6 } [ f 6 or ] unit-test
  84 { f } [ 1 2 xor ] unit-test
  85 { 1 } [ 1 f xor ] unit-test
  86 { 2 } [ f 2 xor ] unit-test
  87 { f } [ f f xor ] unit-test
  88
  89 [ dip ] must-fail
  90 { } [ :c ] unit-test
  91
  92 [ 1 [ call ] dip ] must-fail
  93 { } [ :c ] unit-test
  94
  95 [ 1 2 [ call ] dip ] must-fail
  96 { } [ :c ] unit-test
  97
  98 { 5 } [ 1 [ 2 2 + ] dip + ] unit-test
  99
 100 [ [ ] keep ] must-fail
 101
 102 { 6 } [ 2 [ sq ] keep + ] unit-test
 103
 104 [ [ ] 2keep ] must-fail
 105 [ 1 [ ] 2keep ] must-fail
 106 { 3 1 2 } [ 1 2 [ 2drop 3 ] 2keep ] unit-test
 107
 108 { 0 } [ f [ sq ] [ 0 ] if* ] unit-test
 109 { 4 } [ 2 [ sq ] [ 0 ] if* ] unit-test
 110
 111 { 0 } [ f [ 0 ] unless* ] unit-test
 112 { t } [ t [ "Hello" ] unless* ] unit-test
 113
 114 { "2\n" } [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
 115 { "9\n" } [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
 116
 117 { f } [ f (clone) ] unit-test
 118 { -123 } [ -123 (clone) ] unit-test
 119
 120 { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
 121
 122 { } [ get-callstack set-callstack ] unit-test
 123
 124 [ 3drop get-datastack ] must-fail
 125 { } [ :c ] unit-test
 126
 127 ! Doesn't compile; important
 128 : foo ( a -- b ) ;
 129
 130 << \ foo t "no-compile" set-word-prop >>
 131
 132 [ drop foo ] must-fail
 133 { } [ :c ] unit-test
 134
 135 ! Regression
 136 : (loop) ( a b c d -- )
 137     pickd swap pickd swap
 138     < [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive
 139
 140 : loop ( obj -- )
 141     H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ;
 142
 143 [ loop ] must-fail
 144
 145 { 1 1 2 2 3 3 } [ 1 2 3 [ dup ] tri@ ] unit-test
 146 { 1 4 9 } [ 1 2 3 [ sq ] tri@ ] unit-test
 147 [ [ sq ] tri@ ] must-infer
 148
 149 { 4 } [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test
 150
 151 ! Test traceback accuracy
 152 : last-frame ( -- pair )
 153     6 9 error-continuation get call>> callstack>array subseq ;
 154
 155 {
 156     { [ 1 2 [ 3 throw ] call 4 ] [ 1 2 [ 3 throw ] call 4 ] 3 }
 157 } [
 158     [ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
 159     last-frame
 160 ] unit-test
 161
 162 {
 163     { [ 1 2 [ 3 throw ] dip 4 ] [ 1 2 [ 3 throw ] dip 4 ] 3 }
 164 } [
 165     [ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
 166     last-frame
 167 ] unit-test
 168
 169 {
 170     { [ 1 2 3 throw [ ] call 4 ] [ 1 2 3 throw [ ] call 4 ] 3 }
 171 } [
 172     [ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
 173     last-frame
 174 ] unit-test
 175
 176 {
 177     { [ 1 2 3 throw [ ] dip 4 ] [ 1 2 3 throw [ ] dip 4 ] 3 }
 178 } [
 179     [ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
 180     last-frame
 181 ] unit-test
 182
 183 {
 184     { [ 1 2 3 throw [ ] [ ] if 4 ] [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
 185 } [
 186     [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
 187     last-frame
 188 ] unit-test
 189
 190 { 10 2 3 4 5 } [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test
 191
 192 { 3 -1 5/6 } [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
 193
 194 { { 1 2 } { 3 4 } { 5 6 } } [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
 195
 196 { t } [ { } identity-hashcode fixnum? ] unit-test
 197 { 123 } [ 123 identity-hashcode ] unit-test
 198 { t } [ f identity-hashcode fixnum? ] unit-test
 199
 200 ! Make sure memory protection faults work
 201 [ f 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with
 202 [ 1 <alien> 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with
 203
 204 { 1 2 3 1 2 3 } [ 1 2 3 3dup ] unit-test
 205 { 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4dup ] unit-test
 206
 207 { 2 3 4 1 } [ 1 2 3 4 roll ] unit-test
 208 { 1 2 3 4 } [ 2 3 4 1 -roll ] unit-test