From 52fef83061cf198ca1626e5cfd3e75d5ba97d423 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Mar 2009 15:58:14 -0600 Subject: [PATCH] Fix various unit tests --- basis/bitstreams/bitstreams-tests.factor | 8 +++---- basis/core-text/core-text-tests.factor | 13 +++++------ .../simple-flat-file-tests.factor | 2 +- .../stack-checker/stack-checker-tests.factor | 22 ++++++++----------- .../annotations/annotations-tests.factor | 2 +- basis/ui/tools/listener/listener-tests.factor | 4 ++-- extra/tetris/board/board-tests.factor | 16 +++++++------- extra/ui/gadgets/lists/lists.factor | 10 ++++----- 8 files changed, 36 insertions(+), 41 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index d55910b131..769efcbb04 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -6,17 +6,17 @@ io.streams.byte-array ; IN: bitstreams.tests [ 1 t ] -[ B{ 254 } read-bit ] unit-test +[ B{ 254 } binary read-bit ] unit-test [ 254 8 t ] -[ B{ 254 } 8 swap read-bits ] unit-test +[ B{ 254 } binary 8 swap read-bits ] unit-test [ 4095 12 t ] -[ B{ 255 255 } 12 swap read-bits ] unit-test +[ B{ 255 255 } binary 12 swap read-bits ] unit-test [ B{ 254 } ] [ - 254 8 rot + binary 254 8 rot [ write-bits ] keep stream>> >byte-array ] unit-test diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index 93f92391c8..a5cf69fdee 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-text core-foundation -core-foundation.dictionaries destructors -arrays kernel generalizations math accessors -core-foundation.utilities -combinators hashtables colors ; +USING: tools.test core-text core-text.fonts core-foundation +core-foundation.dictionaries destructors arrays kernel generalizations +math accessors core-foundation.utilities combinators hashtables colors +colors.constants ; IN: core-text.tests : test-font ( name -- font ) @@ -21,8 +20,8 @@ IN: core-text.tests : test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease white &CFRelease - line-typographic-bounds { + test-font &CFRelease tuck COLOR: white &CFRelease + compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] diff --git a/basis/simple-flat-file/simple-flat-file-tests.factor b/basis/simple-flat-file/simple-flat-file-tests.factor index 5b58f569cb..33b6d4ac2a 100644 --- a/basis/simple-flat-file/simple-flat-file-tests.factor +++ b/basis/simple-flat-file/simple-flat-file-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Yun, Jonghyouk. ! 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 diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6e7774aba1..c881ccee11 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -288,7 +288,7 @@ DEFER: bar [ [ [ dup call ] dup call ] infer ] [ inference-error? ] must-fail-with -: m dup call ; inline +: m ( q -- ) dup call ; inline [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with @@ -296,13 +296,13 @@ DEFER: bar [ [ [ 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-if t over if ; inline +: m-if ( a b c -- ) t over if ; inline [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with @@ -488,7 +488,7 @@ ERROR: custom-error ; [ custom-error ] infer ] unit-test -: funny-throw throw ; inline +: funny-throw ( a -- * ) throw ; inline [ T{ effect f 0 0 t } ] [ [ 3 funny-throw ] infer @@ -502,12 +502,8 @@ ERROR: custom-error ; [ dup [ 3 throw ] dip ] infer ] unit-test -! This was a false trigger of the undecidable quotation -! recursion bug -{ 2 1 } [ find-last-sep ] must-infer-as - ! Regression -: missing->r-check 1 load-locals ; +: missing->r-check ( a -- ) 1 load-locals ; [ [ missing->r-check ] infer ] must-fail @@ -516,7 +512,7 @@ ERROR: custom-error ; [ [ [ 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 @@ -544,10 +540,10 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; [ [ 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-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 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 9210c2cab1..7e377aedd9 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -45,4 +45,4 @@ M: string blah-generic ; { string blah-generic } watch -[ ] [ "hi" blah-generic ] unit-test +[ "hi" ] [ "hi" blah-generic ] unit-test diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 337921a00c..cd56dd876e 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -25,7 +25,7 @@ IN: ui.tools.listener.tests ! This should not throw an exception [ ] [ "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 @@ -48,7 +48,7 @@ IN: ui.tools.listener.tests [ ] [ "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 diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor index 518b5544e9..81ee65bcb8 100644 --- a/extra/tetris/board/board-tests.factor +++ b/extra/tetris/board/board-tests.factor @@ -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 rows>> ] unit-test [ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test [ f ] [ 2 3 { 1 1 } block ] unit-test [ 2 3 { 2 3 } block ] must-fail -red 1array [ 2 3 dup { 1 1 } red set-block { 1 1 } block ] unit-test +COLOR: red 1array [ 2 3 dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test [ t ] [ 2 3 { 1 1 } block-free? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test +[ f ] [ 2 3 dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test [ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test [ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test [ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test [ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test [ t ] [ 2 3 { 1 1 } location-valid? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test +[ f ] [ 2 3 dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test [ t ] [ 10 10 10 piece-valid? ] unit-test [ f ] [ 2 3 10 { 1 2 } >>location piece-valid? ] unit-test [ { { f } { f } } ] [ 1 1 add-row rows>> ] unit-test -[ { { f } } ] [ 1 2 dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test -[ { { f } { f } } ] [ 1 2 dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test +[ { { f } } ] [ 1 2 dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test +[ { { f } { f } } ] [ 1 2 dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 4b5ceac086..982aabe2e8 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.vectors classes.tuple math.rectangles colors -kernel sequences models opengl math math.order namespaces -ui.commands ui.gestures ui.render ui.gadgets -ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ; +kernel sequences models opengl math math.order namespaces call +ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels +ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports +ui.gadgets.packs ; IN: ui.gadgets.lists TUPLE: list < pack index presenter color hook ; @@ -32,7 +32,7 @@ TUPLE: list < pack index presenter color hook ; hook>> [ [ list? ] find-parent ] prepend ; : ( hook elt presenter -- gadget ) - keep [ >label text-theme ] dip + [ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip swap >>hook ; inline