core/generic/generic-tests.factor

   1 USING: accessors alien arrays assocs classes classes.algebra
   2 classes.tuple classes.union compiler.units continuations
   3 definitions eval generic generic.math generic.standard
   4 hashtables io io.streams.string kernel layouts math math.order
   5 namespaces parser prettyprint quotations sequences sorting
   6 strings tools.test vectors words generic.single
   7 compiler.crossref ;
   8 IN: generic.tests
   9
  10 GENERIC: foobar ( x -- y )
  11 M: object foobar drop "Hello world" ;
  12 M: fixnum foobar drop "Goodbye cruel world" ;
  13
  14 GENERIC: class-of ( x -- y )
  15
  16 M: fixnum class-of drop "fixnum" ;
  17 M: word   class-of drop "word"   ;
  18
  19 [ "fixnum" ] [ 5 class-of ] unit-test
  20 [ "word" ] [ \ class-of class-of ] unit-test
  21 [ 3.4 class-of ] must-fail
  22
  23 [ "Hello world" ] [ 4 foobar foobar ] unit-test
  24 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
  25
  26 ! Testing unions
  27 UNION: funnies quotation float complex ;
  28
  29 GENERIC: funny ( x -- y )
  30 M: funnies funny drop 2 ;
  31 M: object funny drop 0 ;
  32
  33 [ 2 ] [ [ { } ] funny ] unit-test
  34 [ 0 ] [ { } funny ] unit-test
  35
  36 PREDICATE: very-funny < funnies number? ;
  37
  38 GENERIC: gooey ( x -- y )
  39 M: very-funny gooey sq ;
  40
  41 [ 0.25 ] [ 0.5 gooey ] unit-test
  42
  43 GENERIC: empty-method-test ( x -- y )
  44 M: object empty-method-test ;
  45 TUPLE: for-arguments-sake ;
  46 C: <for-arguments-sake> for-arguments-sake
  47
  48 M: for-arguments-sake empty-method-test drop "Hi" ;
  49
  50 TUPLE: another-one ;
  51 C: <another-one> another-one
  52
  53 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
  54 [ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
  55
  56 ! Weird bug
  57 GENERIC: stack-underflow ( x y -- )
  58 M: object stack-underflow 2drop ;
  59 M: word stack-underflow 2drop ;
  60
  61 GENERIC: union-containment ( x -- y )
  62 M: integer union-containment drop 1 ;
  63 M: number union-containment drop 2 ;
  64
  65 [ 1 ] [ 1 union-containment ] unit-test
  66 [ 2 ] [ 1.0 union-containment ] unit-test
  67
  68 ! Testing recovery from bad method definitions
  69 "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- )
  70 [
  71     "IN: generic.tests M: dictionary unhappy ;" eval( -- )
  72 ] must-fail
  73 [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
  74
  75 GENERIC# complex-combination 1 ( a b -- c )
  76 M: string complex-combination drop ;
  77 M: object complex-combination nip ;
  78
  79 [ "hi" ] [ "hi" 3 complex-combination ] unit-test
  80 [ "hi" ] [ 3 "hi" complex-combination ] unit-test
  81
  82 TUPLE: shit ;
  83
  84 M: shit complex-combination 2array ;
  85 [ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test
  86
  87 [ t ] [ \ complex-combination generic? >boolean ] unit-test
  88
  89 GENERIC: big-generic-test ( x -- x y )
  90 M: fixnum big-generic-test "fixnum" ;
  91 M: bignum big-generic-test "bignum" ;
  92 M: ratio big-generic-test "ratio" ;
  93 M: string big-generic-test "string" ;
  94 M: shit big-generic-test "shit" ;
  95
  96 [ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
  97
  98 [ t ] [ \ + math-generic? ] unit-test
  99
 100 ! Regression
 101 TUPLE: first-one ;
 102 TUPLE: second-one ;
 103 UNION: both first-one union-class ;
 104
 105 GENERIC: wii ( x -- y )
 106 M: both wii drop 3 ;
 107 M: second-one wii drop 4 ;
 108 M: tuple-class wii drop 5 ;
 109 M: integer wii drop 6 ;
 110
 111 [ 3 ] [ T{ first-one } wii ] unit-test
 112
 113 GENERIC: tag-and-f ( x -- x x )
 114
 115 M: fixnum tag-and-f 1 ;
 116
 117 M: bignum tag-and-f 2 ;
 118
 119 M: float tag-and-f 3 ;
 120
 121 M: f tag-and-f 4 ;
 122
 123 [ f 4 ] [ f tag-and-f ] unit-test
 124
 125 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 126
 127 ! Issues with forget
 128 GENERIC: generic-forget-test ( a -- b )
 129
 130 M: f generic-forget-test ;
 131
 132 [ ] [ \ f \ generic-forget-test method "m" set ] unit-test
 133
 134 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 135
 136 [ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test
 137
 138 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 139
 140 [ f ] [ f generic-forget-test ] unit-test
 141
 142 ! erg's regression
 143 [ ] [
 144     """IN: compiler.tests
 145
 146     GENERIC: jeah ( a -- b )
 147     TUPLE: boii ;
 148     M: boii jeah ;
 149     GENERIC: jeah* ( a -- b )
 150     M: boii jeah* jeah ;""" eval( -- )
 151
 152     """IN: compiler.tests
 153     FORGET: boii""" eval( -- )
 154
 155     """IN: compiler.tests
 156     TUPLE: boii ;
 157     M: boii jeah ;""" eval( -- )
 158 ] unit-test
 159
 160 ! call-next-method cache test
 161 GENERIC: c-n-m-cache ( a -- b )
 162
 163 ! Force it to be unoptimized
 164 M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
 165 M: integer c-n-m-cache 1 + ;
 166 M: number c-n-m-cache ;
 167
 168 [ 3 ] [ 2 c-n-m-cache ] unit-test
 169
 170 [ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test
 171
 172 [ 2 ] [ 2 c-n-m-cache ] unit-test
 173
 174 ! Moving a method from one vocab to another doesn't always work
 175 GENERIC: move-method-generic ( a -- b )
 176
 177 [ ] [ "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
 178
 179 [ ] [ "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
 180
 181 [ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
 182
 183 [ { string } ] [ \ move-method-generic order ] unit-test
 184
 185 GENERIC: foozul ( a -- b )
 186 M: reversed foozul ;
 187 M: integer foozul ;
 188 M: slice foozul ;
 189
 190 [ t ] [
 191     reversed \ foozul method-for-class
 192     reversed \ foozul method
 193     eq?
 194 ] unit-test
 195
 196 [ t ] [
 197     fixnum \ <=> method-for-class
 198     real \ <=> method
 199     eq?
 200 ] unit-test
 201
 202 ! FORGET: on method wrappers
 203 GENERIC: forget-test ( a -- b )
 204
 205 M: integer forget-test 3 + ;
 206
 207 [ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
 208
 209 [ { } ] [
 210     \ + compiled-usage keys
 211     [ method-body? ] filter
 212     [ "method-generic" word-prop \ forget-test eq? ] filter
 213 ] unit-test
 214
 215 [ 10 forget-test ] [ no-method? ] must-fail-with