1;;; hash.ms 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16(mat old-hash-table 17 (error? (get-hash-table '((a . b)) 'a #f)) 18 (error? (put-hash-table! (list (cons 'a 'b)) 'a 'b)) 19 (error? (remove-hash-table! (list (cons 'a 'b)) 'a)) 20 (error? (hash-table-map '((a . b)) cons)) 21 (error? (hash-table-for-each '((a . b)) cons)) 22 (begin 23 (define $h-ht (make-hash-table)) 24 (hash-table? $h-ht)) 25 (not (hash-table? 3)) 26 (not (hash-table? '$h-ht)) 27 (null? (hash-table-map $h-ht list)) 28 (eq? (let ([n 0]) 29 (hash-table-for-each $h-ht (lambda (x y) (set! n (+ n 1)))) 30 n) 31 0) 32 (equal? 33 (begin 34 (put-hash-table! $h-ht 'ham 'spam) 35 (hash-table-map $h-ht list)) 36 '((ham spam))) 37 (error? ; wrong number of args 38 (hash-table-map $h-ht (lambda (x) x))) 39 (error? ; wrong number of args 40 (hash-table-for-each $h-ht (lambda (x) x))) 41 ((lambda (x y) (or (equal? x y) (equal? x (reverse y)))) 42 (begin 43 (put-hash-table! $h-ht 'cram 'sham) 44 (hash-table-map $h-ht list)) 45 '((ham spam) (cram sham))) 46 ((lambda (x y) (or (equal? x y) (equal? x (reverse y)))) 47 (begin 48 (put-hash-table! $h-ht 'ham 'jam) 49 (hash-table-map $h-ht list)) 50 '((ham jam) (cram sham))) 51 (eq? (get-hash-table $h-ht 'ham #f) 'jam) 52 (eq? (get-hash-table $h-ht 'cram #f) 'sham) 53 (eq? (get-hash-table $h-ht 'sham #f) #f) 54 (equal? (get-hash-table $h-ht 'jam "rats") "rats") 55 (eq? (let ([n 0]) 56 (hash-table-for-each $h-ht (lambda (x y) (set! n (+ n 1)))) 57 n) 58 2) 59 ((lambda (x y) (or (equal? x y) (equal? x (reverse y)))) 60 (let ([keys '()] [vals '()]) 61 (hash-table-for-each $h-ht 62 (lambda (k v) 63 (set! keys (cons k keys)) 64 (set! vals (cons v vals)))) 65 (map cons vals keys)) 66 '((jam . ham) (sham . cram))) 67 (eq? (collect (collect-maximum-generation)) (void)) 68 ((lambda (x y) (or (equal? x y) (equal? x (reverse y)))) 69 (let ([keys '()] [vals '()]) 70 (hash-table-for-each $h-ht 71 (lambda (k v) 72 (set! keys (cons k keys)) 73 (set! vals (cons v vals)))) 74 (map cons vals keys)) 75 '((jam . ham) (sham . cram))) 76 (eq? (begin 77 (remove-hash-table! $h-ht 'ham) 78 (get-hash-table $h-ht 'ham 'gone!)) 79 'gone!) 80 (equal? 81 (hash-table-map $h-ht list) 82 '((cram sham))) 83 (eq? (collect (collect-maximum-generation)) (void)) 84 (equal? 85 (hash-table-map $h-ht list) 86 '((cram sham))) 87 (eq? (begin 88 (remove-hash-table! $h-ht 'ham) 89 (get-hash-table $h-ht 'ham 'gone!)) 90 'gone!) 91 (equal? 92 (hash-table-map $h-ht list) 93 '((cram sham))) 94 (eq? (begin 95 (remove-hash-table! $h-ht 'sham) 96 (get-hash-table $h-ht 'ham 'never-there!)) 97 'never-there!) 98 (equal? 99 (hash-table-map $h-ht list) 100 '((cram sham))) 101 (eq? (begin 102 (remove-hash-table! $h-ht 'cram) 103 (get-hash-table $h-ht 'cram 'gone-too!)) 104 'gone-too!) 105 (null? (hash-table-map $h-ht list)) 106 107 ; fasling out eq hash tables 108 (equal? 109 (let ([x (cons 'y '!)]) 110 (define ht (make-hash-table)) 111 (put-hash-table! ht x 'because) 112 (put-hash-table! ht 'foo "foo") 113 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 114 (fasl-write (list x ht) p) 115 (close-port p)) 116 (let-values ([(x2 ht2) 117 (apply values 118 (call-with-port 119 (open-file-input-port "testfile.ss") 120 fasl-read))]) 121 (list 122 (get-hash-table ht2 x2 #f) 123 (get-hash-table ht2 'foo #f)))) 124 '(because "foo")) 125 126 ; weak hash table tests 127 (begin 128 (define $h-ht (make-hash-table #t)) 129 (hash-table? $h-ht)) 130 (null? 131 (begin 132 (put-hash-table! $h-ht (string #\a) 'yea!) 133 (collect (collect-maximum-generation)) 134 (hash-table-map $h-ht cons))) 135 (eq? (let ([n 0]) 136 (hash-table-for-each $h-ht (lambda (x y) (set! n (+ n 1)))) 137 n) 138 0) 139 (let ([s (string #\a)]) 140 (put-hash-table! $h-ht s 666) 141 (equal? (get-hash-table $h-ht s #f) 666)) 142 (null? 143 (begin 144 (collect (collect-maximum-generation)) 145 (hash-table-map $h-ht cons))) 146 147 ; make sure that nonweak hash tables are nonweak (explicit #f arg) 148 (begin 149 (define $h-ht (make-hash-table #f)) 150 (hash-table? $h-ht)) 151 (equal? 152 (begin 153 (put-hash-table! $h-ht (string #\a) "bc") 154 (collect (collect-maximum-generation)) 155 (hash-table-map $h-ht string-append)) 156 '("abc")) 157 158 ; make sure that nonweak hash tables are nonweak (implicit #f arg) 159 (begin 160 (define $h-ht (make-hash-table)) 161 (hash-table? $h-ht)) 162 (equal? 163 (begin 164 (put-hash-table! $h-ht (string #\a) "bc") 165 (collect (collect-maximum-generation)) 166 (hash-table-map $h-ht string-append)) 167 '("abc")) 168 169 ; stress tests 170 (let () ; nonweak 171 (define pick 172 (lambda (ls) 173 (list-ref ls (random (length ls))))) 174 (define ht (make-hash-table)) 175 (let* ([ls (remq '|| (oblist))] [n 50000]) 176 (let f ([i 0] [keep '()] [drop '()]) 177 (if (= i n) 178 (and (= (length (hash-table-map ht (lambda (x y) x))) 179 (- n (length drop))) 180 (andmap (lambda (k) 181 (string=? 182 (symbol->string (get-hash-table ht k #f)) 183 (cond 184 [(string? k) k] 185 [(pair? k) (car k)] 186 [(vector? k) (vector-ref k 0)]))) 187 keep) 188 (andmap (lambda (k) (eq? (get-hash-table ht k 'no) 'no)) 189 drop)) 190 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 191 (let ([k (case (pick '(string pair vector)) 192 [(string) s] 193 [(pair) (list s)] 194 [(vector) (vector s)])]) 195 (put-hash-table! ht k x) 196 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 197 (if (= (modulo i 17) 5) 198 (let ([k (pick keep)]) 199 (remove-hash-table! ht k) 200 (let ([drop (cons k drop)]) 201 (when (= (random 5) 3) 202 (remove-hash-table! ht (pick drop))) 203 (f (+ i 1) (remq k keep) drop))) 204 (f (+ i 1) keep drop))))))))) 205 206 (let () ; weak 207 (define pick 208 (lambda (ls) 209 (list-ref ls (random (length ls))))) 210 (define ht (make-hash-table #t)) 211 (let* ([ls (remq '|| (oblist))] [n 50000]) 212 (let f ([i 0] [keep '()] [drop '()]) 213 (if (= i n) 214 (and (<= (length (hash-table-map ht (lambda (x y) x))) 215 (- n (length drop))) 216 (begin 217 (collect (collect-maximum-generation)) 218 (= (length (hash-table-map ht (lambda (x y) x))) 219 (length keep))) 220 (andmap (lambda (k) 221 (string=? 222 (symbol->string (get-hash-table ht k #f)) 223 (cond 224 [(string? k) k] 225 [(pair? k) (car k)] 226 [(vector? k) (vector-ref k 0)]))) 227 keep) 228 (andmap (lambda (k) (eq? (get-hash-table ht k 'no) 'no)) 229 drop)) 230 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 231 (let ([k (case (pick '(string pair vector)) 232 [(string) s] 233 [(pair) (list s)] 234 [(vector) (vector s)])]) 235 (put-hash-table! ht k x) 236 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 237 (if (= (modulo i 17) 5) 238 (let ([k (pick keep)]) 239 (remove-hash-table! ht k) 240 (let ([drop (cons k drop)]) 241 (when (= (random 5) 3) 242 (remove-hash-table! ht (pick drop))) 243 (f (+ i 1) (remq k keep) drop))) 244 (f (+ i 1) keep drop))))))))) 245) 246 247(mat tlc 248 (critical-section 249 (let () 250 (define ht (make-eq-hashtable)) 251 (define keyval '(a . b)) 252 (define next 0) 253 (define tlc (#%$make-tlc ht keyval next)) 254 (define tlc2 (#%$make-tlc ht keyval next)) 255 (and 256 (#%$tlc? tlc) 257 (not (#%$tlc? keyval)) 258 (eq? (#%$tlc-ht tlc) ht) 259 (eq? (#%$tlc-keyval tlc) keyval) 260 (eqv? (#%$tlc-next tlc) next) 261 (begin 262 (#%$set-tlc-next! tlc tlc2) 263 (eq? (#%$tlc-next tlc) tlc2))))) 264) 265 266(define $vector-andmap 267 (lambda (p . v*) 268 (apply andmap p (map vector->list v*)))) 269 270(define $vector-append 271 (lambda v* 272 (list->vector (apply append (map vector->list v*))))) 273 274(define $vector-member? 275 (lambda (x v) 276 (let ([n (vector-length v)]) 277 (let f ([i 0]) 278 (and (not (fx= i n)) 279 (or (equal? (vector-ref v i) x) 280 (f (fx+ i 1)))))))) 281 282(define same-elements? 283 (lambda (v1 v2) 284 (let ([n (vector-length v1)]) 285 (define (each-in? v1 v2) 286 (let f ([i 0]) 287 (or (fx= i n) 288 (and ($vector-member? (vector-ref v1 i) v2) 289 (f (fx+ i 1)))))) 290 (and (fx= (vector-length v2) n) 291 (each-in? v1 v2) 292 (each-in? v2 v1))))) 293 294(define equal-entries? 295 (lambda (ht keys vals) 296 (define-syntax same-entries? 297 (syntax-rules () 298 [(_ e1 keys2 vals2) 299 (let-values ([(keys1 vals1) e1]) 300 (and 301 (same-elements? keys1 keys2) 302 (same-elements? vals1 vals2)))])) 303 304 (and 305 (same-elements? (hashtable-keys ht) keys) 306 (same-elements? (hashtable-values ht) vals) 307 (same-entries? (hashtable-entries ht) keys vals) 308 (same-elements? (hashtable-cells ht) (vector-map cons keys vals)) 309 310 (same-elements? (r6rs:hashtable-keys ht) keys) 311 (same-entries? (r6rs:hashtable-entries ht) keys vals) 312 313 ;; Check requested sizes > hash table size 314 (andmap (lambda (size) 315 (and 316 (same-elements? (hashtable-keys ht size) keys) 317 (same-elements? (hashtable-values ht size) vals) 318 (same-entries? (hashtable-entries ht size) keys vals) 319 (same-elements? (hashtable-cells ht size) (vector-map cons keys vals)))) 320 (list (add1 (hashtable-size ht)) 321 (expt 2 1000))) 322 323 ;; Make sure request of 0 always works: 324 (same-elements? (hashtable-keys ht 0) '#()) 325 (same-elements? (hashtable-values ht 0) '#()) 326 (same-entries? (hashtable-entries ht 0) '#() '#()) 327 (same-elements? (hashtable-cells ht 0) '#()) 328 329 (or 330 (< (hashtable-size ht) 2) 331 ;; Check request of size 2: 332 (let ([twos (lambda (v) 333 (let i-loop ([i 0]) 334 (cond 335 [(= i (vector-length v)) 336 '()] 337 [else 338 (let j-loop ([j (add1 i)]) 339 (cond 340 [(= j (vector-length v)) 341 (i-loop (add1 i))] 342 [else 343 (cons (vector (vector-ref v i) (vector-ref v j)) 344 (j-loop (add1 j)))]))])))]) 345 (let ([keyss (twos keys)] 346 [valss (twos vals)]) 347 (and 348 (let ([got-keys (hashtable-keys ht 2)]) 349 (ormap (lambda (keys) 350 (same-elements? got-keys keys)) 351 keyss)) 352 (let ([got-vals (hashtable-values ht 2)]) 353 (ormap (lambda (vals) 354 (same-elements? got-vals vals)) 355 valss)) 356 (let-values ([(got-keys got-vals) (hashtable-entries ht 2)]) 357 (ormap (lambda (keys vals) 358 (and (same-elements? got-keys keys) 359 (same-elements? got-vals vals))) 360 keyss valss)) 361 (let ([got-cells (hashtable-cells ht 2)]) 362 (ormap (lambda (keys vals) 363 (same-elements? got-cells (vector-map cons keys vals))) 364 keyss valss))))))))) 365 366(mat hashtable-arguments 367 ; make-eq-hashtable 368 (error? ; wrong argument count 369 (make-eq-hashtable 3 #t)) 370 (error? ; invalid size 371 (make-eq-hashtable -1)) 372 (error? ; invalid size 373 (make-eq-hashtable #t)) 374 (error? ; invalid size 375 (make-eq-hashtable #f)) 376 ; make-hashtable 377 (error? ; wrong argument count 378 (make-hashtable)) 379 (error? ; wrong argument count 380 (make-hashtable equal-hash)) 381 (error? ; wrong argument count 382 (make-hashtable equal-hash equal? 45 53)) 383 (error? ; not a procedure 384 (make-hashtable 'a equal? 45)) 385 (error? ; not a procedure 386 (make-hashtable equal-hash 'a 45)) 387 (error? ; invalid size 388 (make-hashtable equal-hash equal? 'a)) 389 (error? ; invalid size 390 (make-hashtable equal-hash equal? -45)) 391 (error? ; invalid size 392 (make-hashtable equal-hash equal? 45.0)) 393 ; make-eqv-hashtable 394 (error? ; wrong argument count 395 (make-eqv-hashtable 3 #t)) 396 (error? ; invalid size 397 (make-eqv-hashtable -1)) 398 (error? ; invalid size 399 (make-eqv-hashtable #t)) 400 (error? ; invalid size 401 (make-eqv-hashtable #f)) 402 (begin 403 (define $ht (make-eq-hashtable)) 404 (define $imht (hashtable-copy $ht)) 405 (define $ht2 (make-eq-hashtable 50)) 406 (and (hashtable? $ht) 407 (eq-hashtable? $ht) 408 (hashtable-mutable? $ht) 409 (not (hashtable-weak? $ht)) 410 (not (eq-hashtable-weak? $ht)) 411 (not (hashtable-ephemeron? $ht)) 412 (not (eq-hashtable-ephemeron? $ht)) 413 (hashtable? $imht) 414 (eq-hashtable? $imht) 415 (not (hashtable-mutable? $imht)) 416 (not (hashtable-weak? $imht)) 417 (not (eq-hashtable-weak? $imht)) 418 (not (hashtable-ephemeron? $imht)) 419 (not (eq-hashtable-ephemeron? $imht)) 420 (hashtable? $ht2) 421 (eq-hashtable? $ht2) 422 (hashtable-mutable? $ht2) 423 (not (hashtable-weak? $ht2)) 424 (not (eq-hashtable-weak? $ht2)) 425 (not (hashtable-ephemeron? $ht2)) 426 (not (eq-hashtable-ephemeron? $ht2)))) 427 (not (hashtable? 3)) 428 (not (hashtable? (make-vector 3))) 429 (not (eq-hashtable? 3)) 430 (not (eq-hashtable? (make-vector 3))) 431 ; hashtable? 432 (error? ; wrong argument count 433 (hashtable?)) 434 (error? ; wrong argument count 435 (hashtable? $ht 3)) 436 (error? ; wrong argument count 437 (eq-hashtable?)) 438 (error? ; wrong argument count 439 (eq-hashtable? $ht 3)) 440 ; hashtable-mutable? 441 (error? ; not a hashtable 442 (hashtable-mutable? (make-vector 3))) 443 (error? ; wrong argument count 444 (hashtable-mutable?)) 445 (error? ; wrong argument count 446 (hashtable-mutable? $ht 3)) 447 ; hashtable-size 448 (error? ; wrong argument count 449 (hashtable-size)) 450 (error? ; wrong argument count 451 (hashtable-size $ht 3)) 452 (error? ; not a hashtable 453 (hashtable-size 'hello)) 454 ; hashtable-ref 455 (error? ; wrong argument count 456 (hashtable-ref)) 457 (error? ; wrong argument count 458 (hashtable-ref $ht)) 459 (error? ; wrong argument count 460 (hashtable-ref $ht 'a)) 461 (error? ; wrong argument count 462 (hashtable-ref $ht 'a 'b 'c)) 463 (error? ; not a hashtable 464 (hashtable-ref '(hash . table) 'a 'b)) 465 ; hashtable-contains? 466 (error? ; wrong argument count 467 (hashtable-contains?)) 468 (error? ; wrong argument count 469 (hashtable-contains? $ht)) 470 (error? ; wrong argument count 471 (hashtable-contains? $ht 'a 'b)) 472 (error? ; not a hashtable 473 (hashtable-contains? '(hash . table) 'a)) 474 ; hashtable-set! 475 (error? ; wrong argument count 476 (hashtable-set!)) 477 (error? ; wrong argument count 478 (hashtable-set! $ht)) 479 (error? ; wrong argument count 480 (hashtable-set! $ht 'a)) 481 (error? ; wrong argument count 482 (hashtable-set! $ht 'a 'b 'c)) 483 (error? ; not a hashtable 484 (hashtable-set! '(hash . table) 'a 'b)) 485 (error? ; hashtable not mutable 486 (hashtable-set! $imht 'a 'b)) 487 ; hashtable-update! 488 (error? ; wrong argument count 489 (hashtable-update!)) 490 (error? ; wrong argument count 491 (hashtable-update! $ht)) 492 (error? ; wrong argument count 493 (hashtable-update! $ht 'a values)) 494 (error? ; wrong argument count 495 (hashtable-update! $ht 'a values 'c 'd)) 496 (error? ; not a hashtable 497 (hashtable-update! '(hash . table) 'a values 'b)) 498 (error? ; hashtable not mutable 499 (hashtable-update! $imht 'a values 'b)) 500 (error? ; not a procedure 501 (hashtable-update! $ht 'a "not a procedure" 'b)) 502 ; hashtable-cell 503 (error? ; wrong argument count 504 (hashtable-cell)) 505 (error? ; wrong argument count 506 (hashtable-cell $ht)) 507 (error? ; wrong argument count 508 (hashtable-cell $ht 'a)) 509 (error? ; wrong argument count 510 (hashtable-cell $ht 'a 'b 'c)) 511 (error? ; not a hashtable 512 (hashtable-cell '(hash . table) 'a 'b)) 513 ; hashtable-ref-cell 514 (error? ; wrong argument count 515 (hashtable-ref-cell)) 516 (error? ; wrong argument count 517 (hashtable-ref-cell $ht)) 518 (error? ; wrong argument count 519 (hashtable-ref-cell $ht 'a 'b)) 520 (error? ; not a hashtable 521 (hashtable-ref-cell '(hash . table) 'a 'b)) 522 ; hashtable-delete! 523 (error? ; wrong argument count 524 (hashtable-delete!)) 525 (error? ; wrong argument count 526 (hashtable-delete! $ht)) 527 (error? ; wrong argument count 528 (hashtable-delete! $ht 'a 'b)) 529 (error? ; not a hashtable 530 (hashtable-delete! '(hash . table) 'a)) 531 (error? ; hashtable not mutable 532 (hashtable-delete! $imht 'a)) 533 ; hashtable-copy 534 (error? ; wrong argument count 535 (hashtable-copy)) 536 (error? ; wrong argument count 537 (hashtable-copy $ht #t 17)) 538 (error? ; not a hashtable 539 (hashtable-copy '(hash . table) #t)) 540 ; hashtable-clear! 541 (error? ; wrong argument count 542 (hashtable-clear!)) 543 (error? ; wrong argument count 544 (hashtable-clear! $ht 17 'foo)) 545 (error? ; not a hashtable 546 (hashtable-clear! '(hash . table))) 547 (error? ; not a hashtable 548 (hashtable-clear! '(hash . table) 17)) 549 (error? ; hashtable not mutable 550 (hashtable-clear! $imht)) 551 (error? ; hashtable not mutable 552 (hashtable-clear! $imht 32)) 553 (error? ; invalid size 554 (hashtable-clear! $ht #t)) 555 ; hashtable-keys 556 (error? ; wrong argument count 557 (hashtable-keys)) 558 (error? ; wrong argument count 559 (hashtable-keys $ht 72 43)) 560 (error? ; not a hashtable 561 (hashtable-keys '(hash . table))) 562 (error? ; bad size 563 (hashtable-keys $ht -79)) 564 (error? ; bad size 565 (hashtable-keys $ht 'not-an-unsigned-integer)) 566 (error? ; wrong argument count 567 (r6rs:hashtable-keys)) 568 (error? ; wrong argument count 569 (r6rs:hashtable-keys $ht 72)) 570 (error? ; not a hashtable 571 (r6rs:hashtable-keys '(hash . table))) 572 ; hashtable-values 573 (error? ; wrong argument count 574 (hashtable-values)) 575 (error? ; wrong argument count 576 (hashtable-values $ht 72 43)) 577 (error? ; not a hashtable 578 (hashtable-values '(hash . table))) 579 (error? ; bad size 580 (hashtable-values $ht -79)) 581 (error? ; bad size 582 (hashtable-values $ht 'not-an-unsigned-integer)) 583 ; hashtable-entries 584 (error? ; wrong argument count 585 (hashtable-entries)) 586 (error? ; wrong argument count 587 (hashtable-entries $ht 72 43)) 588 (error? ; not a hashtable 589 (hashtable-entries '(hash . table))) 590 (error? ; bad size 591 (hashtable-entries $ht -79)) 592 (error? ; bad size 593 (hashtable-entries $ht 'not-an-unsigned-integer)) 594 (error? ; wrong argument count 595 (r6rs:hashtable-entries)) 596 (error? ; wrong argument count 597 (r6rs:hashtable-entries $ht 72)) 598 (error? ; not a hashtable 599 (r6rs:hashtable-entries '(hash . table))) 600 ; hashtable-cells 601 (error? ; wrong argument count 602 (hashtable-cells)) 603 (error? ; wrong argument count 604 (hashtable-cells $ht 72 43)) 605 (error? ; not a hashtable 606 (hashtable-cells '(hash . table))) 607 (error? ; bad size 608 (hashtable-cells $ht -79)) 609 (error? ; bad size 610 (hashtable-cells $ht 'not-an-unsigned-integer)) 611 ; hashtable-hash-function 612 (error? ; wrong argument count 613 (hashtable-hash-function)) 614 (error? ; wrong argument count 615 (hashtable-hash-function $ht $ht)) 616 (error? ; not a hsshtable 617 (hashtable-hash-function '(hash . table))) 618 ; hashtable-equivalence-function 619 (error? ; wrong argument count 620 (hashtable-equivalence-function)) 621 (error? ; wrong argument count 622 (hashtable-equivalence-function $ht $ht)) 623 (error? ; not a hsshtable 624 (hashtable-equivalence-function '(hash . table))) 625 ; hashtable-weak? 626 (error? ; wrong argument count 627 (hashtable-weak?)) 628 (error? ; wrong argument count 629 (hashtable-weak? $ht 3)) 630 (error? ; not a hashtable 631 (hashtable-weak? '(hash . table))) 632 ; hashtable-ephemeron? 633 (error? ; wrong argument count 634 (hashtable-ephemeron?)) 635 (error? ; wrong argument count 636 (hashtable-ephemeron? $ht 3)) 637 (error? ; not a hashtable 638 (hashtable-ephemeron? '(hash . table))) 639) 640 641(mat hash-return-value 642 ; hashtable-ref 643 (error? ; invalid hash-function return value 644 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 645 (hashtable-ref ht 'any #f))) 646 #;(error? ; invalid hash-function return value 647 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 648 (hashtable-ref ht 'any #f))) 649 (error? ; invalid hash-function return value 650 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 651 (hashtable-ref ht 'any #f))) 652 (error? ; invalid hash-function return value 653 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 654 (hashtable-ref ht 'any #f))) 655 ; hashtable-contains? 656 (error? ; invalid hash-function return value 657 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 658 (hashtable-contains? ht 'any))) 659 #;(error? ; invalid hash-function return value 660 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 661 (hashtable-contains? ht 'any))) 662 (error? ; invalid hash-function return value 663 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 664 (hashtable-contains? ht 'any))) 665 (error? ; invalid hash-function return value 666 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 667 (hashtable-contains? ht 'any))) 668 ; hashtable-set! 669 (error? ; invalid hash-function return value 670 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 671 (hashtable-set! ht 'any 'spam))) 672 #;(error? ; invalid hash-function return value 673 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 674 (hashtable-set! ht 'any 'spam))) 675 (error? ; invalid hash-function return value 676 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 677 (hashtable-set! ht 'any 'spam))) 678 (error? ; invalid hash-function return value 679 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 680 (hashtable-set! ht 'any 'spam))) 681 ; hashtable-update! 682 (error? ; invalid hash-function return value 683 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 684 (hashtable-update! ht 'any values 'spam))) 685 #;(error? ; invalid hash-function return value 686 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 687 (hashtable-update! ht 'any values 'spam))) 688 (error? ; invalid hash-function return value 689 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 690 (hashtable-update! ht 'any values 'spam))) 691 (error? ; invalid hash-function return value 692 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 693 (hashtable-update! ht 'any values 'spam))) 694 ; hashtable-cell 695 (error? ; invalid hash-function return value 696 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 697 (hashtable-cell ht 'any 0))) 698 #;(error? ; invalid hash-function return value 699 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 700 (hashtable-cell ht 'any 0))) 701 (error? ; invalid hash-function return value 702 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 703 (hashtable-cell ht 'any 0))) 704 (error? ; invalid hash-function return value 705 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 706 (hashtable-cell ht 'any 0))) 707 ; hashtable-ref-cell 708 (error? ; invalid hash-function return value 709 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 710 (hashtable-ref-cell ht 'any))) 711 #;(error? ; invalid hash-function return value 712 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 713 (hashtable-ref-cell ht 'any))) 714 (error? ; invalid hash-function return value 715 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 716 (hashtable-ref-cell ht 'any))) 717 (error? ; invalid hash-function return value 718 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 719 (hashtable-ref-cell ht 'any))) 720 ; hashtable-delete! 721 (error? ; invalid hash-function return value 722 (let ([ht (make-hashtable (lambda (x) "oops") equal?)]) 723 (hashtable-delete! ht 'any))) 724 #;(error? ; invalid hash-function return value 725 (let ([ht (make-hashtable (lambda (x) -7) equal?)]) 726 (hashtable-delete! ht 'any))) 727 (error? ; invalid hash-function return value 728 (let ([ht (make-hashtable (lambda (x) 3.5) equal?)]) 729 (hashtable-delete! ht 'any))) 730 (error? ; invalid hash-function return value 731 (let ([ht (make-hashtable (lambda (x) 1+2i) equal?)]) 732 (hashtable-delete! ht 'any))) 733) 734 735(mat eq-hashtable-arguments 736 ; make-weak-eq-hashtable 737 (error? ; wrong argument count 738 (make-weak-eq-hashtable 3 #t)) 739 (error? ; invalid size 740 (make-weak-eq-hashtable -1)) 741 (error? ; invalid size 742 (make-weak-eq-hashtable #t)) 743 (error? ; invalid size 744 (make-weak-eq-hashtable #f)) 745 ; make-weak-eq-hashtable 746 (error? ; wrong argument count 747 (make-ephemeron-eq-hashtable 3 #t)) 748 (error? ; invalid size 749 (make-ephemeron-eq-hashtable -1)) 750 (error? ; invalid size 751 (make-ephemeron-eq-hashtable #t)) 752 (error? ; invalid size 753 (make-ephemeron-eq-hashtable #f)) 754 (begin 755 (define $wht (make-weak-eq-hashtable 50)) 756 (define $eht (make-ephemeron-eq-hashtable 50)) 757 (define $imht (hashtable-copy $wht)) 758 (define $imeht (hashtable-copy $eht)) 759 (define $wht2 (make-weak-eq-hashtable)) 760 (define $eht2 (make-ephemeron-eq-hashtable)) 761 (and (hashtable? $wht) 762 (hashtable? $eht) 763 (eq-hashtable? $wht) 764 (eq-hashtable? $eht) 765 (hashtable-weak? $wht) 766 (not (hashtable-ephemeron? $wht)) 767 (hashtable-ephemeron? $eht) 768 (not (hashtable-weak? $eht)) 769 (eq-hashtable-weak? $wht) 770 (not (eq-hashtable-ephemeron? $wht)) 771 (eq-hashtable-ephemeron? $eht) 772 (not (eq-hashtable-weak? $eht)) 773 (hashtable-mutable? $wht) 774 (hashtable-mutable? $eht) 775 (hashtable? $imht) 776 (hashtable? $imeht) 777 (eq-hashtable? $imht) 778 (eq-hashtable? $imeht) 779 (hashtable-weak? $imht) 780 (not (hashtable-ephemeron? $imht)) 781 (hashtable-ephemeron? $imeht) 782 (not (hashtable-weak? $imeht)) 783 (eq-hashtable-weak? $imht) 784 (not (eq-hashtable-ephemeron? $imht)) 785 (eq-hashtable-ephemeron? $imeht) 786 (not (eq-hashtable-weak? $imeht)) 787 (not (hashtable-mutable? $imht)) 788 (not (hashtable-mutable? $imeht)) 789 (hashtable? $wht2) 790 (hashtable? $eht2) 791 (eq-hashtable? $wht2) 792 (eq-hashtable? $eht2) 793 (hashtable-weak? $wht2) 794 (not (hashtable-ephemeron? $wht2)) 795 (hashtable-ephemeron? $eht2) 796 (not (hashtable-weak? $eht2)) 797 (eq-hashtable-weak? $wht2) 798 (not (eq-hashtable-ephemeron? $ht2)) 799 (eq-hashtable-ephemeron? $eht2) 800 (not (eq-hashtable-weak? $eht2)) 801 (hashtable-mutable? $wht2) 802 (hashtable-mutable? $eht2))) 803 ; eq-hashtable-ref 804 (error? ; wrong argument count 805 (eq-hashtable-ref)) 806 (error? ; wrong argument count 807 (eq-hashtable-ref $wht)) 808 (error? ; wrong argument count 809 (eq-hashtable-ref $wht 'a)) 810 (error? ; wrong argument count 811 (eq-hashtable-ref $wht 'a 'b 'c)) 812 (error? ; not a hashtable 813 (eq-hashtable-ref '(hash . table) 'a 'b)) 814 ; eq-hashtable-contains? 815 (error? ; wrong argument count 816 (eq-hashtable-contains?)) 817 (error? ; wrong argument count 818 (eq-hashtable-contains? $wht)) 819 (error? ; wrong argument count 820 (eq-hashtable-contains? $wht 'a 'b)) 821 (error? ; not a hashtable 822 (eq-hashtable-contains? '(hash . table) 'a)) 823 ; eq-hashtable-set! 824 (error? ; wrong argument count 825 (eq-hashtable-set!)) 826 (error? ; wrong argument count 827 (eq-hashtable-set! $wht)) 828 (error? ; wrong argument count 829 (eq-hashtable-set! $wht 'a)) 830 (error? ; wrong argument count 831 (eq-hashtable-set! $wht 'a 'b 'c)) 832 (error? ; not a hashtable 833 (eq-hashtable-set! '(hash . table) 'a 'b)) 834 (error? ; hashtable not mutable 835 (eq-hashtable-set! $imht 'a 'b)) 836 ; eq-hashtable-update! 837 (error? ; wrong argument count 838 (eq-hashtable-update!)) 839 (error? ; wrong argument count 840 (eq-hashtable-update! $wht)) 841 (error? ; wrong argument count 842 (eq-hashtable-update! $wht 'a values)) 843 (error? ; wrong argument count 844 (eq-hashtable-update! $wht 'a values 'c 'd)) 845 (error? ; not a hashtable 846 (eq-hashtable-update! '(hash . table) 'a values 'b)) 847 (error? ; hashtable not mutable 848 (eq-hashtable-update! $imht 'a values 'b)) 849 (error? ; not a procedure 850 (eq-hashtable-update! $wht 'a "not a procedure" 'b)) 851 ; eq-hashtable-delete! 852 (error? ; wrong argument count 853 (eq-hashtable-delete!)) 854 (error? ; wrong argument count 855 (eq-hashtable-delete! $wht)) 856 (error? ; wrong argument count 857 (eq-hashtable-delete! $wht 'a 'b)) 858 (error? ; not a hashtable 859 (eq-hashtable-delete! '(hash . table) 'a)) 860 (error? ; hashtable not mutable 861 (eq-hashtable-delete! $imht 'a)) 862 ; eq-hashtable-cell 863 (error? ; wrong argument count 864 (eq-hashtable-cell)) 865 (error? ; wrong argument count 866 (eq-hashtable-cell $wht)) 867 (error? ; wrong argument count 868 (eq-hashtable-cell $wht 'a)) 869 (error? ; wrong argument count 870 (eq-hashtable-cell $wht 'a 'b 'c)) 871 (error? ; not a hashtable 872 (eq-hashtable-cell '(hash . table) 'a 'b)) 873 ; eq-hashtable-ref-cell 874 (error? ; wrong argument count 875 (eq-hashtable-ref-cell)) 876 (error? ; wrong argument count 877 (eq-hashtable-ref-cell $wht)) 878 (error? ; wrong argument count 879 (eq-hashtable-ref-cell $wht 'a 'b)) 880 (error? ; not a hashtable 881 (eq-hashtable-ref-cell '(hash . table) 'a)) 882 ; eq-hashtable-try-atomic-cell 883 (error? ; wrong argument count 884 (eq-hashtable-try-atomic-cell)) 885 (error? ; wrong argument count 886 (eq-hashtable-try-atomic-cell $wht)) 887 (error? ; wrong argument count 888 (eq-hashtable-try-atomic-cell $wht 'a)) 889 (error? ; wrong argument count 890 (eq-hashtable-try-atomic-cell $wht 'a 'b 'c)) 891 (error? ; not a hashtable 892 (eq-hashtable-try-atomic-cell '(hash . table) 'a 'b)) 893 ; eq-hashtable-weak? 894 (error? ; wrong argument count 895 (eq-hashtable-weak?)) 896 (error? ; wrong argument count 897 (eq-hashtable-weak? $ht 3)) 898 (error? ; not a hashtable 899 (eq-hashtable-weak? '(hash . table))) 900 ; eq-hashtable-ephemeron? 901 (error? ; wrong argument count 902 (eq-hashtable-ephemeron?)) 903 (error? ; wrong argument count 904 (eq-hashtable-ephemeron? $ht 3)) 905 (error? ; not a hashtable 906 (eq-hashtable-ephemeron? '(hash . table))) 907) 908 909(mat symbol-hashtable-arguments 910 (begin 911 (define $symht (make-hashtable symbol-hash eq? 50)) 912 (define $imsymht (hashtable-copy $symht)) 913 #t) 914 ; symbol-hashtable-ref 915 (error? ; wrong argument count 916 (symbol-hashtable-ref)) 917 (error? ; wrong argument count 918 (symbol-hashtable-ref $symht)) 919 (error? ; wrong argument count 920 (symbol-hashtable-ref $symht 'a)) 921 (error? ; wrong argument count 922 (symbol-hashtable-ref $symht 'a 'b 'c)) 923 (error? ; not a hashtable 924 (symbol-hashtable-ref '(hash . table) 'a 'b)) 925 (error? ; not a symbol hashtable 926 (symbol-hashtable-ref $ht 'a 'b)) 927 (error? ; not a symbol 928 (symbol-hashtable-ref $symht '(a) 'b)) 929 (error? ; not a symbol 930 (hashtable-ref $symht '(a) 'b)) 931 ; symbol-hashtable-contains? 932 (error? ; wrong argument count 933 (symbol-hashtable-contains?)) 934 (error? ; wrong argument count 935 (symbol-hashtable-contains? $symht)) 936 (error? ; wrong argument count 937 (symbol-hashtable-contains? $symht 'a 'b)) 938 (error? ; not a hashtable 939 (symbol-hashtable-contains? '(hash . table) 'a)) 940 (error? ; not a symbol hashtable 941 (symbol-hashtable-contains? $ht 'a)) 942 (error? ; not a symbol 943 (symbol-hashtable-contains? $symht '(a))) 944 (error? ; not a symbol 945 (hashtable-contains? $symht '(a))) 946 ; symbol-hashtable-set! 947 (error? ; wrong argument count 948 (symbol-hashtable-set!)) 949 (error? ; wrong argument count 950 (symbol-hashtable-set! $symht)) 951 (error? ; wrong argument count 952 (symbol-hashtable-set! $symht 'a)) 953 (error? ; wrong argument count 954 (symbol-hashtable-set! $symht 'a 'b 'c)) 955 (error? ; not a hashtable 956 (symbol-hashtable-set! '(hash . table) 'a 'b)) 957 (error? ; not a symbol hashtable 958 (symbol-hashtable-set! $ht 'a 'b)) 959 (error? ; not a symbol 960 (symbol-hashtable-set! $symht '(a) 'b)) 961 (error? ; not a symbol 962 (hashtable-set! $symht '(a) 'b)) 963 (error? ; hashtable not mutable 964 (symbol-hashtable-set! $imsymht 'a 'b)) 965 ; symbol-hashtable-update! 966 (error? ; wrong argument count 967 (symbol-hashtable-update!)) 968 (error? ; wrong argument count 969 (symbol-hashtable-update! $symht)) 970 (error? ; wrong argument count 971 (symbol-hashtable-update! $symht 'a values)) 972 (error? ; wrong argument count 973 (symbol-hashtable-update! $symht 'a values 'c 'd)) 974 (error? ; not a hashtable 975 (symbol-hashtable-update! '(hash . table) 'a values 'b)) 976 (error? ; not a symbol hashtable 977 (symbol-hashtable-update! $ht 'a values 'b)) 978 (error? ; not a symbol 979 (symbol-hashtable-update! $symht '(a) values 'b)) 980 (error? ; not a symbol 981 (hashtable-update! $symht '(a) values 'b)) 982 (error? ; hashtable not mutable 983 (symbol-hashtable-update! $imsymht 'a values 'b)) 984 (error? ; not a procedure 985 (symbol-hashtable-update! $symht 'a "not a procedure" 'b)) 986 ; symbol-hashtable-delete! 987 (error? ; wrong argument count 988 (symbol-hashtable-delete!)) 989 (error? ; wrong argument count 990 (symbol-hashtable-delete! $symht)) 991 (error? ; wrong argument count 992 (symbol-hashtable-delete! $symht 'a 'b)) 993 (error? ; not a hashtable 994 (symbol-hashtable-delete! '(hash . table) 'a)) 995 (error? ; not a symbol hashtable 996 (symbol-hashtable-delete! $ht 'a)) 997 (error? ; not a symbol 998 (symbol-hashtable-delete! $symht '(a))) 999 (error? ; not a symbol 1000 (hashtable-delete! $symht '(a))) 1001 (error? ; hashtable not mutable 1002 (symbol-hashtable-delete! $imsymht 'a)) 1003 ; symbol-hashtable-cell 1004 (error? ; wrong argument count 1005 (symbol-hashtable-cell)) 1006 (error? ; wrong argument count 1007 (symbol-hashtable-cell $symht)) 1008 (error? ; wrong argument count 1009 (symbol-hashtable-cell $symht 'a)) 1010 (error? ; wrong argument count 1011 (symbol-hashtable-cell $symht 'a 'b 'c)) 1012 (error? ; not a hashtable 1013 (symbol-hashtable-cell '(hash . table) 'a 'b)) 1014 (error? ; not a symbol hashtable 1015 (symbol-hashtable-cell $ht 'a 'b)) 1016 (error? ; not a symbol 1017 (symbol-hashtable-cell $symht '(a) 'b)) 1018 (error? ; not a symbol 1019 (hashtable-cell $symht '(a) 'b)) 1020 ; symbol-hashtable-ref-cell 1021 (error? ; wrong argument count 1022 (symbol-hashtable-ref-cell)) 1023 (error? ; wrong argument count 1024 (symbol-hashtable-ref-cell $symht)) 1025 (error? ; wrong argument count 1026 (symbol-hashtable-ref-cell $symht 'a 'b)) 1027 (error? ; not a hashtable 1028 (symbol-hashtable-ref-cell '(hash . table) 'a)) 1029 (error? ; not a symbol hashtable 1030 (symbol-hashtable-ref-cell $ht 'a)) 1031 (error? ; not a symbol 1032 (symbol-hashtable-ref-cell $symht '(a))) 1033 (error? ; not a symbol 1034 (hashtable-ref-cell $symht '(a))) 1035) 1036 1037(mat eqv-hashtable-arguments 1038 ; make-weak-eqv-hashtable 1039 (error? ; wrong argument count 1040 (make-weak-eqv-hashtable 3 #t)) 1041 (error? ; invalid size 1042 (make-weak-eqv-hashtable -1)) 1043 (error? ; invalid size 1044 (make-weak-eqv-hashtable #t)) 1045 (error? ; invalid size 1046 (make-weak-eqv-hashtable #f)) 1047 ; make-ephemeron-eqv-hashtable 1048 (error? ; wrong argument count 1049 (make-ephemeron-eqv-hashtable 3 #t)) 1050 (error? ; invalid size 1051 (make-ephemeron-eqv-hashtable -1)) 1052 (error? ; invalid size 1053 (make-ephemeron-eqv-hashtable #t)) 1054 (error? ; invalid size 1055 (make-ephemeron-eqv-hashtable #f)) 1056) 1057 1058(mat nonweak-eq-hashtable 1059 (begin 1060 (define h (make-eq-hashtable 32)) 1061 (and (hashtable? h) 1062 (eq-hashtable? h) 1063 (hashtable-mutable? h) 1064 (not (eq-hashtable-weak? h)) 1065 (not (eq-hashtable-ephemeron? h)) 1066 (not (hashtable-weak? h)) 1067 (not (hashtable-ephemeron? h)))) 1068 (eq? (hashtable-hash-function h) #f) 1069 (eq? (hashtable-equivalence-function h) eq?) 1070 (equal? (hashtable-size h) 0) 1071 (same-elements? (hashtable-keys h) '#()) 1072 (same-elements? (hashtable-values h) '#()) 1073 (equal-entries? h '#() '#()) 1074 (same-elements? (hashtable-cells h) '#()) 1075 (same-elements? (hashtable-cells h 0) '#()) 1076 (same-elements? (hashtable-cells h 10) '#()) 1077 (eqv? (hashtable-set! h 'a 'aval) (void)) 1078 (equal? 1079 (list 1080 (hashtable-contains? h 'a) 1081 (hashtable-contains? h 'b) 1082 (hashtable-contains? h 'c)) 1083 '(#t #f #f)) 1084 (eqv? (hashtable-set! h 'b 'bval) (void)) 1085 (equal? 1086 (list 1087 (hashtable-contains? h 'a) 1088 (hashtable-contains? h 'b) 1089 (hashtable-contains? h 'c)) 1090 '(#t #t #f)) 1091 (eqv? (hashtable-set! h 'c 'cval) (void)) 1092 (equal? 1093 (list 1094 (hashtable-contains? h 'a) 1095 (hashtable-contains? h 'b) 1096 (hashtable-contains? h 'c)) 1097 '(#t #t #t)) 1098 (equal? (hashtable-size h) 3) 1099 (same-elements? (hashtable-keys h) '#(a b c)) 1100 (same-elements? (hashtable-values h) '#(bval cval aval)) 1101 (equal-entries? h '#(b c a) '#(bval cval aval)) 1102 (same-elements? (hashtable-cells h) '#((b . bval) (c . cval) (a . aval))) 1103 (same-elements? (hashtable-cells h (expt 2 100)) '#((b . bval) (c . cval) (a . aval))) 1104 (let ([cells (hashtable-cells h 2)]) 1105 (or (same-elements? cells '#((b . bval) (c . cval))) 1106 (same-elements? cells '#((b . bval) (a . aval))) 1107 (same-elements? cells '#((c . cval) (a . aval))))) 1108 #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (b . bval) (c . cval))) 1109 #;(same-elements? 1110 (let ([v (make-vector 3)] [i 0]) 1111 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 1112 v) 1113 '#((a . aval) (b . bval) (c . cval))) 1114 #;(same-elements? 1115 (let ([v (make-vector 3)] [i 0]) 1116 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 1117 v) 1118 '#((a . aval) (b . bval) (c . cval))) 1119 (equal? (hashtable-ref h 'a 1) 'aval) 1120 (equal? (hashtable-ref h 'b #f) 'bval) 1121 (equal? (hashtable-ref h 'c 'nope) 'cval) 1122 (eqv? (hashtable-delete! h 'b) (void)) 1123 (equal? (hashtable-size h) 2) 1124 (equal-entries? h '#(a c) '#(aval cval)) 1125 (begin 1126 (define h2 (hashtable-copy h #t)) 1127 (and (hashtable? h2) 1128 (eq-hashtable? h2) 1129 (hashtable-mutable? h2) 1130 (not (hashtable-weak? h2)) 1131 (not (eq-hashtable-weak? h2)) 1132 (not (hashtable-ephemeron? h2)) 1133 (not (eq-hashtable-ephemeron? h2)))) 1134 (eq? (hashtable-hash-function h2) #f) 1135 (eq? (hashtable-equivalence-function h2) eq?) 1136 (equal? (hashtable-size h2) 2) 1137 (equal-entries? h2 '#(a c) '#(aval cval)) 1138 (eqv? (hashtable-clear! h 4) (void)) 1139 (equal? 1140 (list 1141 (hashtable-size h) 1142 (hashtable-ref h 'a 1) 1143 (hashtable-ref h 'b #f) 1144 (hashtable-ref h 'c 'nope)) 1145 '(0 1 #f nope)) 1146 (equal-entries? h '#() '#()) 1147 (equal? 1148 (list 1149 (hashtable-size h2) 1150 (hashtable-ref h2 'a 1) 1151 (hashtable-ref h2 'b #f) 1152 (hashtable-ref h2 'c 'nope)) 1153 '(2 aval #f cval)) 1154 (equal-entries? h2 '#(a c) '#(aval cval)) 1155 (eqv? 1156 (hashtable-update! h 'q 1157 (lambda (x) (+ x 1)) 1158 17) 1159 (void)) 1160 (equal? (hashtable-ref h 'q #f) 18) 1161 (eqv? 1162 (hashtable-update! h 'q 1163 (lambda (x) (+ x 1)) 1164 17) 1165 (void)) 1166 (equal? (hashtable-ref h 'q #f) 19) 1167 (equal? (hashtable-size h) 1) 1168 ; test hashtable-copy when some keys may have moved 1169 (let ([t (parameterize ([collect-request-handler void]) 1170 (let ([h4a (make-eq-hashtable 32)] 1171 [k* (map list (make-list 100))]) 1172 (for-each (lambda (x) (hashtable-set! h4a x x)) k*) 1173 (collect) 1174 ; create copy after collection but before otherwise touching h4a 1175 (let ([h4b (hashtable-copy h4a #t)]) 1176 (andmap 1177 (lambda (k) (eq? (hashtable-ref h4b k #f) k)) 1178 k*))))]) 1179 (collect) 1180 t) 1181 1182 ; test for proper shrinkage 1183 (eqv? 1184 (let ([ht (make-eq-hashtable 32)]) 1185 (for-each 1186 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 1187 (let ([k** (map (lambda (x) (map list (make-list 1000))) 1188 (make-list 100))]) 1189 (for-each 1190 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 1191 k**) 1192 k**)) 1193 (#%$hashtable-veclen ht)) 1194 32) 1195) 1196 1197(mat weak-eq-hashtable 1198 (begin 1199 (define ka (list 'a)) 1200 (define kb (list 'b)) 1201 (define kc (list 'c)) 1202 (define kq (list 'q)) 1203 (define ky (list 'y)) 1204 (define kz (list 'z)) 1205 #t) 1206 (begin 1207 (define h (make-weak-eq-hashtable 32)) 1208 (and (hashtable? h) 1209 (eq-hashtable? h) 1210 (hashtable-mutable? h) 1211 (hashtable-weak? h) 1212 (eq-hashtable-weak? h))) 1213 (eq? (hashtable-hash-function h) #f) 1214 (eq? (hashtable-equivalence-function h) eq?) 1215 (equal? (hashtable-size h) 0) 1216 (same-elements? (hashtable-keys h) '#()) 1217 (same-elements? (hashtable-values h) '#()) 1218 (equal-entries? h '#() '#()) 1219 (same-elements? (hashtable-cells h) '#()) 1220 (same-elements? (hashtable-cells h 0) '#()) 1221 (same-elements? (hashtable-cells h 10) '#()) 1222 (eqv? (hashtable-set! h ka 'aval) (void)) 1223 (equal? 1224 (list 1225 (hashtable-contains? h ka) 1226 (hashtable-contains? h kb) 1227 (hashtable-contains? h kc)) 1228 '(#t #f #f)) 1229 (eqv? (hashtable-set! h kb 'bval) (void)) 1230 (equal? 1231 (list 1232 (hashtable-contains? h ka) 1233 (hashtable-contains? h kb) 1234 (hashtable-contains? h kc)) 1235 '(#t #t #f)) 1236 (eqv? (hashtable-set! h kc 'cval) (void)) 1237 (equal? 1238 (list 1239 (hashtable-contains? h ka) 1240 (hashtable-contains? h kb) 1241 (hashtable-contains? h kc)) 1242 '(#t #t #t)) 1243 (equal? (hashtable-size h) 3) 1244 (same-elements? (hashtable-keys h) '#((a) (b) (c))) 1245 (same-elements? (hashtable-values h) '#(bval cval aval)) 1246 (equal-entries? h '#((a) (b) (c)) '#(aval bval cval)) 1247 (same-elements? (hashtable-cells h) (vector (cons ka 'aval) (cons kb 'bval) (cons kc 'cval))) 1248 (same-elements? (hashtable-cells h (expt 2 100)) (vector (cons ka 'aval) (cons kb 'bval) (cons kc 'cval))) 1249 (let ([cells (hashtable-cells h 2)]) 1250 (or (same-elements? cells (vector (cons ka 'aval) (cons kb 'bval))) 1251 (same-elements? cells (vector (cons ka 'aval) (cons kc 'cval))) 1252 (same-elements? cells (vector (cons kb 'bval) (cons kc 'cval))))) 1253 (andmap weak-pair? (vector->list (hashtable-cells h))) 1254 #;(same-elements? (list->vector (hashtable-map h cons)) '#(((a) . aval) ((b) . bval) ((c) . cval))) 1255 #;(same-elements? 1256 (let ([v (make-vector 3)] [i 0]) 1257 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 1258 v) 1259 '#(((a) . aval) ((b) . bval) ((c) . cval))) 1260 #;(same-elements? 1261 (let ([v (make-vector 3)] [i 0]) 1262 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 1263 v) 1264 '#(((a) . aval) ((b) . bval) ((c) . cval))) 1265 (equal? (hashtable-ref h ka 1) 'aval) 1266 (equal? (hashtable-ref h kb #f) 'bval) 1267 (equal? (hashtable-ref h kc 'nope) 'cval) 1268 (eqv? (hashtable-delete! h kb) (void)) 1269 (equal? (hashtable-size h) 2) 1270 (equal-entries? h '#((a) (c)) '#(aval cval)) 1271 (begin 1272 (define h2 (hashtable-copy h #t)) 1273 (and (hashtable? h2) 1274 (eq-hashtable? h2) 1275 (hashtable-mutable? h2) 1276 (eq-hashtable-weak? h2) 1277 (hashtable-weak? h2))) 1278 (eq? (hashtable-hash-function h2) #f) 1279 (eq? (hashtable-equivalence-function h2) eq?) 1280 (equal? (hashtable-size h2) 2) 1281 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 1282 (eqv? (hashtable-clear! h 4) (void)) 1283 (equal? 1284 (list 1285 (hashtable-size h) 1286 (hashtable-ref h ka 1) 1287 (hashtable-ref h kb #f) 1288 (hashtable-ref h kc 'nope)) 1289 '(0 1 #f nope)) 1290 (equal-entries? h '#() '#()) 1291 (equal? 1292 (list 1293 (hashtable-size h2) 1294 (hashtable-ref h2 ka 1) 1295 (hashtable-ref h2 kb #f) 1296 (hashtable-ref h2 kc 'nope)) 1297 '(2 aval #f cval)) 1298 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 1299 (eqv? 1300 (hashtable-update! h kq 1301 (lambda (x) (+ x 1)) 1302 17) 1303 (void)) 1304 (equal? (hashtable-ref h kq #f) 18) 1305 (eqv? 1306 (hashtable-update! h kq 1307 (lambda (x) (+ x 1)) 1308 17) 1309 (void)) 1310 (equal? (hashtable-ref h kq #f) 19) 1311 (equal? (hashtable-size h) 1) 1312 (equal-entries? h '#((q)) '#(19)) 1313 (eqv? 1314 (begin 1315 (set! kq (void)) 1316 (collect (collect-maximum-generation)) 1317 (hashtable-size h)) 1318 0) 1319 (same-elements? (hashtable-keys h) '#()) 1320 (same-elements? (hashtable-values h) '#()) 1321 (equal-entries? h '#() '#()) 1322 (same-elements? (hashtable-cells h) '#()) 1323 (same-elements? (hashtable-cells h 0) '#()) 1324 (same-elements? (hashtable-cells h 10) '#()) 1325 #;(eqv? (hashtable-map h (lambda args (error #f "oops"))) '()) 1326 #;(eqv? (hashtable-for-each h (lambda args (error #f "oops"))) (void)) 1327 #;(eqv? (hashtable-for-each-cell h (lambda args (error #f "oops"))) (void)) 1328 (equal? (hashtable-ref h ky #f) #f) 1329 (eqv? 1330 (hashtable-set! h ky 'toad) 1331 (void)) 1332 (equal? (hashtable-ref h ky #f) 'toad) 1333 (equal? (hashtable-ref h kz #f) #f) 1334 (eqv? 1335 (hashtable-update! h kz list 'frog) 1336 (void)) 1337 (equal? (hashtable-ref h kz #f) '(frog)) 1338 (equal-entries? 1339 h 1340 (vector kz ky) 1341 (vector (hashtable-ref h kz #f) 'toad)) 1342 (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) 1343 (begin 1344 (define h3 (hashtable-copy h2 #f)) 1345 (and (hashtable? h3) 1346 (eq-hashtable? h3) 1347 (not (hashtable-mutable? h3)) 1348 (eq-hashtable-weak? h3) 1349 (hashtable-weak? h3))) 1350 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 1351 (equal-entries? h3 '#((a) (c)) '#(aval cval)) 1352 (equal? 1353 (begin 1354 (set! ka (void)) 1355 (collect (collect-maximum-generation)) 1356 (list (hashtable-size h2) (hashtable-size h3))) 1357 '(1 1)) 1358 (equal-entries? h2 '#((c)) '#(cval)) 1359 (equal-entries? h3 '#((c)) '#(cval)) 1360 (eqv? 1361 (begin 1362 (set! h3 (void)) 1363 (collect (collect-maximum-generation)) 1364 (hashtable-size h2)) 1365 1) 1366 (equal-entries? h2 '#((c)) '#(cval)) 1367 1368 ; test for proper shrinkage 1369 (eqv? 1370 (let ([ht (make-weak-eq-hashtable 32)]) 1371 (for-each 1372 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 1373 (let ([k** (map (lambda (x) (map list (make-list 1000))) 1374 (make-list 100))]) 1375 (for-each 1376 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 1377 k**) 1378 k**)) 1379 (#%$hashtable-veclen ht)) 1380 32) 1381 1382 ; test for proper shrinkage as objects are bwp'd 1383 ; uses delete to trigger final shrinkage 1384 (equal? 1385 (let* ([ht (make-weak-eq-hashtable 32)] 1386 [len (#%$hashtable-veclen ht)]) 1387 (hashtable-set! ht 'a 'b) 1388 (for-each 1389 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 1390 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 1391 (collect (collect-maximum-generation)) 1392 (hashtable-delete! ht 'a) 1393 (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len))) 1394 '(0 #t)) 1395 1396 ; test that weak-hashtable values *do* make keys reachable 1397 (let ([wk1 (list 1)] 1398 [wk2 (list 2)] 1399 [wk3 (list 3)] 1400 [wk4 (list 4)] 1401 [ht (make-weak-eq-hashtable)]) 1402 (hashtable-set! ht wk1 wk1) 1403 (hashtable-set! ht wk2 wk1) 1404 (hashtable-set! ht wk3 wk3) 1405 (hashtable-set! ht wk4 wk2) 1406 (collect (collect-maximum-generation)) 1407 (and 1408 (equal-entries? ht '#((1) (2) (3) (4)) '#((1) (1) (3) (2))) 1409 (equal? (hashtable-ref ht wk1 #f) wk1) 1410 (equal? (hashtable-ref ht wk2 #f) wk1) 1411 (equal? (hashtable-ref ht wk3 #f) wk3) 1412 (equal? (hashtable-ref ht wk4 #f) wk2) 1413 (begin 1414 (set! wk1 #f) 1415 (set! wk2 #f) 1416 (set! wk3 #f) 1417 (collect (collect-maximum-generation)) 1418 (and 1419 (equal-entries? ht '#((1) (2) (3) (4)) '#((1) (1) (3) (2))) 1420 (equal? (hashtable-ref ht wk4 #f) '(2)) 1421 (begin 1422 (set! wk4 #f) 1423 (collect (collect-maximum-generation)) 1424 (equal-entries? ht '#((1) (2) (3)) '#((1) (1) (3)))))))) 1425) 1426 1427(mat ephemeron-eq-hashtable 1428 (begin 1429 (define ka (list 'a)) ; will map to self \ Doesn't do anything to check 1430 (define kb (list 'b)) ; will map to kc \ | ephemeronness, but just in 1431 (define kc (list 'c)) ; will map to kb / / case. 1432 (define kq (list 'q)) 1433 (define ky (list 'y)) 1434 (define kz (list 'z)) 1435 #t) 1436 (begin 1437 (define h (make-ephemeron-eq-hashtable 32)) 1438 (and (hashtable? h) 1439 (eq-hashtable? h) 1440 (hashtable-mutable? h) 1441 (hashtable-ephemeron? h) 1442 (eq-hashtable-ephemeron? h))) 1443 (eq? (hashtable-hash-function h) #f) 1444 (eq? (hashtable-equivalence-function h) eq?) 1445 (equal? (hashtable-size h) 0) 1446 (same-elements? (hashtable-keys h) '#()) 1447 (same-elements? (hashtable-values h) '#()) 1448 (equal-entries? h '#() '#()) 1449 (same-elements? (hashtable-cells h) '#()) 1450 (same-elements? (hashtable-cells h 0) '#()) 1451 (same-elements? (hashtable-cells h 10) '#()) 1452 (eqv? (hashtable-set! h ka ka) (void)) 1453 (equal? 1454 (list 1455 (hashtable-contains? h ka) 1456 (hashtable-contains? h kb) 1457 (hashtable-contains? h kc)) 1458 '(#t #f #f)) 1459 (eqv? (hashtable-set! h kb kc) (void)) 1460 (equal? 1461 (list 1462 (hashtable-contains? h ka) 1463 (hashtable-contains? h kb) 1464 (hashtable-contains? h kc)) 1465 '(#t #t #f)) 1466 (eqv? (hashtable-set! h kc kb) (void)) 1467 (equal? 1468 (list 1469 (hashtable-contains? h ka) 1470 (hashtable-contains? h kb) 1471 (hashtable-contains? h kc)) 1472 '(#t #t #t)) 1473 (equal? (hashtable-size h) 3) 1474 (same-elements? (hashtable-keys h) '#((a) (b) (c))) 1475 (same-elements? (hashtable-values h) '#((a) (b) (c))) 1476 (equal-entries? h '#((a) (b) (c)) '#((a) (c) (b))) 1477 (same-elements? (hashtable-cells h) (vector (cons ka ka) (cons kb kc) (cons kc kb))) 1478 (same-elements? (hashtable-cells h (expt 2 100)) (vector (cons ka ka) (cons kb kc) (cons kc kb))) 1479 (let ([cells (hashtable-cells h 2)]) 1480 (or (same-elements? cells (vector (cons ka ka) (cons kb kc))) 1481 (same-elements? cells (vector (cons ka ka) (cons kc kb))) 1482 (same-elements? cells (vector (cons kb kc) (cons kc kb))))) 1483 (andmap ephemeron-pair? (vector->list (hashtable-cells h))) 1484 #;(same-elements? (list->vector (hashtable-map h cons)) '#(((a) . a) ((b) . c) ((c) . b))) 1485 #;(same-elements? 1486 (let ([v (make-vector 3)] [i 0]) 1487 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 1488 v) 1489 '#(((a) . a) ((b) . c) ((c) . b))) 1490 #;(same-elements? 1491 (let ([v (make-vector 3)] [i 0]) 1492 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 1493 v) 1494 '#(((a) . a) ((b) . c) ((c) . b))) 1495 (equal? (hashtable-ref h ka 1) '(a)) 1496 (equal? (hashtable-ref h kb #f) '(c)) 1497 (equal? (hashtable-ref h kc 'nope) '(b)) 1498 (eqv? (hashtable-delete! h kb) (void)) 1499 (equal? (hashtable-size h) 2) 1500 (equal-entries? h '#((a) (c)) '#((a) (b))) 1501 (begin 1502 (define h2 (hashtable-copy h #t)) 1503 (and (hashtable? h2) 1504 (eq-hashtable? h2) 1505 (hashtable-mutable? h2) 1506 (eq-hashtable-ephemeron? h2) 1507 (hashtable-ephemeron? h2))) 1508 (eq? (hashtable-hash-function h2) #f) 1509 (eq? (hashtable-equivalence-function h2) eq?) 1510 (equal? (hashtable-size h2) 2) 1511 (equal-entries? h2 '#((a) (c)) '#((a) (b))) 1512 (eqv? (hashtable-clear! h 4) (void)) 1513 (equal? 1514 (list 1515 (hashtable-size h) 1516 (hashtable-ref h ka 1) 1517 (hashtable-ref h kb #f) 1518 (hashtable-ref h kc 'nope)) 1519 '(0 1 #f nope)) 1520 (equal-entries? h '#() '#()) 1521 (equal? 1522 (list 1523 (hashtable-size h2) 1524 (hashtable-ref h2 ka 1) 1525 (hashtable-ref h2 kb #f) 1526 (hashtable-ref h2 kc 'nope)) 1527 '(2 (a) #f (b))) 1528 (equal-entries? h2 '#((a) (c)) '#((a) (b))) 1529 (eqv? 1530 (hashtable-update! h kq 1531 (lambda (x) (+ x 1)) 1532 17) 1533 (void)) 1534 (equal? (hashtable-ref h kq #f) 18) 1535 (eqv? 1536 (hashtable-update! h kq 1537 (lambda (x) (+ x 1)) 1538 17) 1539 (void)) 1540 (equal? (hashtable-ref h kq #f) 19) 1541 (equal? (hashtable-size h) 1) 1542 (equal-entries? h '#((q)) '#(19)) 1543 (eqv? 1544 (begin 1545 (set! kq (void)) 1546 (collect (collect-maximum-generation)) 1547 (hashtable-size h)) 1548 0) 1549 (equal-entries? h '#() '#()) 1550 #;(eqv? (hashtable-map h (lambda args (error #f "oops"))) '()) 1551 #;(eqv? (hashtable-for-each h (lambda args (error #f "oops"))) (void)) 1552 #;(eqv? (hashtable-for-each-cell h (lambda args (error #f "oops"))) (void)) 1553 (equal? (hashtable-ref h ky #f) #f) 1554 (eqv? 1555 (hashtable-set! h ky 'toad) 1556 (void)) 1557 (equal? (hashtable-ref h ky #f) 'toad) 1558 (equal? (hashtable-ref h kz #f) #f) 1559 (eqv? 1560 (hashtable-update! h kz list 'frog) 1561 (void)) 1562 (equal? (hashtable-ref h kz #f) '(frog)) 1563 (equal-entries? 1564 h 1565 (vector kz ky) 1566 (vector (hashtable-ref h kz #f) 'toad)) 1567 (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) 1568 (begin 1569 (define h3 (hashtable-copy h2 #f)) 1570 (and (hashtable? h3) 1571 (eq-hashtable? h3) 1572 (not (hashtable-mutable? h3)) 1573 (eq-hashtable-ephemeron? h3) 1574 (hashtable-ephemeron? h3))) 1575 (equal-entries? h2 '#((a) (c)) '#((a) (b))) 1576 (equal-entries? h3 '#((a) (c)) '#((a) (b))) 1577 (equal? 1578 (begin 1579 (set! ka (void)) 1580 (collect (collect-maximum-generation)) 1581 (list (hashtable-size h2) (hashtable-size h3))) 1582 '(1 1)) 1583 (equal-entries? h2 '#((c)) '#((b))) 1584 (equal-entries? h3 '#((c)) '#((b))) 1585 (eqv? 1586 (begin 1587 (set! h3 (void)) 1588 (collect (collect-maximum-generation)) 1589 (hashtable-size h2)) 1590 1) 1591 (equal-entries? h2 '#((c)) '#((b))) 1592 1593 ; test for proper shrinkage 1594 (eqv? 1595 (let ([ht (make-ephemeron-eq-hashtable 32)]) 1596 (for-each 1597 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 1598 (let ([k** (map (lambda (x) (map list (make-list 1000))) 1599 (make-list 100))]) 1600 (for-each 1601 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 1602 k**) 1603 k**)) 1604 (#%$hashtable-veclen ht)) 1605 32) 1606 1607 ; test for proper shrinkage as objects are bwp'd 1608 ; uses delete to trigger final shrinkage 1609 (equal? 1610 (let* ([ht (make-ephemeron-eq-hashtable 32)] 1611 [len (#%$hashtable-veclen ht)]) 1612 (hashtable-set! ht 'a 'b) 1613 (for-each 1614 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 1615 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 1616 (collect (collect-maximum-generation)) 1617 (hashtable-delete! ht 'a) 1618 (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len))) 1619 '(0 #t)) 1620 1621 ; test that ephemeron-hashtable values don't make keys reachable 1622 (let ([wk1 (list 1)] 1623 [wk2 (list 2)] 1624 [wk3 (list 3)] 1625 [wk4 (list 4)] 1626 [ht (make-ephemeron-eq-hashtable)]) 1627 (hashtable-set! ht wk1 wk1) 1628 (hashtable-set! ht wk2 wk1) 1629 (hashtable-set! ht wk3 wk3) 1630 (hashtable-set! ht wk4 wk2) 1631 (collect (collect-maximum-generation)) 1632 (and 1633 (equal-entries? ht '#((1) (2) (3) (4)) '#((1) (1) (3) (2))) 1634 (equal? (hashtable-ref ht wk1 #f) wk1) 1635 (equal? (hashtable-ref ht wk2 #f) wk1) 1636 (equal? (hashtable-ref ht wk3 #f) wk3) 1637 (equal? (hashtable-ref ht wk4 #f) wk2) 1638 (begin 1639 (set! wk1 #f) 1640 (set! wk2 #f) 1641 (set! wk3 #f) 1642 (collect (collect-maximum-generation)) 1643 (and 1644 (equal-entries? ht '#((1) (2) (4)) '#((1) (1) (2))) 1645 (equal? (hashtable-ref ht wk4 #f) '(2)) 1646 (begin 1647 (set! wk4 #f) 1648 (collect (collect-maximum-generation)) 1649 (equal-entries? ht '#() '#())))))) 1650) 1651 1652(mat eq-hashtable-cell 1653 (let () 1654 (define-record fribble (x)) 1655 (define random-object 1656 (lambda (x) 1657 (case (random 9) 1658 [(0) (cons 'a 'b)] 1659 [(1) (vector 'c)] 1660 [(2) (string #\a #\b)] 1661 [(3) (make-fribble 'q)] 1662 [(4) (gensym)] 1663 [(5) (open-output-string)] 1664 [(6) (fxvector 15 55)] 1665 [(7) (lambda () x)] 1666 [(8) (flvector 15.0 55.0)] 1667 [else (box 'top)]))) 1668 (let ([ls1 (let f ([n 10000]) 1669 (if (fx= n 0) 1670 '() 1671 (cons 1672 (cons (random-object 4) (random-object 7)) 1673 (f (fx- n 1)))))] 1674 [ht (make-eq-hashtable)] 1675 [wht (make-weak-eq-hashtable)] 1676 [eht (make-ephemeron-eq-hashtable)]) 1677 (let ([ls2 (map (lambda (a1) (eq-hashtable-cell ht (car a1) (cdr a1))) ls1)] 1678 [ls2-2 (map (lambda (a1) (let loop () 1679 (define c (eq-hashtable-try-atomic-cell ht (car a1) (cdr a1))) 1680 (or c (loop)))) 1681 ls1)] 1682 [ls3 (map (lambda (a1) (hashtable-cell wht (car a1) (cdr a1))) ls1)] 1683 [ls4 (map (lambda (a1) (hashtable-cell eht (car a1) (cdr a1))) ls1)]) 1684 (let ([ls2* (map (lambda (a1) (eq-hashtable-ref-cell ht (car a1))) ls1)] 1685 [ls3* (map (lambda (a1) (hashtable-ref-cell wht (car a1))) ls1)] 1686 [ls4* (map (lambda (a1) (hashtable-ref-cell eht (car a1))) ls1)]) 1687 (unless (andmap (lambda (a2 a2* a3 a3* a4 a4*) 1688 (and (eq? a2 a2*) 1689 (eq? a3 a3*) 1690 (eq? a4 a4*))) 1691 ls2 ls2* ls3 ls3* ls4 ls4*) 1692 (errorf #f "hashtable-ref-cell and hashtable-cell do not retrieve the same cells"))) 1693 (unless (andmap (lambda (a1 a2 a2-2 a3 a4) 1694 (and (eq? (car a1) (car a2)) 1695 (eq? a2 a2-2) 1696 (eq? (car a2) (car a3)) 1697 (eq? (car a2) (car a4)))) 1698 ls1 ls2 ls2-2 ls3 ls4) 1699 (errorf #f "keys are not eq")) 1700 (unless (andmap (lambda (a1 a2 a3 a4) 1701 (and (eq? (cdr a1) (cdr a2)) 1702 (eq? (cdr a2) (cdr a3)) 1703 (eq? (cdr a2) (cdr a4)))) 1704 ls1 ls2 ls3 ls4) 1705 (errorf #f "values are not eq")) 1706 (for-each (lambda (a1) 1707 (let ([o (random-object 3)]) 1708 ;; Value refers to key: 1709 (hashtable-set! eht o (list o (car a1))))) 1710 ls1) 1711 (for-each 1712 (lambda (a1) 1713 (when (fx< (random 10) 5) 1714 (set-car! a1 #f))) 1715 ls1) 1716 (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)]) 1717 (unless (fx= i 0) 1718 (collect) 1719 (unless (andmap (lambda (a2 a3 a4) (and (eq? (car a2) (car a3)) (eq? (car a2) (car a4)))) 1720 ls2 ls3 ls4) 1721 (errorf #f "a2/a3/a4 keys not eq after collection")) 1722 (unless (and (andmap (lambda (a3) (not (bwp-object? (car a3)))) ls3) 1723 (andmap (lambda (a4) (not (bwp-object? (car a4)))) ls4)) 1724 (errorf #f "keys have been bwp'd")) 1725 (loop (fx- i 1)))) 1726 (for-each 1727 (lambda (a2) 1728 (hashtable-delete! ht (car a2)) 1729 (set-car! a2 #f)) 1730 ls2) 1731 (unless (and (equal? (hashtable-keys ht) '#()) 1732 (equal? (hashtable-values ht) '#()) 1733 (zero? (hashtable-size ht))) 1734 (errorf #f "ht has not been cleared out")) 1735 (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)]) 1736 (unless (fx= i 0) 1737 (collect) 1738 (unless (andmap (lambda (a1 a3 a4) 1739 (or (not (car a1)) 1740 (and (eq? (car a1) (car a3)) 1741 (eq? (car a1) (car a4))))) 1742 ls1 ls3 ls4) 1743 (errorf #f "a1/a3/a4 keys not eq after collection")) 1744 (loop (fx- i 1)))) 1745 (for-each 1746 (lambda (a1 a3 a4) 1747 (unless (or (car a1) 1748 (and (bwp-object? (car a3)) 1749 (bwp-object? (car a4)))) 1750 (errorf #f "~s has not been bwp'd I" (car a3)))) 1751 ls1 ls3 ls4) 1752 (for-each (lambda (a1) (set-car! a1 #f)) ls1) 1753 (collect (collect-maximum-generation)) 1754 (unless (and (andmap (lambda (a3) (bwp-object? (car a3))) ls3) 1755 (andmap (lambda (a4) (bwp-object? (car a4))) ls4)) 1756 (errorf #f "keys have not been bwp'd II")) 1757 (unless (and (equal? (hashtable-keys wht) '#()) 1758 (equal? (hashtable-values wht) '#()) 1759 (zero? (hashtable-size wht))) 1760 (errorf #f "wht has not been cleared out")) 1761 (unless (and (equal? (hashtable-keys eht) '#()) 1762 (equal? (hashtable-values eht) '#()) 1763 (zero? (hashtable-size eht))) 1764 (errorf #f "eht has not been cleared out")))) 1765 #t) 1766) 1767 1768(mat $nonweak-eq-hashtable 1769 (begin 1770 (define h (make-eq-hashtable 32)) 1771 (and (hashtable? h) 1772 (eq-hashtable? h) 1773 (hashtable-mutable? h) 1774 (not (eq-hashtable-weak? h)) 1775 (not (hashtable-weak? h)) 1776 (not (eq-hashtable-ephemeron? h)) 1777 (not (hashtable-ephemeron? h)))) 1778 (eq? (hashtable-hash-function h) #f) 1779 (eq? (hashtable-equivalence-function h) eq?) 1780 (equal? (hashtable-size h) 0) 1781 (same-elements? (hashtable-keys h) '#()) 1782 (same-elements? (hashtable-values h) '#()) 1783 (equal-entries? h '#() '#()) 1784 (same-elements? (hashtable-cells h) '#()) 1785 (same-elements? (hashtable-cells h 0) '#()) 1786 (same-elements? (hashtable-cells h 10) '#()) 1787 (eqv? (eq-hashtable-set! h 'a 'aval) (void)) 1788 (equal? 1789 (list 1790 (eq-hashtable-contains? h 'a) 1791 (eq-hashtable-contains? h 'b) 1792 (eq-hashtable-contains? h 'c)) 1793 '(#t #f #f)) 1794 (eqv? (eq-hashtable-set! h 'b 'bval) (void)) 1795 (equal? 1796 (list 1797 (eq-hashtable-contains? h 'a) 1798 (eq-hashtable-contains? h 'b) 1799 (eq-hashtable-contains? h 'c)) 1800 '(#t #t #f)) 1801 (eqv? (eq-hashtable-set! h 'c 'cval) (void)) 1802 (equal? 1803 (list 1804 (eq-hashtable-contains? h 'a) 1805 (eq-hashtable-contains? h 'b) 1806 (eq-hashtable-contains? h 'c)) 1807 '(#t #t #t)) 1808 (equal? (hashtable-size h) 3) 1809 (same-elements? (hashtable-keys h) '#(a b c)) 1810 (same-elements? (hashtable-values h) '#(bval cval aval)) 1811 (equal-entries? h '#(b c a) '#(bval cval aval)) 1812 (same-elements? (hashtable-cells h) '#((a . aval) (b . bval) (c . cval))) 1813 (same-elements? (hashtable-cells h (expt 2 100)) '#((a . aval) (b . bval) (c . cval))) 1814 (let ([cells (hashtable-cells h 2)]) 1815 (or (same-elements? cells '#((a . aval) (b . bval))) 1816 (same-elements? cells '#((a . aval) (c . cval))) 1817 (same-elements? cells '#((b . bval) (c . cval))))) 1818 (equal? (eq-hashtable-ref h 'a 1) 'aval) 1819 (equal? (eq-hashtable-ref h 'b #f) 'bval) 1820 (equal? (eq-hashtable-ref h 'c 'nope) 'cval) 1821 (eqv? (eq-hashtable-delete! h 'b) (void)) 1822 (equal? (hashtable-size h) 2) 1823 (equal-entries? h '#(a c) '#(aval cval)) 1824 (begin 1825 (define h2 (hashtable-copy h #t)) 1826 (and (hashtable? h2) 1827 (eq-hashtable? h2) 1828 (hashtable-mutable? h2) 1829 (not (eq-hashtable-weak? h2)) 1830 (not (hashtable-weak? h2)))) 1831 (equal? (hashtable-size h2) 2) 1832 (equal-entries? h2 '#(a c) '#(aval cval)) 1833 (eqv? (hashtable-clear! h 4) (void)) 1834 (equal? 1835 (list 1836 (hashtable-size h) 1837 (eq-hashtable-ref h 'a 1) 1838 (eq-hashtable-ref h 'b #f) 1839 (eq-hashtable-ref h 'c 'nope)) 1840 '(0 1 #f nope)) 1841 (equal-entries? h '#() '#()) 1842 (equal? 1843 (list 1844 (hashtable-size h2) 1845 (eq-hashtable-ref h2 'a 1) 1846 (eq-hashtable-ref h2 'b #f) 1847 (eq-hashtable-ref h2 'c 'nope)) 1848 '(2 aval #f cval)) 1849 (equal-entries? h2 '#(a c) '#(aval cval)) 1850 (eqv? 1851 (eq-hashtable-update! h 'q 1852 (lambda (x) (+ x 1)) 1853 17) 1854 (void)) 1855 (equal? (eq-hashtable-ref h 'q #f) 18) 1856 (eqv? 1857 (eq-hashtable-update! h 'q 1858 (lambda (x) (+ x 1)) 1859 17) 1860 (void)) 1861 (equal? (eq-hashtable-ref h 'q #f) 19) 1862 (equal? (hashtable-size h) 1) 1863 ; test hashtable-copy when some keys may have moved 1864 (let ([t (parameterize ([collect-request-handler void]) 1865 (let ([h4a (make-eq-hashtable 32)] 1866 [k* (map list (make-list 100))]) 1867 (for-each (lambda (x) (eq-hashtable-set! h4a x x)) k*) 1868 (collect) 1869 ; create copy after collection but before otherwise touching h4a 1870 (let ([h4b (hashtable-copy h4a #t)]) 1871 (andmap 1872 (lambda (k) (eq? (eq-hashtable-ref h4b k #f) k)) 1873 k*))))]) 1874 (collect) 1875 t) 1876 1877 ; test for proper shrinkage, etc. 1878 (equal? 1879 (let* ([ht (make-eq-hashtable)] [minlen (#%$hashtable-veclen ht)]) 1880 (define power-of-two? (lambda (n) (fx= (fxbit-count n) 1))) 1881 (let f ([i 0]) 1882 (unless (fx= i (expt 2 17)) 1883 (let ([k (fx* i 2)]) 1884 (eq-hashtable-set! ht k i) 1885 (f (fx+ i 1)) 1886 (assert (eq-hashtable-contains? ht k)) 1887 (assert (power-of-two? (#%$hashtable-veclen ht))) 1888 (eq-hashtable-delete! ht k)))) 1889 (list (hashtable-size ht) (fx= (#%$hashtable-veclen ht) minlen))) 1890 '(0 #t)) 1891 1892 (equal? 1893 (let ([ht (make-eq-hashtable 32)]) 1894 (define power-of-two? (lambda (n) (fx= (fxbit-count n) 1))) 1895 (let f ([i 0]) 1896 (unless (fx= i (expt 2 17)) 1897 (let ([k (fx* i 2)]) 1898 (eq-hashtable-set! ht k i) 1899 (f (fx+ i 1)) 1900 (assert (eq-hashtable-contains? ht k)) 1901 (assert (power-of-two? (#%$hashtable-veclen ht))) 1902 (eq-hashtable-delete! ht k)))) 1903 (list (hashtable-size ht) (#%$hashtable-veclen ht))) 1904 '(0 32)) 1905) 1906 1907(mat $weak-eq-hashtable 1908 (begin 1909 (define ka (list 'a)) 1910 (define kb (list 'b)) 1911 (define kc (list 'c)) 1912 (define kq (list 'q)) 1913 (define ky (list 'y)) 1914 (define kz (list 'z)) 1915 #t) 1916 (begin 1917 (define h (make-weak-eq-hashtable 32)) 1918 (and (hashtable? h) 1919 (eq-hashtable? h) 1920 (hashtable-mutable? h) 1921 (eq-hashtable-weak? h) 1922 (hashtable-weak? h))) 1923 (eq? (hashtable-hash-function h) #f) 1924 (eq? (hashtable-equivalence-function h) eq?) 1925 (equal? (hashtable-size h) 0) 1926 (same-elements? (hashtable-keys h) '#()) 1927 (same-elements? (hashtable-values h) '#()) 1928 (equal-entries? h '#() '#()) 1929 (same-elements? (hashtable-cells h) '#()) 1930 (same-elements? (hashtable-cells h 0) '#()) 1931 (same-elements? (hashtable-cells h 10) '#()) 1932 (eqv? (eq-hashtable-set! h ka 'aval) (void)) 1933 (equal? 1934 (list 1935 (eq-hashtable-contains? h ka) 1936 (eq-hashtable-contains? h kb) 1937 (eq-hashtable-contains? h kc)) 1938 '(#t #f #f)) 1939 (eqv? (eq-hashtable-set! h kb 'bval) (void)) 1940 (equal? 1941 (list 1942 (eq-hashtable-contains? h ka) 1943 (eq-hashtable-contains? h kb) 1944 (eq-hashtable-contains? h kc)) 1945 '(#t #t #f)) 1946 (eqv? (eq-hashtable-set! h kc 'cval) (void)) 1947 (equal? 1948 (list 1949 (eq-hashtable-contains? h ka) 1950 (eq-hashtable-contains? h kb) 1951 (eq-hashtable-contains? h kc)) 1952 '(#t #t #t)) 1953 (equal? (hashtable-size h) 3) 1954 (same-elements? (hashtable-keys h) '#((a) (b) (c))) 1955 (same-elements? (hashtable-values h) '#(aval bval cval)) 1956 (equal-entries? h '#((a) (b) (c)) '#(aval bval cval)) 1957 (same-elements? (hashtable-cells h) (vector (cons ka 'aval) (cons kb 'bval) (cons kc 'cval))) 1958 (same-elements? (hashtable-cells h (expt 2 100)) (vector (cons ka 'aval) (cons kb 'bval) (cons kc 'cval))) 1959 (let ([cells (hashtable-cells h 2)]) 1960 (or (same-elements? cells (vector (cons ka 'aval) (cons kb 'bval))) 1961 (same-elements? cells (vector (cons ka 'aval) (cons kc 'cval))) 1962 (same-elements? cells (vector (cons kb 'bval) (cons kc 'cval))))) 1963 (andmap weak-pair? (vector->list (hashtable-cells h))) 1964 (equal? (eq-hashtable-ref h ka 1) 'aval) 1965 (equal? (eq-hashtable-ref h kb #f) 'bval) 1966 (equal? (eq-hashtable-ref h kc 'nope) 'cval) 1967 (eqv? (eq-hashtable-delete! h kb) (void)) 1968 (equal? (hashtable-size h) 2) 1969 (equal-entries? h '#((a) (c)) '#(aval cval)) 1970 (begin 1971 (define h2 (hashtable-copy h #t)) 1972 (and (hashtable? h2) 1973 (eq-hashtable? h2) 1974 (hashtable-mutable? h2) 1975 (hashtable-weak? h2) 1976 (eq-hashtable-weak? h2))) 1977 (equal? (hashtable-size h2) 2) 1978 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 1979 (eqv? (hashtable-clear! h 4) (void)) 1980 (equal? 1981 (list 1982 (hashtable-size h) 1983 (eq-hashtable-ref h ka 1) 1984 (eq-hashtable-ref h kb #f) 1985 (eq-hashtable-ref h kc 'nope)) 1986 '(0 1 #f nope)) 1987 (equal-entries? h '#() '#()) 1988 (equal? 1989 (list 1990 (hashtable-size h2) 1991 (eq-hashtable-ref h2 ka 1) 1992 (eq-hashtable-ref h2 kb #f) 1993 (eq-hashtable-ref h2 kc 'nope)) 1994 '(2 aval #f cval)) 1995 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 1996 (eqv? 1997 (eq-hashtable-update! h kq 1998 (lambda (x) (+ x 1)) 1999 17) 2000 (void)) 2001 (equal? (eq-hashtable-ref h kq #f) 18) 2002 (eqv? 2003 (eq-hashtable-update! h kq 2004 (lambda (x) (+ x 1)) 2005 17) 2006 (void)) 2007 (equal? (eq-hashtable-ref h kq #f) 19) 2008 (equal? (hashtable-size h) 1) 2009 (equal-entries? h '#((q)) '#(19)) 2010 (eqv? 2011 (begin 2012 (set! kq (void)) 2013 (collect (collect-maximum-generation)) 2014 (hashtable-size h)) 2015 0) 2016 (equal-entries? h '#() '#()) 2017 (equal? (eq-hashtable-ref h ky #f) #f) 2018 (eqv? 2019 (eq-hashtable-set! h ky 'toad) 2020 (void)) 2021 (equal? (eq-hashtable-ref h ky #f) 'toad) 2022 (equal? (eq-hashtable-ref h kz #f) #f) 2023 (eqv? 2024 (eq-hashtable-update! h kz list 'frog) 2025 (void)) 2026 (equal? (eq-hashtable-ref h kz #f) '(frog)) 2027 (equal-entries? 2028 h 2029 (vector kz ky) 2030 (vector (eq-hashtable-ref h kz #f) 'toad)) 2031 (eqv? (eq-hashtable-ref h '(zippo) 'nil) 'nil) 2032 (begin 2033 (define h3 (hashtable-copy h2 #f)) 2034 (and (hashtable? h3) 2035 (eq-hashtable? h3) 2036 (not (hashtable-mutable? h3)) 2037 (eq-hashtable-weak? h3) 2038 (hashtable-weak? h3))) 2039 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 2040 (equal-entries? h3 '#((a) (c)) '#(aval cval)) 2041 (equal? 2042 (begin 2043 (set! ka (void)) 2044 (collect (collect-maximum-generation)) 2045 (list (hashtable-size h2) (hashtable-size h3))) 2046 '(1 1)) 2047 (equal-entries? h2 '#((c)) '#(cval)) 2048 (equal-entries? h3 '#((c)) '#(cval)) 2049 (eqv? 2050 (begin 2051 (set! h3 (void)) 2052 (collect (collect-maximum-generation)) 2053 (hashtable-size h2)) 2054 1) 2055 (equal-entries? h2 '#((c)) '#(cval)) 2056 2057 ; test for proper shrinkage 2058 (eqv? 2059 (let ([ht (make-weak-eq-hashtable 32)]) 2060 (for-each 2061 (lambda (k*) (for-each (lambda (k) (eq-hashtable-delete! ht k)) k*)) 2062 (let ([k** (map (lambda (x) (map list (make-list 1000))) 2063 (make-list 100))]) 2064 (for-each 2065 (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*)) 2066 k**) 2067 k**)) 2068 (#%$hashtable-veclen ht)) 2069 32) 2070 2071 ; test for proper shrinkage as objects are bwp'd 2072 ; uses delete to trigger final shrinkage 2073 (equal? 2074 (let* ([ht (make-weak-eq-hashtable 32)] 2075 [len (#%$hashtable-veclen ht)]) 2076 (eq-hashtable-set! ht 'a 'b) 2077 (for-each 2078 (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*)) 2079 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 2080 (collect (collect-maximum-generation)) 2081 (eq-hashtable-delete! ht 'a) 2082 (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len))) 2083 '(0 #t)) 2084 ) 2085 2086(mat $ephemeron-eq-hashtable 2087 (begin 2088 (define ka (list 'a)) 2089 (define kb (list 'b)) 2090 (define kc (list 'c)) 2091 (define kq (list 'q)) 2092 (define ky (list 'y)) 2093 (define kz (list 'z)) 2094 #t) 2095 (begin 2096 (define h (make-ephemeron-eq-hashtable 32)) 2097 (and (hashtable? h) 2098 (eq-hashtable? h) 2099 (hashtable-mutable? h) 2100 (eq-hashtable-ephemeron? h) 2101 (hashtable-ephemeron? h))) 2102 (eq? (hashtable-hash-function h) #f) 2103 (eq? (hashtable-equivalence-function h) eq?) 2104 (equal? (hashtable-size h) 0) 2105 (same-elements? (hashtable-keys h) '#()) 2106 (same-elements? (hashtable-values h) '#()) 2107 (equal-entries? h '#() '#()) 2108 (same-elements? (hashtable-cells h) '#()) 2109 (same-elements? (hashtable-cells h 0) '#()) 2110 (same-elements? (hashtable-cells h 10) '#()) 2111 (eqv? (eq-hashtable-set! h ka 'aval) (void)) 2112 (equal? 2113 (list 2114 (eq-hashtable-contains? h ka) 2115 (eq-hashtable-contains? h kb) 2116 (eq-hashtable-contains? h kc)) 2117 '(#t #f #f)) 2118 (eqv? (eq-hashtable-set! h kb 'bval) (void)) 2119 (equal? 2120 (list 2121 (eq-hashtable-contains? h ka) 2122 (eq-hashtable-contains? h kb) 2123 (eq-hashtable-contains? h kc)) 2124 '(#t #t #f)) 2125 (eqv? (eq-hashtable-set! h kc 'cval) (void)) 2126 (equal? 2127 (list 2128 (eq-hashtable-contains? h ka) 2129 (eq-hashtable-contains? h kb) 2130 (eq-hashtable-contains? h kc)) 2131 '(#t #t #t)) 2132 (equal? (hashtable-size h) 3) 2133 (same-elements? (hashtable-keys h) '#((a) (b) (c))) 2134 (same-elements? (hashtable-values h) '#(aval bval cval)) 2135 (equal-entries? h '#((a) (b) (c)) '#(aval bval cval)) 2136 (same-elements? (hashtable-cells h) (vector (cons ka 'aval) (cons kb 'bval) (cons kc 'cval))) 2137 (same-elements? (hashtable-cells h (expt 2 100)) (vector (cons ka 'aval) (cons kb 'bval) (cons kc 'cval))) 2138 (let ([cells (hashtable-cells h 2)]) 2139 (or (same-elements? cells (vector (cons ka 'aval) (cons kb 'bval))) 2140 (same-elements? cells (vector (cons ka 'aval) (cons kc 'cval))) 2141 (same-elements? cells (vector (cons kb 'bval) (cons kc 'cval))))) 2142 (andmap ephemeron-pair? (vector->list (hashtable-cells h))) 2143 (equal? (eq-hashtable-ref h ka 1) 'aval) 2144 (equal? (eq-hashtable-ref h kb #f) 'bval) 2145 (equal? (eq-hashtable-ref h kc 'nope) 'cval) 2146 (eqv? (eq-hashtable-delete! h kb) (void)) 2147 (equal? (hashtable-size h) 2) 2148 (equal-entries? h '#((a) (c)) '#(aval cval)) 2149 (begin 2150 (define h2 (hashtable-copy h #t)) 2151 (and (hashtable? h2) 2152 (eq-hashtable? h2) 2153 (hashtable-mutable? h2) 2154 (hashtable-ephemeron? h2) 2155 (eq-hashtable-ephemeron? h2))) 2156 (equal? (hashtable-size h2) 2) 2157 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 2158 (eqv? (hashtable-clear! h 4) (void)) 2159 (equal? 2160 (list 2161 (hashtable-size h) 2162 (eq-hashtable-ref h ka 1) 2163 (eq-hashtable-ref h kb #f) 2164 (eq-hashtable-ref h kc 'nope)) 2165 '(0 1 #f nope)) 2166 (equal-entries? h '#() '#()) 2167 (equal? 2168 (list 2169 (hashtable-size h2) 2170 (eq-hashtable-ref h2 ka 1) 2171 (eq-hashtable-ref h2 kb #f) 2172 (eq-hashtable-ref h2 kc 'nope)) 2173 '(2 aval #f cval)) 2174 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 2175 (eqv? 2176 (eq-hashtable-update! h kq 2177 (lambda (x) (+ x 1)) 2178 17) 2179 (void)) 2180 (equal? (eq-hashtable-ref h kq #f) 18) 2181 (eqv? 2182 (eq-hashtable-update! h kq 2183 (lambda (x) (+ x 1)) 2184 17) 2185 (void)) 2186 (equal? (eq-hashtable-ref h kq #f) 19) 2187 (equal? (hashtable-size h) 1) 2188 (equal-entries? h '#((q)) '#(19)) 2189 (eqv? 2190 (begin 2191 (set! kq (void)) 2192 (collect (collect-maximum-generation)) 2193 (hashtable-size h)) 2194 0) 2195 (equal-entries? h '#() '#()) 2196 (equal? (eq-hashtable-ref h ky #f) #f) 2197 (eqv? 2198 (eq-hashtable-set! h ky 'toad) 2199 (void)) 2200 (equal? (eq-hashtable-ref h ky #f) 'toad) 2201 (equal? (eq-hashtable-ref h kz #f) #f) 2202 (eqv? 2203 (eq-hashtable-update! h kz list 'frog) 2204 (void)) 2205 (equal? (eq-hashtable-ref h kz #f) '(frog)) 2206 (equal-entries? 2207 h 2208 (vector kz ky) 2209 (vector (eq-hashtable-ref h kz #f) 'toad)) 2210 (eqv? (eq-hashtable-ref h '(zippo) 'nil) 'nil) 2211 (begin 2212 (define h3 (hashtable-copy h2 #f)) 2213 (and (hashtable? h3) 2214 (eq-hashtable? h3) 2215 (not (hashtable-mutable? h3)) 2216 (eq-hashtable-ephemeron? h3) 2217 (hashtable-ephemeron? h3))) 2218 (equal-entries? h2 '#((a) (c)) '#(aval cval)) 2219 (equal-entries? h3 '#((a) (c)) '#(aval cval)) 2220 (equal? 2221 (begin 2222 (set! ka (void)) 2223 (collect (collect-maximum-generation)) 2224 (list (hashtable-size h2) (hashtable-size h3))) 2225 '(1 1)) 2226 (equal-entries? h2 '#((c)) '#(cval)) 2227 (equal-entries? h3 '#((c)) '#(cval)) 2228 (eqv? 2229 (begin 2230 (set! h3 (void)) 2231 (collect (collect-maximum-generation)) 2232 (hashtable-size h2)) 2233 1) 2234 (equal-entries? h2 '#((c)) '#(cval)) 2235 2236 ; test for proper shrinkage 2237 (eqv? 2238 (let ([ht (make-ephemeron-eq-hashtable 32)]) 2239 (for-each 2240 (lambda (k*) (for-each (lambda (k) (eq-hashtable-delete! ht k)) k*)) 2241 (let ([k** (map (lambda (x) (map list (make-list 1000))) 2242 (make-list 100))]) 2243 (for-each 2244 (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*)) 2245 k**) 2246 k**)) 2247 (#%$hashtable-veclen ht)) 2248 32) 2249 2250 ; test for proper shrinkage as objects are bwp'd 2251 ; uses delete to trigger final shrinkage 2252 (equal? 2253 (let* ([ht (make-ephemeron-eq-hashtable 32)] 2254 [len (#%$hashtable-veclen ht)]) 2255 (eq-hashtable-set! ht 'a 'b) 2256 (for-each 2257 (lambda (k*) (map (lambda (k) (eq-hashtable-set! ht k 75)) k*)) 2258 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 2259 (collect (collect-maximum-generation)) 2260 (eq-hashtable-delete! ht 'a) 2261 (list (hashtable-size ht) (= (#%$hashtable-veclen ht) len))) 2262 '(0 #t)) 2263) 2264 2265(mat eq-strange 2266 (begin 2267 (define $ht (make-eq-hashtable)) 2268 (define $wht (make-weak-eq-hashtable)) 2269 (define $eht (make-ephemeron-eq-hashtable)) 2270 (and (hashtable? $ht) 2271 (eq-hashtable? $ht) 2272 (hashtable? $wht) 2273 (eq-hashtable? $wht) 2274 (hashtable? $eht) 2275 (eq-hashtable? $eht))) 2276 (eqv? (hashtable-set! $ht #f 75) (void)) 2277 (eqv? (hashtable-ref $ht #f 80) 75) 2278 (eqv? (hashtable-set! $wht #f 75) (void)) 2279 (eqv? (hashtable-ref $wht #f 80) 75) 2280 (eqv? (hashtable-set! $eht #f 75) (void)) 2281 (eqv? (hashtable-ref $eht #f 80) 75) 2282 (eqv? (hashtable-set! $ht #!bwp "hello") (void)) 2283 (equal? (hashtable-ref $ht #!bwp "goodbye") "hello") 2284 (eqv? (hashtable-set! $wht #!bwp "hello") (void)) 2285 (and (member (hashtable-ref $wht #!bwp "goodbye") '("hello" "goodbye")) #t) 2286 (eqv? (hashtable-set! $eht #!bwp "hello") (void)) 2287 (and (member (hashtable-ref $eht #!bwp "goodbye") '("hello" "goodbye")) #t) 2288 ; make sure that association isn't added before procedure is called 2289 (equal? 2290 (begin 2291 (hashtable-update! $ht 'cupie 2292 (lambda (x) (hashtable-ref $ht 'cupie (cons 'barbie x))) 2293 'doll) 2294 (hashtable-ref $ht 'cupie 'oops)) 2295 '(barbie . doll)) 2296 (equal? 2297 (begin 2298 (hashtable-update! $wht 'cupie 2299 (lambda (x) (hashtable-ref $wht 'cupie (cons 'barbie x))) 2300 'doll) 2301 (hashtable-ref $wht 'cupie 'oops)) 2302 '(barbie . doll)) 2303 (equal? 2304 (begin 2305 (hashtable-update! $eht 'cupie 2306 (lambda (x) (hashtable-ref $eht 'cupie (cons 'barbie x))) 2307 'doll) 2308 (hashtable-ref $eht 'cupie 'oops)) 2309 '(barbie . doll)) 2310) 2311 2312(mat eq-hashtable-stress 2313 ; stress tests 2314 (let () ; nonweak 2315 (define pick 2316 (lambda (ls) 2317 (list-ref ls (random (length ls))))) 2318 (define ht (make-eq-hashtable 4)) 2319 (let ([ls (remq '|| (oblist))] [n 50000]) 2320 (let f ([i 0] [keep '()] [drop '()]) 2321 (if (= i n) 2322 (and (= (hashtable-size ht) (- n (length drop))) 2323 (andmap (lambda (k) 2324 (string=? 2325 (symbol->string (hashtable-ref ht k #f)) 2326 (cond 2327 [(string? k) k] 2328 [(pair? k) (car k)] 2329 [(vector? k) (vector-ref k 0)]))) 2330 keep) 2331 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no)) 2332 drop)) 2333 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 2334 (let ([k (case (pick '(string pair vector)) 2335 [(string) s] 2336 [(pair) (list s)] 2337 [(vector) (vector s)])]) 2338 (hashtable-set! ht k x) 2339 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 2340 (if (= (modulo i 17) 5) 2341 (let ([k (pick keep)]) 2342 (hashtable-delete! ht k) 2343 (let ([drop (cons k drop)]) 2344 (when (= (random 5) 3) 2345 (hashtable-delete! ht (pick drop))) 2346 (f (+ i 1) (remq k keep) drop))) 2347 (f (+ i 1) keep drop))))))))) 2348 2349 (let () ; weak 2350 (define pick 2351 (lambda (ls) 2352 (list-ref ls (random (length ls))))) 2353 (define ht (make-weak-eq-hashtable 4)) 2354 (let ([ls (remq '|| (oblist))] [n 50000]) 2355 (let f ([i 0] [keep '()] [drop '()]) 2356 (if (= i n) 2357 (and (<= (hashtable-size ht) (- n (length drop))) 2358 (begin 2359 (collect (collect-maximum-generation)) 2360 (= (hashtable-size ht) (length keep))) 2361 (andmap (lambda (k) 2362 (string=? 2363 (symbol->string (hashtable-ref ht k #f)) 2364 (cond 2365 [(string? k) k] 2366 [(pair? k) (car k)] 2367 [(vector? k) (vector-ref k 0)]))) 2368 keep) 2369 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no)) 2370 drop)) 2371 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 2372 (let ([k (case (pick '(string pair vector)) 2373 [(string) s] 2374 [(pair) (list s)] 2375 [(vector) (vector s)])]) 2376 (hashtable-set! ht k x) 2377 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 2378 (if (= (modulo i 17) 5) 2379 (let ([k (pick keep)]) 2380 (hashtable-delete! ht k) 2381 (let ([drop (cons k drop)]) 2382 (when (= (random 5) 3) 2383 (hashtable-delete! ht (pick drop))) 2384 (f (+ i 1) (remq k keep) drop))) 2385 (f (+ i 1) keep drop))))))))) 2386 2387 (let () ; ephemeron 2388 (define pick 2389 (lambda (ls) 2390 (list-ref ls (random (length ls))))) 2391 (define ht (make-ephemeron-eq-hashtable 4)) 2392 (let ([ls (remq '|| (oblist))] [n 50000]) 2393 (let f ([i 0] [keep '()] [drop '()]) 2394 (if (= i n) 2395 (and (<= (hashtable-size ht) (- n (length drop))) 2396 (begin 2397 (collect (collect-maximum-generation)) 2398 (= (hashtable-size ht) (length keep))) 2399 (andmap (lambda (k) 2400 (string=? 2401 (symbol->string (hashtable-ref ht k #f)) 2402 (cond 2403 [(string? k) k] 2404 [(pair? k) (car k)] 2405 [(vector? k) (vector-ref k 0)]))) 2406 keep) 2407 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no)) 2408 drop)) 2409 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 2410 (let ([k (case (pick '(string pair vector)) 2411 [(string) s] 2412 [(pair) (list s)] 2413 [(vector) (vector s)])]) 2414 (hashtable-set! ht k x) 2415 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 2416 (if (= (modulo i 17) 5) 2417 (let ([k (pick keep)]) 2418 (hashtable-delete! ht k) 2419 (let ([drop (cons k drop)]) 2420 (when (= (random 5) 3) 2421 (hashtable-delete! ht (pick drop))) 2422 (f (+ i 1) (remq k keep) drop))) 2423 (f (+ i 1) keep drop))))))))) 2424 2425) 2426 2427(mat nonweak-eqv-hashtable 2428 (begin 2429 (define h (make-eqv-hashtable 32)) 2430 (and (hashtable? h) 2431 (not (eq-hashtable? h)) 2432 (hashtable-mutable? h) 2433 (not (hashtable-weak? h)) 2434 (not (hashtable-ephemeron? h)))) 2435 (eq? (hashtable-hash-function h) #f) 2436 (eq? (hashtable-equivalence-function h) eqv?) 2437 (equal? (hashtable-size h) 0) 2438 (same-elements? (hashtable-keys h) '#()) 2439 (same-elements? (hashtable-values h) '#()) 2440 (equal-entries? h '#() '#()) 2441 (same-elements? (hashtable-cells h) '#()) 2442 (same-elements? (hashtable-cells h 0) '#()) 2443 (same-elements? (hashtable-cells h 10) '#()) 2444 (eqv? (hashtable-set! h 'a 'aval) (void)) 2445 (equal? 2446 (list 2447 (hashtable-contains? h 'a) 2448 (hashtable-contains? h 3.4) 2449 (hashtable-contains? h 'c)) 2450 '(#t #f #f)) 2451 (eqv? (hashtable-set! h 3.4 'bval) (void)) 2452 (equal? 2453 (list 2454 (hashtable-contains? h 'a) 2455 (hashtable-contains? h 3.4) 2456 (hashtable-contains? h 'c)) 2457 '(#t #t #f)) 2458 (eqv? (hashtable-set! h 'c 'cval) (void)) 2459 (equal? 2460 (list 2461 (hashtable-contains? h 'a) 2462 (hashtable-contains? h 3.4) 2463 (hashtable-contains? h 'c)) 2464 '(#t #t #t)) 2465 (equal? (hashtable-size h) 3) 2466 (equal-entries? h '#(3.4 c a) '#(bval cval aval)) 2467 #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (3.4 . bval) (c . cval))) 2468 #;(same-elements? 2469 (let ([v (make-vector 3)] [i 0]) 2470 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 2471 v) 2472 '#((a . aval) (3.4 . bval) (c . cval))) 2473 #;(same-elements? 2474 (let ([v (make-vector 3)] [i 0]) 2475 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 2476 v) 2477 '#((a . aval) (3.4 . bval) (c . cval))) 2478 (equal? (hashtable-ref h 'a 1) 'aval) 2479 (equal? (hashtable-ref h 3.4 #f) 'bval) 2480 (equal? (hashtable-ref h 'c 'nope) 'cval) 2481 (eqv? (hashtable-delete! h 3.4) (void)) 2482 (equal? (hashtable-size h) 2) 2483 (equal-entries? h '#(a c) '#(aval cval)) 2484 (begin 2485 (define h2 (hashtable-copy h #t)) 2486 (and (hashtable? h2) 2487 (hashtable-mutable? h2) 2488 (not (hashtable-weak? h2)) 2489 (not (hashtable-ephemeron? h2)))) 2490 (eq? (hashtable-hash-function h2) #f) 2491 (eq? (hashtable-equivalence-function h2) eqv?) 2492 (equal? (hashtable-size h2) 2) 2493 (equal-entries? h2 '#(a c) '#(aval cval)) 2494 (eqv? (hashtable-clear! h 4) (void)) 2495 (equal? 2496 (list 2497 (hashtable-size h) 2498 (hashtable-ref h 'a 1) 2499 (hashtable-ref h 3.4 #f) 2500 (hashtable-ref h 'c 'nope)) 2501 '(0 1 #f nope)) 2502 (equal-entries? h '#() '#()) 2503 (equal? 2504 (list 2505 (hashtable-size h2) 2506 (hashtable-ref h2 'a 1) 2507 (hashtable-ref h2 3.4 #f) 2508 (hashtable-ref h2 'c 'nope)) 2509 '(2 aval #f cval)) 2510 (equal-entries? h2 '#(a c) '#(aval cval)) 2511 (eqv? 2512 (hashtable-update! h 'q 2513 (lambda (x) (+ x 1)) 2514 17) 2515 (void)) 2516 (equal? (hashtable-ref h 'q #f) 18) 2517 (eqv? 2518 (hashtable-update! h 'q 2519 (lambda (x) (+ x 1)) 2520 17) 2521 (void)) 2522 (equal? (hashtable-ref h 'q #f) 19) 2523 (equal? (hashtable-size h) 1) 2524 ; test hashtable-copy when some keys may have moved 2525 (let ([t (parameterize ([collect-request-handler void]) 2526 (let ([h4a (make-eqv-hashtable 32)] 2527 [k* (map list (make-list 100))]) 2528 (for-each (lambda (x) (hashtable-set! h4a x x)) k*) 2529 (collect) 2530 ; create copy after collection but before otherwise touching h4a 2531 (let ([h4b (hashtable-copy h4a #t)]) 2532 (andmap 2533 (lambda (k) (eqv? (hashtable-ref h4b k #f) k)) 2534 k*))))]) 2535 (collect) 2536 t) 2537 2538 ; test for proper shrinkage 2539 (equal? 2540 (let ([ht (make-eqv-hashtable 32)]) 2541 (for-each 2542 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 2543 (let ([k** (map (lambda (x) (map list (make-list 1000))) 2544 (make-list 100))]) 2545 (for-each 2546 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 2547 k**) 2548 k**)) 2549 (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) 2550 '(32 . 32)) 2551 2552 (begin 2553 (hashtable-set! h +nan.0 'nan) 2554 #t) 2555 (eq? 'nan (hashtable-ref h (abs +nan.0) #f)) 2556) 2557 2558(mat weak-eqv-hashtable 2559 (begin 2560 (define ka (list 'a)) 2561 (define kb (list 'b)) 2562 (define kc (list 'c)) 2563 (define kq (list 'q)) 2564 (define ky (list 'y)) 2565 (define kz (list 'z)) 2566 (define km -5.75) 2567 (define kn 17) 2568 (define ko (+ (most-positive-fixnum) 5)) 2569 #t) 2570 (begin 2571 (define h (make-weak-eqv-hashtable 32)) 2572 (and (hashtable? h) 2573 (not (eq-hashtable? h)) 2574 (hashtable-mutable? h) 2575 (hashtable-weak? h))) 2576 (eq? (hashtable-hash-function h) #f) 2577 (eq? (hashtable-equivalence-function h) eqv?) 2578 (equal? (hashtable-size h) 0) 2579 (same-elements? (hashtable-keys h) '#()) 2580 (same-elements? (hashtable-values h) '#()) 2581 (equal-entries? h '#() '#()) 2582 (same-elements? (hashtable-cells h) '#()) 2583 (same-elements? (hashtable-cells h 0) '#()) 2584 (same-elements? (hashtable-cells h 10) '#()) 2585 (eqv? (hashtable-set! h ka 'aval) (void)) 2586 (equal? 2587 (list 2588 (hashtable-contains? h ka) 2589 (hashtable-contains? h kb) 2590 (hashtable-contains? h kc) 2591 (hashtable-contains? h km) 2592 (hashtable-contains? h kn) 2593 (hashtable-contains? h ko)) 2594 '(#t #f #f #f #f #f)) 2595 (eqv? (hashtable-set! h kb 'bval) (void)) 2596 (equal? 2597 (list 2598 (hashtable-contains? h ka) 2599 (hashtable-contains? h kb) 2600 (hashtable-contains? h kc) 2601 (hashtable-contains? h km) 2602 (hashtable-contains? h kn) 2603 (hashtable-contains? h ko)) 2604 '(#t #t #f #f #f #f)) 2605 (eqv? (hashtable-set! h kc 'cval) (void)) 2606 (equal? 2607 (list 2608 (hashtable-contains? h ka) 2609 (hashtable-contains? h kb) 2610 (hashtable-contains? h kc) 2611 (hashtable-contains? h km) 2612 (hashtable-contains? h kn) 2613 (hashtable-contains? h ko)) 2614 '(#t #t #t #f #f #f)) 2615 (eqv? (hashtable-set! h km 'mval) (void)) 2616 (equal? 2617 (list 2618 (hashtable-contains? h ka) 2619 (hashtable-contains? h kb) 2620 (hashtable-contains? h kc) 2621 (hashtable-contains? h km) 2622 (hashtable-contains? h kn) 2623 (hashtable-contains? h ko)) 2624 '(#t #t #t #t #f #f)) 2625 (eqv? (hashtable-set! h kn 'nval) (void)) 2626 (equal? 2627 (list 2628 (hashtable-contains? h ka) 2629 (hashtable-contains? h kb) 2630 (hashtable-contains? h kc) 2631 (hashtable-contains? h km) 2632 (hashtable-contains? h kn) 2633 (hashtable-contains? h ko)) 2634 '(#t #t #t #t #t #f)) 2635 (eqv? (hashtable-set! h ko 'oval) (void)) 2636 (equal? 2637 (list 2638 (hashtable-contains? h ka) 2639 (hashtable-contains? h kb) 2640 (hashtable-contains? h kc) 2641 (hashtable-contains? h km) 2642 (hashtable-contains? h kn) 2643 (hashtable-contains? h ko)) 2644 '(#t #t #t #t #t #t)) 2645 (equal? (hashtable-size h) 6) 2646 (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval)) 2647 #;(same-elements? 2648 (list->vector (hashtable-map h cons)) 2649 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 2650 #;(same-elements? 2651 (let ([v (make-vector 6)] [i 0]) 2652 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 2653 v) 2654 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 2655 #;(same-elements? 2656 (let ([v (make-vector 6)] [i 0]) 2657 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 2658 v) 2659 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 2660 (eq? (hashtable-ref h ka 1) 'aval) 2661 (eq? (hashtable-ref h kb #f) 'bval) 2662 (eq? (hashtable-ref h kc 'nope) 'cval) 2663 (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval) 2664 (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval) 2665 (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval) 2666 (eqv? (hashtable-delete! h kb) (void)) 2667 (equal? (hashtable-size h) 5) 2668 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2669 (begin 2670 (define h2 (hashtable-copy h #t)) 2671 (and (hashtable? h2) 2672 (hashtable-mutable? h2) 2673 (hashtable-weak? h2))) 2674 (eq? (hashtable-hash-function h2) #f) 2675 (eq? (hashtable-equivalence-function h2) eqv?) 2676 (equal? (hashtable-size h2) 5) 2677 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2678 (eqv? (hashtable-clear! h 4) (void)) 2679 (equal? 2680 (list 2681 (hashtable-size h) 2682 (hashtable-ref h ka 1) 2683 (hashtable-ref h kb #f) 2684 (hashtable-ref h kc 'nope) 2685 (hashtable-ref h km 'nope) 2686 (hashtable-ref h kn 'nope) 2687 (hashtable-ref h ko 'nope)) 2688 '(0 1 #f nope nope nope nope)) 2689 (equal-entries? h '#() '#()) 2690 (equal? 2691 (list 2692 (hashtable-size h2) 2693 (hashtable-ref h2 ka 1) 2694 (hashtable-ref h2 kb #f) 2695 (hashtable-ref h2 kc 'nope) 2696 (hashtable-ref h2 (- (+ km 1) 1) 'nope) 2697 (hashtable-ref h2 (- (+ kn 1) 1) 'nope) 2698 (hashtable-ref h2 (- (+ ko 1) 1) 'nope)) 2699 '(5 aval #f cval mval nval oval)) 2700 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2701 (eqv? 2702 (hashtable-update! h kq 2703 (lambda (x) (+ x 1)) 2704 17) 2705 (void)) 2706 (equal? (hashtable-ref h kq #f) 18) 2707 (eqv? 2708 (hashtable-update! h kq 2709 (lambda (x) (+ x 1)) 2710 17) 2711 (void)) 2712 (equal? (hashtable-ref h kq #f) 19) 2713 (equal? (hashtable-size h) 1) 2714 (equal-entries? h '#((q)) '#(19)) 2715 (eqv? 2716 (begin 2717 (set! kq (void)) 2718 (collect (collect-maximum-generation)) 2719 (hashtable-size h)) 2720 0) 2721 (equal-entries? h '#() '#()) 2722 (equal? (hashtable-ref h ky #f) #f) 2723 (eqv? 2724 (hashtable-set! h ky 'toad) 2725 (void)) 2726 (equal? (hashtable-ref h ky #f) 'toad) 2727 (equal? (hashtable-ref h kz #f) #f) 2728 (eqv? 2729 (hashtable-update! h kz list 'frog) 2730 (void)) 2731 (equal? (hashtable-ref h kz #f) '(frog)) 2732 (equal-entries? 2733 h 2734 (vector kz ky) 2735 (vector (hashtable-ref h kz #f) 'toad)) 2736 (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) 2737 (begin 2738 (define h3 (hashtable-copy h2 #f)) 2739 (and (hashtable? h3) 2740 (not (hashtable-mutable? h3)) 2741 (hashtable-weak? h3))) 2742 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2743 (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2744 (equal? 2745 (begin 2746 (set! ka (void)) 2747 (set! km (void)) 2748 (set! kn (void)) 2749 (set! ko (void)) 2750 (collect (collect-maximum-generation)) 2751 (list (hashtable-size h2) (hashtable-size h3))) 2752 '(2 2)) 2753 (equal-entries? h2 `#((c) 17) '#(cval nval)) 2754 (equal-entries? h3 `#((c) 17) '#(cval nval)) 2755 (eqv? 2756 (begin 2757 (set! h3 (void)) 2758 (collect (collect-maximum-generation)) 2759 (hashtable-size h2)) 2760 2) 2761 (equal-entries? h2 `#((c) 17) '#(cval nval)) 2762 2763 ; test for proper shrinkage 2764 (equal? 2765 (let ([ht (make-weak-eqv-hashtable 32)]) 2766 (for-each 2767 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 2768 (let ([k** (map (lambda (x) (map list (make-list 1000))) 2769 (make-list 100))]) 2770 (for-each 2771 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 2772 k**) 2773 k**)) 2774 (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) 2775 '(32 . 32)) 2776 2777 ; test for proper shrinkage as objects are bwp'd 2778 ; uses delete to trigger final shrinkage 2779 (equal? 2780 (let ([ht (make-weak-eqv-hashtable 32)]) 2781 (hashtable-set! ht 'a 'b) 2782 (for-each 2783 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 2784 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 2785 (collect (collect-maximum-generation)) 2786 (hashtable-delete! ht 'a) 2787 (list (hashtable-size ht) 2788 (let-values ([(n1 n2) (#%$hashtable-veclen ht)]) 2789 (= n1 n2 32)))) 2790 '(0 #t)) 2791 ) 2792 2793(mat ephemeron-eqv-hashtable 2794 (begin 2795 (define ka (list 'a)) 2796 (define kb (list 'b)) 2797 (define kc (list 'c)) 2798 (define kq (list 'q)) 2799 (define ky (list 'y)) 2800 (define kz (list 'z)) 2801 (define km -5.75) 2802 (define kn 17) 2803 (define ko (+ (most-positive-fixnum) 5)) 2804 #t) 2805 (begin 2806 (define h (make-ephemeron-eqv-hashtable 32)) 2807 (and (hashtable? h) 2808 (not (eq-hashtable? h)) 2809 (hashtable-mutable? h) 2810 (hashtable-ephemeron? h))) 2811 (eq? (hashtable-hash-function h) #f) 2812 (eq? (hashtable-equivalence-function h) eqv?) 2813 (equal? (hashtable-size h) 0) 2814 (same-elements? (hashtable-keys h) '#()) 2815 (same-elements? (hashtable-values h) '#()) 2816 (equal-entries? h '#() '#()) 2817 (same-elements? (hashtable-cells h) '#()) 2818 (same-elements? (hashtable-cells h 0) '#()) 2819 (same-elements? (hashtable-cells h 10) '#()) 2820 (eqv? (hashtable-set! h ka 'aval) (void)) 2821 (equal? 2822 (list 2823 (hashtable-contains? h ka) 2824 (hashtable-contains? h kb) 2825 (hashtable-contains? h kc) 2826 (hashtable-contains? h km) 2827 (hashtable-contains? h kn) 2828 (hashtable-contains? h ko)) 2829 '(#t #f #f #f #f #f)) 2830 (eqv? (hashtable-set! h kb 'bval) (void)) 2831 (equal? 2832 (list 2833 (hashtable-contains? h ka) 2834 (hashtable-contains? h kb) 2835 (hashtable-contains? h kc) 2836 (hashtable-contains? h km) 2837 (hashtable-contains? h kn) 2838 (hashtable-contains? h ko)) 2839 '(#t #t #f #f #f #f)) 2840 (eqv? (hashtable-set! h kc 'cval) (void)) 2841 (equal? 2842 (list 2843 (hashtable-contains? h ka) 2844 (hashtable-contains? h kb) 2845 (hashtable-contains? h kc) 2846 (hashtable-contains? h km) 2847 (hashtable-contains? h kn) 2848 (hashtable-contains? h ko)) 2849 '(#t #t #t #f #f #f)) 2850 (eqv? (hashtable-set! h km 'mval) (void)) 2851 (equal? 2852 (list 2853 (hashtable-contains? h ka) 2854 (hashtable-contains? h kb) 2855 (hashtable-contains? h kc) 2856 (hashtable-contains? h km) 2857 (hashtable-contains? h kn) 2858 (hashtable-contains? h ko)) 2859 '(#t #t #t #t #f #f)) 2860 (eqv? (hashtable-set! h kn 'nval) (void)) 2861 (equal? 2862 (list 2863 (hashtable-contains? h ka) 2864 (hashtable-contains? h kb) 2865 (hashtable-contains? h kc) 2866 (hashtable-contains? h km) 2867 (hashtable-contains? h kn) 2868 (hashtable-contains? h ko)) 2869 '(#t #t #t #t #t #f)) 2870 (eqv? (hashtable-set! h ko 'oval) (void)) 2871 (equal? 2872 (list 2873 (hashtable-contains? h ka) 2874 (hashtable-contains? h kb) 2875 (hashtable-contains? h kc) 2876 (hashtable-contains? h km) 2877 (hashtable-contains? h kn) 2878 (hashtable-contains? h ko)) 2879 '(#t #t #t #t #t #t)) 2880 (equal? (hashtable-size h) 6) 2881 (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval)) 2882 #;(same-elements? 2883 (list->vector (hashtable-map h cons)) 2884 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 2885 #;(same-elements? 2886 (let ([v (make-vector 6)] [i 0]) 2887 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 2888 v) 2889 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 2890 #;(same-elements? 2891 (let ([v (make-vector 6)] [i 0]) 2892 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 2893 v) 2894 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 2895 (eq? (hashtable-ref h ka 1) 'aval) 2896 (eq? (hashtable-ref h kb #f) 'bval) 2897 (eq? (hashtable-ref h kc 'nope) 'cval) 2898 (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval) 2899 (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval) 2900 (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval) 2901 (eqv? (hashtable-delete! h kb) (void)) 2902 (equal? (hashtable-size h) 5) 2903 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2904 (begin 2905 (define h2 (hashtable-copy h #t)) 2906 (and (hashtable? h2) 2907 (hashtable-mutable? h2) 2908 (hashtable-ephemeron? h2))) 2909 (eq? (hashtable-hash-function h2) #f) 2910 (eq? (hashtable-equivalence-function h2) eqv?) 2911 (equal? (hashtable-size h2) 5) 2912 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2913 (eqv? (hashtable-clear! h 4) (void)) 2914 (equal? 2915 (list 2916 (hashtable-size h) 2917 (hashtable-ref h ka 1) 2918 (hashtable-ref h kb #f) 2919 (hashtable-ref h kc 'nope) 2920 (hashtable-ref h km 'nope) 2921 (hashtable-ref h kn 'nope) 2922 (hashtable-ref h ko 'nope)) 2923 '(0 1 #f nope nope nope nope)) 2924 (equal-entries? h '#() '#()) 2925 (equal? 2926 (list 2927 (hashtable-size h2) 2928 (hashtable-ref h2 ka 1) 2929 (hashtable-ref h2 kb #f) 2930 (hashtable-ref h2 kc 'nope) 2931 (hashtable-ref h2 (- (+ km 1) 1) 'nope) 2932 (hashtable-ref h2 (- (+ kn 1) 1) 'nope) 2933 (hashtable-ref h2 (- (+ ko 1) 1) 'nope)) 2934 '(5 aval #f cval mval nval oval)) 2935 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2936 (eqv? 2937 (hashtable-update! h kq 2938 (lambda (x) (+ x 1)) 2939 17) 2940 (void)) 2941 (equal? (hashtable-ref h kq #f) 18) 2942 (eqv? 2943 (hashtable-update! h kq 2944 (lambda (x) (+ x 1)) 2945 17) 2946 (void)) 2947 (equal? (hashtable-ref h kq #f) 19) 2948 (equal? (hashtable-size h) 1) 2949 (equal-entries? h '#((q)) '#(19)) 2950 (eqv? 2951 (begin 2952 (set! kq (void)) 2953 (collect (collect-maximum-generation)) 2954 (hashtable-size h)) 2955 0) 2956 (equal-entries? h '#() '#()) 2957 (equal? (hashtable-ref h ky #f) #f) 2958 (eqv? 2959 (hashtable-set! h ky 'toad) 2960 (void)) 2961 (equal? (hashtable-ref h ky #f) 'toad) 2962 (equal? (hashtable-ref h kz #f) #f) 2963 (eqv? 2964 (hashtable-update! h kz list 'frog) 2965 (void)) 2966 (equal? (hashtable-ref h kz #f) '(frog)) 2967 (equal-entries? 2968 h 2969 (vector kz ky) 2970 (vector (hashtable-ref h kz #f) 'toad)) 2971 (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) 2972 (begin 2973 (define h3 (hashtable-copy h2 #f)) 2974 (and (hashtable? h3) 2975 (not (hashtable-mutable? h3)) 2976 (hashtable-ephemeron? h3))) 2977 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2978 (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 2979 (equal? 2980 (begin 2981 (set! ka (void)) 2982 (set! km (void)) 2983 (set! kn (void)) 2984 (set! ko (void)) 2985 (collect (collect-maximum-generation)) 2986 (list (hashtable-size h2) (hashtable-size h3))) 2987 '(2 2)) 2988 (equal-entries? h2 `#((c) 17) '#(cval nval)) 2989 (equal-entries? h3 `#((c) 17) '#(cval nval)) 2990 (eqv? 2991 (begin 2992 (set! h3 (void)) 2993 (collect (collect-maximum-generation)) 2994 (hashtable-size h2)) 2995 2) 2996 (equal-entries? h2 `#((c) 17) '#(cval nval)) 2997 2998 ; test for proper shrinkage 2999 (equal? 3000 (let ([ht (make-ephemeron-eqv-hashtable 32)]) 3001 (for-each 3002 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 3003 (let ([k** (map (lambda (x) (map list (make-list 1000))) 3004 (make-list 100))]) 3005 (for-each 3006 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 3007 k**) 3008 k**)) 3009 (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) 3010 '(32 . 32)) 3011 3012 ; test for proper shrinkage as objects are bwp'd 3013 ; uses delete to trigger final shrinkage 3014 (equal? 3015 (let ([ht (make-ephemeron-eqv-hashtable 32)]) 3016 (hashtable-set! ht 'a 'b) 3017 (for-each 3018 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 3019 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 3020 (collect (collect-maximum-generation)) 3021 (hashtable-delete! ht 'a) 3022 (list (hashtable-size ht) 3023 (let-values ([(n1 n2) (#%$hashtable-veclen ht)]) 3024 (= n1 n2 32)))) 3025 '(0 #t)) 3026) 3027 3028(mat eqv-hashtable-cell 3029 (let () 3030 (define-record fribble (x)) 3031 (define random-object 3032 (lambda (x) 3033 (case (random 9) 3034 [(0) (cons 'a 3.4)] 3035 [(1) (vector 'c)] 3036 [(2) (string #\a #\b)] 3037 [(3) (make-fribble 'q)] 3038 [(4) (gensym)] 3039 [(5) (open-output-string)] 3040 [(6) (fxvector 15 55)] 3041 [(7) (lambda () x)] 3042 [(8) (flvector 15.0 55.0)] 3043 [else (box 'top)]))) 3044 (let ([ls1 (let f ([n 10000]) 3045 (if (fx= n 0) 3046 '() 3047 (cons 3048 (cons (random-object 4) (random-object 7)) 3049 (f (fx- n 1)))))] 3050 [ht (make-eqv-hashtable)] 3051 [wht (make-weak-eqv-hashtable)] 3052 [eht (make-ephemeron-eqv-hashtable)]) 3053 (let ([ls2 (map (lambda (a1) (hashtable-cell ht (car a1) (cdr a1))) ls1)] 3054 [ls3 (map (lambda (a1) (hashtable-cell wht (car a1) (cdr a1))) ls1)] 3055 [ls4 (map (lambda (a1) (hashtable-cell eht (car a1) (cdr a1))) ls1)]) 3056 (let ([ls2* (map (lambda (a1) (hashtable-ref-cell ht (car a1))) ls1)] 3057 [ls3* (map (lambda (a1) (hashtable-ref-cell wht (car a1))) ls1)] 3058 [ls4* (map (lambda (a1) (hashtable-ref-cell eht (car a1))) ls1)]) 3059 (unless (andmap (lambda (a2 a2* a3 a3* a4 a4*) 3060 (and (eq? a2 a2*) 3061 (eq? a3 a3*) 3062 (eq? a4 a4*))) 3063 ls2 ls2* ls3 ls3* ls4 ls4*) 3064 (errorf #f "hashtable-ref-cell and hashtable-cell do not retrieve the same cells"))) 3065 (unless (andmap (lambda (a1 a2 a3 a4) 3066 (and (eqv? (car a1) (car a2)) 3067 (eqv? (car a2) (car a3)) 3068 (eqv? (car a2) (car a4)))) 3069 ls1 ls2 ls3 ls4) 3070 (errorf #f "keys are not eqv")) 3071 (unless (andmap (lambda (a1 a2 a3 a4) 3072 (and (eqv? (cdr a1) (cdr a2)) 3073 (eqv? (cdr a2) (cdr a3)) 3074 (eqv? (cdr a2) (cdr a4)))) 3075 ls1 ls2 ls3 ls4) 3076 (errorf #f "values are not eqv")) 3077 (for-each (lambda (a1) 3078 (let ([o (random-object 3)]) 3079 ;; Value refers to key: 3080 (hashtable-set! eht o (list o (car a1))))) 3081 ls1) 3082 (for-each 3083 (lambda (a1) 3084 (when (fx< (random 10) 5) 3085 (set-car! a1 #f))) 3086 ls1) 3087 (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)]) 3088 (unless (fx= i 0) 3089 (collect) 3090 (unless (andmap (lambda (a2 a3 a4) (and (eqv? (car a2) (car a3)) (eqv? (car a2) (car a4)))) 3091 ls2 ls3 ls4) 3092 (errorf #f "a2/a3/a4 keys not eqv after collection")) 3093 (unless (and (andmap (lambda (a3) (not (bwp-object? (car a3)))) ls3) 3094 (andmap (lambda (a4) (not (bwp-object? (car a4)))) ls4)) 3095 (errorf #f "keys have been bwp'd")) 3096 (loop (fx- i 1)))) 3097 (for-each 3098 (lambda (a2) 3099 (hashtable-delete! ht (car a2)) 3100 (set-car! a2 #f)) 3101 ls2) 3102 (unless (and (equal? (hashtable-keys ht) '#()) 3103 (equal? (hashtable-values ht) '#()) 3104 (zero? (hashtable-size ht))) 3105 (errorf #f "ht has not been cleared out")) 3106 (let loop ([i (min (expt (collect-generation-radix) (collect-maximum-generation)) 1000)]) 3107 (unless (fx= i 0) 3108 (collect) 3109 (unless (andmap (lambda (a1 a3 a4) 3110 (or (not (car a1)) 3111 (and (eqv? (car a1) (car a3)) 3112 (eqv? (car a1) (car a4))))) 3113 ls1 ls3 ls4) 3114 (errorf #f "a1/a3/a4 keys not eqv after collection")) 3115 (loop (fx- i 1)))) 3116 (for-each 3117 (lambda (a1 a3 a4) 3118 (unless (or (car a1) 3119 (and (bwp-object? (car a3)) 3120 (bwp-object? (car a4)))) 3121 (errorf #f "~s has not been bwp'd I" (car a3)))) 3122 ls1 ls3 ls4) 3123 (for-each (lambda (a1) (set-car! a1 #f)) ls1) 3124 (collect (collect-maximum-generation)) 3125 (unless (and (andmap (lambda (a3) (bwp-object? (car a3))) ls3) 3126 (andmap (lambda (a4) (bwp-object? (car a4))) ls4)) 3127 (errorf #f "keys have not been bwp'd II")) 3128 (unless (and (equal? (hashtable-keys wht) '#()) 3129 (equal? (hashtable-values wht) '#()) 3130 (zero? (hashtable-size wht))) 3131 (errorf #f "wht has not been cleared out")) 3132 (unless (and (equal? (hashtable-keys eht) '#()) 3133 (equal? (hashtable-values eht) '#()) 3134 (zero? (hashtable-size eht))) 3135 (errorf #f "eht has not been cleared out")))) 3136 #t) 3137 ) 3138 3139(mat eqv-strange 3140 (begin 3141 (define $ht (make-eqv-hashtable)) 3142 (define $wht (make-weak-eqv-hashtable)) 3143 (define $eht (make-weak-eqv-hashtable)) 3144 (and (hashtable? $ht) 3145 (hashtable? $wht) 3146 (hashtable? $eht))) 3147 (eqv? (hashtable-set! $ht #f 75) (void)) 3148 (eqv? (hashtable-ref $ht #f 80) 75) 3149 (eqv? (hashtable-set! $wht #f 75) (void)) 3150 (eqv? (hashtable-ref $wht #f 80) 75) 3151 (eqv? (hashtable-set! $eht #f 75) (void)) 3152 (eqv? (hashtable-ref $eht #f 80) 75) 3153 (eqv? (hashtable-set! $ht #!bwp "hello") (void)) 3154 (equal? (hashtable-ref $ht #!bwp "goodbye") "hello") 3155 (eqv? (hashtable-set! $wht #!bwp "hello") (void)) 3156 (eqv? (hashtable-set! $eht #!bwp "hello") (void)) 3157 (and (member (hashtable-ref $wht #!bwp "goodbye") '("hello" "goodbye")) #t) 3158 (and (member (hashtable-ref $eht #!bwp "goodbye") '("hello" "goodbye")) #t) 3159 ; make sure that association isn't added before procedure is called 3160 (equal? 3161 (begin 3162 (hashtable-update! $ht 'cupie 3163 (lambda (x) (hashtable-ref $ht 'cupie (cons 'barbie x))) 3164 'doll) 3165 (hashtable-ref $ht 'cupie 'oops)) 3166 '(barbie . doll)) 3167 (equal? 3168 (begin 3169 (hashtable-update! $wht 'cupie 3170 (lambda (x) (hashtable-ref $wht 'cupie (cons 'barbie x))) 3171 'doll) 3172 (hashtable-ref $wht 'cupie 'oops)) 3173 '(barbie . doll)) 3174 (equal? 3175 (begin 3176 (hashtable-update! $eht 'cupie 3177 (lambda (x) (hashtable-ref $eht 'cupie (cons 'barbie x))) 3178 'doll) 3179 (hashtable-ref $eht 'cupie 'oops)) 3180 '(barbie . doll)) 3181) 3182 3183(mat eqv-hashtable-stress 3184 ; stress tests 3185 (let () ; nonweak 3186 (define pick 3187 (lambda (ls) 3188 (list-ref ls (random (length ls))))) 3189 (define ht (make-eqv-hashtable 4)) 3190 (let ([ls (remq '|| (oblist))] [n 50000]) 3191 (let f ([i 0] [keep '()] [drop '()]) 3192 (if (= i n) 3193 (and (= (hashtable-size ht) (- n (length drop))) 3194 (andmap (lambda (k) 3195 (string=? 3196 (symbol->string (hashtable-ref ht k #f)) 3197 (cond 3198 [(string? k) k] 3199 [(pair? k) (car k)] 3200 [(vector? k) (vector-ref k 0)]))) 3201 keep) 3202 (andmap (lambda (k) (eqv? (hashtable-ref ht k 'no) 'no)) 3203 drop)) 3204 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 3205 (let ([k (case (pick '(string pair vector)) 3206 [(string) s] 3207 [(pair) (list s)] 3208 [(vector) (vector s)])]) 3209 (hashtable-set! ht k x) 3210 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 3211 (if (= (modulo i 17) 5) 3212 (let ([k (pick keep)]) 3213 (hashtable-delete! ht k) 3214 (let ([drop (cons k drop)]) 3215 (when (= (random 5) 3) 3216 (hashtable-delete! ht (pick drop))) 3217 (f (+ i 1) (remq k keep) drop))) 3218 (f (+ i 1) keep drop))))))))) 3219 3220 (let () ; weak 3221 (define pick 3222 (lambda (ls) 3223 (list-ref ls (random (length ls))))) 3224 (define ht (make-weak-eqv-hashtable 4)) 3225 (let ([ls (remq '|| (oblist))] [n 50000]) 3226 (let f ([i 0] [keep '()] [drop '()]) 3227 (if (= i n) 3228 (and (<= (hashtable-size ht) (- n (length drop))) 3229 (begin 3230 (collect (collect-maximum-generation)) 3231 (= (hashtable-size ht) (length keep))) 3232 (andmap (lambda (k) 3233 (string=? 3234 (symbol->string (hashtable-ref ht k #f)) 3235 (cond 3236 [(string? k) k] 3237 [(pair? k) (car k)] 3238 [(vector? k) (vector-ref k 0)]))) 3239 keep) 3240 (andmap (lambda (k) (eqv? (hashtable-ref ht k 'no) 'no)) 3241 drop)) 3242 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 3243 (let ([k (case (pick '(string pair vector)) 3244 [(string) s] 3245 [(pair) (list s)] 3246 [(vector) (vector s)])]) 3247 (hashtable-set! ht k x) 3248 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 3249 (if (= (modulo i 17) 5) 3250 (let ([k (pick keep)]) 3251 (hashtable-delete! ht k) 3252 (let ([drop (cons k drop)]) 3253 (when (= (random 5) 3) 3254 (hashtable-delete! ht (pick drop))) 3255 (f (+ i 1) (remq k keep) drop))) 3256 (f (+ i 1) keep drop))))))))) 3257 3258 (let () ; ephemeron 3259 (define pick 3260 (lambda (ls) 3261 (list-ref ls (random (length ls))))) 3262 (define ht (make-ephemeron-eqv-hashtable 4)) 3263 (let ([ls (remq '|| (oblist))] [n 50000]) 3264 (let f ([i 0] [keep '()] [drop '()]) 3265 (if (= i n) 3266 (and (<= (hashtable-size ht) (- n (length drop))) 3267 (begin 3268 (collect (collect-maximum-generation)) 3269 (= (hashtable-size ht) (length keep))) 3270 (andmap (lambda (k) 3271 (string=? 3272 (symbol->string (hashtable-ref ht k #f)) 3273 (cond 3274 [(string? k) k] 3275 [(pair? k) (car k)] 3276 [(vector? k) (vector-ref k 0)]))) 3277 keep) 3278 (andmap (lambda (k) (eqv? (hashtable-ref ht k 'no) 'no)) 3279 drop)) 3280 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 3281 (let ([k (case (pick '(string pair vector)) 3282 [(string) s] 3283 [(pair) (list s)] 3284 [(vector) (vector s)])]) 3285 (hashtable-set! ht k x) 3286 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 3287 (if (= (modulo i 17) 5) 3288 (let ([k (pick keep)]) 3289 (hashtable-delete! ht k) 3290 (let ([drop (cons k drop)]) 3291 (when (= (random 5) 3) 3292 (hashtable-delete! ht (pick drop))) 3293 (f (+ i 1) (remq k keep) drop))) 3294 (f (+ i 1) keep drop))))))))) 3295 3296) 3297 3298(mat symbol-hashtable 3299 (let ([ht (make-hashtable symbol-hash eq?)]) 3300 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eq?))) 3301 (let ([ht (make-hashtable symbol-hash eqv?)]) 3302 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eqv?))) 3303 (let ([ht (make-hashtable symbol-hash equal?)]) 3304 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) equal?))) 3305 (let ([ht (make-hashtable symbol-hash symbol=?)]) 3306 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) symbol=?))) 3307 (let ([ht (make-hashtable symbol-hash eq? 17)]) 3308 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eq?))) 3309 (let ([ht (make-hashtable symbol-hash eqv? 17)]) 3310 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) eqv?))) 3311 (let ([ht (make-hashtable symbol-hash equal? 17)]) 3312 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) equal?))) 3313 (let ([ht (make-hashtable symbol-hash symbol=? 17)]) 3314 (and (symbol-hashtable? ht) (eq? (hashtable-equivalence-function ht) symbol=?))) 3315 (begin 3316 (define h (make-hashtable symbol-hash eq? 32)) 3317 (and (hashtable? h) 3318 (symbol-hashtable? h) 3319 (hashtable-mutable? h) 3320 (not (eq-hashtable? h)) 3321 (not (hashtable-weak? h)) 3322 (not (hashtable-ephemeron? h)))) 3323 (eq? (hashtable-hash-function h) symbol-hash) 3324 (eq? (hashtable-equivalence-function h) eq?) 3325 (equal? (hashtable-size h) 0) 3326 (same-elements? (hashtable-keys h) '#()) 3327 (same-elements? (hashtable-values h) '#()) 3328 (equal-entries? h '#() '#()) 3329 (same-elements? (hashtable-cells h) '#()) 3330 (same-elements? (hashtable-cells h 0) '#()) 3331 (same-elements? (hashtable-cells h 10) '#()) 3332 (eqv? (hashtable-set! h 'a 'aval) (void)) 3333 (equal? 3334 (list 3335 (hashtable-contains? h 'a) 3336 (hashtable-contains? h 'b) 3337 (hashtable-contains? h 'c)) 3338 '(#t #f #f)) 3339 (eqv? (hashtable-set! h 'b 'bval) (void)) 3340 (equal? 3341 (list 3342 (hashtable-contains? h 'a) 3343 (hashtable-contains? h 'b) 3344 (hashtable-contains? h 'c)) 3345 '(#t #t #f)) 3346 (eqv? (hashtable-set! h 'c 'cval) (void)) 3347 (equal? 3348 (list 3349 (hashtable-contains? h 'a) 3350 (hashtable-contains? h 'b) 3351 (hashtable-contains? h 'c)) 3352 '(#t #t #t)) 3353 (equal? (hashtable-size h) 3) 3354 (equal-entries? h '#(b c a) '#(bval cval aval)) 3355 #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (b . bval) (c . cval))) 3356 #;(same-elements? 3357 (let ([v (make-vector 3)] [i 0]) 3358 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 3359 v) 3360 '#((a . aval) (b . bval) (c . cval))) 3361 #;(same-elements? 3362 (let ([v (make-vector 3)] [i 0]) 3363 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 3364 v) 3365 '#((a . aval) (b . bval) (c . cval))) 3366 (equal? (hashtable-ref h 'a 1) 'aval) 3367 (equal? (hashtable-ref h 'b #f) 'bval) 3368 (equal? (hashtable-ref h 'c 'nope) 'cval) 3369 (eqv? (hashtable-delete! h 'b) (void)) 3370 (equal? (hashtable-size h) 2) 3371 (equal-entries? h '#(a c) '#(aval cval)) 3372 (begin 3373 (define h2 (hashtable-copy h #t)) 3374 (and (hashtable? h2) 3375 (symbol-hashtable? h2) 3376 (hashtable-mutable? h2) 3377 (not (hashtable-weak? h2)) 3378 (not (hashtable-ephemeron? h2)) 3379 (not (eq-hashtable? h2)))) 3380 (eq? (hashtable-hash-function h2) symbol-hash) 3381 (eq? (hashtable-equivalence-function h2) eq?) 3382 (equal? (hashtable-size h2) 2) 3383 (equal-entries? h2 '#(a c) '#(aval cval)) 3384 (eqv? (hashtable-clear! h 4) (void)) 3385 (equal? 3386 (list 3387 (hashtable-size h) 3388 (hashtable-ref h 'a 1) 3389 (hashtable-ref h 'b #f) 3390 (hashtable-ref h 'c 'nope)) 3391 '(0 1 #f nope)) 3392 (equal-entries? h '#() '#()) 3393 (equal? 3394 (list 3395 (hashtable-size h2) 3396 (hashtable-ref h2 'a 1) 3397 (hashtable-ref h2 'b #f) 3398 (hashtable-ref h2 'c 'nope)) 3399 '(2 aval #f cval)) 3400 (equal-entries? h2 '#(a c) '#(aval cval)) 3401 (eqv? 3402 (hashtable-update! h 'q 3403 (lambda (x) (+ x 1)) 3404 17) 3405 (void)) 3406 (equal? (hashtable-ref h 'q #f) 18) 3407 (eqv? 3408 (hashtable-update! h 'q 3409 (lambda (x) (+ x 1)) 3410 17) 3411 (void)) 3412 (equal? (hashtable-ref h 'q #f) 19) 3413 (equal? (hashtable-size h) 1) 3414 ; test hashtable-copy when some keys may have moved 3415 ; symbol hashes don't change, but keeping test adapted from eq-hashtable mats anyway 3416 (let ([t (parameterize ([collect-request-handler void]) 3417 (let ([h4a (make-hashtable symbol-hash eqv? 32)] 3418 [k* (list-head (oblist) 100)]) 3419 (for-each (lambda (x) (hashtable-set! h4a x x)) k*) 3420 (collect) 3421 ; create copy after collection but before otherwise touching h4a 3422 (let ([h4b (hashtable-copy h4a #t)]) 3423 (andmap 3424 (lambda (k) (eq? (hashtable-ref h4b k #f) k)) 3425 k*))))]) 3426 (collect) 3427 t) 3428 ; test for proper shrinkage 3429 (eqv? 3430 (let ([ht (make-hashtable symbol-hash equal? 32)]) 3431 (for-each 3432 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 3433 (let ([k** (map (lambda (x) (list-head (oblist) 1000)) (make-list 100))]) 3434 (for-each 3435 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 3436 k**) 3437 k**)) 3438 (#%$hashtable-veclen ht)) 3439 32) 3440) 3441 3442(mat $symbol-hashtable 3443 (begin 3444 (define h (make-hashtable symbol-hash eq? 32)) 3445 (and (hashtable? h) 3446 (symbol-hashtable? h) 3447 (hashtable-mutable? h) 3448 (not (eq-hashtable? h)) 3449 (not (hashtable-weak? h)) 3450 (not (hashtable-ephemeron? h)))) 3451 (eq? (hashtable-hash-function h) symbol-hash) 3452 (eq? (hashtable-equivalence-function h) eq?) 3453 (equal? (hashtable-size h) 0) 3454 (same-elements? (hashtable-keys h) '#()) 3455 (same-elements? (hashtable-values h) '#()) 3456 (equal-entries? h '#() '#()) 3457 (same-elements? (hashtable-cells h) '#()) 3458 (same-elements? (hashtable-cells h 0) '#()) 3459 (same-elements? (hashtable-cells h 10) '#()) 3460 (eqv? (symbol-hashtable-set! h 'a 'aval) (void)) 3461 (equal? 3462 (list 3463 (symbol-hashtable-contains? h 'a) 3464 (symbol-hashtable-contains? h 'b) 3465 (symbol-hashtable-contains? h 'c)) 3466 '(#t #f #f)) 3467 (eqv? (symbol-hashtable-set! h 'b 'bval) (void)) 3468 (equal? 3469 (list 3470 (symbol-hashtable-contains? h 'a) 3471 (symbol-hashtable-contains? h 'b) 3472 (symbol-hashtable-contains? h 'c)) 3473 '(#t #t #f)) 3474 (eqv? (symbol-hashtable-set! h 'c 'cval) (void)) 3475 (equal? 3476 (list 3477 (symbol-hashtable-contains? h 'a) 3478 (symbol-hashtable-contains? h 'b) 3479 (symbol-hashtable-contains? h 'c)) 3480 '(#t #t #t)) 3481 (equal? (hashtable-size h) 3) 3482 (equal-entries? h '#(b c a) '#(bval cval aval)) 3483 #;(same-elements? (list->vector (hashtable-map h cons)) '#((a . aval) (b . bval) (c . cval))) 3484 #;(same-elements? 3485 (let ([v (make-vector 3)] [i 0]) 3486 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 3487 v) 3488 '#((a . aval) (b . bval) (c . cval))) 3489 #;(same-elements? 3490 (let ([v (make-vector 3)] [i 0]) 3491 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 3492 v) 3493 '#((a . aval) (b . bval) (c . cval))) 3494 (equal? (symbol-hashtable-ref h 'a 1) 'aval) 3495 (equal? (symbol-hashtable-ref h 'b #f) 'bval) 3496 (equal? (symbol-hashtable-ref h 'c 'nope) 'cval) 3497 (eqv? (symbol-hashtable-delete! h 'b) (void)) 3498 (equal? (hashtable-size h) 2) 3499 (equal-entries? h '#(a c) '#(aval cval)) 3500 (begin 3501 (define h2 (hashtable-copy h #t)) 3502 (and (hashtable? h2) 3503 (symbol-hashtable? h2) 3504 (hashtable-mutable? h2) 3505 (not (hashtable-weak? h2)) 3506 (not (hashtable-ephemeron? h2)) 3507 (not (eq-hashtable? h2)))) 3508 (eq? (hashtable-hash-function h2) symbol-hash) 3509 (eq? (hashtable-equivalence-function h2) eq?) 3510 (equal? (hashtable-size h2) 2) 3511 (equal-entries? h2 '#(a c) '#(aval cval)) 3512 (eqv? (hashtable-clear! h 4) (void)) 3513 (equal? 3514 (list 3515 (hashtable-size h) 3516 (symbol-hashtable-ref h 'a 1) 3517 (symbol-hashtable-ref h 'b #f) 3518 (symbol-hashtable-ref h 'c 'nope)) 3519 '(0 1 #f nope)) 3520 (equal-entries? h '#() '#()) 3521 (equal? 3522 (list 3523 (hashtable-size h2) 3524 (symbol-hashtable-ref h2 'a 1) 3525 (symbol-hashtable-ref h2 'b #f) 3526 (symbol-hashtable-ref h2 'c 'nope)) 3527 '(2 aval #f cval)) 3528 (equal-entries? h2 '#(a c) '#(aval cval)) 3529 (eqv? 3530 (symbol-hashtable-update! h 'q 3531 (lambda (x) (+ x 1)) 3532 17) 3533 (void)) 3534 (equal? (symbol-hashtable-ref h 'q #f) 18) 3535 (eqv? 3536 (symbol-hashtable-update! h 'q 3537 (lambda (x) (+ x 1)) 3538 17) 3539 (void)) 3540 (equal? (symbol-hashtable-ref h 'q #f) 19) 3541 (equal? (hashtable-size h) 1) 3542 (let ([g (gensym)] [s "feisty"]) 3543 (let ([a (symbol-hashtable-cell h g s)]) 3544 (and (pair? a) 3545 (eq? (car a) g) 3546 (eq? (cdr a) s) 3547 (eq? a (symbol-hashtable-ref-cell h g)) 3548 (begin 3549 (hashtable-set! h g 'feisty) 3550 (eq? (cdr a) 'feisty)) 3551 (begin 3552 (set-cdr! a (list "feisty")) 3553 (equal? (hashtable-ref h g #f) '("feisty")))))) 3554 (eq? (symbol-hashtable-ref-cell h (gensym)) #f) 3555 ; test hashtable-copy when some keys may have moved 3556 ; symbol hashes don't change, but keeping test adapted from eq-hashtable mats anyway 3557 (let ([t (parameterize ([collect-request-handler void]) 3558 (let ([h4a (make-hashtable symbol-hash eqv? 32)] 3559 [k* (list-head (oblist) 100)]) 3560 (for-each (lambda (x) (symbol-hashtable-set! h4a x x)) k*) 3561 (collect) 3562 ; create copy after collection but before otherwise touching h4a 3563 (let ([h4b (hashtable-copy h4a #t)]) 3564 (andmap 3565 (lambda (k) (eq? (symbol-hashtable-ref h4b k #f) k)) 3566 k*))))]) 3567 (collect) 3568 t) 3569 ; test for proper shrinkage 3570 (eqv? 3571 (let ([ht (make-hashtable symbol-hash equal? 32)]) 3572 (for-each 3573 (lambda (k*) (for-each (lambda (k) (symbol-hashtable-delete! ht k)) k*)) 3574 (let ([k** (map (lambda (x) (list-head (oblist) 1000)) (make-list 100))]) 3575 (for-each 3576 (lambda (k*) (map (lambda (k) (symbol-hashtable-set! ht k 75)) k*)) 3577 k**) 3578 k**)) 3579 (#%$hashtable-veclen ht)) 3580 32) 3581) 3582 3583(mat symbol-hashtable-stress 3584 ; stress tests 3585 (let () ; nonweak 3586 (define pick 3587 (lambda (ls) 3588 (list-ref ls (random (length ls))))) 3589 (define ht (make-hashtable symbol-hash eq? 4)) 3590 (let ([ls (remq '|| (oblist))] [n 50000]) 3591 (let f ([i 0] [keep '()] [drop '()]) 3592 (if (= i n) 3593 (and (= (hashtable-size ht) (- n (length drop))) 3594 (andmap (lambda (k) 3595 (string=? 3596 (symbol->string (hashtable-ref ht k #f)) 3597 (symbol->string k))) 3598 keep) 3599 (andmap (lambda (k) (eq? (hashtable-ref ht k 'no) 'no)) 3600 drop)) 3601 (let* ([x (pick ls)] [s (string-copy (symbol->string x))]) 3602 (let ([k (gensym s)]) 3603 (hashtable-set! ht k x) 3604 (let ([keep (if (= (modulo i 5) 0) (cons k keep) keep)]) 3605 (if (= (modulo i 17) 5) 3606 (let ([k (pick keep)]) 3607 (hashtable-delete! ht k) 3608 (let ([drop (cons k drop)]) 3609 (when (= (random 5) 3) 3610 (hashtable-delete! ht (pick drop))) 3611 (f (+ i 1) (remq k keep) drop))) 3612 (f (+ i 1) keep drop))))))))) 3613) 3614 3615(mat generic-hashtable 3616 (begin 3617 (define $ght-keys1 '#(a b c d e f g)) 3618 (define $ght-vals1 '#(1 3 5 7 9 11 13)) 3619 (define $ght (make-hashtable equal-hash equal? 8)) 3620 (vector-for-each 3621 (lambda (x i) (hashtable-set! $ght x i)) 3622 $ght-keys1 3623 $ght-vals1) 3624 (hashtable? $ght)) 3625 (not (eq-hashtable? $ght)) 3626 (eq? (hashtable-hash-function $ght) equal-hash) 3627 (eq? (hashtable-equivalence-function $ght) equal?) 3628 (eq? (hashtable-mutable? $ght) #t) 3629 (not (hashtable-weak? $ght)) 3630 (not (hashtable-ephemeron? $ght)) 3631 (eqv? (hashtable-size $ght) (vector-length $ght-keys1)) 3632 (eqv? (#%$hashtable-veclen $ght) 8) 3633 (same-elements? (hashtable-keys $ght) $ght-keys1) 3634 (same-elements? (hashtable-values $ght) $ght-vals1) 3635 (equal-entries? $ght $ght-keys1 $ght-vals1) 3636 (same-elements? (hashtable-cells $ght) (vector-map cons $ght-keys1 $ght-vals1)) 3637 (begin 3638 (define $ght-keys2 '#((a . b) (1 . 2) 3/4 3.4 3.5 1e23 #e1e50 1+1i 3+3.2i -15 #e1e-50 #1=(a . #1#) (#2=(#2# b c)))) 3639 (define $ght-vals2 '#(a b c d e f g h i j k l m)) 3640 (vector-for-each 3641 (lambda (x i) (hashtable-set! $ght x i)) 3642 $ght-keys2 3643 $ght-vals2) 3644 (eq? (hashtable-size $ght) (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))) 3645 (> (#%$hashtable-veclen $ght) 8) 3646 (equal-entries? $ght ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2)) 3647 #;(same-elements? 3648 (list->vector (hashtable-map $ght cons)) 3649 (vector-map cons ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2))) 3650 #;(same-elements? 3651 (let ([v (make-vector (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))] [i 0]) 3652 (hashtable-for-each $ght (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 3653 v) 3654 (vector-map cons ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2))) 3655 #;(same-elements? 3656 (let ([v (make-vector (+ (vector-length $ght-keys1) (vector-length $ght-keys2)))] [i 0]) 3657 (hashtable-for-each-cell $ght (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 3658 v) 3659 (vector-map cons ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2))) 3660 ($vector-andmap 3661 (lambda (k v) (equal? (hashtable-ref $ght k #f) v)) 3662 $ght-keys1 3663 $ght-vals1) 3664 ($vector-andmap 3665 (lambda (k v) (equal? (hashtable-ref $ght k #f) v)) 3666 $ght-keys2 3667 $ght-vals2) 3668 ($vector-andmap 3669 (lambda (k v) (equal? (hashtable-ref $ght k #f) v)) 3670 '#((a . b) (1 . 2) 3/4 3.4 3.5 1e23 #e1e50 1+1i 3+3.2i -15 #e1e-50 #3=(a . #3#) (#4=(#4# b c))) 3671 $ght-vals2) 3672 ($vector-andmap 3673 (lambda (k) (hashtable-contains? $ght k)) 3674 $ght-keys1) 3675 ($vector-andmap 3676 (lambda (k) (hashtable-contains? $ght k)) 3677 $ght-keys2) 3678 (not (hashtable-contains? $ght '(not a key))) 3679 (eq? (hashtable-ref $ght '(not a key) 'not-a-key) 'not-a-key) 3680 (begin 3681 (define $ght2 (hashtable-copy $ght)) 3682 (and (hashtable? $ght2) 3683 (not (hashtable-mutable? $ght2)) 3684 (not (hashtable-weak? $ght2)) 3685 (not (hashtable-ephemeron? $ght2)))) 3686 (eq? (hashtable-hash-function $ght) equal-hash) 3687 (eq? (hashtable-equivalence-function $ght) equal?) 3688 (begin 3689 (define $ght3 (hashtable-copy $ght #t)) 3690 (and (hashtable? $ght3) 3691 (hashtable-mutable? $ght3) 3692 (not (hashtable-weak? $ght3)) 3693 (not (hashtable-ephemeron? $ght3)))) 3694 (eq? (hashtable-hash-function $ght) equal-hash) 3695 (eq? (hashtable-equivalence-function $ght) equal?) 3696 (begin 3697 (vector-for-each 3698 (lambda (k) (hashtable-delete! $ght k)) 3699 $ght-keys1) 3700 #t) 3701 (equal-entries? $ght $ght-keys2 $ght-vals2) 3702 (eqv? (hashtable-size $ght) (vector-length $ght-keys2)) 3703 (begin 3704 (vector-for-each 3705 (lambda (k) (hashtable-delete! $ght k)) 3706 $ght-keys2) 3707 #t) 3708 (equal-entries? $ght '#() '#()) 3709 (eqv? (hashtable-size $ght) 0) 3710 (eqv? (#%$hashtable-veclen $ght) 8) 3711 ; make sure copies are unaffected by deletions 3712 (eq? (hashtable-size $ght2) (+ (vector-length $ght-keys1) (vector-length $ght-keys2))) 3713 (equal-entries? $ght2 ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2)) 3714 (eq? (hashtable-size $ght3) (+ (vector-length $ght-keys1) (vector-length $ght-keys2))) 3715 (equal-entries? $ght3 ($vector-append $ght-keys1 $ght-keys2) ($vector-append $ght-vals1 $ght-vals2)) 3716 (begin 3717 (hashtable-clear! $ght3) 3718 (and 3719 (eqv? (hashtable-size $ght3) 0) 3720 (eqv? (hashtable-size $ght2) (+ (vector-length $ght-keys1) (vector-length $ght-keys2))))) 3721 (error? ; not mutable 3722 (hashtable-clear! $ght2)) 3723 (error? ; not mutable 3724 (hashtable-delete! $ght2 (vector-ref $ght-keys2 0))) 3725 (error? ; not mutable 3726 (hashtable-update! $ght2 (vector-ref $ght-keys2 0) 3727 (lambda (x) (cons x x)) 3728 'oops)) 3729 (error? ; not mutable 3730 (hashtable-update! $ght2 '(not a key) 3731 (lambda (x) (cons x x)) 3732 'oops)) 3733 (eqv? 3734 (hashtable-update! $ght3 '(a . b) 3735 (lambda (x) (+ x 15)) 3736 17) 3737 (void)) 3738 (eqv? 3739 (hashtable-update! $ght3 '(a . b) 3740 (lambda (x) (+ x 29)) 3741 17) 3742 (void)) 3743 (eqv? 3744 (hashtable-update! $ght3 1e23 3745 (lambda (x) (- x 5)) 3746 19) 3747 (void)) 3748 (equal? 3749 (let ([a (hashtable-cell $ght3 '(a . b) 17)]) 3750 (set-cdr! a (+ (cdr a) 100)) 3751 a) 3752 '((a . b) . 161)) 3753 (equal? 3754 (let ([a (hashtable-cell $ght3 #vu8(1 2 3) 'bv)]) 3755 (set-cdr! a (cons (cdr a) 'vb)) 3756 a) 3757 '(#vu8(1 2 3) . (bv . vb))) 3758 (eq? (hashtable-cell $ght3 #vu8(1 2 3) 'bv) 3759 (hashtable-ref-cell $ght3 #vu8(1 2 3))) 3760 (eq? (hashtable-ref-cell $ght3 (gensym)) #f) 3761 (equal-entries? $ght3 '#((a . b) 1e23 #vu8(1 2 3)) '#(161 14 (bv . vb))) 3762 (let () ; carl's test program, with a few additions 3763 (define cov:prof-hash 3764 (lambda (V) 3765 (* (vector-ref V 0) (vector-ref V 1) (vector-ref V 2)))) 3766 (define cov:prof-equal? 3767 (lambda (V W) 3768 (let ((rv (and (= (vector-ref V 0) (vector-ref W 0)) 3769 (= (vector-ref V 1) (vector-ref W 1)) 3770 (= (vector-ref V 2) (vector-ref W 2))))) 3771 rv))) 3772 (define make-random-vector-key 3773 (lambda () 3774 (vector (random 20000) (random 100) (random 1000)))) 3775 (define test-hash 3776 (lambda (n) 3777 (let ([ht (make-hashtable cov:prof-hash cov:prof-equal?)]) 3778 (let loop ([i 0]) 3779 (let ([str (make-random-vector-key)]) 3780 (hashtable-set! ht str i) 3781 (hashtable-update! ht str (lambda (x) (* x 2)) -1) 3782 (let ([a (hashtable-cell ht str 'a)]) (set-cdr! a (- (cdr a)))) 3783 (cond 3784 [(= i n) (= (hashtable-size ht) 1000)] 3785 [(and (hashtable-contains? ht str) 3786 (= (hashtable-ref ht str #f) (* i -2))) 3787 (when (= (hashtable-size ht) 1000) 3788 (hashtable-delete! ht str)) 3789 (loop (+ i 1))] 3790 [else (errorf 'test-hash "hashtable failure for key ~s" str)])))))) 3791 (test-hash 100000)) 3792) 3793 3794(mat generic-hashtable-arguments 3795 (error? ; wrong argument count 3796 (make-weak-hashtable)) 3797 (error? ; wrong argument count 3798 (make-weak-hashtable equal-hash)) 3799 (error? ; wrong argument count 3800 (make-weak-hashtable equal-hash equal? 45 53)) 3801 (error? ; not a procedure 3802 (make-weak-hashtable 'a equal? 45)) 3803 (error? ; not a procedure 3804 (make-weak-hashtable equal-hash 'a 45)) 3805 (error? ; invalid size 3806 (make-weak-hashtable equal-hash equal? 'a)) 3807 (error? ; invalid size 3808 (make-weak-hashtable equal-hash equal? -45)) 3809 (error? ; invalid size 3810 (make-weak-hashtable equal-hash equal? 45.0)) 3811 (error? ; wrong argument count 3812 (make-ephemeron-hashtable)) 3813 (error? ; wrong argument count 3814 (make-ephemeron-hashtable equal-hash)) 3815 (error? ; wrong argument count 3816 (make-ephemeron-hashtable equal-hash equal? 45 53)) 3817 (error? ; not a procedure 3818 (make-ephemeron-hashtable 'a equal? 45)) 3819 (error? ; not a procedure 3820 (make-ephemeron-hashtable equal-hash 'a 45)) 3821 (error? ; invalid size 3822 (make-ephemeron-hashtable equal-hash equal? 'a)) 3823 (error? ; invalid size 3824 (make-ephemeron-hashtable equal-hash equal? -45)) 3825 (error? ; invalid size 3826 (make-ephemeron-hashtable equal-hash equal? 45.0))) 3827 3828(mat weak-equal-hashtable 3829 (begin 3830 (define ka (list 'a)) 3831 (define kb (list 'b)) 3832 (define kc (list 'c)) 3833 (define kq (list 'q)) 3834 (define ky (list 'y)) 3835 (define kz (list 'z)) 3836 (define km -5.75) 3837 (define kn 17) 3838 (define ko (+ (most-positive-fixnum) 5)) 3839 #t) 3840 (begin 3841 (define h (make-weak-hashtable equal-hash equal? 32)) 3842 (and (hashtable? h) 3843 (not (eq-hashtable? h)) 3844 (hashtable-mutable? h) 3845 (hashtable-weak? h))) 3846 (eq? (hashtable-hash-function h) equal-hash) 3847 (eq? (hashtable-equivalence-function h) equal?) 3848 (equal? (hashtable-size h) 0) 3849 (same-elements? (hashtable-keys h) '#()) 3850 (same-elements? (hashtable-values h) '#()) 3851 (equal-entries? h '#() '#()) 3852 (same-elements? (hashtable-cells h) '#()) 3853 (same-elements? (hashtable-cells h 0) '#()) 3854 (same-elements? (hashtable-cells h 10) '#()) 3855 (eqv? (hashtable-set! h ka 'aval) (void)) 3856 (equal? 3857 (list 3858 (hashtable-contains? h ka) 3859 (hashtable-contains? h kb) 3860 (hashtable-contains? h kc) 3861 (hashtable-contains? h km) 3862 (hashtable-contains? h kn) 3863 (hashtable-contains? h ko)) 3864 '(#t #f #f #f #f #f)) 3865 (eqv? (hashtable-set! h kb 'bval) (void)) 3866 (equal? 3867 (list 3868 (hashtable-contains? h ka) 3869 (hashtable-contains? h kb) 3870 (hashtable-contains? h kc) 3871 (hashtable-contains? h km) 3872 (hashtable-contains? h kn) 3873 (hashtable-contains? h ko)) 3874 '(#t #t #f #f #f #f)) 3875 (eqv? (hashtable-set! h kc 'cval) (void)) 3876 (equal? 3877 (list 3878 (hashtable-contains? h ka) 3879 (hashtable-contains? h kb) 3880 (hashtable-contains? h kc) 3881 (hashtable-contains? h km) 3882 (hashtable-contains? h kn) 3883 (hashtable-contains? h ko)) 3884 '(#t #t #t #f #f #f)) 3885 (eqv? (hashtable-set! h km 'mval) (void)) 3886 (equal? 3887 (list 3888 (hashtable-contains? h ka) 3889 (hashtable-contains? h kb) 3890 (hashtable-contains? h kc) 3891 (hashtable-contains? h km) 3892 (hashtable-contains? h kn) 3893 (hashtable-contains? h ko)) 3894 '(#t #t #t #t #f #f)) 3895 (eqv? (hashtable-set! h kn 'nval) (void)) 3896 (equal? 3897 (list 3898 (hashtable-contains? h ka) 3899 (hashtable-contains? h kb) 3900 (hashtable-contains? h kc) 3901 (hashtable-contains? h km) 3902 (hashtable-contains? h kn) 3903 (hashtable-contains? h ko)) 3904 '(#t #t #t #t #t #f)) 3905 (eqv? (hashtable-set! h ko 'oval) (void)) 3906 (equal? 3907 (list 3908 (hashtable-contains? h ka) 3909 (hashtable-contains? h kb) 3910 (hashtable-contains? h kc) 3911 (hashtable-contains? h km) 3912 (hashtable-contains? h kn) 3913 (hashtable-contains? h ko)) 3914 '(#t #t #t #t #t #t)) 3915 (equal? (hashtable-size h) 6) 3916 (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval)) 3917 #;(same-elements? 3918 (list->vector (hashtable-map h cons)) 3919 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 3920 #;(same-elements? 3921 (let ([v (make-vector 6)] [i 0]) 3922 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 3923 v) 3924 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 3925 #;(same-elements? 3926 (let ([v (make-vector 6)] [i 0]) 3927 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 3928 v) 3929 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 3930 (eq? (hashtable-ref h ka 1) 'aval) 3931 (eq? (hashtable-ref h kb #f) 'bval) 3932 (eq? (hashtable-ref h kc 'nope) 'cval) 3933 (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval) 3934 (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval) 3935 (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval) 3936 (eqv? (hashtable-delete! h kb) (void)) 3937 (equal? (hashtable-size h) 5) 3938 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 3939 (begin 3940 (define h2 (hashtable-copy h #t)) 3941 (and (hashtable? h2) 3942 (hashtable-mutable? h2) 3943 (hashtable-weak? h2))) 3944 (eq? (hashtable-hash-function h2) equal-hash) 3945 (eq? (hashtable-equivalence-function h2) equal?) 3946 (equal? (hashtable-size h2) 5) 3947 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 3948 (eqv? (hashtable-clear! h 4) (void)) 3949 (equal? 3950 (list 3951 (hashtable-size h) 3952 (hashtable-ref h ka 1) 3953 (hashtable-ref h kb #f) 3954 (hashtable-ref h kc 'nope) 3955 (hashtable-ref h km 'nope) 3956 (hashtable-ref h kn 'nope) 3957 (hashtable-ref h ko 'nope)) 3958 '(0 1 #f nope nope nope nope)) 3959 (equal-entries? h '#() '#()) 3960 (equal? 3961 (list 3962 (hashtable-size h2) 3963 (hashtable-ref h2 ka 1) 3964 (hashtable-ref h2 kb #f) 3965 (hashtable-ref h2 kc 'nope) 3966 (hashtable-ref h2 (- (+ km 1) 1) 'nope) 3967 (hashtable-ref h2 (- (+ kn 1) 1) 'nope) 3968 (hashtable-ref h2 (- (+ ko 1) 1) 'nope)) 3969 '(5 aval #f cval mval nval oval)) 3970 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 3971 (eqv? 3972 (hashtable-update! h kq 3973 (lambda (x) (+ x 1)) 3974 17) 3975 (void)) 3976 (equal? (hashtable-ref h kq #f) 18) 3977 (eqv? 3978 (hashtable-update! h kq 3979 (lambda (x) (+ x 1)) 3980 17) 3981 (void)) 3982 (equal? (hashtable-ref h kq #f) 19) 3983 (equal? (hashtable-size h) 1) 3984 (equal-entries? h '#((q)) '#(19)) 3985 (eqv? 3986 (begin 3987 (set! kq (void)) 3988 (collect (collect-maximum-generation)) 3989 (hashtable-size h)) 3990 0) 3991 (equal-entries? h '#() '#()) 3992 (equal? (hashtable-ref h ky #f) #f) 3993 (eqv? 3994 (hashtable-set! h ky 'toad) 3995 (void)) 3996 (equal? (hashtable-ref h ky #f) 'toad) 3997 (equal? (hashtable-ref h kz #f) #f) 3998 (eqv? 3999 (hashtable-update! h kz list 'frog) 4000 (void)) 4001 (equal? (hashtable-ref h kz #f) '(frog)) 4002 (equal-entries? 4003 h 4004 (vector kz ky) 4005 (vector (hashtable-ref h kz #f) 'toad)) 4006 (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) 4007 (begin 4008 (define h3 (hashtable-copy h2 #f)) 4009 (and (hashtable? h3) 4010 (not (hashtable-mutable? h3)) 4011 (hashtable-weak? h3))) 4012 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4013 (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4014 (equal? 4015 (begin 4016 (set! ka (void)) 4017 (set! km (void)) 4018 (set! kn (void)) 4019 (set! ko (void)) 4020 (collect (collect-maximum-generation)) 4021 (list (hashtable-size h2) (hashtable-size h3))) 4022 '(2 2)) 4023 (equal-entries? h2 `#((c) 17) '#(cval nval)) 4024 (equal-entries? h3 `#((c) 17) '#(cval nval)) 4025 (eqv? 4026 (begin 4027 (set! h3 (void)) 4028 (collect (collect-maximum-generation)) 4029 (hashtable-size h2)) 4030 2) 4031 (equal-entries? h2 `#((c) 17) '#(cval nval)) 4032 4033 ; test for proper shrinkage 4034 (equal? 4035 (let ([ht (make-weak-hashtable equal-hash equal? 32)]) 4036 (for-each 4037 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 4038 (let ([k** (map (lambda (x) (map list (make-list 1000))) 4039 (make-list 100))]) 4040 (for-each 4041 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 4042 k**) 4043 k**)) 4044 (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) 4045 '(32 . 32)) 4046 4047 ; test for proper shrinkage as objects are bwp'd 4048 ; uses delete to trigger final shrinkage 4049 (equal? 4050 (let ([ht (make-weak-hashtable equal-hash equal? 32)]) 4051 (hashtable-set! ht 'a 'b) 4052 (for-each 4053 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 4054 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 4055 (collect (collect-maximum-generation)) 4056 (hashtable-delete! ht 'a) 4057 (list (hashtable-size ht) 4058 (let-values ([(n1 n2) (#%$hashtable-veclen ht)]) 4059 (= n1 n2 32)))) 4060 '(0 #t)) 4061 ) 4062 4063(mat ephemeron-equal-hashtable 4064 (begin 4065 (define ka (list 'a)) 4066 (define kb (list 'b)) 4067 (define kc (list 'c)) 4068 (define kq (list 'q)) 4069 (define ky (list 'y)) 4070 (define kz (list 'z)) 4071 (define km -5.75) 4072 (define kn 17) 4073 (define ko (+ (most-positive-fixnum) 5)) 4074 #t) 4075 (begin 4076 (define h (make-ephemeron-hashtable equal-hash equal? 32)) 4077 (and (hashtable? h) 4078 (not (eq-hashtable? h)) 4079 (hashtable-mutable? h) 4080 (hashtable-ephemeron? h))) 4081 (eq? (hashtable-hash-function h) equal-hash) 4082 (eq? (hashtable-equivalence-function h) equal?) 4083 (equal? (hashtable-size h) 0) 4084 (same-elements? (hashtable-keys h) '#()) 4085 (same-elements? (hashtable-values h) '#()) 4086 (equal-entries? h '#() '#()) 4087 (same-elements? (hashtable-cells h) '#()) 4088 (same-elements? (hashtable-cells h 0) '#()) 4089 (same-elements? (hashtable-cells h 10) '#()) 4090 (eqv? (hashtable-set! h ka 'aval) (void)) 4091 (equal? 4092 (list 4093 (hashtable-contains? h ka) 4094 (hashtable-contains? h kb) 4095 (hashtable-contains? h kc) 4096 (hashtable-contains? h km) 4097 (hashtable-contains? h kn) 4098 (hashtable-contains? h ko)) 4099 '(#t #f #f #f #f #f)) 4100 (eqv? (hashtable-set! h kb 'bval) (void)) 4101 (equal? 4102 (list 4103 (hashtable-contains? h ka) 4104 (hashtable-contains? h kb) 4105 (hashtable-contains? h kc) 4106 (hashtable-contains? h km) 4107 (hashtable-contains? h kn) 4108 (hashtable-contains? h ko)) 4109 '(#t #t #f #f #f #f)) 4110 (eqv? (hashtable-set! h kc 'cval) (void)) 4111 (equal? 4112 (list 4113 (hashtable-contains? h ka) 4114 (hashtable-contains? h kb) 4115 (hashtable-contains? h kc) 4116 (hashtable-contains? h km) 4117 (hashtable-contains? h kn) 4118 (hashtable-contains? h ko)) 4119 '(#t #t #t #f #f #f)) 4120 (eqv? (hashtable-set! h km 'mval) (void)) 4121 (equal? 4122 (list 4123 (hashtable-contains? h ka) 4124 (hashtable-contains? h kb) 4125 (hashtable-contains? h kc) 4126 (hashtable-contains? h km) 4127 (hashtable-contains? h kn) 4128 (hashtable-contains? h ko)) 4129 '(#t #t #t #t #f #f)) 4130 (eqv? (hashtable-set! h kn 'nval) (void)) 4131 (equal? 4132 (list 4133 (hashtable-contains? h ka) 4134 (hashtable-contains? h kb) 4135 (hashtable-contains? h kc) 4136 (hashtable-contains? h km) 4137 (hashtable-contains? h kn) 4138 (hashtable-contains? h ko)) 4139 '(#t #t #t #t #t #f)) 4140 (eqv? (hashtable-set! h ko 'oval) (void)) 4141 (equal? 4142 (list 4143 (hashtable-contains? h ka) 4144 (hashtable-contains? h kb) 4145 (hashtable-contains? h kc) 4146 (hashtable-contains? h km) 4147 (hashtable-contains? h kn) 4148 (hashtable-contains? h ko)) 4149 '(#t #t #t #t #t #t)) 4150 (equal? (hashtable-size h) 6) 4151 (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval)) 4152 #;(same-elements? 4153 (list->vector (hashtable-map h cons)) 4154 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 4155 #;(same-elements? 4156 (let ([v (make-vector 6)] [i 0]) 4157 (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) 4158 v) 4159 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 4160 #;(same-elements? 4161 (let ([v (make-vector 6)] [i 0]) 4162 (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) 4163 v) 4164 `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) 4165 (eq? (hashtable-ref h ka 1) 'aval) 4166 (eq? (hashtable-ref h kb #f) 'bval) 4167 (eq? (hashtable-ref h kc 'nope) 'cval) 4168 (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval) 4169 (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval) 4170 (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval) 4171 (eqv? (hashtable-delete! h kb) (void)) 4172 (equal? (hashtable-size h) 5) 4173 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4174 (begin 4175 (define h2 (hashtable-copy h #t)) 4176 (and (hashtable? h2) 4177 (hashtable-mutable? h2) 4178 (hashtable-ephemeron? h2))) 4179 (eq? (hashtable-hash-function h2) equal-hash) 4180 (eq? (hashtable-equivalence-function h2) equal?) 4181 (equal? (hashtable-size h2) 5) 4182 (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4183 (eqv? (hashtable-clear! h 4) (void)) 4184 (equal? 4185 (list 4186 (hashtable-size h) 4187 (hashtable-ref h ka 1) 4188 (hashtable-ref h kb #f) 4189 (hashtable-ref h kc 'nope) 4190 (hashtable-ref h km 'nope) 4191 (hashtable-ref h kn 'nope) 4192 (hashtable-ref h ko 'nope)) 4193 '(0 1 #f nope nope nope nope)) 4194 (equal-entries? h '#() '#()) 4195 (equal? 4196 (list 4197 (hashtable-size h2) 4198 (hashtable-ref h2 ka 1) 4199 (hashtable-ref h2 kb #f) 4200 (hashtable-ref h2 kc 'nope) 4201 (hashtable-ref h2 (- (+ km 1) 1) 'nope) 4202 (hashtable-ref h2 (- (+ kn 1) 1) 'nope) 4203 (hashtable-ref h2 (- (+ ko 1) 1) 'nope)) 4204 '(5 aval #f cval mval nval oval)) 4205 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4206 (eqv? 4207 (hashtable-update! h kq 4208 (lambda (x) (+ x 1)) 4209 17) 4210 (void)) 4211 (equal? (hashtable-ref h kq #f) 18) 4212 (eqv? 4213 (hashtable-update! h kq 4214 (lambda (x) (+ x 1)) 4215 17) 4216 (void)) 4217 (equal? (hashtable-ref h kq #f) 19) 4218 (equal? (hashtable-size h) 1) 4219 (equal-entries? h '#((q)) '#(19)) 4220 (eqv? 4221 (begin 4222 (set! kq (void)) 4223 (collect (collect-maximum-generation)) 4224 (hashtable-size h)) 4225 0) 4226 (equal-entries? h '#() '#()) 4227 (equal? (hashtable-ref h ky #f) #f) 4228 (eqv? 4229 (hashtable-set! h ky 'toad) 4230 (void)) 4231 (equal? (hashtable-ref h ky #f) 'toad) 4232 (equal? (hashtable-ref h kz #f) #f) 4233 (eqv? 4234 (hashtable-update! h kz list 'frog) 4235 (void)) 4236 (equal? (hashtable-ref h kz #f) '(frog)) 4237 (equal-entries? 4238 h 4239 (vector kz ky) 4240 (vector (hashtable-ref h kz #f) 'toad)) 4241 (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) 4242 (begin 4243 (define h3 (hashtable-copy h2 #f)) 4244 (and (hashtable? h3) 4245 (not (hashtable-mutable? h3)) 4246 (hashtable-ephemeron? h3))) 4247 (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4248 (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) 4249 (equal? 4250 (begin 4251 (set! ka (void)) 4252 (set! km (void)) 4253 (set! kn (void)) 4254 (set! ko (void)) 4255 (collect (collect-maximum-generation)) 4256 (list (hashtable-size h2) (hashtable-size h3))) 4257 '(2 2)) 4258 (equal-entries? h2 `#((c) 17) '#(cval nval)) 4259 (equal-entries? h3 `#((c) 17) '#(cval nval)) 4260 (eqv? 4261 (begin 4262 (set! h3 (void)) 4263 (collect (collect-maximum-generation)) 4264 (hashtable-size h2)) 4265 2) 4266 (equal-entries? h2 `#((c) 17) '#(cval nval)) 4267 4268 ; test for proper shrinkage 4269 (equal? 4270 (let ([ht (make-ephemeron-hashtable equal-hash equal? 32)]) 4271 (for-each 4272 (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) 4273 (let ([k** (map (lambda (x) (map list (make-list 1000))) 4274 (make-list 100))]) 4275 (for-each 4276 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 4277 k**) 4278 k**)) 4279 (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) 4280 '(32 . 32)) 4281 4282 ; test for proper shrinkage as objects are bwp'd 4283 ; uses delete to trigger final shrinkage 4284 (equal? 4285 (let ([ht (make-ephemeron-hashtable equal-hash equal? 32)]) 4286 (hashtable-set! ht 'a 'b) 4287 (for-each 4288 (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) 4289 (map (lambda (x) (map list (make-list 1000))) (make-list 100))) 4290 (collect (collect-maximum-generation)) 4291 (hashtable-delete! ht 'a) 4292 (list (hashtable-size ht) 4293 (let-values ([(n1 n2) (#%$hashtable-veclen ht)]) 4294 (= n1 n2 32)))) 4295 '(0 #t)) 4296) 4297 4298(mat hash-functions 4299 ; equal-hash 4300 (error? ; wrong argument count 4301 (equal-hash)) 4302 (error? ; wrong argument count 4303 (equal-hash 0 0)) 4304 ; symbol-hash 4305 (error? ; wrong argument count 4306 (symbol-hash)) 4307 (error? ; wrong argument count 4308 (symbol-hash 'a 'a)) 4309 (error? ; not a symbol 4310 (symbol-hash "hello")) 4311 ; string-hash 4312 (error? ; wrong argument count 4313 (string-hash)) 4314 (error? ; wrong argument count 4315 (string-hash 'a 'a)) 4316 (error? ; not a string 4317 (string-hash 'hello)) 4318 ; string-ci-hash 4319 (error? ; wrong argument count 4320 (string-ci-hash)) 4321 (error? ; wrong argument count 4322 (string-ci-hash 'a 'a)) 4323 (error? ; not a string 4324 (string-ci-hash 'hello)) 4325 (let ([hc (equal-hash '(a b c))]) 4326 (and (integer? hc) 4327 (exact? hc) 4328 (>= hc 0) 4329 (= (equal-hash '(a b c)) hc))) 4330 (let ([hc (string-hash "hello")]) 4331 (and (integer? hc) 4332 (exact? hc) 4333 (>= hc 0) 4334 (= (string-hash "hello") hc))) 4335 (let ([hc (string-ci-hash "hello")]) 4336 (and (integer? hc) 4337 (exact? hc) 4338 (>= hc 0) 4339 (= (string-ci-hash "HelLo") hc))) 4340 (let ([hc (equal-hash (stencil-vector 3 'one 'two))]) 4341 (and (integer? hc) 4342 (exact? hc) 4343 (>= hc 0) 4344 (= (equal-hash (stencil-vector 3 'one 'two)) hc))) 4345 (let f ([ls (oblist)]) 4346 (define okay? 4347 (lambda (x) 4348 (let ([hc (symbol-hash x)]) 4349 (and (integer? hc) 4350 (exact? hc) 4351 (>= hc 0) 4352 (= (symbol-hash x) hc))))) 4353 (and (okay? (car ls)) 4354 (let g ([ls ls] [n 10]) 4355 (or (null? ls) 4356 (if (= n 0) 4357 (f ls) 4358 (g (cdr ls) (- n 1))))))) 4359 ; adapted from Flatt's r6rs tests for string-ci=? 4360 (eqv? (string-ci-hash "z") (string-ci-hash "Z")) 4361 (not (eqv? (string-ci-hash "z") (string-ci-hash "a"))) 4362 (eqv? (string-ci-hash "Stra\xDF;e") (string-ci-hash "Strasse")) 4363 (eqv? (string-ci-hash "Stra\xDF;e") (string-ci-hash "STRASSE")) 4364 (eqv? (string-ci-hash "\x39E;\x391;\x39F;\x3A3;") (string-ci-hash "\x3BE;\x3B1;\x3BF;\x3C2;")) 4365 (eqv? (string-ci-hash "\x39E;\x391;\x39F;\x3A3;") (string-ci-hash "\x3BE;\x3B1;\x3BF;\x3C3;")) 4366) 4367 4368(mat fasl-eq-hashtable 4369 ; fasling out eq hash tables 4370 (equal? 4371 (let ([x (cons 'y '!)]) 4372 (define ht (make-eq-hashtable)) 4373 (eq-hashtable-set! ht x 'because) 4374 (eq-hashtable-set! ht 'foo "foo") 4375 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 4376 (fasl-write (list x ht) p) 4377 (close-port p)) 4378 (let-values ([(x2 ht2) 4379 (apply values 4380 (call-with-port 4381 (open-file-input-port "testfile.ss") 4382 fasl-read))]) 4383 (list 4384 (eq-hashtable-weak? ht2) 4385 (eq-hashtable-ephemeron? ht2) 4386 (eq-hashtable-ref ht2 x2 #f) 4387 (eq-hashtable-ref ht2 'foo #f)))) 4388 '(#f #f because "foo")) 4389 ; fasling out weak eq hash table 4390 (equal? 4391 (with-interrupts-disabled 4392 (let ([x (cons 'y '!)]) 4393 (define ht (make-weak-eq-hashtable)) 4394 (eq-hashtable-set! ht x 'because) 4395 (eq-hashtable-set! ht 'foo "foo") 4396 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 4397 (fasl-write (list x ht) p) 4398 (close-port p)) 4399 (let-values ([(x2 ht2) 4400 (apply values 4401 (call-with-port 4402 (open-file-input-port "testfile.ss") 4403 fasl-read))]) 4404 (list 4405 (eq-hashtable-weak? ht2) 4406 (eq-hashtable-ephemeron? ht2) 4407 (eq-hashtable-ref ht2 x2 #f) 4408 (eq-hashtable-ref ht2 'foo #f))))) 4409 '(#t #f because "foo")) 4410 (equal? 4411 (let ([ht2 (cadr (call-with-port 4412 (open-file-input-port "testfile.ss") 4413 fasl-read))]) 4414 (collect (collect-maximum-generation)) 4415 (list 4416 (hashtable-keys ht2) 4417 (eq-hashtable-ref ht2 'foo #f))) 4418 '(#(foo) "foo")) 4419 ; fasling out ephemeron eq hash table 4420 (equal? 4421 (with-interrupts-disabled 4422 (let ([x (cons 'y '!)]) 4423 (define ht (make-ephemeron-eq-hashtable)) 4424 (eq-hashtable-set! ht x 'because) 4425 (eq-hashtable-set! ht 'foo "foo") 4426 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 4427 (fasl-write (list x ht) p) 4428 (close-port p)) 4429 (let-values ([(x2 ht2) 4430 (apply values 4431 (call-with-port 4432 (open-file-input-port "testfile.ss") 4433 fasl-read))]) 4434 (list 4435 (eq-hashtable-weak? ht2) 4436 (eq-hashtable-ephemeron? ht2) 4437 (eq-hashtable-ref ht2 x2 #f) 4438 (eq-hashtable-ref ht2 'foo #f))))) 4439 '(#f #t because "foo")) 4440 (equal? 4441 (let ([ht2 (cadr (call-with-port 4442 (open-file-input-port "testfile.ss") 4443 fasl-read))]) 4444 (collect (collect-maximum-generation)) 4445 (list 4446 (hashtable-keys ht2) 4447 (eq-hashtable-ref ht2 'foo #f))) 4448 '(#(foo) "foo")) 4449 ; fasling eq hash tables via compile-file 4450 (begin 4451 (with-output-to-file "testfile.ss" 4452 (lambda () 4453 (pretty-print 4454 '(module ($feh-ls $feh-ht) 4455 (define-syntax ls 4456 (let ([ls '(1 2 3)]) 4457 (lambda (x) 4458 #`(quote #,(datum->syntax #'* ls))))) 4459 (define $feh-ls ls) 4460 (define $feh-ht 4461 (let () 4462 (define-syntax a 4463 (let ([ht (make-eq-hashtable)]) 4464 (eq-hashtable-set! ht 'q 'p) 4465 (eq-hashtable-set! ht ls (cdr ls)) 4466 (eq-hashtable-set! ht (cdr ls) (cddr ls)) 4467 (eq-hashtable-set! ht (cddr ls) ls) 4468 (lambda (x) #`(quote #,(datum->syntax #'* ht))))) 4469 a))))) 4470 'replace) 4471 (compile-file "testfile") 4472 (load "testfile.so") 4473 #t) 4474 (eq? (eq-hashtable-ref $feh-ht 'q #f) 'p) 4475 (eq? (eq-hashtable-ref $feh-ht $feh-ls #f) (cdr $feh-ls)) 4476 (eq? (eq-hashtable-ref $feh-ht (cdr $feh-ls) #f) (cddr $feh-ls)) 4477 (eq? (eq-hashtable-ref $feh-ht (cddr $feh-ls) #f) $feh-ls) 4478 (begin 4479 (eq-hashtable-set! $feh-ht 'p 'r) 4480 #t) 4481 (eq? (eq-hashtable-ref $feh-ht 'p #f) 'r) 4482 (begin 4483 (eq-hashtable-set! $feh-ht 'q 'not-p) 4484 #t) 4485 (eq? (eq-hashtable-ref $feh-ht 'q #f) 'not-p) 4486) 4487 4488(mat fasl-symbol-hashtable 4489 ; fasling out symbol hash tables 4490 (equal? 4491 (let () 4492 (define ht (make-hashtable symbol-hash eq?)) 4493 (symbol-hashtable-set! ht 'why? 'because) 4494 (symbol-hashtable-set! ht 'foo "foo") 4495 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 4496 (fasl-write ht p) 4497 (close-port p)) 4498 (let ([ht2 (call-with-port (open-file-input-port "testfile.ss") fasl-read)]) 4499 (list 4500 (symbol-hashtable-ref ht2 'why? #f) 4501 (symbol-hashtable-ref ht2 'foo #f)))) 4502 '(because "foo")) 4503 (#%$fasl-file-equal? "testfile.ss" "testfile.ss") 4504 (eqv? (strip-fasl-file "testfile.ss" "testfile1.ss" (fasl-strip-options)) (void)) 4505 (#%$fasl-file-equal? "testfile.ss" "testfile1.ss") 4506 (equal? 4507 (let ([ht2 (call-with-port (open-file-input-port "testfile1.ss" (file-options compressed)) fasl-read)]) 4508 (list 4509 (symbol-hashtable-ref ht2 'why? #f) 4510 (symbol-hashtable-ref ht2 'foo #f))) 4511 '(because "foo")) 4512 (begin 4513 (call-with-port (open-file-output-port "testfile1.ss" (file-options replace)) 4514 (lambda (p) 4515 (fasl-write (call-with-port (open-file-input-port "testfile.ss") fasl-read) p))) 4516 #t) 4517 (#%$fasl-file-equal? "testfile.ss" "testfile1.ss") 4518 (#%$fasl-file-equal? "testfile1.ss" "testfile.ss") 4519 (begin 4520 (call-with-port (open-file-output-port "testfile1.ss" (file-options replace)) 4521 (lambda (p) 4522 (let ([ht (call-with-port (open-file-input-port "testfile.ss") fasl-read)]) 4523 (symbol-hashtable-set! ht 'why? 'why-not?) 4524 (fasl-write ht p)))) 4525 #t) 4526 (not (#%$fasl-file-equal? "testfile.ss" "testfile1.ss")) 4527 (not (#%$fasl-file-equal? "testfile1.ss" "testfile.ss")) 4528 (begin 4529 (call-with-port (open-file-output-port "testfile1.ss" (file-options replace)) 4530 (lambda (p) 4531 (let ([ht (call-with-port (open-file-input-port "testfile.ss") fasl-read)]) 4532 (symbol-hashtable-set! ht (gensym) 'foiled) 4533 (fasl-write ht p)))) 4534 #t) 4535 (not (#%$fasl-file-equal? "testfile.ss" "testfile1.ss")) 4536 (not (#%$fasl-file-equal? "testfile1.ss" "testfile.ss")) 4537 4538 ; fasling symbol hash tables via compile-file 4539 (begin 4540 (with-output-to-file "testfile.ss" 4541 (lambda () 4542 (pretty-print 4543 '(define $fsh-ht 4544 (let () 4545 (define-syntax a 4546 (let ([ht (make-hashtable symbol-hash symbol=?)]) 4547 (symbol-hashtable-set! ht 'q 'p) 4548 (symbol-hashtable-set! ht 'p 's) 4549 (let ([g (gensym "hello")]) 4550 (symbol-hashtable-set! ht g g) 4551 (symbol-hashtable-set! ht 'g g)) 4552 (lambda (x) #`(quote #,(datum->syntax #'* ht))))) 4553 a)))) 4554 'replace) 4555 (compile-file "testfile") 4556 (load "testfile.so") 4557 #t) 4558 (eq? (symbol-hashtable-ref $fsh-ht 'q #f) 'p) 4559 (eq? (symbol-hashtable-ref $fsh-ht 'p #f) 's) 4560 (let ([g (symbol-hashtable-ref $fsh-ht 'g #f)]) 4561 (eq? (symbol-hashtable-ref $fsh-ht g #f) g)) 4562 (eq? (symbol-hashtable-ref $fsh-ht 'spam #f) #f) 4563 (begin 4564 (symbol-hashtable-set! $fsh-ht 'p 'r) 4565 #t) 4566 (eq? (symbol-hashtable-ref $fsh-ht 'p #f) 'r) 4567 (begin 4568 (symbol-hashtable-set! $fsh-ht 'q 'not-p) 4569 #t) 4570 (eq? (symbol-hashtable-ref $fsh-ht 'q #f) 'not-p) 4571) 4572 4573(mat fasl-other-hashtable 4574 ; can't fasl out other kinds of hashtables 4575 (error? 4576 (let ([x (cons 'y '!)]) 4577 (define ht (make-eqv-hashtable)) 4578 (hashtable-set! ht x 'because) 4579 (hashtable-set! ht 'foo "foo") 4580 (hashtable-set! ht 3.1415 "pi") 4581 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 4582 (with-exception-handler 4583 (lambda (c) (close-port p) (raise-continuable c)) 4584 (lambda () (fasl-write (list x ht) p)))))) 4585 (error? 4586 (let ([x (cons 'y '!)]) 4587 (define ht (make-hashtable string-hash string=?)) 4588 (hashtable-set! ht "hello" 'goodbye) 4589 (let ([p (open-file-output-port "testfile.ss" (file-options replace))]) 4590 (with-exception-handler 4591 (lambda (c) (close-port p) (raise-continuable c)) 4592 (lambda () (fasl-write (list x ht) p)))))) 4593) 4594 4595(mat ht 4596 (begin 4597 (display-string (separate-eval `(parameterize ([source-directories 4598 (list 4599 ,*mats-dir* 4600 ,(format "~a/../s" *mats-dir*) 4601 ,(format "~a/../../s" *mats-dir*))]) 4602 (load "ht.ss")))) 4603 #t) 4604) 4605