core/kernel/kernel-tests.factor

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