You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1258 lines
50 KiB
Scheme
1258 lines
50 KiB
Scheme
;;; newhash.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
#|
|
|
Documentation notes:
|
|
- hashtable-copy can create immutable weak eq hashtables. an immutable weak
|
|
hashtable is immutable in the sense that it cannot be modified by
|
|
hashtable-set! or hashtable-update!, but the disappearance of key, val
|
|
pairs can be detected with hashtable-size, hashtable-keys, and
|
|
hashtable-entries.
|
|
- symbols are collectable, so weak hash tables should not be used to create
|
|
permanent associations with symbols as keys
|
|
|#
|
|
|
|
#|
|
|
; csv7:
|
|
(define make-hash-table) ; weakflag
|
|
(define hash-table?) ; x
|
|
(define put-hash-table!) ; hashtable key obj
|
|
(define get-hash-table) ; hashtable key default
|
|
(define remove-hash-table!) ; hashtable key
|
|
(define hash-table-map) ; hashtable proc
|
|
(define hash-table-for-each) ; hashtable proc
|
|
|
|
;;; r6rs:
|
|
(define make-eq-hashtable) ; [k], k >= 0
|
|
(define make-eqv-hashtable) ; [k], k >= 0
|
|
(define make-hashtable) ; hashproc equivproc [k], k >= 0
|
|
(define hashtable?) ; x
|
|
(define hashtable-size) ; hashtable
|
|
(define hashtable-ref) ; hashtable key default
|
|
(define hashtable-set!) ; hashtable key obj
|
|
(define hashtable-delete!) ; hashtable key
|
|
(define hashtable-contains?) ; hashtable key
|
|
(define hashtable-update!) ; hashtable key proc default
|
|
(define hashtable-copy) ; hashtable [mutableflag]
|
|
(define hashtable-clear!) ; hashtable [k], k >= 0
|
|
(define hashtable-keys) ; hashtable
|
|
(define hashtable-entries) ; hashtable
|
|
(define hashtable-cells) ; hashtable
|
|
(define hashtable-equivalence-function) ; hashtable
|
|
(define hashtable-hash-function) ; hashtable
|
|
(define hashtable-mutable?) ; hashtable
|
|
(define equal-hash) ; obj
|
|
(define string-hash) ; string
|
|
(define string-ci-hash) ; string
|
|
(define symbol-hash) ; symbol
|
|
|
|
;;; other generic hash operators
|
|
(define hashtable-cell)
|
|
(define hashtable-weak?) ; hashtable
|
|
(define hashtable-ephemeron?) ; hashtable
|
|
|
|
;;; eq-hashtable operators
|
|
(define make-weak-eq-hashtable) ; [k], k >= 0
|
|
(define eq-hashtable-ref) ; eq-hashtable key default
|
|
(define eq-hashtable-contains?) ; eq-hashtable key
|
|
(define eq-hashtable-set!) ; eq-hashtable key obj
|
|
(define eq-hashtable-update!) ; eq-hashtable key proc default
|
|
(define eq-hashtable-cell) ; eq-hashtable key default
|
|
(define eq-hashtable-delete!) ; eq-hashtable key
|
|
(define eq-hashtable-weak?) ; eq-hashtable
|
|
(define eq-hashtable-ephemeron?) ; eq-hashtable
|
|
|
|
;;; eq-hashtable operators
|
|
(define make-symbol-hashtable) ; [k], k >= 0
|
|
(define symbol-hashtable-ref) ; symbol-hashtable key default
|
|
(define symbol-hashtable-contains?) ; symbol-hashtable key
|
|
(define symbol-hashtable-set!) ; symbol-hashtable key obj
|
|
(define symbol-hashtable-update!) ; symbol-hashtable key proc default
|
|
(define symbol-hashtable-cell) ; symbol-hashtable key default
|
|
(define symbol-hashtable-delete!) ; symbol-hashtable key
|
|
|
|
;;; eqv-hashtable operators
|
|
(define make-weak-eqv-hashtable) ; [k], k >= 0
|
|
|
|
;;; unsafe eq-hashtable operators
|
|
(define $make-eq-hashtable) ; fxminlen subtype, fxminlen = 2^n, n >= 0
|
|
(define $eq-hashtable-keys) ; eq-hashtable
|
|
(define $eq-hashtable-values) ; eq-hashtable
|
|
(define $eq-hashtable-entries) ; eq-hashtable
|
|
(define $eq-hashtable-cells) ; eq-hashtable
|
|
(define $eq-hashtable-copy) ; eq-hashtable [mutableflag]
|
|
(define $eq-hashtable-clear!) ; eq-hashtable [fxminlen]
|
|
|
|
;;; inspection
|
|
(define $hashtable-veclen)
|
|
(define $hashtable-report)
|
|
|#
|
|
|
|
(let ()
|
|
(include "hashtable-types.ss")
|
|
|
|
(define do-hash
|
|
(lambda (hash x mask who)
|
|
; NB: the hash function should return a nonnegative exact integer.
|
|
; NB: we check only that it returns an exact integer, i.e., extend the semantics to
|
|
; NB: allow negative exact integers.
|
|
(let ([i (hash x)])
|
|
(cond
|
|
[(fixnum? i) (fxlogand i mask)]
|
|
[(bignum? i) (logand i mask)]
|
|
[else ($oops who "invalid hash-function ~s return value ~s for ~s" hash i x)]))))
|
|
|
|
(define size->minlen
|
|
(lambda (who k)
|
|
(define maxbits (fx- (fixnum-width) 4))
|
|
(cond
|
|
[(and (fixnum? k) (fx>= k 0))
|
|
(fxmax 8 (fxsll 1 (fxmin maxbits (fxlength (fx- k 1)))))]
|
|
[(and (bignum? k) (>= k 0)) (fxsll 1 maxbits)]
|
|
[else ($oops who "invalid size argument ~s" k)])))
|
|
|
|
(define $gen-hashtable-ref
|
|
(lambda (h x v who)
|
|
(let ([vec (ht-vec h)] [equiv? (gen-ht-equiv? h)])
|
|
(let loop ([b (vector-ref vec (do-hash (gen-ht-hash h) x (fx- (vector-length vec) 1) who))])
|
|
(if (null? b)
|
|
v
|
|
(let ([a (car b)])
|
|
(if (equiv? (car a) x) (cdr a) (loop (cdr b)))))))))
|
|
|
|
(define $gen-hashtable-contains?
|
|
(lambda (h x who)
|
|
(let ([vec (ht-vec h)] [equiv? (gen-ht-equiv? h)])
|
|
(let loop ([b (vector-ref vec (do-hash (gen-ht-hash h) x (fx- (vector-length vec) 1) who))])
|
|
(and (not (null? b))
|
|
(or (equiv? (caar b) x)
|
|
(loop (cdr b))))))))
|
|
|
|
(module ($gen-hashtable-set! $gen-hashtable-update! $gen-hashtable-cell $gen-hashtable-delete!)
|
|
(define-syntax incr-size!
|
|
(syntax-rules ()
|
|
[(_ h vec who)
|
|
(let ([size (fx+ (ht-size h) 1)] [n (vector-length vec)])
|
|
(ht-size-set! h size)
|
|
(when (and (fx> size n) (fx< n (fxsrl (most-positive-fixnum) 1)))
|
|
(adjust! h vec (fxsll n 1) who)))]))
|
|
|
|
(define-syntax decr-size!
|
|
(syntax-rules ()
|
|
[(_ h vec who)
|
|
(let ([size (fx- (ht-size h) 1)] [n (vector-length vec)])
|
|
(ht-size-set! h size)
|
|
(when (and (fx< size (fxsrl n 2)) (fx> n (ht-minlen h)))
|
|
(adjust! h vec (fxsrl n 1) who)))]))
|
|
|
|
(define adjust!
|
|
(lambda (h vec1 n2 who)
|
|
(let ([vec2 (make-vector n2 '())]
|
|
[mask2 (fx- n2 1)]
|
|
[hash (gen-ht-hash h)])
|
|
(vector-for-each
|
|
(lambda (b)
|
|
(for-each
|
|
(lambda (a)
|
|
(let ([hc (do-hash hash (car a) mask2 who)])
|
|
(vector-set! vec2 hc (cons a (vector-ref vec2 hc)))))
|
|
b))
|
|
vec1)
|
|
(ht-vec-set! h vec2))))
|
|
|
|
(define $gen-hashtable-set!
|
|
(lambda (h x v who)
|
|
(let ([vec (ht-vec h)] [equiv? (gen-ht-equiv? h)])
|
|
(let ([idx (do-hash (gen-ht-hash h) x (fx- (vector-length vec) 1) who)])
|
|
(let ([bucket (vector-ref vec idx)])
|
|
(let loop ([b bucket])
|
|
(if (null? b)
|
|
(begin
|
|
(vector-set! vec idx (cons (cons x v) bucket))
|
|
(incr-size! h vec who))
|
|
(let ([a (car b)])
|
|
(if (equiv? (car a) x) (set-cdr! a v) (loop (cdr b)))))))))))
|
|
|
|
(define $gen-hashtable-update!
|
|
(lambda (h x p v who)
|
|
(let ([vec (ht-vec h)] [equiv? (gen-ht-equiv? h)])
|
|
(let ([idx (do-hash (gen-ht-hash h) x (fx- (vector-length vec) 1) who)])
|
|
(let ([bucket (vector-ref vec idx)])
|
|
(let loop ([b bucket])
|
|
(if (null? b)
|
|
(begin
|
|
(vector-set! vec idx (cons (cons x (p v)) bucket))
|
|
(incr-size! h vec who))
|
|
(let ([a (car b)])
|
|
(if (equiv? (car a) x)
|
|
(set-cdr! a (p (cdr a)))
|
|
(loop (cdr b)))))))))))
|
|
|
|
(define $gen-hashtable-cell
|
|
(lambda (h x v who)
|
|
(let ([vec (ht-vec h)] [equiv? (gen-ht-equiv? h)])
|
|
(let ([idx (do-hash (gen-ht-hash h) x (fx- (vector-length vec) 1) who)])
|
|
(let ([bucket (vector-ref vec idx)])
|
|
(let loop ([b bucket])
|
|
(if (null? b)
|
|
(let ([a (cons x v)])
|
|
(vector-set! vec idx (cons a bucket))
|
|
(incr-size! h vec who)
|
|
a)
|
|
(let ([a (car b)])
|
|
(if (equiv? (car a) x)
|
|
a
|
|
(loop (cdr b)))))))))))
|
|
|
|
(define $gen-hashtable-delete!
|
|
(lambda (h x who)
|
|
(let ([vec (ht-vec h)] [equiv? (gen-ht-equiv? h)])
|
|
(let ([idx (do-hash (gen-ht-hash h) x (fx- (vector-length vec) 1) who)])
|
|
(let loop ([b (vector-ref vec idx)] [p #f])
|
|
(unless (null? b)
|
|
(let ([a (car b)])
|
|
(if (equiv? (car a) x)
|
|
(begin
|
|
(if p (set-cdr! p (cdr b)) (vector-set! vec idx (cdr b)))
|
|
(decr-size! h vec who))
|
|
(loop (cdr b) b))))))))))
|
|
|
|
(module ($gen-hashtable-copy $symbol-hashtable-copy)
|
|
(define copy-hashtable-vector
|
|
(lambda (h)
|
|
(let* ([vec1 (ht-vec h)]
|
|
[n (vector-length vec1)]
|
|
[vec2 (make-vector n '())])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n))
|
|
(vector-set! vec2 i
|
|
(map (lambda (a) (cons (car a) (cdr a)))
|
|
(vector-ref vec1 i))))
|
|
vec2)))
|
|
|
|
(define $gen-hashtable-copy
|
|
(lambda (h mutable?)
|
|
(make-gen-ht 'generic mutable? (copy-hashtable-vector h) (ht-minlen h) (ht-size h)
|
|
(gen-ht-hash h) (gen-ht-equiv? h))))
|
|
|
|
(define $symbol-hashtable-copy
|
|
(lambda (h mutable?)
|
|
(make-symbol-ht 'symbol mutable? (copy-hashtable-vector h) (ht-minlen h) (ht-size h)
|
|
(symbol-ht-equiv? h)))))
|
|
|
|
(define $ht-hashtable-clear!
|
|
(lambda (h minlen)
|
|
(ht-vec-set! h (make-vector minlen '()))
|
|
(ht-minlen-set! h minlen)
|
|
(ht-size-set! h 0)))
|
|
|
|
(define $ht-hashtable-keys
|
|
(lambda (h max-sz)
|
|
(let ([size (fxmin max-sz (ht-size h))])
|
|
(let ([keys (make-vector size)]
|
|
[vec (ht-vec h)])
|
|
(let ([n (vector-length vec)])
|
|
(let f ([i 0] [ikey 0])
|
|
(unless (or (fx= i n) (fx= ikey size))
|
|
(let g ([b (vector-ref vec i)] [ikey ikey])
|
|
(if (or (null? b) (fx= ikey size))
|
|
(f (fx+ i 1) ikey)
|
|
(begin
|
|
(vector-set! keys ikey (caar b))
|
|
(g (cdr b) (fx+ ikey 1))))))))
|
|
keys))))
|
|
|
|
(define $ht-hashtable-values
|
|
(lambda (h max-sz)
|
|
(let ([size (fxmin max-sz (ht-size h))])
|
|
(let ([vals (make-vector size)]
|
|
[vec (ht-vec h)])
|
|
(let ([n (vector-length vec)])
|
|
(let f ([i 0] [ival 0])
|
|
(unless (or (fx= i n) (fx= ival size))
|
|
(let g ([b (vector-ref vec i)] [ival ival])
|
|
(if (or (null? b) (fx= ival size))
|
|
(f (fx+ i 1) ival)
|
|
(begin
|
|
(vector-set! vals ival (cdar b))
|
|
(g (cdr b) (fx+ ival 1))))))))
|
|
vals))))
|
|
|
|
(define $ht-hashtable-entries
|
|
(lambda (h max-sz)
|
|
(let ([size (fxmin max-sz (ht-size h))])
|
|
(let ([keys (make-vector size)]
|
|
[vals (make-vector size)]
|
|
[vec (ht-vec h)])
|
|
(let ([n (vector-length vec)])
|
|
(let f ([i 0] [ikey 0])
|
|
(unless (or (fx= i n) (fx= ikey size))
|
|
(let g ([b (vector-ref vec i)] [ikey ikey])
|
|
(if (or (null? b) (fx= ikey size))
|
|
(f (fx+ i 1) ikey)
|
|
(let ([a (car b)])
|
|
(vector-set! keys ikey (car a))
|
|
(vector-set! vals ikey (cdr a))
|
|
(g (cdr b) (fx+ ikey 1))))))))
|
|
(values keys vals)))))
|
|
|
|
(define $ht-hashtable-cells
|
|
(lambda (h max-sz)
|
|
(let ([size (fxmin max-sz (ht-size h))])
|
|
(let ([cells (make-vector size)]
|
|
[vec (ht-vec h)])
|
|
(let ([n (vector-length vec)])
|
|
(let f ([i 0] [icell 0])
|
|
(unless (or (fx= i n) (fx= icell size))
|
|
(let g ([b (vector-ref vec i)] [icell icell])
|
|
(if (or (null? b) (fx= icell size))
|
|
(f (fx+ i 1) icell)
|
|
(let ([a (car b)])
|
|
(vector-set! cells icell a)
|
|
(g (cdr b) (fx+ icell 1))))))))
|
|
cells))))
|
|
|
|
(define eqv-generic?
|
|
(lambda (x)
|
|
; all numbers except fixnums must go through generic hashtable
|
|
(or (flonum? x) (bignum? x) (ratnum? x) ($exactnum? x) ($inexactnum? x))))
|
|
|
|
(define $eqv-hashtable-ref
|
|
(lambda (h x v who)
|
|
(if (eqv-generic? x)
|
|
($gen-hashtable-ref (eqv-ht-genht h) x v who)
|
|
(#3%eq-hashtable-ref (eqv-ht-eqht h) x v))))
|
|
|
|
(define $eqv-hashtable-contains?
|
|
(lambda (h x who)
|
|
(if (eqv-generic? x)
|
|
($gen-hashtable-contains? (eqv-ht-genht h) x who)
|
|
(#3%eq-hashtable-contains? (eqv-ht-eqht h) x))))
|
|
|
|
(define $eqv-hashtable-set!
|
|
(lambda (h x v who)
|
|
(if (eqv-generic? x)
|
|
($gen-hashtable-set! (eqv-ht-genht h) x v who)
|
|
(#3%eq-hashtable-set! (eqv-ht-eqht h) x v))))
|
|
|
|
(define $eqv-hashtable-update!
|
|
(lambda (h x p v who)
|
|
(if (eqv-generic? x)
|
|
($gen-hashtable-update! (eqv-ht-genht h) x p v who)
|
|
(#3%eq-hashtable-update! (eqv-ht-eqht h) x p v))))
|
|
|
|
(define $eqv-hashtable-cell
|
|
(lambda (h x v who)
|
|
(if (eqv-generic? x)
|
|
($gen-hashtable-cell (eqv-ht-genht h) x v who)
|
|
(#3%eq-hashtable-cell (eqv-ht-eqht h) x v))))
|
|
|
|
(define $eqv-hashtable-delete!
|
|
(lambda (h x who)
|
|
(if (eqv-generic? x)
|
|
($gen-hashtable-delete! (eqv-ht-genht h) x who)
|
|
(#3%eq-hashtable-delete! (eqv-ht-eqht h) x))))
|
|
|
|
(define $eqv-hashtable-copy
|
|
(lambda (h mutable?)
|
|
(make-eqv-ht 'eqv mutable?
|
|
($eq-hashtable-copy (eqv-ht-eqht h) mutable?)
|
|
($gen-hashtable-copy (eqv-ht-genht h) mutable?))))
|
|
|
|
(module ($eqv-hashtable-keys $eqv-hashtable-values $eqv-hashtable-entries $eqv-hashtable-cells)
|
|
(define vector-append
|
|
(lambda (v1 v2)
|
|
(let ([n1 (vector-length v1)] [n2 (vector-length v2)])
|
|
(if (fx= n1 0)
|
|
v2
|
|
(if (fx= n2 0)
|
|
v1
|
|
(let ([v (make-vector (fx+ n1 n2))])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n1))
|
|
(vector-set! v i (vector-ref v1 i)))
|
|
(do ([i 0 (fx+ i 1)] [j n1 (fx+ j 1)])
|
|
((fx= i n2))
|
|
(vector-set! v j (vector-ref v2 i)))
|
|
v))))))
|
|
(define $eqv-hashtable-keys
|
|
(lambda (h max-sz)
|
|
(let* ([keys1 ($eq-hashtable-keys (eqv-ht-eqht h) max-sz)]
|
|
[keys2 ($ht-hashtable-keys (eqv-ht-genht h) (fx- max-sz (vector-length keys1)))])
|
|
(vector-append keys1 keys2))))
|
|
(define $eqv-hashtable-values
|
|
(lambda (h max-sz)
|
|
(let* ([vals1 ($eq-hashtable-values (eqv-ht-eqht h) max-sz)]
|
|
[vals2 ($ht-hashtable-values (eqv-ht-genht h) (fx- max-sz (vector-length vals1)))])
|
|
(vector-append vals1 vals2))))
|
|
(define $eqv-hashtable-entries
|
|
(lambda (h max-sz)
|
|
(let*-values ([(keys1 vals1) ($eq-hashtable-entries (eqv-ht-eqht h) max-sz)]
|
|
[(keys2 vals2) ($ht-hashtable-entries (eqv-ht-genht h) (fx- max-sz (vector-length keys1)))])
|
|
(values
|
|
(vector-append keys1 keys2)
|
|
(vector-append vals1 vals2)))))
|
|
(define $eqv-hashtable-cells
|
|
(lambda (h max-sz)
|
|
(let* ([cells1 ($eq-hashtable-cells (eqv-ht-eqht h) max-sz)]
|
|
[cells2 ($ht-hashtable-cells (eqv-ht-genht h) (fx- max-sz (vector-length cells1)))])
|
|
(vector-append cells1 cells2)))))
|
|
|
|
(define number-hash
|
|
(lambda (z)
|
|
(cond
|
|
[(fixnum? z) (if (fx< z 0) (fxnot z) z)]
|
|
[(flonum? z) ($flhash z)]
|
|
[(bignum? z) (modulo z (most-positive-fixnum))]
|
|
[(ratnum? z) (number-hash (+ (* (numerator z) 5) (denominator z)))]
|
|
[else (logxor (lognot (number-hash (real-part z))) (number-hash (imag-part z)))])))
|
|
|
|
(set! $make-eq-hashtable ; assumes minlen is a power of two >= 1
|
|
(lambda (minlen subtype)
|
|
(make-eq-ht 'eq #t ($make-eqhash-vector minlen) minlen 0 subtype)))
|
|
|
|
(set-who! $hashtable-veclen
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eqv) (values (vector-length (ht-vec (eqv-ht-eqht h))) (vector-length (ht-vec (eqv-ht-genht h))))]
|
|
[else (vector-length (ht-vec h))])))
|
|
|
|
(set-who! $ht-veclen
|
|
(lambda (h)
|
|
(unless (ht? h) ($oops who "~s is not an ht" h))
|
|
(vector-length (ht-vec h))))
|
|
|
|
(set-who! $ht-minlen
|
|
(lambda (h)
|
|
(unless (ht? h) ($oops who "~s is not an ht" h))
|
|
(ht-minlen h)))
|
|
|
|
(let ()
|
|
(define report
|
|
(lambda (h bucket-length)
|
|
(define (rnd n) (/ (round (* (inexact n) 100)) 100))
|
|
(let ([vec (ht-vec h)])
|
|
(let ([n (vector-length vec)])
|
|
(let f ([i 0] [cnt 0] [m 0] [ss 0])
|
|
(if (= i n)
|
|
(let ([mean (/ cnt n)])
|
|
(printf
|
|
"size, count, max, mean, std = ~s, ~s, ~s, ~s, ~s~%"
|
|
n cnt m (rnd mean)
|
|
(rnd (* (sqrt (- (/ ss n) (* mean mean)))))))
|
|
(let ([k (bucket-length (vector-ref vec i))])
|
|
(f (+ i 1) (+ cnt k) (max k m) (+ ss (* k k))))))))))
|
|
(define eq-bucket-length
|
|
(lambda (b)
|
|
(if (fixnum? b) 0 (fx1+ (eq-bucket-length ($tlc-next b))))))
|
|
(set-who! $hashtable-report
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) (report h eq-bucket-length)]
|
|
[(eqv)
|
|
(report (eqv-ht-eqht h) eq-bucket-length)
|
|
(report (eqv-ht-genht h) length)]
|
|
[else (report h length)]))))
|
|
|
|
; csv7 interface
|
|
(set! make-hash-table
|
|
(case-lambda
|
|
[() ($make-eq-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-normal))]
|
|
[(weak?) ($make-eq-hashtable (constant hashtable-default-size)
|
|
(if weak?
|
|
(constant eq-hashtable-subtype-weak)
|
|
(constant eq-hashtable-subtype-normal)))]))
|
|
|
|
(set! hash-table?
|
|
(lambda (x)
|
|
(eq-ht? x)))
|
|
|
|
(set-who! put-hash-table!
|
|
(lambda (h x v)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(unless (xht-mutable? h) ($oops who "~s is not mutable" h))
|
|
(#3%eq-hashtable-set! h x v)))
|
|
|
|
(set-who! get-hash-table
|
|
(lambda (h x d)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(#3%eq-hashtable-ref h x d)))
|
|
|
|
(set-who! remove-hash-table!
|
|
(lambda (h x)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(unless (xht-mutable? h) ($oops who "~s is not mutable" h))
|
|
(#3%eq-hashtable-delete! h x)))
|
|
|
|
(set-who! hash-table-map
|
|
(lambda (h p)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(unless (procedure? p) ($oops who "~s is not a procedure" p))
|
|
(let-values ([(keys vals) ($eq-hashtable-entries h (most-positive-fixnum))])
|
|
(let f ([i (vector-length keys)] [ls '()])
|
|
(if (fx= i 0)
|
|
ls
|
|
(let ([i (fx- i 1)])
|
|
(f i (cons (p (vector-ref keys i) (vector-ref vals i)) ls))))))))
|
|
|
|
(set-who! hash-table-for-each
|
|
(lambda (h p)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(unless (procedure? p) ($oops who "~s is not a procedure" p))
|
|
(let-values ([(keys vals) ($eq-hashtable-entries h (most-positive-fixnum))])
|
|
(vector-for-each p keys vals))))
|
|
|
|
(set-who! make-eq-hashtable
|
|
(case-lambda
|
|
[() ($make-eq-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-normal))]
|
|
[(k) ($make-eq-hashtable (size->minlen who k) (constant eq-hashtable-subtype-normal))]))
|
|
|
|
(set-who! make-weak-eq-hashtable
|
|
(case-lambda
|
|
[() ($make-eq-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-weak))]
|
|
[(k) ($make-eq-hashtable (size->minlen who k) (constant eq-hashtable-subtype-weak))]))
|
|
|
|
(set-who! make-ephemeron-eq-hashtable
|
|
(case-lambda
|
|
[() ($make-eq-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-ephemeron))]
|
|
[(k) ($make-eq-hashtable (size->minlen who k) (constant eq-hashtable-subtype-ephemeron))]))
|
|
|
|
(let ()
|
|
(define $make-hashtable
|
|
(lambda (minlen hash equiv?)
|
|
(if (and (eq? hash symbol-hash)
|
|
(or (eq? equiv? eq?)
|
|
(eq? equiv? symbol=?)
|
|
(eq? equiv? eqv?)
|
|
(eq? equiv? equal?)))
|
|
(make-symbol-ht 'symbol #t (make-vector minlen '()) minlen 0 equiv?)
|
|
(make-gen-ht 'generic #t (make-vector minlen '()) minlen 0 hash equiv?))))
|
|
(define $make-eqv-hashtable
|
|
(lambda (minlen subtype)
|
|
(make-eqv-ht 'eqv #t
|
|
($make-eq-hashtable minlen subtype)
|
|
($make-hashtable minlen number-hash eqv?))))
|
|
(set-who! make-hashtable
|
|
(case-lambda
|
|
[(hash equiv?)
|
|
(unless (procedure? hash) ($oops who "~s is not a procedure" hash))
|
|
(unless (procedure? equiv?) ($oops who "~s is not a procedure" equiv?))
|
|
($make-hashtable (constant hashtable-default-size) hash equiv?)]
|
|
[(hash equiv? k)
|
|
(unless (procedure? hash) ($oops who "~s is not a procedure" hash))
|
|
(unless (procedure? equiv?) ($oops who "~s is not a procedure" equiv?))
|
|
($make-hashtable (size->minlen who k) hash equiv?)]))
|
|
(set-who! make-eqv-hashtable
|
|
(case-lambda
|
|
[() ($make-eqv-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-normal))]
|
|
[(k) ($make-eqv-hashtable (size->minlen who k) (constant eq-hashtable-subtype-normal))]))
|
|
(set-who! make-weak-eqv-hashtable
|
|
(case-lambda
|
|
[() ($make-eqv-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-weak))]
|
|
[(k) ($make-eqv-hashtable (size->minlen who k) (constant eq-hashtable-subtype-weak))]))
|
|
(set-who! make-ephemeron-eqv-hashtable
|
|
(case-lambda
|
|
[() ($make-eqv-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-ephemeron))]
|
|
[(k) ($make-eqv-hashtable (size->minlen who k) (constant eq-hashtable-subtype-ephemeron))])))
|
|
|
|
(set! eq-hashtable-ref
|
|
(lambda (h x v)
|
|
(unless (eq-ht? h)
|
|
($oops 'eq-hashtable-ref "~s is not an eq hashtable" h))
|
|
(#3%eq-hashtable-ref h x v)))
|
|
|
|
(set! eq-hashtable-contains?
|
|
(lambda (h x)
|
|
(unless (eq-ht? h)
|
|
($oops 'eq-hashtable-contains? "~s is not an eq hashtable" h))
|
|
(#3%eq-hashtable-contains? h x)))
|
|
|
|
(set! eq-hashtable-set!
|
|
(lambda (h x v)
|
|
(unless (eq-ht? h)
|
|
($oops 'eq-hashtable-set! "~s is not an eq hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops 'eq-hashtable-set! "~s is not mutable" h))
|
|
(#3%eq-hashtable-set! h x v)))
|
|
|
|
(set! eq-hashtable-update!
|
|
(lambda (h x p v)
|
|
(unless (eq-ht? h)
|
|
($oops 'eq-hashtable-update! "~s is not an eq hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops 'eq-hashtable-update! "~s is not mutable" h))
|
|
(unless (procedure? p)
|
|
($oops 'eq-hashtable-update! "~s is not a procedure" p))
|
|
(#3%eq-hashtable-update! h x p v)))
|
|
|
|
(set! eq-hashtable-cell
|
|
(lambda (h x v)
|
|
(unless (eq-ht? h)
|
|
($oops 'eq-hashtable-cell "~s is not an eq hashtable" h))
|
|
(#3%eq-hashtable-cell h x v)))
|
|
|
|
(set! eq-hashtable-delete!
|
|
(lambda (h x)
|
|
(unless (eq-ht? h)
|
|
($oops 'eq-hashtable-delete! "~s is not an eq hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops 'eq-hashtable-delete! "~s is not mutable" h))
|
|
(#3%eq-hashtable-delete! h x)))
|
|
|
|
(set-who! eq-hashtable-weak?
|
|
(lambda (h)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(eq? (constant eq-hashtable-subtype-weak) (eq-ht-subtype h))))
|
|
|
|
(set-who! eq-hashtable-ephemeron?
|
|
(lambda (h)
|
|
(unless (eq-ht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(eq? (constant eq-hashtable-subtype-ephemeron) (eq-ht-subtype h))))
|
|
|
|
(set-who! hashtable-weak?
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) (eq? (constant eq-hashtable-subtype-weak) (eq-ht-subtype h))]
|
|
[(eqv) (eq? (constant eq-hashtable-subtype-weak) (eq-ht-subtype (eqv-ht-eqht h)))]
|
|
[else #f])))
|
|
|
|
(set-who! hashtable-ephemeron?
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) (eq? (constant eq-hashtable-subtype-ephemeron) (eq-ht-subtype h))]
|
|
[(eqv) (eq? (constant eq-hashtable-subtype-ephemeron) (eq-ht-subtype (eqv-ht-eqht h)))]
|
|
[else #f])))
|
|
|
|
(set-who! symbol-hashtable-ref
|
|
(lambda (h x v)
|
|
(unless (symbol-ht? h) ($oops who "~s is not a symbol hashtable" h))
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-ref h x v)))
|
|
|
|
(set-who! symbol-hashtable-contains?
|
|
(lambda (h x)
|
|
(unless (symbol-ht? h) ($oops who "~s is not a symbol hashtable" h))
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-contains? h x)))
|
|
|
|
(set-who! symbol-hashtable-set!
|
|
(lambda (h x v)
|
|
(unless (symbol-ht? h) ($oops who "~s is not a symbol hashtable" h))
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(unless (xht-mutable? h) ($oops who "~s is not mutable" h))
|
|
(#3%symbol-hashtable-set! h x v)))
|
|
|
|
(set-who! symbol-hashtable-update!
|
|
(lambda (h x p v)
|
|
(unless (symbol-ht? h) ($oops who "~s is not a symbol hashtable" h))
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(unless (xht-mutable? h) ($oops who "~s is not mutable" h))
|
|
(unless (procedure? p)
|
|
($oops who "~s is not a procedure" p))
|
|
(#3%symbol-hashtable-update! h x p v)))
|
|
|
|
(set-who! symbol-hashtable-cell
|
|
(lambda (h x v)
|
|
(unless (symbol-ht? h) ($oops who "~s is not a symbol hashtable" h))
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-cell h x v)))
|
|
|
|
(set-who! symbol-hashtable-delete!
|
|
(lambda (h x)
|
|
(unless (symbol-ht? h) ($oops who "~s is not a symbol hashtable" h))
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(unless (xht-mutable? h) ($oops who "~s is not mutable" h))
|
|
(#3%symbol-hashtable-delete! h x)))
|
|
|
|
(set-who! hashtable-ref
|
|
(lambda (h x v)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) (#3%eq-hashtable-ref h x v)]
|
|
[(symbol)
|
|
(unless (symbol? x) ($oops 'symbol-hash "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-ref h x v)]
|
|
[(eqv) ($eqv-hashtable-ref h x v who)]
|
|
[else ($gen-hashtable-ref h x v who)])))
|
|
|
|
(set-who! hashtable-contains?
|
|
(lambda (h x)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) (#3%eq-hashtable-contains? h x)]
|
|
[(symbol)
|
|
(unless (symbol? x) ($oops 'symbol-hash "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-contains? h x)]
|
|
[(eqv) ($eqv-hashtable-contains? h x who)]
|
|
[else ($gen-hashtable-contains? h x who)])))
|
|
|
|
(set-who! hashtable-set!
|
|
(lambda (h x v)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops who "~s is not mutable" h))
|
|
(case (xht-type h)
|
|
[(eq) (#3%eq-hashtable-set! h x v)]
|
|
[(symbol)
|
|
(unless (symbol? x) ($oops 'symbol-hash "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-set! h x v)]
|
|
[(eqv) ($eqv-hashtable-set! h x v who)]
|
|
[else ($gen-hashtable-set! h x v who)])))
|
|
|
|
(set-who! hashtable-update!
|
|
(lambda (h x p v)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops who "~s is not mutable" h))
|
|
(unless (procedure? p)
|
|
($oops who "~s is not a procedure" p))
|
|
(case (xht-type h)
|
|
[(eq) (#3%eq-hashtable-update! h x p v)]
|
|
[(symbol)
|
|
(unless (symbol? x) ($oops 'symbol-hash "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-update! h x p v)]
|
|
[(eqv) ($eqv-hashtable-update! h x p v who)]
|
|
[else ($gen-hashtable-update! h x p v who)])))
|
|
|
|
(set-who! hashtable-cell
|
|
(lambda (h x v)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) (#3%eq-hashtable-cell h x v)]
|
|
[(symbol)
|
|
(unless (symbol? x) ($oops 'symbol-hash "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-cell h x v)]
|
|
[(eqv) ($eqv-hashtable-cell h x v who)]
|
|
[else ($gen-hashtable-cell h x v who)])))
|
|
|
|
(set-who! hashtable-delete!
|
|
(lambda (h x)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops who "~s is not mutable" h))
|
|
(case (xht-type h)
|
|
[(eq) (#3%eq-hashtable-delete! h x)]
|
|
[(symbol)
|
|
(unless (symbol? x) ($oops 'symbol-hash "~s is not a symbol" x))
|
|
(#3%symbol-hashtable-delete! h x)]
|
|
[(eqv) ($eqv-hashtable-delete! h x who)]
|
|
[else ($gen-hashtable-delete! h x who)])))
|
|
|
|
(set! hashtable-copy
|
|
(rec hashtable-copy
|
|
(case-lambda
|
|
[(h) (hashtable-copy h #f)]
|
|
[(h mutable?)
|
|
(unless (xht? h)
|
|
($oops 'hashtable-copy "~s is not a hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) ($eq-hashtable-copy h (and mutable? #t))]
|
|
[(symbol) ($symbol-hashtable-copy h (and mutable? #t))]
|
|
[(eqv) ($eqv-hashtable-copy h (and mutable? #t))]
|
|
[else ($gen-hashtable-copy h (and mutable? #t))])])))
|
|
|
|
(set-who! hashtable-clear!
|
|
(let ()
|
|
(case-lambda
|
|
[(h)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops who "~s is not mutable" h))
|
|
(case (xht-type h)
|
|
[(eq) ($eq-hashtable-clear! h (ht-minlen h))]
|
|
[(eqv)
|
|
(let ([h (eqv-ht-eqht h)]) ($eq-hashtable-clear! h (ht-minlen h)))
|
|
(let ([h (eqv-ht-genht h)]) ($ht-hashtable-clear! h (ht-minlen h)))]
|
|
[else ($ht-hashtable-clear! h (ht-minlen h))])]
|
|
[(h k)
|
|
(unless (xht? h)
|
|
($oops who "~s is not a hashtable" h))
|
|
(unless (xht-mutable? h)
|
|
($oops who "~s is not mutable" h))
|
|
(let ([minlen (size->minlen who k)])
|
|
(case (xht-type h)
|
|
[(eq) ($eq-hashtable-clear! h minlen)]
|
|
[(eqv)
|
|
($eq-hashtable-clear! (eqv-ht-eqht h) minlen)
|
|
($ht-hashtable-clear! (eqv-ht-genht h) minlen)]
|
|
[else ($ht-hashtable-clear! h minlen)]))])))
|
|
|
|
(let ()
|
|
(define (invalid-length who max-sz)
|
|
($oops who "~s is not a valid length" max-sz))
|
|
(define (invalid-table who h)
|
|
($oops who "~s is not a hashtable" h))
|
|
|
|
(define-syntax hashtable-content-dispatch
|
|
(syntax-rules ()
|
|
[(_ who $eq-hashtable-content $eqv-hashtable-content $ht-hashtable-content)
|
|
(let ()
|
|
(define (dispatch h max-sz)
|
|
(unless (xht? h) (invalid-table who h))
|
|
(case (xht-type h)
|
|
[(eq) ($eq-hashtable-content h max-sz)]
|
|
[(eqv) ($eqv-hashtable-content h max-sz)]
|
|
[else ($ht-hashtable-content h max-sz)]))
|
|
(case-lambda
|
|
[(h max-sz)
|
|
(cond
|
|
[(fixnum? max-sz)
|
|
(unless (fx>= max-sz 0) (invalid-length who max-sz))
|
|
(dispatch h max-sz)]
|
|
[(bignum? max-sz)
|
|
(unless (>= max-sz 0) (invalid-length who max-sz))
|
|
(dispatch h (most-positive-fixnum))]
|
|
[else (invalid-length who max-sz)])]
|
|
[(h) (dispatch h (most-positive-fixnum))]))]))
|
|
|
|
(set-who! hashtable-keys
|
|
(hashtable-content-dispatch who
|
|
$eq-hashtable-keys
|
|
$eqv-hashtable-keys
|
|
$ht-hashtable-keys))
|
|
|
|
(set-who! #(r6rs: hashtable-keys)
|
|
(lambda (h)
|
|
(unless (xht? h) (invalid-table who h))
|
|
(case (xht-type h)
|
|
[(eq) ($eq-hashtable-keys h (most-positive-fixnum))]
|
|
[(eqv) ($eqv-hashtable-keys h (most-positive-fixnum))]
|
|
[else ($ht-hashtable-keys h (most-positive-fixnum))])))
|
|
|
|
(set-who! hashtable-values
|
|
(hashtable-content-dispatch who
|
|
$eq-hashtable-values
|
|
$eqv-hashtable-values
|
|
$ht-hashtable-values))
|
|
|
|
(set-who! hashtable-entries
|
|
(hashtable-content-dispatch who
|
|
$eq-hashtable-entries
|
|
$eqv-hashtable-entries
|
|
$ht-hashtable-entries))
|
|
|
|
(set-who! #(r6rs: hashtable-entries)
|
|
(lambda (h)
|
|
(unless (xht? h) (invalid-table who h))
|
|
(case (xht-type h)
|
|
[(eq) ($eq-hashtable-entries h (most-positive-fixnum))]
|
|
[(eqv) ($eqv-hashtable-entries h (most-positive-fixnum))]
|
|
[else ($ht-hashtable-entries h (most-positive-fixnum))])))
|
|
|
|
(set-who! hashtable-cells
|
|
(hashtable-content-dispatch who
|
|
$eq-hashtable-cells
|
|
$eqv-hashtable-cells
|
|
$ht-hashtable-cells)))
|
|
|
|
(set! hashtable-size
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops 'hashtable-size "~s is not a hashtable" h))
|
|
(if (eq? (xht-type h) 'eqv)
|
|
(fx+ (ht-size (eqv-ht-eqht h))
|
|
(ht-size (eqv-ht-genht h)))
|
|
(ht-size h))))
|
|
|
|
(set! hashtable-mutable?
|
|
(lambda (h)
|
|
(unless (xht? h)
|
|
($oops 'hashtable-mutable? "~s is not a hashtable" h))
|
|
(xht-mutable? h)))
|
|
|
|
(set! hashtable?
|
|
(lambda (x)
|
|
(xht? x)))
|
|
|
|
(set! eq-hashtable?
|
|
(lambda (x)
|
|
(eq-ht? x)))
|
|
|
|
(set! symbol-hashtable?
|
|
(lambda (x)
|
|
(symbol-ht? x)))
|
|
|
|
(set-who! $hashtable-size->minlen
|
|
(lambda (k)
|
|
(size->minlen who k)))
|
|
|
|
(set-who! hashtable-hash-function
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq eqv) #f]
|
|
[(symbol) symbol-hash]
|
|
[else (gen-ht-hash h)])))
|
|
|
|
(set-who! hashtable-equivalence-function
|
|
(lambda (h)
|
|
(unless (xht? h) ($oops who "~s is not an eq hashtable" h))
|
|
(case (xht-type h)
|
|
[(eq) eq?]
|
|
[(symbol) (symbol-ht-equiv? h)]
|
|
[(eqv) eqv?]
|
|
[else (gen-ht-equiv? h)])))
|
|
|
|
(let ()
|
|
(define (hcabs hc) (if (fx< hc 0) (fxnot hc) hc))
|
|
|
|
(define (update hc k)
|
|
(fxlogxor (#3%fx+ (#3%fxsll hc 2) hc) k))
|
|
|
|
(define bytevector-hash
|
|
(lambda (bv)
|
|
(define (bvupdate hc bv i)
|
|
(update hc (bytevector-u8-ref bv i)))
|
|
(let ([n (bytevector-length bv)])
|
|
(if (fx<= n 16)
|
|
(do ([i 0 (fx+ i 1)] [hc 440697712 (bvupdate hc bv i)])
|
|
((fx= i n) (hcabs hc)))
|
|
(do ([i 0 (fx+ i 1)]
|
|
[hc 440697712 (bvupdate hc bv i)])
|
|
((fx= i 5)
|
|
(do ([i (fx- n 5) (fx+ i 1)]
|
|
[hc hc (bvupdate hc bv i)])
|
|
((fx= i n)
|
|
(let ([stride (fxsrl n 4)])
|
|
(do ([i 5 (fx+ i stride)]
|
|
[hc hc (bvupdate hc bv i)])
|
|
((fx>= i n) (hcabs hc))))))))))))
|
|
|
|
(set-who! string-hash
|
|
(lambda (s)
|
|
(define (strupdate hc s i)
|
|
(update hc (char->integer (string-ref s i))))
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(let ([n (string-length s)])
|
|
(if (fx<= n 16)
|
|
(do ([i 0 (fx+ i 1)] [hc 523658599 (strupdate hc s i)])
|
|
((fx= i n) (hcabs hc)))
|
|
(do ([i 0 (fx+ i 1)]
|
|
[hc 523658599 (strupdate hc s i)])
|
|
((fx= i 5)
|
|
(do ([i (fx- n 5) (fx+ i 1)]
|
|
[hc hc (strupdate hc s i)])
|
|
((fx= i n)
|
|
(let ([stride (fxsrl n 4)])
|
|
(do ([i 5 (fx+ i stride)]
|
|
[hc hc (strupdate hc s i)])
|
|
((fx>= i n) (hcabs hc))))))))))))
|
|
|
|
(set-who! string-ci-hash
|
|
(lambda (s)
|
|
(define (charupdate hc c) (update hc (char->integer c)))
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(let ([n (string-length s)])
|
|
(let f ([i 0] [hc 523658599])
|
|
(if (fx= i n)
|
|
(hcabs hc)
|
|
(let g ([c* ($string-char-foldcase (string-ref s i))] [hc hc])
|
|
(if (char? c*)
|
|
(f (fx+ i 1) (charupdate hc c*))
|
|
(g (cdr c*) (charupdate hc (car c*))))))))))
|
|
|
|
(set-who! symbol-hash
|
|
(lambda (x)
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(or ($symbol-hash x)
|
|
(and (gensym? x) (begin (gensym->unique-string x) ($symbol-hash x)))
|
|
($oops who "symbol hash is not set for ~s" x))))
|
|
|
|
(set-who! equal-hash
|
|
(lambda (x)
|
|
(define (f x hc i)
|
|
(let ([i (fx- i 1)])
|
|
(cond
|
|
[(fx<= i 0) (values hc 0)]
|
|
[(pair? x)
|
|
(let ([i/2 (fxsrl (fx+ i 1) 1)])
|
|
(let-values ([(hc i^) (f (car x) (update hc 119001092) i/2)])
|
|
(f (cdr x) hc (fx+ (fx- i i/2) i^))))]
|
|
[(vector? x)
|
|
(let ([n (vector-length x)] [hc (update hc 513566316)])
|
|
(if (fx= n 0)
|
|
(values hc i)
|
|
(let g ([j 0] [hc hc] [i i])
|
|
(if (or (fx= j n) (fx= i 0))
|
|
(values hc i)
|
|
(let ([i/2 (fxsrl (fx+ i 1) 1)])
|
|
(let-values ([(hc i^) (f (vector-ref x j) hc i/2)])
|
|
(g (fx+ j 1) hc (fx+ (fx- i i/2) i^))))))))]
|
|
[(null? x) (values (update hc 496904691) i)]
|
|
[(box? x) (f (unbox x) (update hc 410225874) i)]
|
|
[(symbol? x) (values (update hc (symbol-hash x)) i)]
|
|
[(string? x) (values (update hc (string-hash x)) i)]
|
|
[(number? x) (values (update hc (number-hash x)) i)]
|
|
[(bytevector? x) (values (update hc (bytevector-hash x)) i)]
|
|
[(boolean? x) (values (update hc (if x 336200167 307585980)) i)]
|
|
[(char? x) (values (update hc (char->integer x)) i)]
|
|
[(and ($record? x) ($record-hash-procedure x))
|
|
=> (lambda (rec-hash)
|
|
(let ([new-i i])
|
|
(let ([sub-hc (rec-hash
|
|
x
|
|
(lambda (v)
|
|
(if (fx<= new-i 0)
|
|
0
|
|
(let-values ([(sub-hc sub-i) (f v 0 i)])
|
|
(set! new-i sub-i)
|
|
sub-hc))))])
|
|
(let ([hc (update hc (if (fixnum? sub-hc)
|
|
sub-hc
|
|
(modulo (abs sub-hc) (greatest-fixnum))))])
|
|
(values hc new-i)))))]
|
|
[else (values (update hc 120634730) i)])))
|
|
(let-values ([(hc i) (f x 523658599 64)])
|
|
(hcabs hc)))))
|
|
|
|
(record-writer (type-descriptor hashtable)
|
|
(lambda (x p wr)
|
|
(display "#<hashtable>" p)))
|
|
|
|
(record-writer (type-descriptor eq-ht)
|
|
(lambda (x p wr)
|
|
(display "#<eq hashtable>" p)))
|
|
|
|
(record-writer (type-descriptor eqv-ht)
|
|
(lambda (x p wr)
|
|
(display "#<eqv hashtable>" p)))
|
|
)
|
|
|
|
;;; eq hashtable operations must be compiled with
|
|
;;; generate-interrupt-trap #f and optimize-level 3
|
|
;;; so they can't be interrupted by a collection
|
|
;;; see also library routines in library.ss
|
|
(eval-when (compile)
|
|
(generate-interrupt-trap #f)
|
|
(optimize-level 3))
|
|
|
|
(let ()
|
|
(include "hashtable-types.ss")
|
|
|
|
(set! $eq-hashtable-keys
|
|
(lambda (h max-sz)
|
|
(let ([vec (ht-vec h)] [size (fxmin max-sz (ht-size h))])
|
|
(let ([n (vector-length vec)] [keys (make-vector size)])
|
|
(let outer ([i 0] [j 0])
|
|
(if (or (fx= i n) (fx= j size))
|
|
keys
|
|
(let inner ([b (vector-ref vec i)] [j j])
|
|
(if (or (fixnum? b) (fx= j size))
|
|
(outer (fx+ i 1) j)
|
|
(let ([keyval ($tlc-keyval b)])
|
|
(vector-set! keys j (car keyval))
|
|
(inner ($tlc-next b) (fx+ j 1)))))))))))
|
|
|
|
(set! $eq-hashtable-values
|
|
(lambda (h max-sz)
|
|
(let ([vec (ht-vec h)] [size (fxmin max-sz (ht-size h))])
|
|
(let ([n (vector-length vec)] [vals (make-vector size)])
|
|
(let outer ([i 0] [j 0])
|
|
(if (or (fx= i n) (fx= j size))
|
|
vals
|
|
(let inner ([b (vector-ref vec i)] [j j])
|
|
(if (or (fixnum? b) (fx= j size))
|
|
(outer (fx+ i 1) j)
|
|
(let ([keyval ($tlc-keyval b)])
|
|
(vector-set! vals j (cdr keyval))
|
|
(inner ($tlc-next b) (fx+ j 1)))))))))))
|
|
|
|
(set! $eq-hashtable-entries
|
|
(lambda (h max-sz)
|
|
(let ([vec (ht-vec h)] [size (fxmin max-sz (ht-size h))])
|
|
(let ([n (vector-length vec)]
|
|
[keys (make-vector size)]
|
|
[vals (make-vector size)])
|
|
(let outer ([i 0] [j 0])
|
|
(if (or (fx= i n) (fx= j size))
|
|
(values keys vals)
|
|
(let inner ([b (vector-ref vec i)] [j j])
|
|
(if (or (fixnum? b) (fx= j size))
|
|
(outer (fx+ i 1) j)
|
|
(let ([keyval ($tlc-keyval b)])
|
|
(vector-set! keys j (car keyval))
|
|
(vector-set! vals j (cdr keyval))
|
|
(inner ($tlc-next b) (fx+ j 1)))))))))))
|
|
|
|
(set! $eq-hashtable-cells
|
|
(lambda (h max-sz)
|
|
(let ([vec (ht-vec h)] [size (fxmin max-sz (ht-size h))])
|
|
(let ([n (vector-length vec)] [cells (make-vector size)])
|
|
(let outer ([i 0] [j 0])
|
|
(if (or (fx= i n) (fx= j size))
|
|
cells
|
|
(let inner ([b (vector-ref vec i)] [j j])
|
|
(if (or (fixnum? b) (fx= j size))
|
|
(outer (fx+ i 1) j)
|
|
(let ([keyval ($tlc-keyval b)])
|
|
(vector-set! cells j keyval)
|
|
(inner ($tlc-next b) (fx+ j 1)))))))))))
|
|
|
|
(set! $eq-hashtable-copy
|
|
(lambda (h1 mutable?)
|
|
(let ([subtype (eq-ht-subtype h1)])
|
|
(let* ([vec1 (ht-vec h1)]
|
|
[n (vector-length vec1)]
|
|
[vec2 ($make-eqhash-vector n)]
|
|
[h2 (make-eq-ht 'eq mutable? vec2 (ht-minlen h1) (ht-size h1) subtype)])
|
|
(let outer ([i 0])
|
|
(if (fx= i n)
|
|
h2
|
|
(begin
|
|
(vector-set! vec2 i
|
|
(let inner ([b (vector-ref vec1 i)])
|
|
(if (fixnum? b)
|
|
b
|
|
($make-tlc h2
|
|
(let* ([keyval ($tlc-keyval b)] [key (car keyval)] [val (cdr keyval)])
|
|
(cond
|
|
[(eq? subtype (constant eq-hashtable-subtype-normal)) (cons key val)]
|
|
[(eq? subtype (constant eq-hashtable-subtype-weak)) (weak-cons key val)]
|
|
[else (ephemeron-cons key val)]))
|
|
(inner ($tlc-next b))))))
|
|
(outer (fx+ i 1)))))
|
|
h2))))
|
|
|
|
(set! $eq-hashtable-clear!
|
|
(lambda (h minlen)
|
|
(let* ([vec (ht-vec h)] [n (vector-length vec)])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n))
|
|
(let loop ([b (vector-ref vec i)])
|
|
(if (fixnum? b)
|
|
(vector-set! vec i i)
|
|
(let ([next ($tlc-next b)])
|
|
($set-tlc-next! b #f)
|
|
(loop next)))))
|
|
(ht-size-set! h 0)
|
|
(unless (fx= n minlen)
|
|
(ht-vec-set! h ($make-eqhash-vector minlen))))))
|
|
|
|
(let ()
|
|
;; An equal/hash mapping contains an equal or hash procedure (or #f)
|
|
;; plus the rtd where the procedure was installed. It also has a weak
|
|
;; list of uids for child rtds that have inherited the setting, in
|
|
;; case the rtd's setting changes.
|
|
(define-record-type equal/hash
|
|
(fields maybe-proc rtd (mutable inheritors))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (maybe-proc rtd)
|
|
(new maybe-proc rtd '())))))
|
|
|
|
(let ()
|
|
(define (get-equal/hash who rtd key)
|
|
(unless (record-type-descriptor? rtd)
|
|
($oops who "~s is not a record-type descriptor" rtd))
|
|
(let ([e/h ($sgetprop (record-type-uid rtd) key #f)])
|
|
(and e/h
|
|
(eq? (equal/hash-rtd e/h) rtd)
|
|
(equal/hash-maybe-proc e/h))))
|
|
(define (set-equal/hash! who rtd key proc)
|
|
(unless (record-type-descriptor? rtd)
|
|
($oops who "~s is not a record-type descriptor" rtd))
|
|
(unless (or (not proc) (procedure? proc))
|
|
($oops who "~s is not a procedure or #f" proc))
|
|
(with-tc-mutex
|
|
(let* ([uid (record-type-uid rtd)]
|
|
[old-e/h ($sgetprop uid key #f)])
|
|
;; Remove the old record from anywhere that it's inherited,
|
|
;; and a later lookup will re-inherit:
|
|
(when old-e/h
|
|
(for-each
|
|
(lambda (uid)
|
|
(unless (bwp-object? uid)
|
|
(when (eq? ($sgetprop uid key #f) old-e/h)
|
|
($sremprop uid key))))
|
|
(equal/hash-inheritors old-e/h)))
|
|
(if proc
|
|
($sputprop uid key (make-equal/hash proc rtd))
|
|
($sremprop uid key)))))
|
|
(set-who! record-type-equal-procedure
|
|
(case-lambda
|
|
[(rtd) (get-equal/hash who rtd 'equal-proc)]
|
|
[(rtd equal-proc) (set-equal/hash! who rtd 'equal-proc equal-proc)]))
|
|
(set-who! record-type-hash-procedure
|
|
(case-lambda
|
|
[(rtd) (get-equal/hash who rtd 'hash-proc)]
|
|
[(rtd hash-proc) (set-equal/hash! who rtd 'hash-proc hash-proc)])))
|
|
|
|
(let ()
|
|
;; Gets an `equal/hash` record for the given rtd, finding
|
|
;; it from a parent rtd and caching if necessary:
|
|
(define (lookup-equal/hash record key)
|
|
(let* ([rtd ($record-type-descriptor record)] [uid (record-type-uid rtd)])
|
|
; Get out quick w/o mutex if equal/hash record is present
|
|
(or ($sgetprop uid key #f)
|
|
(with-tc-mutex
|
|
(let f ([uid uid] [rtd rtd])
|
|
;; Double-check first time around to avoid a race
|
|
(or ($sgetprop uid key #f)
|
|
(let ([parent-rtd (record-type-parent rtd)])
|
|
(if parent-rtd
|
|
;; Cache parent's value, and register as an inheritor:
|
|
(let ([e/h (f (record-type-uid parent-rtd) parent-rtd)])
|
|
(equal/hash-inheritors-set! e/h (weak-cons uid (equal/hash-inheritors e/h)))
|
|
($sputprop uid key e/h)
|
|
e/h)
|
|
;; Cache an empty `equal/hash` record:
|
|
(let ([e/h (make-equal/hash #f rtd)])
|
|
($sputprop uid key e/h)
|
|
e/h)))))))))
|
|
(let ()
|
|
(define (lookup-equal-procedure record1 record2)
|
|
(let ([e/h (lookup-equal/hash record1 'equal-proc)])
|
|
(let ([proc (equal/hash-maybe-proc e/h)])
|
|
(if proc
|
|
(and
|
|
(eq? (equal/hash-rtd (lookup-equal/hash record2 'equal-proc)) (equal/hash-rtd e/h))
|
|
proc)
|
|
(let ([default-proc (default-record-equal-procedure)])
|
|
(and default-proc
|
|
(not (equal/hash-maybe-proc (lookup-equal/hash record2 'equal-proc)))
|
|
default-proc))))))
|
|
(set-who! $record-equal-procedure
|
|
(lambda (record1 record2)
|
|
(lookup-equal-procedure record1 record2)))
|
|
(set-who! record-equal-procedure
|
|
(lambda (record1 record2)
|
|
(unless ($record? record1) ($oops who "~s is not a record" record1))
|
|
(unless ($record? record2) ($oops who "~s is not a record" record2))
|
|
(lookup-equal-procedure record1 record2))))
|
|
(let ()
|
|
(define (lookup-hash-procedure record)
|
|
(or (equal/hash-maybe-proc (lookup-equal/hash record 'hash-proc))
|
|
(default-record-hash-procedure)))
|
|
(set-who! $record-hash-procedure
|
|
(lambda (record)
|
|
(lookup-hash-procedure record)))
|
|
(set-who! record-hash-procedure
|
|
(lambda (record)
|
|
(unless ($record? record) ($oops who "~s is not a record" record))
|
|
(lookup-hash-procedure record))))))
|
|
)
|