20071025 16:27:34 04:00



;;; Ikarus Scheme  A compiler for R6RS Scheme.

20080129 00:34:34 05:00



;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum

20071025 16:27:34 04:00



;;;




;;; This program is free software: you can redistribute it and/or modify




;;; it under the terms of the GNU General Public License version 3 as




;;; published by the Free Software Foundation.




;;;




;;; This program is distributed in the hope that it will be useful, but




;;; WITHOUT ANY WARRANTY; without even the implied warranty of




;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU




;;; General Public License for more details.




;;;




;;; You should have received a copy of the GNU General Public License




;;; along with this program. If not, see <http://www.gnu.org/licenses/>.





20070909 21:16:07 04:00







(library (ikarus hashtables)

20090411 14:39:53 04:00



(export makeeqhashtable makeeqvhashtable makehashtable

20081021 05:52:42 04:00



hashtableref hashtableset! hashtable?

20071210 12:00:12 05:00



hashtablesize hashtabledelete! hashtablecontains?




hashtableupdate! hashtablekeys hashtablemutable?




hashtableclear! hashtableentries hashtablecopy

20081021 05:52:42 04:00



hashtableequivalencefunction hashtablehashfunction

20071210 12:00:12 05:00



stringhash stringcihash symbolhash)




(import




(ikarus system $pairs)




(ikarus system $vectors)




(ikarus system $tcbuckets)




(ikarus system $fx)

20081021 05:52:42 04:00



(except (ikarus)

20081031 23:09:03 04:00



makeeqhashtable makeeqvhashtable makehashtable

20081021 05:52:42 04:00



hashtableref hashtableset! hashtable?

20071210 12:00:12 05:00



hashtablesize hashtabledelete! hashtablecontains?




hashtableupdate! hashtablekeys hashtablemutable?




hashtableclear! hashtableentries hashtablecopy

20081021 05:52:42 04:00



hashtableequivalencefunction hashtablehashfunction

20071210 12:00:12 05:00



stringhash stringcihash symbolhash))





20090411 14:39:53 04:00



(definestruct hasht (vec count tc mutable? hashf equivf hashf0))

20070909 21:16:07 04:00







;;; directly from Dybvig's paper




(define tcpop




(lambda (tc)




(let ([x ($car tc)])




(if (eq? x ($cdr tc))




#f




(let ([v ($car x)])




($setcar! tc ($cdr x))




($setcar! x #f)




($setcdr! x #f)




v)))))








;;; assqlike lookup




(define directlookup




(lambda (x b)




(if (fixnum? b)




#f




(if (eq? x ($tcbucketkey b))




b




(directlookup x ($tcbucketnext b))))))








(define rehashlookup




(lambda (h tc x)




(cond




[(tcpop tc) =>




(lambda (b)




(if (eq? ($tcbucketnext b) #f)




(rehashlookup h tc x)




(begin




(readd! h b)




(if (eq? x ($tcbucketkey b))




b




(rehashlookup h tc x)))))]




[else #f])))








(define getbucketindex




(lambda (b)




(let ([next ($tcbucketnext b)])




(if (fixnum? next)




next




(getbucketindex next)))))








(define replace!




(lambda (lb x y)




(let ([n ($tcbucketnext lb)])




(cond




[(eq? n x)




($settcbucketnext! lb y)




(void)]




[else




(replace! n x y)]))))








(define readd!




(lambda (h b)




(let ([vec (hashtvec h)]




[next ($tcbucketnext b)])




;;; first remove it from its old place




(let ([idx




(if (fixnum? next)




next




(getbucketindex next))])




(let ([fst ($vectorref vec idx)])




(cond




[(eq? fst b)




($vectorset! vec idx next)]




[else




(replace! fst b next)])))




;;; reset the tcbuckettconc FIRST




($settcbuckettconc! b (hashttc h))




;;; then add it to the new place




(let ([k ($tcbucketkey b)])

20071210 12:00:12 05:00



(let ([ih (pointervalue k)])

20070909 21:16:07 04:00



(let ([idx ($fxlogand ih ($fx ($vectorlength vec) 1))])




(let ([n ($vectorref vec idx)])




($settcbucketnext! b n)




($vectorset! vec idx b)




(void))))))))





20071010 07:36:19 04:00



(define (getbucket h x)

20081031 23:09:03 04:00



(define (gethashed h x ih)




(let ([equiv? (hashtequivf h)]




[vec (hashtvec h)])




(let ([idx (bitwiseand ih ($fx ($vectorlength vec) 1))])




(let f ([b ($vectorref vec idx)])




(cond




[(fixnum? b) #f]




[(equiv? x ($tcbucketkey b)) b]




[else (f ($tcbucketnext b))])))))

20081021 05:52:42 04:00



(cond




[(hashthashf h) =>




(lambda (hashf)

20081031 23:09:03 04:00



(gethashed h x (hashf x)))]




[(and (eq? eqv? (hashtequivf h)) (number? x))




(gethashed h x (numberhash x))]

20081021 05:52:42 04:00



[else




(let ([pv (pointervalue x)]




[vec (hashtvec h)])




(let ([ih pv])




(let ([idx ($fxlogand ih ($fx ($vectorlength vec) 1))])




(let ([b ($vectorref vec idx)])




(or (directlookup x b)




(rehashlookup h (hashttc h) x))))))]))

20071010 07:36:19 04:00







(define (gethash h x v)




(cond




[(getbucket h x) =>




(lambda (b) ($tcbucketval b))]




[else v]))





20071210 12:00:12 05:00



(define (inhash? h x)

20071010 07:36:19 04:00



(and (getbucket h x) #t))








(define (delhash h x)

20071125 16:23:39 05:00



(define unlink!




(lambda (h b)




(let ([vec (hashtvec h)]




[next ($tcbucketnext b)])




;;; first remove it from its old place




(let ([idx




(if (fixnum? next)




next




(getbucketindex next))])




(let ([fst ($vectorref vec idx)])




(cond




[(eq? fst b)




($vectorset! vec idx next)]




[else




(replace! fst b next)])))




;;; set next to be #f, denoting, not in table




($settcbucketnext! b #f))))

20071010 07:36:19 04:00



(cond

20071125 08:45:19 05:00



[(getbucket h x) =>

20081031 23:09:03 04:00



(lambda (b)

20071125 08:45:19 05:00



(unlink! h b)

20071125 16:23:39 05:00



;;; don't forget the count.

20071125 08:45:19 05:00



(sethashtcount! h ( (hashtcount h) 1)))]))

20071010 07:36:19 04:00




20070909 21:16:07 04:00



(define puthash!




(lambda (h x v)

20081031 23:09:03 04:00



(define (puthashed h x v ih)




(let ([equiv? (hashtequivf h)]




[vec (hashtvec h)])




(let ([idx (bitwiseand ih ($fx ($vectorlength vec) 1))])




(let f ([b ($vectorref vec idx)])




(cond




[(fixnum? b)




($vectorset! vec idx




(vector x v ($vectorref vec idx)))




(let ([ct (hashtcount h)])




(sethashtcount! h ($fxadd1 ct))




(when ($fx> ct ($vectorlength vec))




(enlargetable h)))]




[(equiv? x ($tcbucketkey b))




($settcbucketval! b v)]




[else (f ($tcbucketnext b))])))))

20081021 05:52:42 04:00



(cond




[(hashthashf h) =>




(lambda (hashf)

20081031 23:09:03 04:00



(puthashed h x v (hashf x)))]




[(and (eq? eqv? (hashtequivf h)) (number? x))




(puthashed h x v (numberhash x))]

20081021 05:52:42 04:00



[else




(let ([pv (pointervalue x)]




[vec (hashtvec h)])




(let ([ih pv])




(let ([idx ($fxlogand ih ($fx ($vectorlength vec) 1))])




(let ([b ($vectorref vec idx)])




(cond




[(or (directlookup x b) (rehashlookup h (hashttc h) x))




=>




(lambda (b)




($settcbucketval! b v)




(void))]




[else




(let ([bucket




($maketcbucket (hashttc h) x v




($vectorref vec idx))])




(if ($fx= (pointervalue x) pv)




($vectorset! vec idx bucket)




(let* ([ih (pointervalue x)]




[idx




($fxlogand ih ($fx ($vectorlength vec) 1))])




($settcbucketnext! bucket ($vectorref vec idx))




($vectorset! vec idx bucket))))




(let ([ct (hashtcount h)])




(sethashtcount! h ($fxadd1 ct))




(when ($fx> ct ($vectorlength vec))




(enlargetable h)))])))))])))

20071010 07:36:19 04:00







(define (updatehash! h x proc default)




(cond




[(getbucket h x) =>




(lambda (b) ($settcbucketval! b (proc ($tcbucketval b))))]




[else (puthash! h x (proc default))]))





20070909 21:16:07 04:00



(define enlargetable




(lambda (h)

20081021 05:52:42 04:00



(define (enlargehashtable h hashf)




(define insertb




(lambda (b vec mask)




(let* ([x ($tcbucketkey b)]




[ih (hashf x)]




[idx (bitwiseand ih mask)]




[next ($tcbucketnext b)])




($settcbucketnext! b ($vectorref vec idx))




($vectorset! vec idx b)




(unless (fixnum? next)




(insertb next vec mask)))))




(define moveall




(lambda (vec1 i n vec2 mask)




(unless ($fx= i n)




(let ([b ($vectorref vec1 i)])




(unless (fixnum? b)




(insertb b vec2 mask))




(moveall vec1 ($fxadd1 i) n vec2 mask)))))




(let* ([vec1 (hashtvec h)]




[n1 ($vectorlength vec1)]




[n2 ($fxsll n1 1)]




[vec2 (makebasevec n2)])




(moveall vec1 0 n1 vec2 ($fx n2 1))




(sethashtvec! h vec2)))




(cond




[(hashthashf h) =>




(lambda (hashf)




(enlargehashtable h hashf))]

20081031 23:09:03 04:00



[(eq? eq? (hashtequivf h))




(enlargehashtable h




(lambda (x) (pointervalue x)))]

20081021 05:52:42 04:00



[else

20081031 23:09:03 04:00



(enlargehashtable h




(lambda (x)




(if (number? x)




(numberhash x)




(pointervalue x))))])))

20070909 21:16:07 04:00







(define initvec




(lambda (v i n)




(if ($fx= i n)




v




(begin




($vectorset! v i i)




(initvec v ($fxadd1 i) n)))))








(define makebasevec




(lambda (n)




(initvec (makevector n) 0 n)))





20071010 08:24:12 04:00



(define (clearhash! h)




(let ([v (hashtvec h)])




(initvec v 0 (vectorlength v)))

20081031 23:09:03 04:00



(unless (hashthashf h)




(sethashttc! h




(let ([x (cons #f #f)])




(cons x x))))

20071010 08:24:12 04:00



(sethashtcount! h 0))








(define (getkeys h)




(let ([v (hashtvec h)] [n (hashtcount h)])




(let ([kv (makevector n)])




(let f ([i ($fxsub1 n)] [j ($fxsub1 (vectorlength v))] [kv kv] [v v])




(cond




[($fx= i 1) kv]




[else




(let ([b ($vectorref v j)])




(if (fixnum? b)




(f i ($fxsub1 j) kv v)




(f (let f ([i i] [b b] [kv kv])




($vectorset! kv i ($tcbucketkey b))




(let ([b ($tcbucketnext b)]




[i ($fxsub1 i)])




(cond




[(fixnum? b) i]




[else (f i b kv)])))




($fxsub1 j) kv v)))])))))





20071111 01:19:18 05:00



(define (getentries h)




(let ([v (hashtvec h)] [n (hashtcount h)])




(let ([kv (makevector n)] [vv (makevector n)])




(let f ([i ($fxsub1 n)] [j ($fxsub1 (vectorlength v))] [kv kv] [vv vv] [v v])




(cond




[($fx= i 1) (values kv vv)]




[else




(let ([b ($vectorref v j)])




(if (fixnum? b)




(f i ($fxsub1 j) kv vv v)




(f (let f ([i i] [b b] [kv kv] [vv vv])




($vectorset! kv i ($tcbucketkey b))




($vectorset! vv i ($tcbucketval b))




(let ([b ($tcbucketnext b)]




[i ($fxsub1 i)])




(cond




[(fixnum? b) i]




[else (f i b kv vv)])))




($fxsub1 j) kv vv v)))])))))





20071112 00:50:00 05:00



(define (hashtcopy h mutable?)




(define (duphasht h mutable? n)

20081021 05:52:42 04:00



(let* ([hashf (hashthashf h)]

20081031 23:09:03 04:00



[tc (and (not hashf) (let ([x (cons #f #f)]) (cons x x)))])

20090411 14:39:53 04:00



(makehasht (makebasevec n) 0 tc mutable?




hashf (hashtequivf h) (hashthashf0 h))))

20071112 00:50:00 05:00



(let ([v (hashtvec h)] [n (hashtcount h)])




(let ([r (duphasht h mutable? (vectorlength v))])




(let f ([i ($fxsub1 n)] [j ($fxsub1 (vectorlength v))] [r r] [v v])




(cond




[($fx= i 1) r]




[else




(let ([b ($vectorref v j)])




(if (fixnum? b)




(f i ($fxsub1 j) r v)




(f (let f ([i i] [b b] [r r])




(puthash! r ($tcbucketkey b) ($tcbucketval b))




(let ([b ($tcbucketnext b)] [i ($fxsub1 i)])




(cond




[(fixnum? b) i]




[else (f i b r)])))




($fxsub1 j) r v)))])))))





20070909 21:16:07 04:00



;;; public interface

20071009 09:22:02 04:00



(define (hashtable? x) (hasht? x))

20070909 21:16:07 04:00




20071010 07:09:18 04:00



(define makeeqhashtable




(caselambda




[()




(let ([x (cons #f #f)])




(let ([tc (cons x x)])

20090411 14:39:53 04:00



(makehasht (makebasevec 32) 0 tc #t #f eq? #f)))]

20081021 05:52:42 04:00



[(k)




(if (and (or (fixnum? k) (bignum? k)) (>= k 0))

20071010 07:09:18 04:00



(makeeqhashtable)

20081021 05:52:42 04:00



(die 'makeeqhashtable "invalid initial capacity" k))]))





20081031 23:09:03 04:00



(define makeeqvhashtable




(caselambda




[()




(let ([x (cons #f #f)])




(let ([tc (cons x x)])

20090411 14:39:53 04:00



(makehasht (makebasevec 32) 0 tc #t #f eqv? #f)))]

20081031 23:09:03 04:00



[(k)




(if (and (or (fixnum? k) (bignum? k)) (>= k 0))




(makeeqvhashtable)




(die 'makeeqvhashtable "invalid initial capacity" k))]))





20081021 05:52:42 04:00



(define makehashtable




(caselambda




[(hashf equivf) (makehashtable hashf equivf 0)]




[(hashf equivf k)




(define who 'makehashtable)




(define (wrap f)




(cond




[(or (eq? f symbolhash)




(eq? f stringhash)




(eq? f stringcihash))




f]




[else




(lambda (k)




(let ([i (f k)])




(if (and (or (fixnum? i) (bignum? i)) (>= i 0))




i




(die #f "invalid return value from hash function" i))))]))




(unless (procedure? hashf)




(die who "hash function is not a procedure" hashf))




(unless (procedure? equivf)




(die who "equivalence function is not a procedure" equivf))




(if (and (or (fixnum? k) (bignum? k)) (>= k 0))

20090411 14:39:53 04:00



(makehasht (makebasevec 32) 0 #f #t (wrap hashf) equivf hashf)

20081021 05:52:42 04:00



(die who "invalid initial capacity" k))]))

20070909 21:16:07 04:00




20071009 09:22:02 04:00



(define hashtableref

20070909 21:16:07 04:00



(lambda (h x v)




(if (hasht? h)




(gethash h x v)

20071215 08:22:49 05:00



(die 'hashtableref "not a hash table" h))))

20070909 21:16:07 04:00




20071010 07:36:19 04:00



(define hashtablecontains?




(lambda (h x)




(if (hasht? h)




(inhash? h x)

20071215 08:22:49 05:00



(die 'hashtablecontains? "not a hash table" h))))

20071010 07:36:19 04:00




20071009 09:22:02 04:00



(define hashtableset!

20070909 21:16:07 04:00



(lambda (h x v)




(if (hasht? h)

20071010 08:24:12 04:00



(if (hashtmutable? h)




(puthash! h x v)

20071215 08:22:49 05:00



(die 'hashtableset! "hashtable is immutable" h))




(die 'hashtableset! "not a hash table" h))))

20070909 21:16:07 04:00




20071010 07:36:19 04:00



(define hashtableupdate!




(lambda (h x proc default)




(if (hasht? h)

20071010 08:24:12 04:00



(if (hashtmutable? h)




(if (procedure? proc)




(updatehash! h x proc default)

20071215 08:22:49 05:00



(die 'hashtableupdate! "not a procedure" proc))




(die 'hashtableupdate! "hashtable is immutable" h))




(die 'hashtableupdate! "not a hash table" h))))

20071010 07:36:19 04:00







(define hashtablesize




(lambda (h)




(if (hasht? h)




(hashtcount h)

20071215 08:22:49 05:00



(die 'hashtablesize "not a hash table" h))))

20071010 07:36:19 04:00







(define hashtabledelete!




(lambda (h x)




;;; FIXME: should shrink table if number of keys drops below




;;; (sqrt (vectorlength (hashtvec h)))




(if (hasht? h)

20071010 08:24:12 04:00



(if (hashtmutable? h)




(delhash h x)

20081021 05:52:42 04:00



(die 'hashtabledelete! "hash table is immutable" h))

20071215 08:22:49 05:00



(die 'hashtabledelete! "not a hash table" h))))

20071010 07:36:19 04:00




20071111 01:19:18 05:00



(define (hashtableentries h)

20081021 05:52:42 04:00



(if (hasht? h)

20071111 01:19:18 05:00



(getentries h)

20071215 08:22:49 05:00



(die 'hashtableentries "not a hash table" h)))

20071111 01:19:18 05:00




20071010 08:24:12 04:00



(define (hashtablekeys h)




(if (hasht? h)




(getkeys h)

20071215 08:22:49 05:00



(die 'hashtablekeys "not a hash table" h)))

20071010 08:24:12 04:00







(define (hashtablemutable? h)




(if (hasht? h)




(hashtmutable? h)

20071215 08:22:49 05:00



(die 'hashtablemutable? "not a hash table" h)))

20071010 08:24:12 04:00







(define (hashtableclear! h)




(if (hasht? h)




(if (hashtmutable? h)




(clearhash! h)

20081021 05:52:42 04:00



(die 'hashtableclear! "hash table is immutable" h))

20071215 08:22:49 05:00



(die 'hashtableclear! "not a hash table" h)))

20071112 00:50:00 05:00







(define hashtablecopy




(caselambda




[(h)

20071210 12:00:12 05:00



(if (hasht? h)

20081021 05:52:42 04:00



(if (hashtmutable? h)

20071112 00:52:43 05:00



(hashtcopy h #f)




h)

20071215 08:22:49 05:00



(die 'hashtablecopy "not a hash table" h))]

20071112 00:50:00 05:00



[(h mutable?)

20071210 12:00:12 05:00



(if (hasht? h)

20071112 00:52:43 05:00



(if (or mutable? (hashtmutable? h))




(hashtcopy h (and mutable? #t))




h)

20071215 08:22:49 05:00



(die 'hashtablecopy "not a hash table" h))]))

20071112 00:50:00 05:00




20081021 05:52:42 04:00



(define (hashtableequivalencefunction h)




(if (hasht? h)




(hashtequivf h)




(die 'hashtableequivalencefunction "not a hash table" h)))








(define (hashtablehashfunction h)




(if (hasht? h)

20090411 14:39:53 04:00



(hashthashf0 h)

20081021 05:52:42 04:00



(die 'hashtablehashfunction "not a hash table" h)))





20071122 16:55:25 05:00



(define (stringhash s)

20081021 05:52:42 04:00



(if (string? s)

20071122 16:55:25 05:00



(foreigncall "ikrt_string_hash" s)

20071215 08:22:49 05:00



(die 'stringhash "not a string" s)))

20071122 16:55:25 05:00




20071122 17:04:10 05:00



(define (stringcihash s)




(if (string? s)




(foreigncall "ikrt_string_hash"




(stringfoldcase s))

20071215 08:22:49 05:00



(die 'stringcihash "not a string" s)))

20071122 17:04:10 05:00







(define (symbolhash s)




(if (symbol? s)




(foreigncall "ikrt_string_hash" (symbol>string s))

20071215 08:22:49 05:00



(die 'symbolhash "not a symbol" s)))

20071122 17:04:10 05:00




20081031 23:09:03 04:00



(define (numberhash x)




(cond




[(fixnum? x) x]




[(flonum? x) (foreigncall "ikrt_flonum_hash" x)]




[(bignum? x) (foreigncall "ikrt_bignum_hash" x)]




[(ratnum? x)




(fxxor




(numberhash (numerator x))




(numberhash (denominator x)))]




[else




(fxxor




(numberhash (realpart x))




(numberhash (imagpart x)))]))





20081116 20:01:24 05:00



(setrtdprinter! (typedescriptor hasht)




(lambda (x p wr)




(display "#<hashtable>" p)))

20070909 21:16:07 04:00



)
