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 vocabs.loader
8 { 0 } [ f size ] unit-test
9 { t } [ [ \ = \ = ] all-equal? ] unit-test
24 } [ 1 2 10 <iota> [ 3array ] 2with map ] unit-test
27 ! Don't leak extra roots if error is thrown
28 { } [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test
30 [ -1 f <array> ] must-fail
31 { } [ 10 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
32 ! { } [ 1000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test ! Travis CI fails
34 ! Make sure we report the correct error on stack underflow
36 2 head ${ KERNEL-ERROR ERROR-DATASTACK-UNDERFLOW } =
42 3 [ { } set-retainstack ] dip ]
43 [ 2 head ${ KERNEL-ERROR ERROR-RETAINSTACK-UNDERFLOW } =
48 : overflow-d ( -- ) 3 overflow-d ;
50 : (overflow-d-alt) ( -- n ) 3 ;
52 : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
54 : overflow-r ( -- ) 3 load-local overflow-r ;
57 { overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
58 [ t "no-compile" set-word-prop ] each
62 2 head ${ KERNEL-ERROR ERROR-DATASTACK-OVERFLOW } =
68 2 head ${ KERNEL-ERROR ERROR-DATASTACK-OVERFLOW } =
71 { } [ [ :c ] with-string-writer drop ] unit-test
74 2 head ${ KERNEL-ERROR ERROR-RETAINSTACK-OVERFLOW } =
79 [ -7 <byte-array> ] must-fail
81 { 3 } [ t 3 and ] unit-test
82 { f } [ f 3 and ] unit-test
83 { f } [ 3 f and ] unit-test
84 { 4 } [ 4 6 or ] unit-test
85 { 6 } [ f 6 or ] unit-test
86 { f } [ 1 2 xor ] unit-test
87 { 1 } [ 1 f xor ] unit-test
88 { 2 } [ f 2 xor ] unit-test
89 { f } [ f f xor ] unit-test
94 [ 1 [ call ] dip ] must-fail
97 [ 1 2 [ call ] dip ] must-fail
100 { 5 } [ 1 [ 2 2 + ] dip + ] unit-test
102 [ [ ] keep ] must-fail
104 { 6 } [ 2 [ sq ] keep + ] unit-test
106 [ [ ] 2keep ] must-fail
107 [ 1 [ ] 2keep ] must-fail
108 { 3 1 2 } [ 1 2 [ 2drop 3 ] 2keep ] unit-test
110 { 0 } [ f [ sq ] [ 0 ] if* ] unit-test
111 { 4 } [ 2 [ sq ] [ 0 ] if* ] unit-test
113 { 0 } [ f [ 0 ] unless* ] unit-test
114 { t } [ t [ "Hello" ] unless* ] unit-test
116 { "2\n" } [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
117 { "9\n" } [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
119 { f } [ f (clone) ] unit-test
120 { -123 } [ -123 (clone) ] unit-test
122 { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
124 { } [ get-callstack set-callstack ] unit-test
126 [ 3drop get-datastack ] must-fail
129 ! Doesn't compile; important
132 << \ foo t "no-compile" set-word-prop >>
134 [ drop foo ] must-fail
138 : (loop) ( a b c d -- )
139 pickd swap pickd swap
140 < [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive
143 H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ;
147 { 1 1 2 2 3 3 } [ 1 2 3 [ dup ] tri@ ] unit-test
148 { 1 4 9 } [ 1 2 3 [ sq ] tri@ ] unit-test
149 [ [ sq ] tri@ ] must-infer
151 { 4 } [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test
153 ! Test traceback accuracy
154 : last-frame ( -- pair )
155 6 9 error-continuation get call>> callstack>array subseq ;
158 { [ 1 2 [ 3 throw ] call 4 ] [ 1 2 [ 3 throw ] call 4 ] 3 }
160 [ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
165 { [ 1 2 [ 3 throw ] dip 4 ] [ 1 2 [ 3 throw ] dip 4 ] 3 }
167 [ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
172 { [ 1 2 3 throw [ ] call 4 ] [ 1 2 3 throw [ ] call 4 ] 3 }
174 [ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
179 { [ 1 2 3 throw [ ] dip 4 ] [ 1 2 3 throw [ ] dip 4 ] 3 }
181 [ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
186 { [ 1 2 3 throw [ ] [ ] if 4 ] [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
188 [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
192 { 10 2 3 4 5 } [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test
194 { 3 -1 5/6 } [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
196 { { 1 2 } { 3 4 } { 5 6 } } [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
198 { t } [ { } identity-hashcode fixnum? ] unit-test
199 { 123 } [ 123 identity-hashcode ] unit-test
200 { t } [ f identity-hashcode fixnum? ] unit-test
202 ! Make sure memory protection faults work
203 [ f 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with
204 [ 1 <alien> 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with
206 { 1 2 3 1 2 3 } [ 1 2 3 3dup ] unit-test
207 { 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4dup ] unit-test
209 { 2 3 4 1 } [ 1 2 3 4 roll ] unit-test
210 { 1 2 3 4 } [ 2 3 4 1 -roll ] unit-test
212 { } [ "kernel" reload ] long-unit-test