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

Fix various unit tests

db4
Slava Pestov 2009-03-07 15:58:14 -06:00
parent 08c3842403
commit 52fef83061
8 changed files with 36 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/bitstreams/bitstreams-tests.factor
View File

@ -6,17 +6,17 @@ io.streams.byte-array ;
IN: bitstreams.tests IN: bitstreams.tests
[ 1 t ] [ 1 t ]
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test [ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
[ 254 8 t ] [ 254 8 t ]
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test [ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ 4095 12 t ] [ 4095 12 t ]
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test [ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 254 } ] [ B{ 254 } ]
[ [
<string-writer> <bitstream-writer> 254 8 rot binary <byte-writer> <bitstream-writer> 254 8 rot
[ write-bits ] keep stream>> >byte-array [ write-bits ] keep stream>> >byte-array
] unit-test ] unit-test

13
basis/core-text/core-text-tests.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text core-foundation USING: tools.test core-text core-text.fonts core-foundation
core-foundation.dictionaries destructors core-foundation.dictionaries destructors arrays kernel generalizations
arrays kernel generalizations math accessors math accessors core-foundation.utilities combinators hashtables colors
core-foundation.utilities colors.constants ;
combinators hashtables colors ;
IN: core-text.tests IN: core-text.tests
: test-font ( name -- font ) : test-font ( name -- font )
@ -21,8 +20,8 @@ IN: core-text.tests
: test-typographic-bounds ( string font -- ? ) : test-typographic-bounds ( string font -- ? )
[ [
test-font &CFRelease white <CTLine> &CFRelease test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
line-typographic-bounds { compute-line-metrics {
[ width>> float? ] [ width>> float? ]
[ ascent>> float? ] [ ascent>> float? ]
[ descent>> float? ] [ descent>> float? ]

2
basis/simple-flat-file/simple-flat-file-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Yun, Jonghyouk. ! Copyright (C) 2009 Yun, Jonghyouk.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: simple-flat-file tools.test memoize ; USING: simple-flat-file tools.test memoize assocs ;
IN: simple-flat-file.tests IN: simple-flat-file.tests

22
basis/stack-checker/stack-checker-tests.factor
View File

@ -288,7 +288,7 @@ DEFER: bar
[ [ [ dup call ] dup call ] infer ] [ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with [ inference-error? ] must-fail-with
: m dup call ; inline : m ( q -- ) dup call ; inline
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
@ -296,13 +296,13 @@ DEFER: bar
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
: m'' [ dup curry ] ; inline : m'' ( -- q ) [ dup curry ] ; inline
: m''' m'' call call ; inline : m''' ( -- ) m'' call call ; inline
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with [ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
: m-if t over if ; inline : m-if ( a b c -- ) t over if ; inline
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
@ -488,7 +488,7 @@ ERROR: custom-error ;
[ custom-error ] infer [ custom-error ] infer
] unit-test ] unit-test
: funny-throw throw ; inline : funny-throw ( a -- * ) throw ; inline
[ T{ effect f 0 0 t } ] [ [ T{ effect f 0 0 t } ] [
[ 3 funny-throw ] infer [ 3 funny-throw ] infer
@ -502,12 +502,8 @@ ERROR: custom-error ;
[ dup [ 3 throw ] dip ] infer [ dup [ 3 throw ] dip ] infer
] unit-test ] unit-test
! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as
! Regression ! Regression
: missing->r-check 1 load-locals ; : missing->r-check ( a -- ) 1 load-locals ;
[ [ missing->r-check ] infer ] must-fail [ [ missing->r-check ] infer ] must-fail
@ -516,7 +512,7 @@ ERROR: custom-error ;
[ [ [ f dup ] [ ] while ] infer ] must-fail [ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
[ [ erg's-inference-bug ] infer ] must-fail [ [ erg's-inference-bug ] infer ] must-fail
@ -544,10 +540,10 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
[ [ inference-invalidation-d ] infer ] must-fail [ [ inference-invalidation-d ] infer ] must-fail
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail [ [ bad-recursion-3 ] infer ] must-fail
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
: bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive

2
basis/tools/annotations/annotations-tests.factor
View File

@ -45,4 +45,4 @@ M: string blah-generic ;
{ string blah-generic } watch { string blah-generic } watch
[ ] [ "hi" blah-generic ] unit-test [ "hi" ] [ "hi" blah-generic ] unit-test

4
basis/ui/tools/listener/listener-tests.factor
View File

@ -25,7 +25,7 @@ IN: ui.tools.listener.tests
! This should not throw an exception ! This should not throw an exception
[ ] [ "interactor" get evaluate-input ] unit-test [ ] [ "interactor" get evaluate-input ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
@ -48,7 +48,7 @@ IN: ui.tools.listener.tests
[ ] [ "hi" "interactor" get set-editor-string ] unit-test [ ] [ "hi" "interactor" get set-editor-string ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test [ ] [ "interactor" get evaluate-input ] unit-test

16
extra/tetris/board/board-tests.factor
View File

@ -1,23 +1,23 @@
USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ; USING: accessors arrays colors colors.constants kernel tetris.board tetris.piece tools.test ;
[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test [ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
[ { { f f } { f f } { f f } } ] [ 2 3 <board> rows>> ] unit-test [ { { f f } { f f } { f f } } ] [ 2 3 <board> rows>> ] unit-test
[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test [ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
[ f ] [ 2 3 <board> { 1 1 } block ] unit-test [ f ] [ 2 3 <board> { 1 1 } block ] unit-test
[ 2 3 <board> { 2 3 } block ] must-fail [ 2 3 <board> { 2 3 } block ] must-fail
red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test COLOR: red 1array [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test
[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test [ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test [ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test
[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test [ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test
[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test [ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test
[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test [ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test [ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test [ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test [ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test [ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test [ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test
[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test [ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test [ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
[ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test [ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test [ { { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test
[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test [ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test

10
extra/ui/gadgets/lists/lists.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.vectors classes.tuple math.rectangles colors USING: accessors math.vectors classes.tuple math.rectangles colors
kernel sequences models opengl math math.order namespaces kernel sequences models opengl math math.order namespaces call
ui.commands ui.gestures ui.render ui.gadgets ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ; ui.gadgets.packs ;
IN: ui.gadgets.lists IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ; TUPLE: list < pack index presenter color hook ;
@ -32,7 +32,7 @@ TUPLE: list < pack index presenter color hook ;
hook>> [ [ list? ] find-parent ] prepend ; hook>> [ [ list? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget ) : <list-presentation> ( hook elt presenter -- gadget )
keep [ >label text-theme ] dip [ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip
<presentation> <presentation>
swap >>hook ; inline swap >>hook ; inline