Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / compiler / cfg / builder / builder-tests.factor

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index a9f3f2eaa97f063e21156c1e5057cc5f5614c9e1..b2f25fdeb18ec7092ca3712cc33ae764196f0f6b 100644 (file)
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -1,17 +1,63 @@
+USING: tools.test kernel sequences words sequences.private fry
+prettyprint alien alien.accessors math.private compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
+compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
+compiler.cfg arrays locals byte-arrays kernel.private math
+slots.private vectors sbufs strings math.partial-dispatch
+strings.private ;
 IN: compiler.cfg.builder.tests
-USING: tools.test kernel sequences
-words sequences.private fry prettyprint alien
-math.private compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.debugger  ;
 
 ! Just ensure that various CFGs build correctly.
+: unit-test-cfg ( quot -- )
+    '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+
+: blahblah ( nodes -- ? )
+    { fixnum } declare [
+        dup 3 bitand 1 = [ drop t ] [
+            dup 3 bitand 2 = [
+                blahblah
+            ] [ drop f ] if
+        ] if
+    ] any? ; inline recursive
+
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+    test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
 {
     [ ]
     [ dup ]
     [ swap ]
-    [ >r r> ]
+    [ [ ] dip ]
     [ fixnum+ ]
+    [ fixnum+fast ]
+    [ 3 fixnum+fast ]
+    [ fixnum*fast ]
+    [ 3 fixnum*fast ]
+    [ 3 swap fixnum*fast ]
+    [ fixnum-shift-fast ]
+    [ 10 fixnum-shift-fast ]
+    [ -10 fixnum-shift-fast ]
+    [ 0 fixnum-shift-fast ]
+    [ 10 swap fixnum-shift-fast ]
+    [ -10 swap fixnum-shift-fast ]
+    [ 0 swap fixnum-shift-fast ]
+    [ fixnum-bitnot ]
+    [ eq? ]
+    [ "hi" eq? ]
     [ fixnum< ]
+    [ 5 fixnum< ]
+    [ float+ ]
+    [ 3.0 float+ ]
+    [ float<= ]
+    [ fixnum>bignum ]
+    [ bignum>fixnum ]
+    [ fixnum>float ]
+    [ float>fixnum ]
+    [ 3 f <array> ]
     [ [ 1 ] [ 2 ] if ]
     [ fixnum< [ 1 ] [ 2 ] if ]
     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
@@ -22,8 +68,41 @@ compiler.cfg.builder compiler.cfg.debugger  ;
     [ "int" f "malloc" { "int" } alien-invoke ]
     [ "int" { "int" } "cdecl" alien-indirect ]
     [ "int" { "int" } "cdecl" [ ] alien-callback ]
+    [ swap - + * ]
+    [ swap slot ]
+    [ blahblah ]
+    [ 1000 [ dup [ reverse ] when ] times ]
+    [ 1array ]
+    [ 1 2 ? ]
+    [ { array } declare [ ] map ]
+    [ { array } declare dup 1 slot [ 1 slot ] when ]
+    [ [ dup more? ] [ dup ] produce ]
+    [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+    [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+    [
+        { fixnum sbuf } declare 2dup 3 slot fixnum> [
+            over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+        ] [ ] if
+    ]
+    [ [ 2 fixnum* ] when 3 ]
+    [ [ 2 fixnum+ ] when 3 ]
+    [ [ 2 fixnum- ] when 3 ]
+    [ 10000 [ ] times ]
+    [
+        over integer? [
+            over dup 16 <-integer-fixnum
+            [ 0 >=-integer-fixnum ] [ drop f ] if [
+                nip dup
+                [ ] [ ] if
+            ] [ 2drop f ] if
+        ] [ 2drop f ] if
+    ]
+    [
+        pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
+        set-string-nth-fast
+    ]
 } [
-    '[ _ test-cfg drop ] [ ] swap unit-test
+    unit-test-cfg
 ] each
 
 : test-1 ( -- ) test-1 ;
@@ -34,6 +113,47 @@ compiler.cfg.builder compiler.cfg.debugger  ;
     test-1
     test-2
     test-3
-} [
-    '[ _ test-cfg drop ] [ ] swap unit-test
+} [ unit-test-cfg ] each
+
+{
+    byte-array
+    simple-alien
+    alien
+    POSTPONE: f
+} [| class |
+    {
+        alien-signed-1
+        alien-signed-2
+        alien-signed-4
+        alien-unsigned-1
+        alien-unsigned-2
+        alien-unsigned-4
+        alien-cell
+        alien-float
+        alien-double
+    } [| word |
+        { class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+    ] each
+    
+    {
+        set-alien-signed-1
+        set-alien-signed-2
+        set-alien-signed-4
+        set-alien-unsigned-1
+        set-alien-unsigned-2
+        set-alien-unsigned-4
+    } [| word |
+        { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+    ] each
+    
+    { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
+    
+    { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+    
+    { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
+    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 ] each