diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor deleted file mode 100644 index 805c3a4be4..0000000000 --- a/core/generic/generic-tests.factor +++ /dev/null @@ -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 - -M: for-arguments-sake empty-method-test drop "Hi" ; - -TUPLE: another-one ; -C: another-one - -[ "Hi" ] [ empty-method-test empty-method-test ] unit-test -[ T{ another-one f } ] [ 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 ;" "move-method-test-1" parse-stream drop ] unit-test - -[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" "move-method-test-2" parse-stream drop ] unit-test - -[ ] [ "IN: generic.tests.a" "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 diff --git a/core/generic/hook/hook-tests.factor b/core/generic/hook/hook-tests.factor new file mode 100644 index 0000000000..8be8355cd4 --- /dev/null +++ b/core/generic/hook/hook-tests.factor @@ -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 + diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor index 2279fd019c..34f09f87d7 100644 --- a/core/generic/math/math-tests.factor +++ b/core/generic/math/math-tests.factor @@ -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 diff --git a/core/generic/single/single-tests.factor b/core/generic/standard/standard-tests.factor similarity index 50% rename from core/generic/single/single-tests.factor rename to core/generic/standard/standard-tests.factor index 6be03042cb..37946102a1 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -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 perimiter ] unit-test [ 30.0 ] [ 10 4 3 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 + +M: for-arguments-sake empty-method-test drop "Hi" ; + +TUPLE: another-one ; +C: another-one + +[ "Hi" ] [ empty-method-test empty-method-test ] unit-test +[ T{ another-one f } ] [ 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 big-mix-test ] unit-test [ "parallelogram" ] [ 10 4 3 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 ;" "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 ;" "move-method-test-2" parse-stream drop ] unit-test + +[ ] [ "IN: generic.standard.tests.a" "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