Artifact
4feed06d7a57184b6ec68e88bfdd0ad556298380:
- File
hash-table.fs
— part of check-in
[8f95c5e90e]
at
2019-02-26 22:04:59
on branch trunk
— Free memory during Google+ import
(user:
bernd
size: 3895)
\ generic hash table functions
2 64s buffer: hashinit
\ this computes a cryptographic somewhat secure hash over the input string
2 64s buffer: hash-state
: string-hash ( addr u -- ) hashinit hash-state [ 2 64s ]L move
false hash-state hashkey2 ;
: hash$ ( -- addr u ) hash-state [ 2 64s ]L ;
\ hierarchical hash table
\ hash tables store key,value-pairs.
\ Each hierarchy uses one byte of state as index (only lower 7 bits)
\ if there is a collission, add another indirection
uvalue last#
: #!? ( addrval u addrkey u bucket -- true / addrval u addrkey u false )
>r r@ @ 0= IF r@ $! r@ cell+ $! r> to last#
true EXIT THEN
2dup r@ $@ str= IF 2drop r@ cell+ $! r> to last# true EXIT THEN
rdrop false ;
: #@? ( addrkey u bucket -- addrval u true / addrkey u false )
>r r@ @ 0= IF rdrop false EXIT THEN
2dup r@ $@ str= IF 2drop r> dup to last# cell+ $@ true EXIT THEN
rdrop false ;
: bucket-off ( bucket -- ) dup $off cell+ $off ;
: #free? ( addrkey u bucket -- true / addrkey u false )
>r r@ @ 0= IF rdrop false EXIT THEN
2dup r@ $@ str= IF 2drop r> bucket-off true EXIT THEN
rdrop false ;
$180 cells Constant table-size#
: hash@ ( bucket -- addr ) >r
r@ @ 0= IF table-size# allocate throw dup r> ! dup table-size# erase
ELSE r> @ THEN ;
warnings @ warnings off \ hash-bang will be redefined
: #! ( addrval u addrkey u hash -- ) { hash }
2dup string-hash hash$ bounds ?DO
I c@ $7F and 2* cells hash hash@ + #!? IF
UNLOOP EXIT THEN
I c@ $80 or $80 + cells hash hash@ + to hash
LOOP 2drop 2drop true abort" hash exhausted, please reboot universe" ;
warnings !
: #@ ( addrkey u hash -- addrval u / 0 0 ) { hash }
2dup string-hash hash$ bounds ?DO
I c@ $7F and 2* cells hash @ dup 0= IF 2drop LEAVE THEN
+ #@? IF UNLOOP EXIT THEN
I c@ $80 or $80 + cells hash @ + to hash
LOOP 2drop #0. ;
: #free ( addrkey u hash -- ) { hash }
2dup string-hash hash$ bounds ?DO
I c@ $7F and 2* cells hash @ dup 0= IF 2drop LEAVE THEN
+ #free? IF UNLOOP EXIT THEN
I c@ $80 or $80 + cells hash @ + to hash
LOOP 2drop ;
: #frees ( hash -- ) dup @ 0= IF drop EXIT THEN >r
r@ @ $100 cells bounds DO I $free cell +LOOP
r@ @ $100 cells + $80 cells bounds DO I recurse cell +LOOP
r@ @ free throw r> off ;
-1 8 rshift invert Constant msbyte#
: leftalign ( key -- key' )
BEGIN dup msbyte# and 0= WHILE 8 lshift dup 0= UNTIL THEN ;
: #key ( addrkey u hash -- path / -1 ) 0 { hash key }
2dup string-hash hash$ drop cell bounds ?DO
key 8 lshift I c@ $80 or or to key
I c@ $7F and 2* cells hash @ dup 0= IF 2drop LEAVE THEN
+ #@? IF 2drop key -$81 and leftalign UNLOOP EXIT THEN
I c@ $80 or $80 + cells hash @ + to hash
LOOP 2drop -1 ;
: #.key ( path hash -- item ) @ { hash }
BEGIN
hash 0= IF drop 0 EXIT THEN
$100 um* dup $80 and WHILE
$80 + cells hash + @ to hash
REPEAT \ stack: pathlow pathhigh (<=$7F)
nip 2* cells hash + ;
: #map { hash xt -- } \ xt: ( ... node -- ... )
hash @ 0= ?EXIT
hash @ $100 cells bounds DO
I @ IF I xt execute THEN
2 cells +LOOP
hash @ $100 cells + $80 cells bounds DO
I @ IF I xt recurse THEN
cell +LOOP ;
: #.entry ( hash-entry -- ) dup $@ type ." -> " cell+ $@ type cr ;
0 warnings !@
: #. ( hash -- ) ['] #.entry #map ;
warnings !
' Variable alias hash:
\ test: move dictionary to hash
\\\
variable ht
: test ( -- )
context @ cell+ BEGIN @ dup WHILE
dup name>string 2dup ht #!
REPEAT drop ;
: test1 ( -- )
context @ cell+ BEGIN @ dup WHILE
dup name>string 2dup ht #@ str= 0= IF ." unequal" cr THEN
REPEAT drop ;
: test2 ( -- )
context @ cell+ BEGIN @ dup WHILE
dup name>string 2dup ht #key dup hex. cr ht #.key $@ str= 0= IF ." unequal" cr THEN
REPEAT drop ;