core/test/tuple.factor

   1 USING: errors definitions generic kernel kernel-internals math
   2 parser sequences test words hashtables namespaces ;
   3 IN: temporary
   4
   5 [ t ] [ \ tuple-class \ class class< ] unit-test
   6 [ f ] [ \ class \ tuple-class class< ] unit-test
   7
   8 TUPLE: rect x y w h ;
   9 C: rect
  10     [ set-rect-h ] keep
  11     [ set-rect-w ] keep
  12     [ set-rect-y ] keep
  13     [ set-rect-x ] keep ;
  14
  15 : move ( x rect -- )
  16     [ rect-x + ] keep set-rect-x ;
  17
  18 [ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
  19
  20 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
  21
  22 GENERIC: delegation-test
  23 M: object delegation-test drop 3 ;
  24 TUPLE: quux-tuple ;
  25 C: quux-tuple ;
  26 M: quux-tuple delegation-test drop 4 ;
  27 TUPLE: quuux-tuple ;
  28 C: quuux-tuple
  29     [ set-delegate ] keep ;
  30
  31 [ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
  32
  33 GENERIC: delegation-test-2
  34 TUPLE: quux-tuple-2 ;
  35 C: quux-tuple-2 ;
  36 M: quux-tuple-2 delegation-test-2 drop 4 ;
  37 TUPLE: quuux-tuple-2 ;
  38 C: quuux-tuple-2
  39     [ set-delegate ] keep ;
  40
  41 [ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
  42
  43 ! Make sure we handle changing shapes!
  44
  45 [
  46     FORGET: point
  47     FORGET: point?
  48     FORGET: point-x
  49     TUPLE: point x y ;
  50     C: point [ set-point-y ] keep [ set-point-x ] keep ;
  51
  52     100 200 <point>
  53
  54     ! Use eval to sequence parsing explicitly
  55     "IN: temporary TUPLE: point x y z ;" eval
  56
  57     point-x
  58 ] unit-test-fails
  59
  60 TUPLE: predicate-test ;
  61 : predicate-test drop f ;
  62
  63 [ t ] [ <predicate-test> predicate-test? ] unit-test
  64
  65 PREDICATE: tuple silly-pred
  66     class \ rect = ;
  67
  68 GENERIC: area
  69 M: silly-pred area dup rect-w swap rect-h * ;
  70
  71 TUPLE: circle radius ;
  72 M: circle area circle-radius sq pi * ;
  73
  74 [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
  75
  76 [ ] [ "IN: temporary  SYMBOL: #x  TUPLE: #x ;" eval ] unit-test
  77
  78 ! Hashcode breakage
  79 TUPLE: empty ;
  80 [ t ] [ <empty> hashcode fixnum? ] unit-test
  81
  82 TUPLE: delegate-clone ;
  83
  84 [ T{ delegate-clone T{ empty f } } ]
  85 [ T{ delegate-clone T{ empty f } } clone ] unit-test
  86
  87 FORGET: empty
  88
  89 [ t ] [ \ null \ delegate-clone class< ] unit-test
  90 [ f ] [ \ object \ delegate-clone class< ] unit-test
  91 [ f ] [ \ object \ delegate-clone class< ] unit-test
  92 [ t ] [ \ delegate-clone \ tuple class< ] unit-test
  93 [ f ] [ \ tuple \ delegate-clone class< ] unit-test
  94
  95 ! Compiler regression
  96 [ t ] [ [ t length ] catch no-method-object ] unit-test
  97
  98 [ "<constructor-test>" ]
  99 [ "TUPLE: constructor-test ; C: constructor-test ;" eval word word-name ] unit-test
 100
 101 ! There was a typo in check-shape; it would unintern the wrong
 102 ! words!
 103 [ "temporary-1" ]
 104 [
 105     "IN: temporary-1 SYMBOL: foobar IN: temporary TUPLE: foobar ;" eval
 106     "foobar" { "temporary" "temporary-1" } [ vocab ] map
 107     hash-stack word-vocabulary
 108 ] unit-test
 109
 110 TUPLE: size-test a b c d ;
 111
 112 [ t ] [
 113     T{ size-test } array-capacity
 114     size-test tuple-size =
 115 ] unit-test
 116
 117 GENERIC: <yo-momma>
 118
 119 TUPLE: yo-momma ;
 120
 121 [ f ] [ \ <yo-momma> generic? ] unit-test
 122
 123 ! Test forget
 124 [ t ] [ \ yo-momma class? ] unit-test
 125 [ ] [ \ yo-momma forget ] unit-test
 126 [ f ] [ \ yo-momma typemap get hash-values memq? ] unit-test
 127
 128 [ f ] [ \ yo-momma interned? ] unit-test
 129 [ f ] [ \ yo-momma? interned? ] unit-test
 130 [ f ] [ \ <yo-momma> interned? ] unit-test
 131
 132 ! Test if C: sets last word correctly
 133 [ ] [ "IN: temporary TUPLE: C:-test ; C: C:-test ( -- x ) ;" eval ] unit-test
 134 [ "<C:-test>" ] [ word word-name ] unit-test
 135 [ "( -- x )" ] [ "<C:-test>" "temporary" lookup stack-effect effect>string ] unit-test
 136
 137 TUPLE: loc-recording ;
 138
 139 [ f ] [ \ loc-recording where not ] unit-test
 140 [ f ] [ \ <loc-recording> where not ] unit-test
 141 [ f ] [ \ loc-recording? where not ] unit-test
 142
 143 ! Ensure C: puts the word in the right vocabulary
 144 [ f ] [
 145     "IN: temporary TUPLE: xyz ; IN: temporary2 C: xyz ;" eval
 146     "<xyz>" "temporary2" lookup
 147 ] unit-test