/core/kernel/kernel-tests.factor

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