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)

20071210 12:00:12 05:00



(export makeeqhashtable hashtableref hashtableset! hashtable?




hashtablesize hashtabledelete! hashtablecontains?




hashtableupdate! hashtablekeys hashtablemutable?




hashtableclear! hashtableentries hashtablecopy




stringhash stringcihash symbolhash)




(import




(ikarus system $pairs)




(ikarus system $vectors)




(ikarus system $tcbuckets)




(ikarus system $fx)




(except (ikarus) makeeqhashtable hashtableref hashtableset! hashtable?




hashtablesize hashtabledelete! hashtablecontains?




hashtableupdate! hashtablekeys hashtablemutable?




hashtableclear! hashtableentries hashtablecopy




stringhash stringcihash symbolhash))








(definestruct hasht (vec count tc mutable?))

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)




(let ([pv (pointervalue x)]




[vec (hashtvec h)])

20071210 12:00:12 05:00



(let ([ih pv])

20071010 07:36:19 04:00



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




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




(or (directlookup x b)




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








(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) =>




(lambda (b)




(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)




(let ([pv (pointervalue x)]




[vec (hashtvec h)])

20071210 12:00:12 05:00



(let ([ih pv])

20070909 21:16:07 04:00



(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)

20071210 12:00:12 05:00



(let* ([ih (pointervalue x)]

20070909 21:16:07 04:00



[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 insertb




(lambda (b vec mask)




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




[pv (pointervalue x)]

20071210 12:00:12 05:00



[ih pv]

20070909 21:16:07 04:00



[idx ($fxlogand 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)))))








(define enlargetable




(lambda (h)




(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))))








(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)))




(sethashttc! h




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




(cons x x)))




(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)




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




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




(makehasht (makebasevec n) 0 tc mutable?))))




(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)])

20071010 08:24:12 04:00



(makehasht (makebasevec 32) 0 tc #t)))]

20071010 07:09:18 04:00



[(k)




(if (and (or (fixnum? k) (bignum? k))




(>= k 0))




(makeeqhashtable)

20071215 08:22:49 05:00



(die 'makeeqhashtable

20071025 14:32:26 04:00



"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)

20071215 08:22:49 05:00



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




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

20071010 07:36:19 04:00




20071111 01:19:18 05:00



(define (hashtableentries h)




(if (hasht? h)




(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)

20071215 08:22:49 05:00



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




(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)

20071112 00:52:43 05:00



(if (hashtmutable? h)




(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




20071122 16:55:25 05:00



(define (stringhash s)




(if (string? s)




(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




20070909 21:16:07 04:00



)
