Return to hash.fs CVS log | Up to [gforth] / gforth |
Added stuff for documenting Forth source and integrating it into the texi file changed checks for DOMAINOS to checks for apollo (which is defined on apollos) changed "-evaluate" (which did not work anyway) to "--evaluate" added debugging.fs and assert.fs to startup.fs
1: \ Hashed dictionaries 15jul94py 2: 3: 11 value hashbits 4: 1 hashbits lshift Value Hashlen 5: 6: Variable insRule insRule on 7: Variable revealed 8: 9: \ Memory handling 10oct94py 10: 11: Variable HashPointer 12: Variable HashTable 13: Variable HashIndex 14: 15: \ DelFix and NewFix are from bigFORTH 15jul94py 16: 17: : DelFix ( addr root -- ) dup @ 2 pick ! ! ; 18: : NewFix ( root len # -- addr ) 19: BEGIN 2 pick @ ?dup 0= WHILE 2dup * allocate throw 20: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop 21: REPEAT >r drop r@ @ rot ! r@ swap erase r> ; 22: 23: \ compute hash key 15jul94py 24: 25: : hash ( addr len -- key ) 26: hashbits (hashkey1) ; 27: \ (hashkey) 28: \ Hashlen 1- and ; 29: 30: 31: : hash-find ( addr len wordlist -- nfa / false ) 32: [ 3 cells ] Literal + @ >r 33: 2dup hash r> xor cells HashTable @ + @ (hashfind) ; 34: 35: \ hash vocabularies 16jul94py 36: 37: : lastlink! ( addr link -- ) 38: BEGIN dup @ dup WHILE nip REPEAT drop ! ; 39: 40: : (reveal ( addr voc -- ) [ 3 cells ] Literal + dup @ 0< IF 2drop EXIT THEN 41: @ over cell+ count $1F and Hash xor cells >r 42: HashPointer 2 Cells $400 NewFix 43: tuck cell+ ! r> HashTable @ + insRule @ 44: IF dup @ 2 pick ! ! ELSE lastlink! THEN revealed on ; 45: 46: : hash-reveal ( -- ) (reveal) last? IF 47: current @ (reveal THEN ; 48: 49: : addall ( -- ) 50: voclink 51: BEGIN @ dup @ WHILE dup 'initvoc REPEAT drop ; 52: 53: : clearhash ( -- ) 54: HashTable @ Hashlen cells bounds 55: DO I @ 56: BEGIN dup WHILE 57: dup @ swap HashPointer DelFix 58: REPEAT I ! 59: cell +LOOP HashIndex off ; 60: 61: : re-hash clearhash addall ; 62: : (rehash) ( addr -- ) 63: drop revealed @ IF re-hash revealed off THEN ; 64: 65: Create hashsearch ' hash-find A, ' hash-reveal A, ' (rehash) A, 66: 67: \ hash allocate and vocabulary initialization 10oct94py 68: 69: : hash-alloc ( addr -- addr ) HashTable @ 0= IF 70: Hashlen cells allocate throw HashTable ! 71: HashTable @ Hashlen cells erase THEN 72: HashIndex @ over ! 1 HashIndex +! 73: HashIndex @ Hashlen >= 74: IF clearhash 75: 1 hashbits 1+ dup to hashbits lshift to hashlen 76: HashTable @ free 77: addall 78: THEN ; 79: 80: : (initvoc) ( addr -- ) 81: cell+ dup @ 0< IF drop EXIT THEN 82: insRule @ >r insRule off hash-alloc 83: 3 cells - hashsearch over cell+ ! dup 84: BEGIN @ dup WHILE 2dup swap (reveal REPEAT 85: 2drop r> insRule ! ; 86: 87: ' (initvoc) IS 'initvoc 88: 89: \ Hash-Find 01jan93py 90: 91: addall \ Baum aufbauen 92: \ Baumsuche ist installiert. 93: 94: : hash-cold ( -- ) Defers 'cold 95: HashPointer off HashTable off HashIndex off 96: voclink 97: BEGIN @ dup @ WHILE 98: dup cell - @ >r 99: dup 'initvoc 100: r> over cell - ! 101: REPEAT drop ; 102: ' hash-cold IS 'cold 103: 104: : .words ( -- ) 105: base @ >r hex HashTable @ Hashlen 0 106: DO cr i 2 .r ." : " dup i cells + 107: BEGIN @ dup WHILE 108: dup cell+ @ .name REPEAT drop 109: LOOP drop r> base ! ; 110: 111: \ \ this stuff is for evaluating the hash function 112: \ : square dup * ; 113: 114: \ : countwl ( -- sum sumsq ) 115: \ \ gives the number of words in the current wordlist 116: \ \ and the sum of squares for the sublist lengths 117: \ 0 0 118: \ hashtable @ Hashlen cells bounds DO 119: \ 0 i BEGIN 120: \ @ dup WHILE 121: \ swap 1+ swap 122: \ REPEAT 123: \ drop 124: \ swap over square + 125: \ >r + r> 126: \ 1 cells 127: \ +LOOP ; 128: 129: \ : chisq ( -- n ) 130: \ \ n should have about the same size as Hashlen 131: \ countwl Hashlen 2 pick */ swap - ;