core/tuples/tuples-tests.factor

   1 USING: definitions generic kernel kernel.private math
   2 math.constants parser sequences tools.test words assocs
   3 namespaces quotations sequences.private classes continuations
   4 generic.standard effects tuples tuples.private arrays vectors
   5 strings ;
   6 IN: temporary
   7
   8 [ t ] [ \ tuple-class \ class class< ] unit-test
   9 [ f ] [ \ class \ tuple-class class< ] unit-test
  10
  11 TUPLE: rect x y w h ;
  12 : <rect> rect construct-boa ;
  13
  14 : move ( x rect -- )
  15     [ rect-x + ] keep set-rect-x ;
  16
  17 [ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
  18
  19 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
  20
  21 GENERIC: delegation-test
  22 M: object delegation-test drop 3 ;
  23 TUPLE: quux-tuple ;
  24 : <quux-tuple> quux-tuple construct-empty ;
  25 M: quux-tuple delegation-test drop 4 ;
  26 TUPLE: quuux-tuple ;
  27 : <quuux-tuple> { set-delegate } quuux-tuple construct ;
  28
  29 [ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
  30
  31 GENERIC: delegation-test-2
  32 TUPLE: quux-tuple-2 ;
  33 : <quux-tuple-2> quux-tuple-2 construct-empty ;
  34 M: quux-tuple-2 delegation-test-2 drop 4 ;
  35 TUPLE: quuux-tuple-2 ;
  36 : <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
  37
  38 [ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
  39
  40 ! Make sure we handle changing shapes!
  41 TUPLE: point x y ;
  42
  43 C: <point> point
  44
  45 100 200 <point> "p" set
  46
  47 ! Use eval to sequence parsing explicitly
  48 "IN: temporary TUPLE: point x y z ; do-parse-hook" eval
  49
  50 [ 100 ] [ "p" get point-x ] unit-test
  51 [ 200 ] [ "p" get point-y ] unit-test
  52 [ f ] [ "p" get "point-z" "temporary" lookup execute ] unit-test
  53
  54 300 "p" get "set-point-z" "temporary" lookup execute
  55
  56 "IN: temporary TUPLE: point z y ; do-parse-hook" eval
  57
  58 [ "p" get point-x ] unit-test-fails
  59 [ 200 ] [ "p" get point-y ] unit-test
  60 [ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test
  61
  62 TUPLE: predicate-test ;
  63
  64 C: <predicate-test> predicate-test
  65
  66 : predicate-test drop f ;
  67
  68 [ t ] [ <predicate-test> predicate-test? ] unit-test
  69
  70 PREDICATE: tuple silly-pred
  71     class \ rect = ;
  72
  73 GENERIC: area
  74 M: silly-pred area dup rect-w swap rect-h * ;
  75
  76 TUPLE: circle radius ;
  77 M: circle area circle-radius sq pi * ;
  78
  79 [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
  80
  81 [ ] [ "IN: temporary  SYMBOL: #x  TUPLE: #x ;" eval ] unit-test
  82
  83 ! Hashcode breakage
  84 TUPLE: empty ;
  85
  86 C: <empty> empty
  87
  88 [ t ] [ <empty> hashcode fixnum? ] unit-test
  89
  90 TUPLE: delegate-clone ;
  91
  92 [ T{ delegate-clone T{ empty f } } ]
  93 [ T{ delegate-clone T{ empty f } } clone ] unit-test
  94
  95 [ t ] [ \ null \ delegate-clone class< ] unit-test
  96 [ f ] [ \ object \ delegate-clone class< ] unit-test
  97 [ f ] [ \ object \ delegate-clone class< ] unit-test
  98 [ t ] [ \ delegate-clone \ tuple class< ] unit-test
  99 [ f ] [ \ tuple \ delegate-clone class< ] unit-test
 100
 101 ! Compiler regression
 102 [ t ] [ [ t length ] catch no-method-object ] unit-test
 103
 104 [ "<constructor-test>" ]
 105 [ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
 106
 107 TUPLE: size-test a b c d ;
 108
 109 [ t ] [
 110     T{ size-test } array-capacity
 111     size-test tuple-size =
 112 ] unit-test
 113
 114 GENERIC: <yo-momma>
 115
 116 TUPLE: yo-momma ;
 117
 118 "IN: temporary C: <yo-momma> yo-momma" eval
 119
 120 [ f ] [ \ <yo-momma> generic? ] unit-test
 121
 122 ! Test forget
 123 [ t ] [ \ yo-momma class? ] unit-test
 124 [ ] [ \ yo-momma forget ] unit-test
 125 [ f ] [ \ yo-momma typemap get values memq? ] unit-test
 126
 127 [ f ] [ \ yo-momma interned? ] unit-test
 128
 129 TUPLE: loc-recording ;
 130
 131 [ f ] [ \ loc-recording where not ] unit-test
 132
 133 ! 'forget' wasn't robust enough
 134
 135 TUPLE: forget-robustness ;
 136
 137 GENERIC: forget-robustness-generic
 138
 139 M: forget-robustness forget-robustness-generic ;
 140
 141 M: integer forget-robustness-generic ;
 142
 143 [ ] [ \ forget-robustness-generic forget ] unit-test
 144 [ ] [ \ forget-robustness forget ] unit-test
 145 [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
 146
 147 ! rapido found this one
 148 GENERIC# m1 0 ( s n -- n )
 149 GENERIC# m2 1 ( s n -- v )
 150
 151 TUPLE: t1 ;
 152
 153 M: t1 m1 drop ;
 154 M: t1 m2 nip ;
 155
 156 TUPLE: t2 ;
 157
 158 M: t2 m1 drop ;
 159 M: t2 m2 nip ;
 160
 161 TUPLE: t3 ;
 162
 163 M: t3 m1 drop ;
 164 M: t3 m2 nip ;
 165
 166 TUPLE: t4 ;
 167
 168 M: t4 m1 drop ;
 169 M: t4 m2 nip ;
 170
 171 C: <t4> t4
 172
 173 [ 1 ] [ 1 <t4> m1 ] unit-test
 174 [ 1 ] [ <t4> 1 m2 ] unit-test
 175
 176 ! another combination issue
 177 GENERIC: silly
 178
 179 UNION: my-union slice repetition column array vector reversed ;
 180
 181 M: my-union silly "x" ;
 182
 183 M: array silly "y" ;
 184
 185 M: column silly "fdsfds" ;
 186
 187 M: repetition silly "zzz" ;
 188
 189 M: reversed silly "zz" ;
 190
 191 M: slice silly "tt" ;
 192
 193 M: string silly "t" ;
 194
 195 M: vector silly "z" ;
 196
 197 [ "zz" ] [ 123 <reversed> silly nip ] unit-test
 198
 199 ! Typo
 200 SYMBOL: not-a-tuple-class
 201
 202 [
 203     "IN: temporary C: <not-a-tuple-class> not-a-tuple-class"
 204     eval
 205 ] unit-test-fails
 206
 207 [ t ] [
 208     "not-a-tuple-class" "temporary" lookup symbol?
 209 ] unit-test
 210
 211 ! Missing check
 212 [ not-a-tuple-class construct-boa ] unit-test-fails
 213 [ not-a-tuple-class construct-empty ] unit-test-fails
 214
 215 ! Reshaping bug. It's only an issue when optimizer compiler is
 216 ! enabled.
 217 parse-hook get [
 218     TUPLE: erg's-reshape-problem a b c ;
 219
 220     C: <erg's-reshape-problem> erg's-reshape-problem
 221
 222     [ ] [
 223         "IN: temporary TUPLE: erg's-reshape-problem a b c d ;" eval
 224     ] unit-test
 225
 226
 227     [ 1 2 ] [
 228         ! <erg's-reshape-problem> hasn't been recompiled yet, so
 229         ! we just created a tuple using an obsolete layout
 230         1 2 3 <erg's-reshape-problem>
 231
 232         ! that's ok, but... this shouldn't fail:
 233         "IN: temporary TUPLE: erg's-reshape-problem a b d c ;" eval
 234
 235         { erg's-reshape-problem-a erg's-reshape-problem-b }
 236         get-slots
 237     ] unit-test
 238 ] when
 239
 240 ! We want to make sure constructors are recompiled when
 241 ! tuples are reshaped
 242 : cons-test-1 \ erg's-reshape-problem construct-empty ;
 243 : cons-test-2 \ erg's-reshape-problem construct-boa ;
 244 : cons-test-3
 245     { erg's-reshape-problem-a }
 246     \ erg's-reshape-problem construct ;
 247
 248 "IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval
 249
 250 [ t ] [
 251     {
 252         <erg's-reshape-problem>
 253         cons-test-1
 254         cons-test-2
 255         cons-test-3
 256     } [ changed-words get key? ] all?
 257 ] unit-test