-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2011 John Benediktsson, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private slots.private math
assocs math.private sequences sequences.private vectors ;
: hash@ ( key array -- i )
[ hashcode >fixnum dup fixnum+fast ] dip wrap ; inline
-: probe ( array i -- array i )
- 2 fixnum+fast over wrap ; inline
+: probe ( array i probe# -- array i probe# )
+ 2 fixnum+fast [ fixnum+fast over wrap ] keep ; inline
: no-key ( key array -- array n ? ) nip f f ; inline
-: (key@) ( key array i -- array n ? )
- 3dup swap array-nth
- dup ((empty)) eq?
- [ 3drop no-key ] [
- = [ rot drop t ] [ probe (key@) ] if
+: (key@) ( key array i probe# -- array n ? )
+ [ 3dup swap array-nth ] dip over ((empty)) eq?
+ [ drop 3drop no-key ] [
+ [ = ] dip swap
+ [ drop rot drop t ]
+ [ probe (key@) ]
+ if
] if ; inline recursive
: key@ ( key hash -- array n ? )
array>> dup length>> 0 eq?
- [ no-key ] [ 2dup hash@ (key@) ] if ; inline
+ [ no-key ] [ 2dup hash@ 0 (key@) ] if ; inline
: <hash-array> ( n -- array )
1 + next-power-of-2 4 * ((empty)) <array> ; inline
: reset-hash ( n hash -- )
swap <hash-array> >>array init-hash ; inline
-: (new-key@) ( key keys i -- keys n empty? )
- 3dup swap array-nth dup ((empty)) eq? [
- 2drop rot drop t
+: hash-count+ ( hash -- )
+ [ 1 fixnum+fast ] change-count drop ; inline
+
+: hash-deleted+ ( hash -- )
+ [ 1 fixnum+fast ] change-deleted drop ; inline
+
+: hash-deleted- ( hash -- )
+ [ 1 fixnum-fast ] change-deleted drop ; inline
+
+! i = first-empty-or-found
+! j = first-deleted
+! empty? = if true, key was not found
+!
+! if empty? is f:
+! - we want to store into i
+!
+! if empty? is t:
+! - we want to store into j if j is not f
+! - otherwise we want to store into i
+! - ... and increment count
+
+: (new-key@) ( key array i probe# j -- array i j empty? )
+ [ 2dup swap array-nth ] 2dip pick tombstone?
+ [
+ rot ((empty)) eq?
+ [ nip [ drop ] 3dip t ]
+ [ pick or [ probe ] dip (new-key@) ]
+ if
] [
- = [
- rot drop f
- ] [
- probe (new-key@)
- ] if
+ [ [ pick ] dip = ] 2dip rot
+ [ nip [ drop ] 3dip f ]
+ [ [ probe ] dip (new-key@) ]
+ if
] if ; inline recursive
-: new-key@ ( key hash -- array n empty? )
- array>> 2dup hash@ (new-key@) ; inline
+: new-key@ ( key hash -- array n )
+ [ array>> 2dup hash@ 0 f (new-key@) ] keep swap
+ [ over [ hash-deleted- ] [ hash-count+ ] if swap or ] [ 2drop ] if ; inline
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
-: hash-count+ ( hash -- )
- [ 1 + ] change-count drop ; inline
-
-: hash-deleted+ ( hash -- )
- [ 1 + ] change-deleted drop ; inline
-
: (rehash) ( hash alist -- )
swap [ swapd set-at ] curry assoc-each ; inline
[ count>> 3 fixnum*fast 1 fixnum+fast ]
[ array>> length>> ] bi fixnum> ; inline
-: hash-stale? ( hash -- ? )
- [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
-
: grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1 + ] bi ] keep
[ reset-hash ] keep
swap (rehash) ;
: ?grow-hash ( hash -- )
- dup hash-large? [
- grow-hash
- ] [
- dup hash-stale? [
- grow-hash
- ] [
- drop
- ] if
- ] if ; inline
+ dup hash-large? [ grow-hash ] [ drop ] if ; inline
PRIVATE>
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
M: hashtable clear-assoc ( hash -- )
- [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
+ [ init-hash ] [ array>> [ drop ((empty)) ] map! drop ] bi ;
M: hashtable delete-at ( key hash -- )
[ nip ] [ key@ ] 2bi [
] if ;
M: hashtable assoc-size ( hash -- n )
- [ count>> ] [ deleted>> ] bi - ;
+ [ count>> ] [ deleted>> ] bi - ; inline
: rehash ( hash -- )
- dup >alist [
- dup clear-assoc
- ] dip (rehash) ;
+ dup >alist [ dup clear-assoc ] dip (rehash) ;
M: hashtable set-at ( value key hash -- )
- dup ?grow-hash
- 2dup new-key@
- [ rot hash-count+ set-nth-pair ]
- [ rot drop set-nth-pair ] if ;
+ dup ?grow-hash dupd new-key@ set-nth-pair ;
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
: push-unsafe ( elt seq -- )
[ length ] keep
[ underlying>> set-array-nth ]
- [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ]
+ [ [ 1 fixnum+fast { array-capacity } declare ] dip length<< ]
2bi ; inline
PRIVATE>
M: hashtable >alist
- [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
+ [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
[
[
[ 1 fixnum-shift-fast ] dip
[ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
] dip
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
- ] 2curry each
+ ] 2curry each-integer
] keep { } like ;
M: hashtable clone
- (clone) [ clone ] change-array ;
+ (clone) [ clone ] change-array ; inline
M: hashtable equal?
- over hashtable? [
- 2dup [ assoc-size ] bi@ eq?
- [ assoc= ] [ 2drop f ] if
- ] [ 2drop f ] if ;
+ over hashtable? [ assoc= ] [ 2drop f ] if ;
! Default method
-M: assoc new-assoc drop <hashtable> ;
+M: assoc new-assoc drop <hashtable> ; inline
-M: f new-assoc drop <hashtable> ;
+M: f new-assoc drop <hashtable> ; inline
: >hashtable ( assoc -- hashtable )
H{ } assoc-clone-like ;
M: hashtable assoc-like
- drop dup hashtable? [ >hashtable ] unless ;
+ drop dup hashtable? [ >hashtable ] unless ; inline
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
+! borrowed from boost::hash_combine, but the
+! magic number is 2^29/phi instead of 2^32/phi
+! due to max fixnum value on 32-bit machines
+: hash-combine ( obj oldhash -- newhash )
+ [ hashcode 0x13c6ef37 + ] dip
+ [ 6 shift ] [ -2 shift ] bi + + ;
+
INSTANCE: hashtable assoc
projects / factor.git / blobdiff