core/generic/generic-tests.factor

   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
   6 io.streams.string ;
   7 IN: generic.tests
   8
   9 GENERIC: foobar ( x -- y )
  10 M: object foobar drop "Hello world" ;
  11 M: fixnum foobar drop "Goodbye cruel world" ;
  12
  13 GENERIC: class-of ( x -- y )
  14
  15 M: fixnum class-of drop "fixnum" ;
  16 M: word   class-of drop "word"   ;
  17
  18 [ "fixnum" ] [ 5 class-of ] unit-test
  19 [ "word" ] [ \ class-of class-of ] unit-test
  20 [ 3.4 class-of ] must-fail
  21
  22 [ "Hello world" ] [ 4 foobar foobar ] unit-test
  23 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
  24
  25 ! Testing unions
  26 UNION: funnies quotation float complex ;
  27
  28 GENERIC: funny ( x -- y )
  29 M: funnies funny drop 2 ;
  30 M: object funny drop 0 ;
  31
  32 [ 2 ] [ [ { } ] funny ] unit-test
  33 [ 0 ] [ { } funny ] unit-test
  34
  35 PREDICATE: very-funny < funnies number? ;
  36
  37 GENERIC: gooey ( x -- y )
  38 M: very-funny gooey sq ;
  39
  40 [ 0.25 ] [ 0.5 gooey ] unit-test
  41
  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
  46
  47 M: for-arguments-sake empty-method-test drop "Hi" ;
  48
  49 TUPLE: another-one ;
  50 C: <another-one> another-one
  51
  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
  54
  55 ! Weird bug
  56 GENERIC: stack-underflow ( x y -- )
  57 M: object stack-underflow 2drop ;
  58 M: word stack-underflow 2drop ;
  59
  60 GENERIC: union-containment ( x -- y )
  61 M: integer union-containment drop 1 ;
  62 M: number union-containment drop 2 ;
  63
  64 [ 1 ] [ 1 union-containment ] unit-test
  65 [ 2 ] [ 1.0 union-containment ] unit-test
  66
  67 ! Testing recovery from bad method definitions
  68 "IN: generic.tests GENERIC: unhappy ( x -- x )" eval
  69 [
  70     "IN: generic.tests M: dictionary unhappy ;" eval
  71 ] must-fail
  72 [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
  73
  74 GENERIC# complex-combination 1 ( a b -- c )
  75 M: string complex-combination drop ;
  76 M: object complex-combination nip ;
  77
  78 [ "hi" ] [ "hi" 3 complex-combination ] unit-test
  79 [ "hi" ] [ 3 "hi" complex-combination ] unit-test
  80
  81 TUPLE: shit ;
  82
  83 M: shit complex-combination 2array ;
  84 [ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test
  85
  86 [ t ] [ \ complex-combination generic? >boolean ] unit-test
  87
  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" ;
  94
  95 [ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
  96
  97 [ t ] [ \ + math-generic? ] unit-test
  98
  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
 107
 108 [ t ] [ { hashtable equal? } method-spec? ] unit-test
 109 [ f ] [ { word = } method-spec? ] unit-test
 110
 111 ! Regression
 112 TUPLE: first-one ;
 113 TUPLE: second-one ;
 114 UNION: both first-one union-class ;
 115
 116 GENERIC: wii ( x -- y )
 117 M: both wii drop 3 ;
 118 M: second-one wii drop 4 ;
 119 M: tuple-class wii drop 5 ;
 120 M: integer wii drop 6 ;
 121
 122 [ 3 ] [ T{ first-one } wii ] unit-test
 123
 124 GENERIC: tag-and-f ( x -- x x )
 125
 126 M: fixnum tag-and-f 1 ;
 127
 128 M: bignum tag-and-f 2 ;
 129
 130 M: float tag-and-f 3 ;
 131
 132 M: f tag-and-f 4 ;
 133
 134 [ f 4 ] [ f tag-and-f ] unit-test
 135
 136 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 137
 138 ! Issues with forget
 139 GENERIC: generic-forget-test-1 ( a b -- c )
 140
 141 M: integer generic-forget-test-1 / ;
 142
 143 [ t ] [
 144     \ / usage [ word? ] filter
 145     [ name>> "integer=>generic-forget-test-1" = ] any?
 146 ] unit-test
 147
 148 [ ] [
 149     [ \ generic-forget-test-1 forget ] with-compilation-unit
 150 ] unit-test
 151
 152 [ f ] [
 153     \ / usage [ word? ] filter
 154     [ name>> "integer=>generic-forget-test-1" = ] any?
 155 ] unit-test
 156
 157 GENERIC: generic-forget-test-2 ( a b -- c )
 158
 159 M: sequence generic-forget-test-2 = ;
 160
 161 [ t ] [
 162     \ = usage [ word? ] filter
 163     [ name>> "sequence=>generic-forget-test-2" = ] any?
 164 ] unit-test
 165
 166 [ ] [
 167     [ { sequence generic-forget-test-2 } forget ] with-compilation-unit
 168 ] unit-test
 169
 170 [ f ] [
 171     \ = usage [ word? ] filter
 172     [ name>> "sequence=>generic-forget-test-2" = ] any?
 173 ] unit-test
 174
 175 GENERIC: generic-forget-test-3 ( a -- b )
 176
 177 M: f generic-forget-test-3 ;
 178
 179 [ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
 180
 181 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 182
 183 [ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
 184
 185 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 186
 187 [ f ] [ f generic-forget-test-3 ] unit-test
 188
 189 : a-word ( -- ) ;
 190
 191 GENERIC: a-generic ( a -- b )
 192
 193 M: integer a-generic a-word ;
 194
 195 [ ] [ \ integer \ a-generic method "m" set ] unit-test
 196
 197 [ t ] [ "m" get \ a-word usage memq? ] unit-test
 198
 199 [ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
 200
 201 [ f ] [ "m" get \ a-word usage memq? ] unit-test
 202
 203 ! erg's regression
 204 [ ] [
 205     <"
 206     IN: compiler.tests
 207
 208     GENERIC: jeah ( a -- b )
 209     TUPLE: boii ;
 210     M: boii jeah ;
 211     GENERIC: jeah* ( a -- b )
 212     M: boii jeah* jeah ;
 213     "> eval
 214
 215     <"
 216     IN: compiler.tests
 217     FORGET: boii
 218     "> eval
 219
 220     <"
 221     IN: compiler.tests
 222     TUPLE: boii ;
 223     M: boii jeah ;
 224     "> eval
 225 ] unit-test
 226
 227 ! call-next-method cache test
 228 GENERIC: c-n-m-cache ( a -- b )
 229
 230 ! Force it to be unoptimized
 231 M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
 232 M: integer c-n-m-cache 1 + ;
 233 M: number c-n-m-cache ;
 234
 235 [ 3 ] [ 2 c-n-m-cache ] unit-test
 236
 237 [ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
 238
 239 [ 2 ] [ 2 c-n-m-cache ] unit-test
 240
 241 ! Moving a method from one vocab to another doesn't always work
 242 GENERIC: move-method-generic ( a -- b )
 243
 244 [ ] [ "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
 245
 246 [ ] [ "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
 247
 248 [ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
 249
 250 [ { string } ] [ \ move-method-generic order ] unit-test