hash-table.fs 3.92 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ generic hash table functions

bernd's avatar
bernd committed
3
2 64s buffer: hashinit
bernd's avatar
bernd committed
4

Bernd Paysan's avatar
Bernd Paysan committed
5
\ this computes a cryptographic somewhat secure hash over the input string
bernd's avatar
bernd committed
6

7
User hash-state 2 64s cell- uallot drop
bernd's avatar
bernd committed
8

Bernd Paysan's avatar
Bernd Paysan committed
9 10
: string-hash ( addr u -- )  hashinit hash-state [ 2 64s ]L move
    false hash-state hashkey2 ;
bernd's avatar
bernd committed
11

Bernd Paysan's avatar
Bernd Paysan committed
12
: hash$ ( -- addr u )  hash-state [ 2 64s ]L ;
bernd's avatar
bernd committed
13 14 15 16

\ hierarchical hash table

\ hash tables store key,value-pairs.
bernd's avatar
bernd committed
17
\ Each hierarchy uses one byte of state as index (only lower 7 bits)
bernd's avatar
bernd committed
18 19
\ if there is a collission, add another indirection

bernd's avatar
bernd committed
20
uvalue last#
bernd's avatar
bernd committed
21

bernd's avatar
bernd committed
22
: #!? ( addrval u addrkey u bucket -- true / addrval u addrkey u false )
bernd's avatar
bernd committed
23 24 25
    >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
bernd's avatar
bernd committed
26 27 28 29
    rdrop false ;

: #@? ( addrkey u bucket -- addrval u true / addrkey u false )
    >r r@ @ 0= IF  rdrop false  EXIT  THEN
bernd's avatar
bernd committed
30
    2dup r@ $@ str=  IF  2drop r> dup to last# cell+ $@ true  EXIT  THEN
bernd's avatar
bernd committed
31 32
    rdrop false ;    

bernd's avatar
bernd committed
33 34
: bucket-off ( bucket -- ) dup $off cell+ $off ;

35
: #free? ( addrkey u bucket -- true / addrkey u false )
bernd's avatar
bernd committed
36
    >r r@ @ 0= IF  rdrop false  EXIT  THEN
bernd's avatar
bernd committed
37
    2dup r@ $@ str=  IF  2drop r> bucket-off true  EXIT  THEN
38
    rdrop false ;
bernd's avatar
bernd committed
39 40 41 42

$180 cells Constant table-size#

: hash@ ( bucket -- addr )  >r
43
    r@ @ 0= IF  table-size# allocate throw dup table-size# erase dup r> !
bernd's avatar
bernd committed
44 45 46 47 48
    ELSE  r> @  THEN ;

warnings @ warnings off \ hash-bang will be redefined

: #! ( addrval u addrkey u hash -- ) { hash }
bernd's avatar
bernd committed
49
    2dup string-hash  hash$ bounds ?DO
bernd's avatar
bernd committed
50 51
	I c@ $7F and 2* cells hash hash@ + #!? IF
	    UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
52
	I c@ $80 or $80 + cells hash hash@ + to hash
bernd's avatar
bernd committed
53 54 55 56 57
    LOOP  2drop 2drop true abort" hash exhausted, please reboot universe" ;

warnings !

: #@ ( addrkey u hash -- addrval u / 0 0 ) { hash }
bernd's avatar
bernd committed
58
    2dup string-hash  hash$ bounds ?DO
bernd's avatar
bernd committed
59 60
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
	+ #@? IF  UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
61
	I c@ $80 or $80 + cells hash @ + to hash
bernd's avatar
bernd committed
62
    LOOP  2drop #0. ;
bernd's avatar
bernd committed
63

Bernd Paysan's avatar
Bernd Paysan committed
64 65
: #+! ( addr1 u1 addr2 u2 hash -- ) >r
    2dup r@ #@ d0= IF  r> #!  ELSE  2drop rdrop last# cell+ $+!  THEN ;
66

67
: #free ( addrkey u hash -- )  { hash }
bernd's avatar
bernd committed
68
    2dup string-hash  hash$ bounds ?DO
bernd's avatar
bernd committed
69
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
70
	+ #free? IF  UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
71
	I c@ $80 or $80 + cells hash @ + to hash
bernd's avatar
bernd committed
72
    LOOP  2drop ;
bernd's avatar
bernd committed
73

74 75 76
: #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
77 78
    r@ @ free throw  r> off ;

bernd's avatar
bernd committed
79 80 81 82 83
-1 8 rshift invert Constant msbyte#

: leftalign ( key -- key' )
    BEGIN  dup msbyte# and 0= WHILE  8 lshift  dup 0= UNTIL  THEN ;

bernd's avatar
bernd committed
84
: #key ( addrkey u hash -- path / -1 ) 0 { hash key }
bernd's avatar
bernd committed
85
    2dup string-hash  hash$ drop cell bounds ?DO
bernd's avatar
bernd committed
86
	key 8 lshift I c@ $80 or or  to key
bernd's avatar
bernd committed
87
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
bernd's avatar
bernd committed
88
	+ #@? IF  2drop key -$81 and leftalign   UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
89
	I c@ $80 or $80 + cells hash @ + to hash
bernd's avatar
bernd committed
90 91
    LOOP  2drop -1 ;

bernd's avatar
bernd committed
92
: #.key ( path hash -- item ) @ { hash }
bernd's avatar
bernd committed
93
    BEGIN
bernd's avatar
bernd committed
94
	hash 0= IF  drop 0  EXIT  THEN
bernd's avatar
bernd committed
95
	$100 um* dup $80 and WHILE
96
	    $80 + cells hash + @ to hash
Bernd Paysan's avatar
Bernd Paysan committed
97
    REPEAT \ stack: pathlow pathhigh (<=$7F)
bernd's avatar
bernd committed
98
    nip 2* cells hash + ;
bernd's avatar
bernd committed
99

bernd's avatar
bernd committed
100
: #map  { hash xt -- } \ xt: ( ... node -- ... )
bernd's avatar
bernd committed
101
    hash @ 0= ?EXIT
bernd's avatar
bernd committed
102 103 104 105
    hash @ $100 cells bounds DO
	I @ IF  I xt execute  THEN
    2 cells +LOOP
    hash @ $100 cells + $80 cells bounds DO
bernd's avatar
bernd committed
106
	I @ IF  I xt recurse  THEN
bernd's avatar
bernd committed
107 108 109 110
    cell +LOOP ;

: #.entry ( hash-entry -- ) dup $@ type ."  -> " cell+ $@ type cr ;

bernd's avatar
bernd committed
111
0 warnings !@
bernd's avatar
bernd committed
112
: #. ( hash -- )  ['] #.entry #map ;
bernd's avatar
bernd committed
113
warnings !
bernd's avatar
bernd committed
114

Bernd Paysan's avatar
Bernd Paysan committed
115 116
' Variable alias hash:

bernd's avatar
bernd committed
117 118
\ test: move dictionary to hash

119
\\\
bernd's avatar
bernd committed
120 121 122 123 124
variable ht
: test ( -- )
    context @ cell+ BEGIN  @ dup  WHILE
	    dup name>string 2dup ht #!
    REPEAT  drop ;
bernd's avatar
bernd committed
125 126 127 128 129 130 131 132
: 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 ;