1 USING: tools.test kernel sequences words sequences.private fry
2 prettyprint alien alien.accessors math.private compiler.tree.builder
3 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
4 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
5 compiler.cfg arrays locals byte-arrays kernel.private math
6 slots.private vectors sbufs strings math.partial-dispatch
7 hashtables assocs combinators.short-circuit
8 strings.private accessors compiler.cfg.instructions ;
9 IN: compiler.cfg.builder.tests
11 ! Just ensure that various CFGs build correctly.
12 : unit-test-cfg ( quot -- )
13 '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
15 : blahblah ( nodes -- ? )
17 dup 3 bitand 1 = [ drop t ] [
22 ] any? ; inline recursive
26 : test-case-1 ( -- ? ) f ;
29 test-case-1 [ test-case-2 ] [ ] if ; inline recursive
41 [ 3 swap fixnum*fast ]
43 [ 10 fixnum-shift-fast ]
44 [ -10 fixnum-shift-fast ]
45 [ 0 fixnum-shift-fast ]
46 [ 10 swap fixnum-shift-fast ]
47 [ -10 swap fixnum-shift-fast ]
48 [ 0 swap fixnum-shift-fast ]
63 [ fixnum< [ 1 ] [ 2 ] if ]
64 [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
65 [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
68 [ [ 2 ] [ 3 throw ] if 4 ]
69 [ "int" f "malloc" { "int" } alien-invoke ]
70 [ "int" { "int" } "cdecl" alien-indirect ]
71 [ "int" { "int" } "cdecl" [ ] alien-callback ]
75 [ 1000 [ dup [ reverse ] when ] times ]
78 [ { array } declare [ ] map ]
79 [ { array } declare dup 1 slot [ 1 slot ] when ]
80 [ [ dup more? ] [ dup ] produce ]
81 [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
82 [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
84 { fixnum sbuf } declare 2dup 3 slot fixnum> [
85 over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
88 [ [ 2 fixnum* ] when 3 ]
89 [ [ 2 fixnum+ ] when 3 ]
90 [ [ 2 fixnum- ] when 3 ]
94 over dup 16 <-integer-fixnum
95 [ 0 >=-integer-fixnum ] [ drop f ] if [
102 pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
109 : test-1 ( -- ) test-1 ;
110 : test-2 ( -- ) 3 . test-2 ;
111 : test-3 ( a -- b ) dup [ test-3 ] when ;
117 } [ unit-test-cfg ] each
136 { class } word '[ _ declare 10 _ execute ] unit-test-cfg
137 { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
148 { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
149 { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
152 { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
153 { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
155 { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
156 { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
158 { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
159 { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
162 : count-insns ( quot insn-check -- ? )
163 [ test-mr [ instructions>> ] map ] dip
164 '[ _ count ] sigma ; inline
166 : contains-insn? ( quot insn-check -- ? )
167 count-insns 0 > ; inline
169 [ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
171 [ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
174 [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
175 [ ##set-alien-integer-1? ] contains-insn?
179 [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
180 [ ##set-alien-integer-1? ] contains-insn?
184 [ { byte-array fixnum } declare set-alien-unsigned-1 ]
185 [ ##set-alien-integer-1? ] contains-insn?
190 [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
194 [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
195 [ [ ##unbox-any-c-ptr? ] contains-insn? ]
196 [ [ ##unbox-alien? ] contains-insn? ] bi
199 \ alien-float "intrinsic" word-prop [
201 [ { byte-array fixnum } declare alien-cell 4 alien-float ]
202 [ [ ##box-alien? ] contains-insn? ]
203 [ [ ##allot? ] contains-insn? ] bi
207 [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
208 [ [ ##box-alien? ] contains-insn? ]
209 [ [ ##allot? ] contains-insn? ] bi
212 [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
215 ! Regression. Make sure everything is inlined correctly
216 [ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test