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