core/hashtables/hashtables-tests.factor

   1 USING: accessors arrays assocs continuations fry hashtables
   2 hashtables.private kernel make math memory namespaces sequences
   3 tools.test ;
   4
   5 ! hash@
   6 { 18 } [
   7     77 20 f <array> hash@
   8 ] unit-test
   9
  10 { H{ } } [ { } [ dup ] H{ } map>assoc ] unit-test
  11
  12 { } [ 1000 iota [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
  13
  14 { V{ } }
  15 [ 1000 iota [ dup sq swap "testhash" get at = ] reject ]
  16 unit-test
  17
  18 { t }
  19 [ "testhash" get hashtable? ]
  20 unit-test
  21
  22 { f }
  23 [ { 1 { 2 3 } } hashtable? ]
  24 unit-test
  25
  26 { t } [
  27     "value" "key"
  28     [ associate ] [ H{ } clone [ set-at ] keep ] 2bi
  29     [ = ] [ [ array>> length ] bi@ = ] 2bi and
  30 ] unit-test
  31
  32 ! Test some hashcodes.
  33
  34 { t } [ [ 1 2 3 ] hashcode [ 1 2 3 ] hashcode = ] unit-test
  35 { t } [ [ 1 [ 2 3 ] 4 ] hashcode [ 1 [ 2 3 ] 4 ] hashcode = ] unit-test
  36
  37 { t } [ 12 hashcode 12 hashcode = ] unit-test
  38 { t } [ 12 >bignum hashcode 12 hashcode = ] unit-test
  39
  40 ! Test various odd keys to see if they work.
  41
  42 16 <hashtable> "testhash" set
  43
  44 t { 2 3 } "testhash" get set-at
  45 f 100000000000000000000000000 "testhash" get set-at
  46 { } { [ { } ] } "testhash" get set-at
  47
  48 { t } [ { 2 3 } "testhash" get at ] unit-test
  49 { f } [ 100000000000000000000000000 "testhash" get at* drop ] unit-test
  50 { { } } [ { [ { } ] } clone "testhash" get at* drop ] unit-test
  51
  52 ! Regression
  53 3 <hashtable> "broken-remove" set
  54 1 W{ \ + } dup "x" set "broken-remove" get set-at
  55 2 W{ \ = } dup "y" set "broken-remove" get set-at
  56 "x" get "broken-remove" get delete-at
  57 2 "y" get "broken-remove" get set-at
  58 { 1 } [ "broken-remove" get keys length ] unit-test
  59
  60 {
  61     { "salmon" "fish" }
  62     { "crocodile" "reptile" }
  63     { "cow" "mammal" }
  64     { "visual basic" "language" }
  65 } >hashtable "testhash" set
  66
  67 { f f } [
  68     "visual basic" "testhash" get delete-at
  69     "visual basic" "testhash" get at*
  70 ] unit-test
  71
  72 { t } [ H{ } dup = ] unit-test
  73 { f } [ "xyz" H{ } = ] unit-test
  74 { t } [ H{ } H{ } = ] unit-test
  75 { f } [ H{ { 1 3 } } H{ } = ] unit-test
  76 { f } [ H{ } H{ { 1 3 } } = ] unit-test
  77 { t } [ H{ { 1 3 } } H{ { 1 3 } } = ] unit-test
  78 { f } [ H{ { 1 3 } } H{ { 1 "hey" } } = ] unit-test
  79
  80 ! Testing the hash element counting
  81
  82 H{ } clone "counting" set
  83 "value" "key" "counting" get set-at
  84 { 1 } [ "counting" get assoc-size ] unit-test
  85 "value" "key" "counting" get set-at
  86 { 1 } [ "counting" get assoc-size ] unit-test
  87 "key" "counting" get delete-at
  88 { 0 } [ "counting" get assoc-size ] unit-test
  89 "key" "counting" get delete-at
  90 { 0 } [ "counting" get assoc-size ] unit-test
  91
  92 ! Test rehashing
  93
  94 2 <hashtable> "rehash" set
  95
  96 1 1 "rehash" get set-at
  97 2 2 "rehash" get set-at
  98 3 3 "rehash" get set-at
  99 4 4 "rehash" get set-at
 100 5 5 "rehash" get set-at
 101 6 6 "rehash" get set-at
 102
 103 { 6 } [ "rehash" get assoc-size ] unit-test
 104
 105 { 6 } [ "rehash" get clone assoc-size ] unit-test
 106
 107 "rehash" get clear-assoc
 108
 109 { 0 } [ "rehash" get assoc-size ] unit-test
 110
 111 {
 112     3
 113 } [
 114     2 H{
 115         { 1 2 }
 116         { 2 3 }
 117     } clone at
 118 ] unit-test
 119
 120 ! There was an assoc in place of assoc* somewhere
 121 3 <hashtable> "f-hash-test" set
 122
 123 10 [ f f "f-hash-test" get set-at ] times
 124
 125 { 1 } [ "f-hash-test" get assoc-size ] unit-test
 126
 127 ! Resource leak...
 128 H{ } "x" set
 129 100 [ drop "x" get clear-assoc ] each-integer
 130
 131 ! non-integer capacity not allowed
 132 [ 0.75 <hashtable> ] must-fail
 133
 134 ! Another crash discovered by erg
 135 { } [
 136     H{ } clone
 137     [ 1 swap set-at ] ignore-errors
 138     [ 2 swap set-at ] ignore-errors
 139     [ 3 swap set-at ] ignore-errors
 140     drop
 141 ] unit-test
 142
 143 { H{ { -1 4 } { -3 16 } { -5 36 } } } [
 144     H{ { 1 2 } { 3 4 } { 5 6 } }
 145     [ [ neg ] dip sq ] assoc-map
 146 ] unit-test
 147
 148 ! make sure growth and capacity use same load-factor
 149 { t } [
 150     100 iota
 151     [ [ <hashtable> ] map ]
 152     [ [ H{ } clone [ '[ dup _ set-at ] each-integer ] keep ] map ] bi
 153     [ [ array>> length ] bi@ = ] 2all?
 154 ] unit-test
 155
 156 ! Bug discovered by littledan
 157 { { 5 5 5 5 } } [
 158     [
 159         H{
 160             { 1 2 }
 161             { 2 3 }
 162             { 3 4 }
 163             { 4 5 }
 164             { 5 6 }
 165         } clone
 166         dup keys length ,
 167         dup assoc-size ,
 168         dup rehash
 169         dup keys length ,
 170         assoc-size ,
 171     ] { } make
 172 ] unit-test
 173
 174 { { "one" "two" 3 } } [
 175     { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
 176 ] unit-test
 177
 178 ! We want this to work
 179 { } [ hashtable new "h" set ] unit-test
 180
 181 { 0 } [ "h" get assoc-size ] unit-test
 182
 183 { f f } [ "goo" "h" get at* ] unit-test
 184
 185 { } [ 1 2 "h" get set-at ] unit-test
 186
 187 { 1 } [ "h" get assoc-size ] unit-test
 188
 189 { 1 } [ 2 "h" get at ] unit-test
 190
 191 ! Previously this could break as hashtable new created a backing an
 192 ! empty backing array and the code assumed its length was > 0.
 193 { f f } [
 194     compact-gc 77 hashtable new [ clone ] change-array at*
 195 ] unit-test
 196
 197 ! Random test case
 198 { "A" } [
 199     100 iota [ dup ] H{ } map>assoc 32 over
 200     delete-at "A" 32 pick set-at 32 of
 201 ] unit-test