1 USING: accessors alien arrays definitions generic generic.standard
2 generic.math assocs hashtables io kernel math namespaces parser
3 prettyprint sequences strings tools.test vectors words
4 quotations classes classes.algebra classes.tuple continuations
5 layouts classes.union sorting compiler.units eval multiline
9 GENERIC: foobar ( x -- y )
10 M: object foobar drop "Hello world" ;
11 M: fixnum foobar drop "Goodbye cruel world" ;
13 GENERIC: class-of ( x -- y )
15 M: fixnum class-of drop "fixnum" ;
16 M: word class-of drop "word" ;
18 [ "fixnum" ] [ 5 class-of ] unit-test
19 [ "word" ] [ \ class-of class-of ] unit-test
20 [ 3.4 class-of ] must-fail
22 [ "Hello world" ] [ 4 foobar foobar ] unit-test
23 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
26 UNION: funnies quotation float complex ;
28 GENERIC: funny ( x -- y )
29 M: funnies funny drop 2 ;
30 M: object funny drop 0 ;
32 [ 2 ] [ [ { } ] funny ] unit-test
33 [ 0 ] [ { } funny ] unit-test
35 PREDICATE: very-funny < funnies number? ;
37 GENERIC: gooey ( x -- y )
38 M: very-funny gooey sq ;
40 [ 0.25 ] [ 0.5 gooey ] unit-test
42 GENERIC: empty-method-test ( x -- y )
43 M: object empty-method-test ;
44 TUPLE: for-arguments-sake ;
45 C: <for-arguments-sake> for-arguments-sake
47 M: for-arguments-sake empty-method-test drop "Hi" ;
50 C: <another-one> another-one
52 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
53 [ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
56 GENERIC: stack-underflow ( x y -- )
57 M: object stack-underflow 2drop ;
58 M: word stack-underflow 2drop ;
60 GENERIC: union-containment ( x -- y )
61 M: integer union-containment drop 1 ;
62 M: number union-containment drop 2 ;
64 [ 1 ] [ 1 union-containment ] unit-test
65 [ 2 ] [ 1.0 union-containment ] unit-test
67 ! Testing recovery from bad method definitions
68 "IN: generic.tests GENERIC: unhappy ( x -- x )" eval
70 "IN: generic.tests M: dictionary unhappy ;" eval
72 [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
74 GENERIC# complex-combination 1 ( a b -- c )
75 M: string complex-combination drop ;
76 M: object complex-combination nip ;
78 [ "hi" ] [ "hi" 3 complex-combination ] unit-test
79 [ "hi" ] [ 3 "hi" complex-combination ] unit-test
83 M: shit complex-combination 2array ;
84 [ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test
86 [ t ] [ \ complex-combination generic? >boolean ] unit-test
88 GENERIC: big-generic-test ( x -- x y )
89 M: fixnum big-generic-test "fixnum" ;
90 M: bignum big-generic-test "bignum" ;
91 M: ratio big-generic-test "ratio" ;
92 M: string big-generic-test "string" ;
93 M: shit big-generic-test "shit" ;
95 [ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
97 [ t ] [ \ + math-generic? ] unit-test
99 ! Test math-combination
100 [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
101 [ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
102 [ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
103 [ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
104 [ number ] [ \ number \ float math-class-max ] unit-test
105 [ float ] [ \ real \ float math-class-max ] unit-test
106 [ fixnum ] [ \ fixnum \ null math-class-max ] unit-test
111 UNION: both first-one union-class ;
113 GENERIC: wii ( x -- y )
115 M: second-one wii drop 4 ;
116 M: tuple-class wii drop 5 ;
117 M: integer wii drop 6 ;
119 [ 3 ] [ T{ first-one } wii ] unit-test
121 GENERIC: tag-and-f ( x -- x x )
123 M: fixnum tag-and-f 1 ;
125 M: bignum tag-and-f 2 ;
127 M: float tag-and-f 3 ;
131 [ f 4 ] [ f tag-and-f ] unit-test
133 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
136 GENERIC: generic-forget-test-1 ( a b -- c )
138 M: integer generic-forget-test-1 / ;
141 \ / usage [ word? ] filter
142 [ name>> "integer=>generic-forget-test-1" = ] any?
146 [ \ generic-forget-test-1 forget ] with-compilation-unit
150 \ / usage [ word? ] filter
151 [ name>> "integer=>generic-forget-test-1" = ] any?
154 GENERIC: generic-forget-test-2 ( a b -- c )
156 M: sequence generic-forget-test-2 = ;
159 \ = usage [ word? ] filter
160 [ name>> "sequence=>generic-forget-test-2" = ] any?
164 [ { sequence generic-forget-test-2 } forget ] with-compilation-unit
168 \ = usage [ word? ] filter
169 [ name>> "sequence=>generic-forget-test-2" = ] any?
172 GENERIC: generic-forget-test-3 ( a -- b )
174 M: f generic-forget-test-3 ;
176 [ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
178 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
180 [ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
182 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
184 [ f ] [ f generic-forget-test-3 ] unit-test
188 GENERIC: a-generic ( a -- b )
190 M: integer a-generic a-word ;
192 [ ] [ \ integer \ a-generic method "m" set ] unit-test
194 [ t ] [ "m" get \ a-word usage memq? ] unit-test
196 [ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
198 [ f ] [ "m" get \ a-word usage memq? ] unit-test
205 GENERIC: jeah ( a -- b )
208 GENERIC: jeah* ( a -- b )
224 ! call-next-method cache test
225 GENERIC: c-n-m-cache ( a -- b )
227 ! Force it to be unoptimized
228 M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
229 M: integer c-n-m-cache 1 + ;
230 M: number c-n-m-cache ;
232 [ 3 ] [ 2 c-n-m-cache ] unit-test
234 [ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
236 [ 2 ] [ 2 c-n-m-cache ] unit-test
238 ! Moving a method from one vocab to another doesn't always work
239 GENERIC: move-method-generic ( a -- b )
241 [ ] [ "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
243 [ ] [ "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
245 [ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
247 [ { string } ] [ \ move-method-generic order ] unit-test