228 lines
5.9 KiB
Factor
228 lines
5.9 KiB
Factor
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
|