USING: accessors assocs classes classes.algebra compiler.units eval generic.single kernel math strings tools.test words ; IN: classes.predicate.tests PREDICATE: negative < integer 0 < ; PREDICATE: positive < integer 0 > ; { t } [ negative integer class< ] unit-test { t } [ positive integer class< ] unit-test { f } [ integer negative class< ] unit-test { f } [ integer positive class< ] unit-test { f } [ negative negative class< ] unit-test { f } [ positive negative class< ] unit-test GENERIC: abs ( n -- n ) M: integer abs ; M: negative abs -1 * ; M: positive abs ; { 10 } [ -10 abs ] unit-test { 10 } [ 10 abs ] unit-test { 0 } [ 0 abs ] unit-test ! Bug report from Bruno Deferrari TUPLE: tuple-a slot ; TUPLE: tuple-b < tuple-a ; PREDICATE: tuple-c < tuple-b slot>> ; GENERIC: ptest ( tuple -- x ) M: tuple-a ptest drop tuple-a ; M: tuple-c ptest drop tuple-c ; { tuple-a } [ tuple-b new ptest ] unit-test { tuple-c } [ tuple-b new t >>slot ptest ] unit-test PREDICATE: tuple-d < tuple-a slot>> ; GENERIC: ptest' ( tuple -- x ) M: tuple-a ptest' drop tuple-a ; M: tuple-d ptest' drop tuple-d ; { tuple-a } [ tuple-b new ptest' ] unit-test { tuple-d } [ tuple-b new t >>slot ptest' ] unit-test PREDICATE: bad-inheritance-predicate < string ; [ "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- ) ] [ error>> bad-inheritance? ] must-fail-with PREDICATE: bad-inheritance-predicate2 < string ; PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ; [ "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- ) ] [ error>> bad-inheritance? ] must-fail-with ! This must not fail PREDICATE: tup < string ; UNION: u tup ; { } [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test ! Changing the metaclass of the predicate superclass should work GENERIC: change-meta-test ( a -- b ) TUPLE: change-meta-test-class length ; PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ; M: change-meta-test-predicate change-meta-test length>> ; { f } [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test [ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with { 7 } [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test { } [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test ! Should not have changed { change-meta-test-class } [ change-meta-test-predicate superclass-of ] unit-test [ { } change-meta-test ] [ no-method? ] must-fail-with { 4 } [ { 1 2 3 4 } change-meta-test ] unit-test { } [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test { f } [ change-meta-test-predicate class? ] unit-test { t } [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test