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

generic: clean up unit tests a bit

db4
Slava Pestov 2010-08-21 13:04:37 -07:00
parent 8227fff723
commit 0d6f3354ab
4 changed files with 232 additions and 278 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

227
core/generic/generic-tests.factor
View File

@ -1,227 +0,0 @@
USING: accessors alien arrays assocs classes classes.algebra
classes.tuple classes.union compiler.units continuations
definitions eval generic generic.math generic.standard
hashtables io io.streams.string kernel layouts math math.order
namespaces parser prettyprint quotations sequences sorting
strings tools.test vectors words generic.single
compiler.crossref ;
IN: generic.tests
GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ;
M: fixnum foobar drop "Goodbye cruel world" ;
GENERIC: class-of ( x -- y )
M: fixnum class-of drop "fixnum" ;
M: word class-of drop "word" ;
[ "fixnum" ] [ 5 class-of ] unit-test
[ "word" ] [ \ class-of class-of ] unit-test
[ 3.4 class-of ] must-fail
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
! Testing unions
UNION: funnies quotation float complex ;
GENERIC: funny ( x -- y )
M: funnies funny drop 2 ;
M: object funny drop 0 ;
[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test
PREDICATE: very-funny < funnies number? ;
GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test
GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
C: <for-arguments-sake> for-arguments-sake
M: for-arguments-sake empty-method-test drop "Hi" ;
TUPLE: another-one ;
C: <another-one> another-one
[ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
[ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
! Weird bug
GENERIC: stack-underflow ( x y -- )
M: object stack-underflow 2drop ;
M: word stack-underflow 2drop ;
GENERIC: union-containment ( x -- y )
M: integer union-containment drop 1 ;
M: number union-containment drop 2 ;
[ 1 ] [ 1 union-containment ] unit-test
[ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- )
[
"IN: generic.tests M: dictionary unhappy ;" eval( -- )
] must-fail
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
M: object complex-combination nip ;
[ "hi" ] [ "hi" 3 complex-combination ] unit-test
[ "hi" ] [ 3 "hi" complex-combination ] unit-test
TUPLE: shit ;
M: shit complex-combination 2array ;
[ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test
[ t ] [ \ complex-combination generic? >boolean ] unit-test
GENERIC: big-generic-test ( x -- x y )
M: fixnum big-generic-test "fixnum" ;
M: bignum big-generic-test "bignum" ;
M: ratio big-generic-test "ratio" ;
M: string big-generic-test "string" ;
M: shit big-generic-test "shit" ;
[ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
[ t ] [ \ + math-generic? ] unit-test
! Regression
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
GENERIC: wii ( x -- y )
M: both wii drop 3 ;
M: second-one wii drop 4 ;
M: tuple-class wii drop 5 ;
M: integer wii drop 6 ;
[ 3 ] [ T{ first-one } wii ] unit-test
GENERIC: tag-and-f ( x -- x x )
M: fixnum tag-and-f 1 ;
M: bignum tag-and-f 2 ;
M: float tag-and-f 3 ;
M: f tag-and-f 4 ;
[ f 4 ] [ f tag-and-f ] unit-test
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
! Issues with forget
GENERIC: generic-forget-test ( a -- b )
M: f generic-forget-test ;
[ ] [ \ f \ generic-forget-test method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ f ] [ f generic-forget-test ] unit-test
! erg's regression
[ ] [
"""IN: compiler.tests
GENERIC: jeah ( a -- b )
TUPLE: boii ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ;""" eval( -- )
"""IN: compiler.tests
FORGET: boii""" eval( -- )
"""IN: compiler.tests
TUPLE: boii ;
M: boii jeah ;""" eval( -- )
] unit-test
! call-next-method cache test
GENERIC: c-n-m-cache ( a -- b )
! Force it to be unoptimized
M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
M: integer c-n-m-cache 1 + ;
M: number c-n-m-cache ;
[ 3 ] [ 2 c-n-m-cache ] unit-test
[ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test
[ 2 ] [ 2 c-n-m-cache ] unit-test
! Moving a method from one vocab to another doesn't always work
GENERIC: move-method-generic ( a -- b )
[ ] [ "IN: generic.tests.a USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ { string } ] [ \ move-method-generic order ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
[ t ] [
reversed \ foozul method-for-class
reversed \ foozul method
eq?
] unit-test
[ t ] [
fixnum \ <=> method-for-class
real \ <=> method
eq?
] unit-test
! FORGET: on method wrappers
GENERIC: forget-test ( a -- b )
M: integer forget-test 3 + ;
[ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
[ { } ] [
\ + effect-dependencies-of keys [ method? ] filter
[ "method-generic" word-prop \ forget-test eq? ] filter
] unit-test
[ 10 forget-test ] [ no-method? ] must-fail-with
! Declarations on methods
GENERIC: flushable-generic ( a -- b ) flushable
M: integer flushable-generic ;
[ t ] [ \ flushable-generic flushable? ] unit-test
[ t ] [ M\ integer flushable-generic flushable? ] unit-test
GENERIC: non-flushable-generic ( a -- b )
M: integer non-flushable-generic ; flushable
[ f ] [ \ non-flushable-generic flushable? ] unit-test
[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test

36
core/generic/hook/hook-tests.factor Normal file
View File

@ -0,0 +1,36 @@
USING: arrays generic generic.single growable kernel math
namespaces sequences strings tools.test vectors words ;
IN: generic.hook.tests
SYMBOL: my-var
HOOK: my-hook my-var ( -- x )
M: integer my-hook "an integer" ;
M: string my-hook "a string" ;
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
HOOK: call-next-hooker my-var ( -- x )
M: sequence call-next-hooker "sequence" ;
M: array call-next-hooker call-next-method "array " prepend ;
M: vector call-next-hooker call-next-method "vector " prepend ;
M: growable call-next-hooker call-next-method "growable " prepend ;
[ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
[ t ] [
{ } \ nth effective-method nip M\ sequence nth eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test

2
core/generic/math/math-tests.factor
View File

@ -18,4 +18,4 @@ IN: generic.math.tests
[ number ] [ fixnum number math-class-max ] unit-test [ number ] [ fixnum number math-class-max ] unit-test
[ number ] [ number fixnum math-class-max ] unit-test [ number ] [ number fixnum math-class-max ] unit-test
[ t ] [ \ + math-generic? ] unit-test

245
core/generic/single/single-tests.factor → core/generic/standard/standard-tests.factor
View File

@ -3,20 +3,35 @@ generic.standard generic.single strings sequences arrays kernel
accessors words byte-arrays bit-arrays parser namespaces make accessors words byte-arrays bit-arrays parser namespaces make
quotations stack-checker vectors growable hashtables sbufs quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ; definitions generic sets graphs assocs grouping see eval
classes.union classes.tuple compiler.units io.streams.string
compiler.crossref math.order ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
FROM: namespaces => set ; FROM: namespaces => set ;
SPECIALIZED-VECTOR: c:double SPECIALIZED-VECTOR: c:double
IN: generic.single.tests IN: generic.standard.tests
GENERIC: class-of ( x -- y )
M: fixnum class-of drop "fixnum" ;
M: word class-of drop "word" ;
[ "fixnum" ] [ 5 class-of ] unit-test
[ "word" ] [ \ class-of class-of ] unit-test
[ 3.4 class-of ] must-fail
GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ;
M: fixnum foobar drop "Goodbye cruel world" ;
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
GENERIC: lo-tag-test ( obj -- obj' ) GENERIC: lo-tag-test ( obj -- obj' )
M: integer lo-tag-test 3 + ; M: integer lo-tag-test 3 + ;
M: float lo-tag-test 4 - ; M: float lo-tag-test 4 - ;
M: rational lo-tag-test 2 - ; M: rational lo-tag-test 2 - ;
M: complex lo-tag-test sq ; M: complex lo-tag-test sq ;
[ 8 ] [ 5 >bignum lo-tag-test ] unit-test [ 8 ] [ 5 >bignum lo-tag-test ] unit-test
@ -27,11 +42,8 @@ M: complex lo-tag-test sq ;
GENERIC: hi-tag-test ( obj -- obj' ) GENERIC: hi-tag-test ( obj -- obj' )
M: string hi-tag-test ", in bed" append ; M: string hi-tag-test ", in bed" append ;
M: integer hi-tag-test 3 + ; M: integer hi-tag-test 3 + ;
M: array hi-tag-test [ hi-tag-test ] map ; M: array hi-tag-test [ hi-tag-test ] map ;
M: sequence hi-tag-test reverse ; M: sequence hi-tag-test reverse ;
[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test [ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
@ -40,6 +52,22 @@ M: sequence hi-tag-test reverse ;
[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test [ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
UNION: funnies quotation float complex ;
GENERIC: funny ( x -- y )
M: funnies funny drop 2 ;
M: object funny drop 0 ;
GENERIC: union-containment ( x -- y )
M: integer union-containment drop 1 ;
M: number union-containment drop 2 ;
[ 1 ] [ 1 union-containment ] unit-test
[ 2 ] [ 1.0 union-containment ] unit-test
[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test
TUPLE: shape ; TUPLE: shape ;
TUPLE: abstract-rectangle < shape width height ; TUPLE: abstract-rectangle < shape width height ;
@ -86,6 +114,26 @@ M: circle perimiter 2 * pi * ;
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test [ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test [ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
PREDICATE: very-funny < funnies number? ;
GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test
GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
C: <for-arguments-sake> for-arguments-sake
M: for-arguments-sake empty-method-test drop "Hi" ;
TUPLE: another-one ;
C: <another-one> another-one
[ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
[ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
GENERIC: big-mix-test ( obj -- obj' ) GENERIC: big-mix-test ( obj -- obj' )
M: object big-mix-test drop "object" ; M: object big-mix-test drop "object" ;
@ -113,14 +161,12 @@ M: circle big-mix-test drop "circle" ;
[ "integer" ] [ 3 big-mix-test ] unit-test [ "integer" ] [ 3 big-mix-test ] unit-test
[ "float" ] [ 5.0 big-mix-test ] unit-test [ "float" ] [ 5.0 big-mix-test ] unit-test
[ "complex" ] [ -1 sqrt big-mix-test ] unit-test [ "complex" ] [ -1 sqrt big-mix-test ] unit-test
[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test [ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test [ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test [ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test [ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test [ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test [ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
[ "string" ] [ "hello" big-mix-test ] unit-test [ "string" ] [ "hello" big-mix-test ] unit-test
[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test [ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test [ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
@ -144,6 +190,80 @@ M: byte-array small-lo-tag drop "byte-array" ;
[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test [ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
! Testing recovery from bad method definitions
"IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- )
[
"IN: generic.standard.tests M: dictionary unhappy ;" eval( -- )
] must-fail
[ ] [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
M: object complex-combination nip ;
[ "hi" ] [ "hi" 3 complex-combination ] unit-test
[ "hi" ] [ 3 "hi" complex-combination ] unit-test
! Regression
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
GENERIC: wii ( x -- y )
M: both wii drop 3 ;
M: second-one wii drop 4 ;
M: tuple-class wii drop 5 ;
M: integer wii drop 6 ;
[ 3 ] [ T{ first-one } wii ] unit-test
GENERIC: tag-and-f ( x -- x x )
M: fixnum tag-and-f 1 ;
M: bignum tag-and-f 2 ;
M: float tag-and-f 3 ;
M: f tag-and-f 4 ;
[ f 4 ] [ f tag-and-f ] unit-test
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
! Issues with forget
GENERIC: generic-forget-test ( a -- b )
M: f generic-forget-test ;
[ ] [ \ f \ generic-forget-test method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ ] [ "IN: generic.standard.tests M: f generic-forget-test ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ f ] [ f generic-forget-test ] unit-test
! erg's regression
[ ] [
"""IN: generic.standard.tests
GENERIC: jeah ( a -- b )
TUPLE: boii ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ;""" eval( -- )
"""IN: generic.standard.tests
FORGET: boii""" eval( -- )
"""IN: generic.standard.tests
TUPLE: boii ;
M: boii jeah ;""" eval( -- )
] unit-test
! Testing next-method ! Testing next-method
TUPLE: person ; TUPLE: person ;
@ -240,49 +360,74 @@ M: c funky* "c" , call-next-method ;
{ { "a" "x" "z" } { "a" "y" "z" } } member? { { "a" "x" "z" } { "a" "y" "z" } } member?
] unit-test ] unit-test
! Hooks ! Changing method combination should not fail
SYMBOL: my-var [ ] [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
HOOK: my-hook my-var ( -- x ) [ ] [ "IN: generic.standard.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
M: integer my-hook "an integer" ; [ f ] [ "xyz" "generic.standard.tests" lookup pic-def>> ] unit-test
M: string my-hook "a string" ; [ f ] [ "xyz" "generic.standard.tests" lookup "decision-tree" word-prop ] unit-test
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
HOOK: call-next-hooker my-var ( -- x )
M: sequence call-next-hooker "sequence" ;
M: array call-next-hooker call-next-method "array " prepend ;
M: vector call-next-hooker call-next-method "vector " prepend ;
M: growable call-next-hooker call-next-method "growable " prepend ;
[ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
[ t ] [
{ } \ nth effective-method nip M\ sequence nth eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test
[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
! Corner case ! Corner case
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ] [ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ] [ error>> bad-dispatch-position? ]
must-fail-with must-fail-with
[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test ! Generic words cannot be inlined
[ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail [ ] [ "IN: generic.standard.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
[ "IN: generic.standard.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail
! Moving a method from one vocab to another didn't always work
GENERIC: move-method-generic ( a -- b )
[ ] [ "IN: generic.standard.tests.a USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ ] [ "IN: generic.standard.tests.b USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
[ ] [ "IN: generic.standard.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ { string } ] [ \ move-method-generic order ] unit-test
! FORGET: on method wrappers
GENERIC: forget-test ( a -- b )
M: integer forget-test 3 + ;
[ ] [ "IN: generic.standard.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
[ { } ] [
\ + effect-dependencies-of keys [ method? ] filter
[ "method-generic" word-prop \ forget-test eq? ] filter
] unit-test
[ 10 forget-test ] [ no-method? ] must-fail-with
! Declarations on methods
GENERIC: flushable-generic ( a -- b ) flushable
M: integer flushable-generic ;
[ t ] [ \ flushable-generic flushable? ] unit-test
[ t ] [ M\ integer flushable-generic flushable? ] unit-test
GENERIC: non-flushable-generic ( a -- b )
M: integer non-flushable-generic ; flushable
[ f ] [ \ non-flushable-generic flushable? ] unit-test
[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test
! method-for-object and method-for-class
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
[ t ] [
reversed \ foozul method-for-class
reversed \ foozul method
eq?
] unit-test
[ t ] [
fixnum \ <=> method-for-class
real \ <=> method
eq?
] unit-test