core/kernel/kernel-tests.factor

   1 USING: arrays byte-arrays kernel kernel.private literals math
   2 memory namespaces sequences tools.test math.private quotations
   3 continuations prettyprint io.streams.string debugger assocs
   4 sequences.private accessors locals.backend grouping words
   5 system alien alien.accessors ;
   6 IN: kernel.tests
   7
   8 [ 0 ] [ f size ] unit-test
   9 [ t ] [ [ \ = \ = ] all-equal? ] unit-test
  10
  11 ! Don't leak extra roots if error is thrown
  12 [ ] [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test
  13
  14 [ ] [ 1000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
  15
  16 ! Make sure we report the correct error on stack underflow
  17 [ clear drop ] [
  18     ${ "kernel-error" ERROR-DATASTACK-UNDERFLOW f f } =
  19 ] must-fail-with
  20
  21 [ ] [ :c ] unit-test
  22
  23 [
  24     3 [ { } set-retainstack ] dip ]
  25     [ ${ "kernel-error" ERROR-RETAINSTACK-UNDERFLOW f f } =
  26 ] must-fail-with
  27
  28 [ ] [ :c ] unit-test
  29
  30 : overflow-d ( -- ) 3 overflow-d ;
  31
  32 : (overflow-d-alt) ( -- n ) 3 ;
  33
  34 : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
  35
  36 : overflow-r ( -- ) 3 load-local overflow-r ;
  37
  38 <<
  39 { overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
  40 [ t "no-compile" set-word-prop ] each
  41 >>
  42
  43 [ overflow-d ] [
  44     ${ "kernel-error" ERROR-DATASTACK-OVERFLOW f f } =
  45 ] must-fail-with
  46
  47 [ ] [ :c ] unit-test
  48
  49 [ overflow-d-alt ] [
  50     ${ "kernel-error" ERROR-DATASTACK-OVERFLOW f f } =
  51 ] must-fail-with
  52
  53 [ ] [ [ :c ] with-string-writer drop ] unit-test
  54
  55 [ overflow-r ] [
  56     ${ "kernel-error" ERROR-RETAINSTACK-OVERFLOW f f } =
  57 ] must-fail-with
  58
  59 [ ] [ :c ] unit-test
  60
  61 : overflow-c ( -- ) overflow-c overflow-c ;
  62
  63 ! The VM cannot recover from callstack overflow on Windows,
  64 ! because no facility exists to run memory protection
  65 ! fault handlers on an alternate callstack.
  66 os windows? [
  67     [ overflow-c ] [
  68         ${ "kernel-error" ERROR-CALLSTACK-OVERFLOW f f } =
  69     ] must-fail-with
  70 ] unless
  71
  72 [ -7 <byte-array> ] must-fail
  73
  74 [ 3 ] [ t 3 and ] unit-test
  75 [ f ] [ f 3 and ] unit-test
  76 [ f ] [ 3 f and ] unit-test
  77 [ 4 ] [ 4 6 or ] unit-test
  78 [ 6 ] [ f 6 or ] unit-test
  79 [ f ] [ 1 2 xor ] unit-test
  80 [ 1 ] [ 1 f xor ] unit-test
  81 [ 2 ] [ f 2 xor ] unit-test
  82 [ f ] [ f f xor ] unit-test
  83
  84 [ dip ] must-fail
  85 [ ] [ :c ] unit-test
  86
  87 [ 1 [ call ] dip ] must-fail
  88 [ ] [ :c ] unit-test
  89
  90 [ 1 2 [ call ] dip ] must-fail
  91 [ ] [ :c ] unit-test
  92
  93 [ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test
  94
  95 [ [ ] keep ] must-fail
  96
  97 [ 6 ] [ 2 [ sq ] keep + ] unit-test
  98
  99 [ [ ] 2keep ] must-fail
 100 [ 1 [ ] 2keep ] must-fail
 101 [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
 102
 103 [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test
 104 [ 4 ] [ 2 [ sq ] [ 0 ] if* ] unit-test
 105
 106 [ 0 ] [ f [ 0 ] unless* ] unit-test
 107 [ t ] [ t [ "Hello" ] unless* ] unit-test
 108
 109 [ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
 110 [ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
 111
 112 [ f ] [ f (clone) ] unit-test
 113 [ -123 ] [ -123 (clone) ] unit-test
 114
 115 [ 6 2 ] [ 1 2 [ 5 + ] dip ] unit-test
 116
 117 [ ] [ callstack set-callstack ] unit-test
 118
 119 [ 3drop datastack ] must-fail
 120 [ ] [ :c ] unit-test
 121
 122 ! Doesn't compile; important
 123 : foo ( a -- b ) ;
 124
 125 << \ foo t "no-compile" set-word-prop >>
 126
 127 [ drop foo ] must-fail
 128 [ ] [ :c ] unit-test
 129
 130 ! Regression
 131 : (loop) ( a b c d -- )
 132     [ pick ] dip swap [ pick ] dip swap
 133     < [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive
 134
 135 : loop ( obj -- )
 136     H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ;
 137
 138 [ loop ] must-fail
 139
 140 ! Discovered on Windows
 141 : total-failure-1 ( -- a ) "" [ ] map unimplemented ;
 142
 143 [ total-failure-1 ] 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     error-continuation get call>> callstack>array 6 head* 3 tail* ;
 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