steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing unit tests

db4
Slava Pestov 2008-10-19 03:51:01 -05:00
parent 8734b82105
commit 4ae66793f0
1 changed files with 42 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
basis/compiler/tests/templates.factor
View File

@ -1,11 +1,15 @@
! Black box testing of templating optimization USING: generalizations accessors arrays compiler kernel
USING: accessors arrays compiler kernel kernel.private math kernel.private math hashtables.private math.private namespaces
hashtables.private math.private namespaces sequences sequences sequences.private tools.test namespaces.private
sequences.private tools.test namespaces.private slots.private slots.private sequences.private byte-arrays alien
sequences.private byte-arrays alien alien.accessors layouts alien.accessors layouts words definitions compiler.units io
words definitions compiler.units io combinators vectors ; combinators vectors ;
IN: compiler.tests IN: compiler.tests
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
! in here are still useful.
! Oops! ! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test [ 5000 ] [ [ 5000 ] compile-call ] unit-test
[ "hi" ] [ [ "hi" ] compile-call ] unit-test [ "hi" ] [ [ "hi" ] compile-call ] unit-test
@ -102,7 +106,7 @@ unit-test
] unit-test ] unit-test
! Test how dispatch handles the end of a basic block ! Test how dispatch handles the end of a basic block
: try-breaking-dispatch ( n a b -- a b str ) : try-breaking-dispatch ( n a b -- x str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ; float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2 ( -- ? ) : try-breaking-dispatch-2 ( -- ? )
@ -121,7 +125,7 @@ unit-test
] unit-test ] unit-test
! Regression ! Regression
: hellish-bug-1 2drop ; : hellish-bug-1 ( a b -- ) 2drop ;
: hellish-bug-2 ( i array x -- x ) : hellish-bug-2 ( i array x -- x )
2dup 1 slot eq? [ 2drop ] [ 2dup 1 slot eq? [ 2drop ] [
@ -131,7 +135,7 @@ unit-test
pick 2dup hellish-bug-1 3drop pick 2dup hellish-bug-1 3drop
] 2keep ] 2keep
] unless >r 2 fixnum+fast r> hellish-bug-2 ] unless >r 2 fixnum+fast r> hellish-bug-2
] if ; inline ] if ; inline recursive
: hellish-bug-3 ( hash array -- ) : hellish-bug-3 ( hash array -- )
0 swap hellish-bug-2 drop ; 0 swap hellish-bug-2 drop ;
@ -334,6 +338,35 @@ TUPLE: my-tuple ;
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test [ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
nip 2 fixnum+fast
] [
drop {
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
} cleave
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
! Regression ! Regression
: dispatch-alignment-regression ( -- c ) : dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare { tuple vector } 3 slot { word } declare