Fix various unit tests
Slava Pestov
parent
08c3842403
commit
52fef83061
|
|
@ -6,17 +6,17 @@ io.streams.byte-array ;
|
|||
IN: bitstreams.tests
|
||||
|
||||
[ 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 ]
|
||||
[ 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 ]
|
||||
[ 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 } ]
|
||||
[
|
||||
<string-writer> <bitstream-writer> 254 8 rot
|
||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <CTLine> &CFRelease
|
||||
line-typographic-bounds {
|
||||
test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
|
||||
compute-line-metrics {
|
||||
[ width>> float? ]
|
||||
[ ascent>> float? ]
|
||||
[ descent>> float? ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -45,4 +45,4 @@ M: string blah-generic ;
|
|||
|
||||
{ string blah-generic } watch
|
||||
|
||||
[ ] [ "hi" blah-generic ] unit-test
|
||||
[ "hi" ] [ "hi" blah-generic ] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <board> rows>> ] unit-test
|
||||
[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
|
||||
[ f ] [ 2 3 <board> { 1 1 } block ] unit-test
|
||||
[ 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
|
||||
[ f ] [ 2 3 <board> dup { 1 1 } 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 } red set-block { 0 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 } COLOR: red set-block { 1 2 } 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
|
||||
[ f ] [ 2 3 <board> { -1 0 } 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
|
||||
[ 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
|
||||
[ 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 } } ] [ 1 2 <board> dup { 0 1 } 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 } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test
|
||||
[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <list-presentation> ( hook elt presenter -- gadget )
|
||||
keep [ >label text-theme ] dip
|
||||
[ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip
|
||||
<presentation>
|
||||
swap >>hook ; inline
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue