Artifact
106ca727954a3f0e36aedb3cc5c7609b4d90155c:
0000: 23 21 72 36 72 73 0a 3b 3b 20 43 6f 70 79 72 69 #!r6rs.;; Copyri
0010: 67 68 74 20 28 43 29 20 32 30 30 39 20 41 6e 64 ght (C) 2009 And
0020: 72 65 61 73 20 52 6f 74 74 6d 61 6e 6e 2e 20 41 reas Rottmann. A
0030: 6c 6c 20 72 69 67 68 74 73 20 72 65 73 65 72 76 ll rights reserv
0040: 65 64 2e 20 4c 69 63 65 6e 73 65 64 0a 3b 3b 20 ed. Licensed.;;
0050: 75 6e 64 65 72 20 61 6e 20 4d 49 54 2d 73 74 79 under an MIT-sty
0060: 6c 65 20 6c 69 63 65 6e 73 65 2e 20 53 65 65 20 le license. See
0070: 74 68 65 20 66 69 6c 65 20 4c 49 43 45 4e 53 45 the file LICENSE
0080: 20 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 6c in the original
0090: 0a 3b 3b 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 74 .;; collection t
00a0: 68 69 73 20 66 69 6c 65 20 69 73 20 64 69 73 74 his file is dist
00b0: 72 69 62 75 74 65 64 20 77 69 74 68 2e 0a 0a 28 ributed with...(
00c0: 6c 69 62 72 61 72 79 20 28 73 72 66 69 20 73 36 library (srfi s6
00d0: 39 20 62 61 73 69 63 2d 68 61 73 68 2d 74 61 62 9 basic-hash-tab
00e0: 6c 65 73 29 0a 20 20 28 65 78 70 6f 72 74 0a 20 les). (export.
00f0: 20 20 20 3b 3b 20 54 79 70 65 20 63 6f 6e 73 74 ;; Type const
0100: 72 75 63 74 6f 72 73 20 61 6e 64 20 70 72 65 64 ructors and pred
0110: 69 63 61 74 65 0a 20 20 20 20 6d 61 6b 65 2d 68 icate. make-h
0120: 61 73 68 2d 74 61 62 6c 65 20 68 61 73 68 2d 74 ash-table hash-t
0130: 61 62 6c 65 3f 20 61 6c 69 73 74 2d 3e 68 61 73 able? alist->has
0140: 68 2d 74 61 62 6c 65 0a 0a 20 20 20 20 3b 3b 20 h-table.. ;;
0150: 52 65 66 6c 65 63 74 69 76 65 20 71 75 65 72 69 Reflective queri
0160: 65 73 0a 20 20 20 20 68 61 73 68 2d 74 61 62 6c es. hash-tabl
0170: 65 2d 65 71 75 69 76 61 6c 65 6e 63 65 2d 66 75 e-equivalence-fu
0180: 6e 63 74 69 6f 6e 20 68 61 73 68 2d 74 61 62 6c nction hash-tabl
0190: 65 2d 68 61 73 68 2d 66 75 6e 63 74 69 6f 6e 0a e-hash-function.
01a0: 0a 20 20 20 20 3b 3b 20 44 65 61 6c 69 6e 67 20 . ;; Dealing
01b0: 77 69 74 68 20 73 69 6e 67 6c 65 20 65 6c 65 6d with single elem
01c0: 65 6e 74 73 0a 20 20 20 20 68 61 73 68 2d 74 61 ents. hash-ta
01d0: 62 6c 65 2d 72 65 66 20 68 61 73 68 2d 74 61 62 ble-ref hash-tab
01e0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
01f0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 0a 20 ash-table-set!.
0200: 20 20 20 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 hash-table-de
0210: 6c 65 74 65 21 20 68 61 73 68 2d 74 61 62 6c 65 lete! hash-table
0220: 2d 65 78 69 73 74 73 3f 0a 20 20 20 20 68 61 73 -exists?. has
0230: 68 2d 74 61 62 6c 65 2d 75 70 64 61 74 65 21 20 h-table-update!
0240: 68 61 73 68 2d 74 61 62 6c 65 2d 75 70 64 61 74 hash-table-updat
0250: 65 21 2f 64 65 66 61 75 6c 74 0a 0a 20 20 20 20 e!/default..
0260: 3b 3b 20 44 65 61 6c 69 6e 67 20 77 69 74 68 20 ;; Dealing with
0270: 74 68 65 20 77 68 6f 6c 65 20 63 6f 6e 74 65 6e the whole conten
0280: 74 73 0a 20 20 20 20 68 61 73 68 2d 74 61 62 6c ts. hash-tabl
0290: 65 2d 73 69 7a 65 20 68 61 73 68 2d 74 61 62 6c e-size hash-tabl
02a0: 65 2d 6b 65 79 73 20 68 61 73 68 2d 74 61 62 6c e-keys hash-tabl
02b0: 65 2d 76 61 6c 75 65 73 20 68 61 73 68 2d 74 61 e-values hash-ta
02c0: 62 6c 65 2d 77 61 6c 6b 0a 20 20 20 20 68 61 73 ble-walk. has
02d0: 68 2d 74 61 62 6c 65 2d 66 6f 6c 64 20 68 61 73 h-table-fold has
02e0: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 h-table->alist h
02f0: 61 73 68 2d 74 61 62 6c 65 2d 63 6f 70 79 20 68 ash-table-copy h
0300: 61 73 68 2d 74 61 62 6c 65 2d 6d 65 72 67 65 21 ash-table-merge!
0310: 0a 0a 20 20 20 20 3b 3b 20 48 61 73 68 69 6e 67 .. ;; Hashing
0320: 0a 20 20 20 20 68 61 73 68 20 73 74 72 69 6e 67 . hash string
0330: 2d 68 61 73 68 20 73 74 72 69 6e 67 2d 63 69 2d -hash string-ci-
0340: 68 61 73 68 20 68 61 73 68 2d 62 79 2d 69 64 65 hash hash-by-ide
0350: 6e 74 69 74 79 29 0a 20 20 28 69 6d 70 6f 72 74 ntity). (import
0360: 0a 20 20 20 20 28 72 65 6e 61 6d 65 20 28 72 6e . (rename (rn
0370: 72 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 rs).
0380: 28 73 74 72 69 6e 67 2d 68 61 73 68 20 72 6e 72 (string-hash rnr
0390: 73 3a 73 74 72 69 6e 67 2d 68 61 73 68 29 0a 20 s:string-hash).
03a0: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
03b0: 6e 67 2d 63 69 2d 68 61 73 68 20 72 6e 72 73 3a ng-ci-hash rnrs:
03c0: 73 74 72 69 6e 67 2d 63 69 2d 68 61 73 68 29 29 string-ci-hash))
03d0: 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 6b 65 2d )..(define make-
03e0: 68 61 73 68 2d 74 61 62 6c 65 0a 20 20 28 63 61 hash-table. (ca
03f0: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 se-lambda. ((
0400: 65 71 6c 3f 20 68 61 73 68 29 0a 20 20 20 20 20 eql? hash).
0410: 28 6d 61 6b 65 2d 68 61 73 68 74 61 62 6c 65 20 (make-hashtable
0420: 68 61 73 68 20 65 71 6c 3f 29 29 0a 20 20 20 20 hash eql?)).
0430: 28 28 65 71 6c 3f 29 0a 20 20 20 20 20 28 63 6f ((eql?). (co
0440: 6e 64 20 28 28 65 71 3f 20 65 71 6c 3f 20 65 71 nd ((eq? eql? eq
0450: 3f 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ?). (
0460: 6d 61 6b 65 2d 65 71 2d 68 61 73 68 74 61 62 6c make-eq-hashtabl
0470: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 e)). (
0480: 28 65 71 3f 20 65 71 6c 3f 20 65 71 76 3f 29 0a (eq? eql? eqv?).
0490: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
04a0: 65 2d 65 71 76 2d 68 61 73 68 74 61 62 6c 65 29 e-eqv-hashtable)
04b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 65 ). ((e
04c0: 71 3f 20 65 71 6c 3f 20 65 71 75 61 6c 3f 29 0a q? eql? equal?).
04d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
04e0: 65 2d 68 61 73 68 74 61 62 6c 65 20 65 71 75 61 e-hashtable equa
04f0: 6c 2d 68 61 73 68 20 65 71 6c 3f 29 29 0a 20 20 l-hash eql?)).
0500: 20 20 20 20 20 20 20 20 20 28 28 65 71 3f 20 65 ((eq? e
0510: 71 6c 3f 20 73 74 72 69 6e 67 3d 3f 29 0a 20 20 ql? string=?).
0520: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
0530: 68 61 73 68 74 61 62 6c 65 20 72 6e 72 73 3a 73 hashtable rnrs:s
0540: 74 72 69 6e 67 2d 68 61 73 68 20 65 71 6c 3f 29 tring-hash eql?)
0550: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 65 ). ((e
0560: 71 3f 20 65 71 6c 3f 20 73 74 72 69 6e 67 2d 63 q? eql? string-c
0570: 69 3d 3f 29 0a 20 20 20 20 20 20 20 20 20 20 20 i=?).
0580: 20 28 6d 61 6b 65 2d 68 61 73 68 74 61 62 6c 65 (make-hashtable
0590: 20 72 6e 72 73 3a 73 74 72 69 6e 67 2d 63 69 2d rnrs:string-ci-
05a0: 68 61 73 68 20 65 71 6c 3f 29 29 0a 20 20 20 20 hash eql?)).
05b0: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 (else.
05c0: 20 20 20 20 20 20 20 20 20 28 61 73 73 65 72 74 (assert
05d0: 69 6f 6e 2d 76 69 6f 6c 61 74 69 6f 6e 20 27 6d ion-violation 'm
05e0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 0a 20 ake-hash-table.
05f0: 20 20 20 20 20 20 20 20 20 20 20 20 22 75 6e 72 "unr
0600: 65 63 6f 67 6e 69 7a 65 64 20 65 71 75 69 76 61 ecognized equiva
0610: 6c 65 6e 63 65 20 70 72 65 64 69 63 61 74 65 22 lence predicate"
0620: 20 65 71 6c 3f 29 29 29 29 0a 20 20 20 20 28 28 eql?)))). ((
0630: 29 0a 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 ). (make-has
0640: 68 74 61 62 6c 65 20 65 71 75 61 6c 2d 68 61 73 htable equal-has
0650: 68 20 65 71 75 61 6c 3f 29 29 29 29 0a 0a 28 64 h equal?))))..(d
0660: 65 66 69 6e 65 20 68 61 73 68 2d 74 61 62 6c 65 efine hash-table
0670: 3f 20 68 61 73 68 74 61 62 6c 65 3f 29 0a 0a 28 ? hashtable?)..(
0680: 64 65 66 69 6e 65 20 6e 6f 74 2d 74 68 65 72 65 define not-there
0690: 20 28 6c 69 73 74 20 27 6e 6f 74 2d 74 68 65 72 (list 'not-ther
06a0: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6c e))..(define (al
06b0: 69 73 74 2d 3e 68 61 73 68 2d 74 61 62 6c 65 20 ist->hash-table
06c0: 61 6c 69 73 74 20 2e 20 61 72 67 73 29 0a 20 20 alist . args).
06d0: 28 6c 65 74 20 28 28 74 61 62 6c 65 20 28 61 70 (let ((table (ap
06e0: 70 6c 79 20 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ply make-hash-ta
06f0: 62 6c 65 20 61 72 67 73 29 29 29 0a 20 20 20 20 ble args))).
0700: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
0710: 61 20 28 65 6e 74 72 79 29 0a 20 20 20 20 20 20 a (entry).
0720: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 74 (hasht
0730: 61 62 6c 65 2d 75 70 64 61 74 65 21 20 74 61 62 able-update! tab
0740: 6c 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 le.
0750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0760: 20 20 20 20 20 20 28 63 61 72 20 65 6e 74 72 79 (car entry
0770: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0790: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 (lambda (x)
07a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
07b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
07c0: 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 78 (if (eq? x
07d0: 20 6e 6f 74 2d 74 68 65 72 65 29 20 28 63 64 72 not-there) (cdr
07e0: 20 65 6e 74 72 79 29 20 78 29 29 0a 20 20 20 20 entry) x)).
07f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e n
0810: 6f 74 2d 74 68 65 72 65 29 29 0a 20 20 20 20 20 ot-there)).
0820: 20 20 20 20 20 20 20 20 20 61 6c 69 73 74 29 0a alist).
0830: 20 20 20 20 74 61 62 6c 65 29 29 0a 0a 28 64 65 table))..(de
0840: 66 69 6e 65 20 68 61 73 68 2d 74 61 62 6c 65 2d fine hash-table-
0850: 65 71 75 69 76 61 6c 65 6e 63 65 2d 66 75 6e 63 equivalence-func
0860: 74 69 6f 6e 20 68 61 73 68 74 61 62 6c 65 2d 65 tion hashtable-e
0870: 71 75 69 76 61 6c 65 6e 63 65 2d 66 75 6e 63 74 quivalence-funct
0880: 69 6f 6e 29 0a 28 64 65 66 69 6e 65 20 68 61 73 ion).(define has
0890: 68 2d 74 61 62 6c 65 2d 68 61 73 68 2d 66 75 6e h-table-hash-fun
08a0: 63 74 69 6f 6e 20 68 61 73 68 74 61 62 6c 65 2d ction hashtable-
08b0: 68 61 73 68 2d 66 75 6e 63 74 69 6f 6e 29 0a 0a hash-function)..
08c0: 28 64 65 66 69 6e 65 20 28 66 61 69 6c 75 72 65 (define (failure
08d0: 2d 74 68 75 6e 6b 20 77 68 6f 20 6b 65 79 29 0a -thunk who key).
08e0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
08f0: 20 28 61 73 73 65 72 74 69 6f 6e 2d 76 69 6f 6c (assertion-viol
0900: 61 74 69 6f 6e 20 77 68 6f 20 22 6e 6f 20 61 73 ation who "no as
0910: 73 6f 63 69 61 74 69 6f 6e 20 66 6f 72 20 6b 65 sociation for ke
0920: 79 22 20 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 y" key)))..(defi
0930: 6e 65 20 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ne hash-table-re
0940: 66 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 f. (case-lambda
0950: 0a 20 20 20 20 28 28 74 61 62 6c 65 20 6b 65 79 . ((table key
0960: 20 74 68 75 6e 6b 29 0a 20 20 20 20 20 28 6c 65 thunk). (le
0970: 74 20 28 28 76 61 6c 20 28 68 61 73 68 74 61 62 t ((val (hashtab
0980: 6c 65 2d 72 65 66 20 74 61 62 6c 65 20 6b 65 79 le-ref table key
0990: 20 6e 6f 74 2d 74 68 65 72 65 29 29 29 0a 20 20 not-there))).
09a0: 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 76 61 (if (eq? va
09b0: 6c 20 6e 6f 74 2d 74 68 65 72 65 29 0a 20 20 20 l not-there).
09c0: 20 20 20 20 20 20 20 20 28 74 68 75 6e 6b 29 0a (thunk).
09d0: 20 20 20 20 20 20 20 20 20 20 20 76 61 6c 29 29 val))
09e0: 29 0a 20 20 20 20 28 28 74 61 62 6c 65 20 6b 65 ). ((table ke
09f0: 79 29 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 y). (hash-ta
0a00: 62 6c 65 2d 72 65 66 20 74 61 62 6c 65 20 6b 65 ble-ref table ke
0a10: 79 20 28 66 61 69 6c 75 72 65 2d 74 68 75 6e 6b y (failure-thunk
0a20: 20 27 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 'hash-table-ref
0a30: 20 6b 65 79 29 29 29 29 29 0a 0a 28 64 65 66 69 key)))))..(defi
0a40: 6e 65 20 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ne hash-table-re
0a50: 66 2f 64 65 66 61 75 6c 74 20 68 61 73 68 74 61 f/default hashta
0a60: 62 6c 65 2d 72 65 66 29 0a 28 64 65 66 69 6e 65 ble-ref).(define
0a70: 20 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 hash-table-set!
0a80: 20 68 61 73 68 74 61 62 6c 65 2d 73 65 74 21 29 hashtable-set!)
0a90: 0a 28 64 65 66 69 6e 65 20 68 61 73 68 2d 74 61 .(define hash-ta
0aa0: 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 61 73 68 ble-delete! hash
0ab0: 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 29 0a 28 table-delete!).(
0ac0: 64 65 66 69 6e 65 20 68 61 73 68 2d 74 61 62 6c define hash-tabl
0ad0: 65 2d 65 78 69 73 74 73 3f 20 68 61 73 68 74 61 e-exists? hashta
0ae0: 62 6c 65 2d 63 6f 6e 74 61 69 6e 73 3f 29 0a 0a ble-contains?)..
0af0: 28 64 65 66 69 6e 65 20 68 61 73 68 2d 74 61 62 (define hash-tab
0b00: 6c 65 2d 75 70 64 61 74 65 21 0a 20 20 28 63 61 le-update!. (ca
0b10: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 se-lambda. ((
0b20: 74 61 62 6c 65 20 6b 65 79 20 70 72 6f 63 20 74 table key proc t
0b30: 68 75 6e 6b 29 0a 20 20 20 20 20 28 68 61 73 68 hunk). (hash
0b40: 74 61 62 6c 65 2d 75 70 64 61 74 65 21 20 74 61 table-update! ta
0b50: 62 6c 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ble.
0b60: 20 20 20 20 20 20 20 20 20 20 20 20 6b 65 79 0a key.
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b80: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
0b90: 28 76 61 6c 29 0a 20 20 20 20 20 20 20 20 20 20 (val).
0ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0bb0: 28 69 66 20 28 65 71 3f 20 76 61 6c 20 6e 6f 74 (if (eq? val not
0bc0: 2d 74 68 65 72 65 29 0a 20 20 20 20 20 20 20 20 -there).
0bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0be0: 20 20 20 20 20 20 28 74 68 75 6e 6b 29 0a 20 20 (thunk).
0bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c00: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 6f (pro
0c10: 63 20 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 c val))).
0c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c30: 20 6e 6f 74 2d 74 68 65 72 65 29 29 0a 20 20 20 not-there)).
0c40: 20 28 28 74 61 62 6c 65 20 6b 65 79 20 70 72 6f ((table key pro
0c50: 63 29 0a 20 20 20 20 20 28 68 61 73 68 2d 74 61 c). (hash-ta
0c60: 62 6c 65 2d 75 70 64 61 74 65 21 20 74 61 62 6c ble-update! tabl
0c70: 65 20 6b 65 79 20 70 72 6f 63 20 28 66 61 69 6c e key proc (fail
0c80: 75 72 65 2d 74 68 75 6e 6b 20 27 68 61 73 68 2d ure-thunk 'hash-
0c90: 74 61 62 6c 65 2d 75 70 64 61 74 65 21 20 6b 65 table-update! ke
0ca0: 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y)))))..(define
0cb0: 68 61 73 68 2d 74 61 62 6c 65 2d 75 70 64 61 74 hash-table-updat
0cc0: 65 21 2f 64 65 66 61 75 6c 74 20 68 61 73 68 74 e!/default hasht
0cd0: 61 62 6c 65 2d 75 70 64 61 74 65 21 29 0a 0a 28 able-update!)..(
0ce0: 64 65 66 69 6e 65 20 68 61 73 68 2d 74 61 62 6c define hash-tabl
0cf0: 65 2d 73 69 7a 65 20 68 61 73 68 74 61 62 6c 65 e-size hashtable
0d00: 2d 73 69 7a 65 29 0a 0a 28 64 65 66 69 6e 65 20 -size)..(define
0d10: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
0d20: 20 74 61 62 6c 65 29 0a 20 20 28 76 65 63 74 6f table). (vecto
0d30: 72 2d 3e 6c 69 73 74 20 28 68 61 73 68 74 61 62 r->list (hashtab
0d40: 6c 65 2d 6b 65 79 73 20 74 61 62 6c 65 29 29 29 le-keys table)))
0d50: 0a 0a 28 64 65 66 69 6e 65 20 28 68 61 73 68 2d ..(define (hash-
0d60: 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 74 61 62 table-values tab
0d70: 6c 65 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 le). (let-value
0d80: 73 20 28 28 28 6b 65 79 73 20 76 61 6c 75 65 73 s (((keys values
0d90: 29 20 28 68 61 73 68 74 61 62 6c 65 2d 65 6e 74 ) (hashtable-ent
0da0: 72 69 65 73 20 74 61 62 6c 65 29 29 29 0a 20 20 ries table))).
0db0: 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 (vector->list
0dc0: 76 61 6c 75 65 73 29 29 29 0a 0a 28 64 65 66 69 values)))..(defi
0dd0: 6e 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 77 ne (hash-table-w
0de0: 61 6c 6b 20 74 61 62 6c 65 20 70 72 6f 63 29 0a alk table proc).
0df0: 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 (let-values ((
0e00: 28 6b 65 79 73 20 76 61 6c 75 65 73 29 20 28 68 (keys values) (h
0e10: 61 73 68 74 61 62 6c 65 2d 65 6e 74 72 69 65 73 ashtable-entries
0e20: 20 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 76 table))). (v
0e30: 65 63 74 6f 72 2d 66 6f 72 2d 65 61 63 68 20 70 ector-for-each p
0e40: 72 6f 63 20 6b 65 79 73 20 76 61 6c 75 65 73 29 roc keys values)
0e50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 61 73 ))..(define (has
0e60: 68 2d 74 61 62 6c 65 2d 66 6f 6c 64 20 74 61 62 h-table-fold tab
0e70: 6c 65 20 6b 6f 6e 73 20 6b 6e 69 6c 29 0a 20 20 le kons knil).
0e80: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 6b (let-values (((k
0e90: 65 79 73 20 76 61 6c 75 65 73 29 20 28 68 61 73 eys values) (has
0ea0: 68 74 61 62 6c 65 2d 65 6e 74 72 69 65 73 20 74 htable-entries t
0eb0: 61 62 6c 65 29 29 29 0a 20 20 20 20 28 6c 65 74 able))). (let
0ec0: 20 28 28 73 69 7a 65 20 28 76 65 63 74 6f 72 2d ((size (vector-
0ed0: 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 29 0a 20 length keys))).
0ee0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
0ef0: 28 69 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 (i 0).
0f00: 20 20 20 20 20 20 20 28 76 61 6c 20 6b 6e 69 6c (val knil
0f10: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
0f20: 3e 3d 20 69 20 73 69 7a 65 29 0a 20 20 20 20 20 >= i size).
0f30: 20 20 20 20 20 20 20 76 61 6c 0a 20 20 20 20 20 val.
0f40: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 (loop (+
0f50: 69 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 i 1).
0f60: 20 20 20 20 20 20 20 28 6b 6f 6e 73 20 28 76 65 (kons (ve
0f70: 63 74 6f 72 2d 72 65 66 20 6b 65 79 73 20 69 29 ctor-ref keys i)
0f80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 61 6c (vector-ref val
0f90: 75 65 73 20 69 29 20 76 61 6c 29 29 29 29 29 29 ues i) val))))))
0fa0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 61 73 68 )..(define (hash
0fb0: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 61 -table->alist ta
0fc0: 62 6c 65 29 0a 20 20 28 68 61 73 68 2d 74 61 62 ble). (hash-tab
0fd0: 6c 65 2d 66 6f 6c 64 20 74 61 62 6c 65 0a 20 20 le-fold table.
0fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ff0: 20 28 6c 61 6d 62 64 61 20 28 6b 20 76 20 6c 29 (lambda (k v l)
1000: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1010: 20 20 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6e (cons (con
1020: 73 20 6b 20 76 29 20 6c 29 29 0a 20 20 20 20 20 s k v) l)).
1030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 28 '(
1040: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 61 73 )))..(define has
1050: 68 2d 74 61 62 6c 65 2d 63 6f 70 79 20 68 61 73 h-table-copy has
1060: 68 74 61 62 6c 65 2d 63 6f 70 79 29 0a 0a 28 64 htable-copy)..(d
1070: 65 66 69 6e 65 20 28 68 61 73 68 2d 74 61 62 6c efine (hash-tabl
1080: 65 2d 6d 65 72 67 65 21 20 74 61 62 6c 65 31 20 e-merge! table1
1090: 74 61 62 6c 65 32 29 0a 20 20 28 68 61 73 68 2d table2). (hash-
10a0: 74 61 62 6c 65 2d 77 61 6c 6b 20 74 61 62 6c 65 table-walk table
10b0: 32 20 28 6c 61 6d 62 64 61 20 28 6b 20 76 29 0a 2 (lambda (k v).
10c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 (has
10e0: 68 74 61 62 6c 65 2d 73 65 74 21 20 74 61 62 6c htable-set! tabl
10f0: 65 31 20 6b 20 76 29 29 29 0a 20 20 74 61 62 6c e1 k v))). tabl
1100: 65 31 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 e1)..(define (ma
1110: 6b 65 2d 68 61 73 68 65 72 20 68 61 73 68 2d 70 ke-hasher hash-p
1120: 72 6f 63 29 0a 20 20 28 63 61 73 65 2d 6c 61 6d roc). (case-lam
1130: 62 64 61 0a 20 20 20 20 28 28 6f 62 6a 29 0a 20 bda. ((obj).
1140: 20 20 20 20 3b 3b 20 52 36 52 53 20 64 6f 65 73 ;; R6RS does
1150: 6e 27 74 20 67 75 61 72 61 6e 74 65 65 20 74 68 n't guarantee th
1160: 61 74 20 74 68 65 20 72 65 73 75 6c 74 20 6f 66 at the result of
1170: 20 74 68 65 20 68 61 73 68 20 70 72 6f 63 65 64 the hash proced
1180: 75 72 65 0a 20 20 20 20 20 3b 3b 20 69 73 20 6e ure. ;; is n
1190: 6f 6e 2d 6e 65 67 61 74 69 76 65 2c 20 73 6f 20 on-negative, so
11a0: 77 65 20 75 73 65 20 6d 6f 64 2e 0a 20 20 20 20 we use mod..
11b0: 20 28 6d 6f 64 20 28 68 61 73 68 2d 70 72 6f 63 (mod (hash-proc
11c0: 20 6f 62 6a 29 20 28 67 72 65 61 74 65 73 74 2d obj) (greatest-
11d0: 66 69 78 6e 75 6d 29 29 29 0a 20 20 20 20 28 28 fixnum))). ((
11e0: 6f 62 6a 20 62 6f 75 6e 64 29 0a 20 20 20 20 20 obj bound).
11f0: 28 6d 6f 64 20 28 68 61 73 68 2d 70 72 6f 63 20 (mod (hash-proc
1200: 6f 62 6a 29 20 62 6f 75 6e 64 29 29 29 29 0a 0a obj) bound))))..
1210: 28 64 65 66 69 6e 65 20 68 61 73 68 20 28 6d 61 (define hash (ma
1220: 6b 65 2d 68 61 73 68 65 72 20 65 71 75 61 6c 2d ke-hasher equal-
1230: 68 61 73 68 29 29 0a 28 64 65 66 69 6e 65 20 68 hash)).(define h
1240: 61 73 68 2d 62 79 2d 69 64 65 6e 74 69 74 79 20 ash-by-identity
1250: 28 6d 61 6b 65 2d 68 61 73 68 65 72 20 65 71 75 (make-hasher equ
1260: 61 6c 2d 68 61 73 68 29 29 20 20 3b 3b 20 56 65 al-hash)) ;; Ve
1270: 72 79 20 73 6c 6f 77 2e 0a 28 64 65 66 69 6e 65 ry slow..(define
1280: 20 73 74 72 69 6e 67 2d 68 61 73 68 20 28 6d 61 string-hash (ma
1290: 6b 65 2d 68 61 73 68 65 72 20 72 6e 72 73 3a 73 ke-hasher rnrs:s
12a0: 74 72 69 6e 67 2d 68 61 73 68 29 29 0a 28 64 65 tring-hash)).(de
12b0: 66 69 6e 65 20 73 74 72 69 6e 67 2d 63 69 2d 68 fine string-ci-h
12c0: 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 65 72 ash (make-hasher
12d0: 20 72 6e 72 73 3a 73 74 72 69 6e 67 2d 63 69 2d rnrs:string-ci-
12e0: 68 61 73 68 29 29 0a 0a 29 0a hash))..).