1 USING: math tools.test classes.algebra words kernel sequences assocs
2 accessors eval definitions compiler.units generic strings classes
4 IN: classes.predicate.tests
6 PREDICATE: negative < integer 0 < ;
7 PREDICATE: positive < integer 0 > ;
9 [ t ] [ negative integer class< ] unit-test
10 [ t ] [ positive integer class< ] unit-test
11 [ f ] [ integer negative class< ] unit-test
12 [ f ] [ integer positive class< ] unit-test
13 [ f ] [ negative negative class< ] unit-test
14 [ f ] [ positive negative class< ] unit-test
16 GENERIC: abs ( n -- n )
18 M: negative abs -1 * ;
21 [ 10 ] [ -10 abs ] unit-test
22 [ 10 ] [ 10 abs ] unit-test
23 [ 0 ] [ 0 abs ] unit-test
25 ! Bug report from Bruno Deferrari
27 TUPLE: tuple-b < tuple-a ;
29 PREDICATE: tuple-c < tuple-b slot>> ;
31 GENERIC: ptest ( tuple -- x )
32 M: tuple-a ptest drop tuple-a ;
33 M: tuple-c ptest drop tuple-c ;
35 [ tuple-a ] [ tuple-b new ptest ] unit-test
36 [ tuple-c ] [ tuple-b new t >>slot ptest ] unit-test
38 PREDICATE: tuple-d < tuple-a slot>> ;
40 GENERIC: ptest' ( tuple -- x )
41 M: tuple-a ptest' drop tuple-a ;
42 M: tuple-d ptest' drop tuple-d ;
44 [ tuple-a ] [ tuple-b new ptest' ] unit-test
45 [ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test
47 PREDICATE: bad-inheritance-predicate < string ;
49 "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- )
50 ] [ error>> bad-inheritance? ] must-fail-with
52 PREDICATE: bad-inheritance-predicate2 < string ;
53 PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ;
55 "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- )
56 ] [ error>> bad-inheritance? ] must-fail-with
59 PREDICATE: tup < string ;
62 [ ] [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test
64 ! Changing the metaclass of the predicate superclass should work
65 GENERIC: change-meta-test ( a -- b )
67 TUPLE: change-meta-test-class length ;
69 PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ;
71 M: change-meta-test-predicate change-meta-test length>> ;
73 [ f ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test
75 [ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with
76 [ 7 ] [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test
78 [ ] [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test
80 ! Should not have changed
81 [ change-meta-test-class ] [ change-meta-test-predicate superclass ] unit-test
82 [ { } change-meta-test ] [ no-method? ] must-fail-with
83 [ 4 ] [ { 1 2 3 4 } change-meta-test ] unit-test
85 [ ] [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test
87 [ f ] [ change-meta-test-predicate class? ] unit-test
89 [ t ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test