generic: clean up unit tests a bit
Slava Pestov
parent
8227fff723
commit
0d6f3354ab
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -18,4 +18,4 @@ IN: generic.math.tests
|
|||
[ number ] [ fixnum number math-class-max ] unit-test
|
||||
[ number ] [ number fixnum math-class-max ] unit-test
|
||||
|
||||
|
||||
[ t ] [ \ + math-generic? ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,20 +3,35 @@ generic.standard generic.single strings sequences arrays kernel
|
|||
accessors words byte-arrays bit-arrays parser namespaces make
|
||||
quotations stack-checker vectors growable hashtables sbufs
|
||||
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
|
||||
FROM: namespaces => set ;
|
||||
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' )
|
||||
|
||||
M: integer lo-tag-test 3 + ;
|
||||
|
||||
M: float lo-tag-test 4 - ;
|
||||
|
||||
M: rational lo-tag-test 2 - ;
|
||||
|
||||
M: complex lo-tag-test sq ;
|
||||
|
||||
[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
|
||||
|
|
@ -27,11 +42,8 @@ M: complex lo-tag-test sq ;
|
|||
GENERIC: hi-tag-test ( obj -- obj' )
|
||||
|
||||
M: string hi-tag-test ", in bed" append ;
|
||||
|
||||
M: integer hi-tag-test 3 + ;
|
||||
|
||||
M: array hi-tag-test [ hi-tag-test ] map ;
|
||||
|
||||
M: sequence hi-tag-test reverse ;
|
||||
|
||||
[ 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
|
||||
|
||||
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: abstract-rectangle < shape width height ;
|
||||
|
|
@ -86,6 +114,26 @@ M: circle perimiter 2 * pi * ;
|
|||
[ 14 ] [ 4 3 <rectangle> 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' )
|
||||
|
||||
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
|
||||
[ "float" ] [ 5.0 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" ] [ ?{ t f t } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
|
||||
[ "sequence" ] [ V{ "a" "b" } 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" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
|
||||
[ "string" ] [ "hello" big-mix-test ] unit-test
|
||||
[ "rectangle" ] [ 1 2 <rectangle> 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
|
||||
|
||||
! 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
|
||||
TUPLE: person ;
|
||||
|
||||
|
|
@ -240,49 +360,74 @@ M: c funky* "c" , call-next-method ;
|
|||
{ { "a" "x" "z" } { "a" "y" "z" } } member?
|
||||
] unit-test
|
||||
|
||||
! Hooks
|
||||
SYMBOL: my-var
|
||||
HOOK: my-hook my-var ( -- x )
|
||||
! Changing method combination should not fail
|
||||
[ ] [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: generic.standard.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
|
||||
|
||||
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
|
||||
|
||||
[ ] [ "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
|
||||
[ f ] [ "xyz" "generic.standard.tests" lookup pic-def>> ] unit-test
|
||||
[ f ] [ "xyz" "generic.standard.tests" lookup "decision-tree" word-prop ] unit-test
|
||||
|
||||
! 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? ]
|
||||
must-fail-with
|
||||
|
||||
[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
|
||||
[ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail
|
||||
! Generic words cannot be inlined
|
||||
[ ] [ "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
|
||||
Loading…
Reference in New Issue