Annotation of gforth/hash.fs, revision 1.18

1.1       pazsan      1: \ Hashed dictionaries                                  15jul94py
                      2: 
1.10      anton       3: \ Copyright (C) 1995 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     20: 
1.18    ! jwilke     21: [IFUNDEF] e? : e? name 2drop false ; [THEN]
        !            22: 
        !            23: e? ec
        !            24: [IF]
        !            25: : reserve-mem here swap allot ;
        !            26: \ ToDo: check memory space with unused
        !            27: \ move to a kernel/memory.fs
        !            28: [ELSE]
        !            29: : reserve-mem allocate throw ;
        !            30: [THEN]
        !            31: 
        !            32: [IFUNDEF] hashbits
1.9       anton      33: 11 value hashbits
1.18    ! jwilke     34: [THEN]
1.2       anton      35: 1 hashbits lshift Value Hashlen
1.1       pazsan     36: 
1.18    ! jwilke     37: \ compute hash key                                     15jul94py
        !            38: 
        !            39: [IFUNDEF] hash
        !            40: : hash ( addr len -- key )
        !            41:     hashbits (hashkey1) ;
        !            42: [THEN]
        !            43: 
1.1       pazsan     44: Variable insRule        insRule on
1.4       pazsan     45: Variable revealed
1.1       pazsan     46: 
1.4       pazsan     47: \ Memory handling                                      10oct94py
1.1       pazsan     48: 
                     49: Variable HashPointer
1.4       pazsan     50: Variable HashIndex
1.13      anton      51: 0 Value HashTable
1.1       pazsan     52: 
1.18    ! jwilke     53: \ forward declarations
        !            54: 0 Value hashsearch-map
        !            55: Defer hash-alloc
        !            56: 
1.4       pazsan     57: \ DelFix and NewFix are from bigFORTH                  15jul94py
1.1       pazsan     58: 
                     59: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
                     60: : NewFix  ( root len # -- addr )
1.18    ! jwilke     61:   BEGIN  2 pick @ ?dup  0= WHILE  2dup * reserve-mem
1.1       pazsan     62:          over 0 ?DO  dup 4 pick DelFix 2 pick +  LOOP  drop
                     63:   REPEAT  >r drop r@ @ rot ! r@ swap erase r> ;
                     64: 
1.12      anton      65: : bucket ( addr len wordlist -- bucket-addr )
                     66:     \ @var{bucket-addr} is the address of a cell that points to the first
                     67:     \ element in the list of the bucket for the string @var{addr len}
                     68:     wordlist-extend @ -rot hash xor ( bucket# )
1.13      anton      69:     cells HashTable + ;
1.2       anton      70: 
                     71: : hash-find ( addr len wordlist -- nfa / false )
1.12      anton      72:     >r 2dup r> bucket @ (hashfind) ;
1.1       pazsan     73: 
                     74: \ hash vocabularies                                    16jul94py
                     75: 
                     76: : lastlink! ( addr link -- )
                     77:   BEGIN  dup @ dup  WHILE  nip  REPEAT  drop ! ;
                     78: 
1.14      anton      79: : (reveal ( nfa wid -- )
1.12      anton      80:     over name>string rot bucket >r
                     81:     HashPointer 2 Cells $400 NewFix
                     82:     tuck cell+ ! r> insRule @
                     83:     IF
                     84:        dup @ 2 pick ! !
                     85:     ELSE
                     86:        lastlink!
                     87:     THEN
                     88:     revealed on ;
                     89: 
1.14      anton      90: : hash-reveal ( nfa wid -- )
                     91:     2dup (reveal) (reveal ;
1.1       pazsan     92: 
1.18    ! jwilke     93: : inithash ( wid -- )
        !            94:     wordlist-extend
        !            95:     insRule @ >r  insRule off  hash-alloc 3 cells - dup
        !            96:     BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
        !            97:     2drop  r> insRule ! ;
        !            98: 
1.4       pazsan     99: : addall  ( -- )
                    100:     voclink
1.18    ! jwilke    101:     BEGIN  @ dup WHILE
        !           102:           dup 0 wordlist-link -
        !           103:           dup wordlist-map @ hashsearch-map = 
        !           104:           IF  inithash ELSE drop THEN
        !           105:     REPEAT  drop ;
1.4       pazsan    106: 
                    107: : clearhash  ( -- )
1.13      anton     108:     HashTable Hashlen cells bounds
1.4       pazsan    109:     DO  I @
1.15      pazsan    110:        BEGIN  dup  WHILE
                    111:               dup @ swap HashPointer DelFix
1.4       pazsan    112:         REPEAT  I !
1.18    ! jwilke    113:     cell +LOOP  HashIndex off 
        !           114:     voclink
        !           115:     BEGIN @ dup WHILE
        !           116:          dup 0 wordlist-link -
        !           117:          dup wordlist-map @ hashsearch-map = 
        !           118:          IF 0 swap wordlist-extend ! ELSE drop THEN
        !           119:     REPEAT drop ;
        !           120: 
        !           121: : rehashall  ( wid -- ) 
        !           122:   drop revealed @ 
        !           123:   IF   clearhash addall revealed off 
        !           124:   THEN ;
1.4       pazsan    125: 
1.18    ! jwilke    126: : (rehash)   ( wid -- )
        !           127:   dup wordlist-extend @ 0=
        !           128:   IF   inithash
        !           129:   ELSE rehashall THEN ;
        !           130: 
        !           131: \ >rom ?!
        !           132: align here    ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
        !           133: to hashsearch-map
1.4       pazsan    134: 
                    135: \ hash allocate and vocabulary initialization          10oct94py
                    136: 
1.18    ! jwilke    137: :noname ( hash-alloc ) ( addr -- addr )  
        !           138:   HashTable 0= 
        !           139:   IF  Hashlen cells reserve-mem TO HashTable
        !           140:       HashTable Hashlen cells erase THEN
1.4       pazsan    141:   HashIndex @ over !  1 HashIndex +!
                    142:   HashIndex @ Hashlen >=
1.18    ! jwilke    143:   [ e? ec [IF] ]
        !           144:   ABORT" no more space in hashtable"
        !           145:   [ [ELSE] ]
1.17      pazsan    146:   IF  HashTable >r clearhash
1.4       pazsan    147:       1 hashbits 1+ dup  to hashbits  lshift  to hashlen
1.17      pazsan    148:       r> free >r  0 to HashTable
                    149:       addall r> throw
1.18    ! jwilke    150:   THEN 
        !           151:   [ [THEN] ] ; is hash-alloc
1.1       pazsan    152: 
                    153: \ Hash-Find                                            01jan93py
1.18    ! jwilke    154: e? cross 0= 
        !           155: [IF]
1.16      pazsan    156: : make-hash
1.18    ! jwilke    157:   hashsearch-map forth-wordlist cell+ !
        !           158:   addall ;
        !           159:   make-hash \ Baumsuche ist installiert.
        !           160: [ELSE]
        !           161:   hashsearch-map forth-wordlist cell+ !
        !           162: [THEN]
1.16      pazsan    163: 
1.18    ! jwilke    164: \ for ec version display that vocabulary goes hashed
1.1       pazsan    165: 
1.18    ! jwilke    166: : hash-cold  ( -- )
        !           167: [ e? ec [IF] ] ." Hashing..." [ [THEN] ]
1.13      anton     168:   HashPointer off  0 TO HashTable  HashIndex off
1.18    ! jwilke    169:   addall
        !           170: \  voclink
        !           171: \  BEGIN  @ dup WHILE
        !           172: \         dup 0 wordlist-link - initvoc
        !           173: \  REPEAT  drop 
        !           174: [ e? ec [IF] ] ." Done" cr [ [THEN] ] ;
        !           175: 
        !           176: ' hash-cold INIT8 chained
1.5       pazsan    177: 
1.1       pazsan    178: : .words  ( -- )
1.13      anton     179:   base @ >r hex HashTable  Hashlen 0
1.4       pazsan    180:   DO  cr  i 2 .r ." : " dup i cells +
1.1       pazsan    181:       BEGIN  @ dup  WHILE
1.18    ! jwilke    182:              dup cell+ @ head>string type space  REPEAT  drop
1.1       pazsan    183:   LOOP  drop r> base ! ;
                    184: 
1.2       anton     185: \ \ this stuff is for evaluating the hash function
                    186: \ : square dup * ;
                    187: 
                    188: \ : countwl  ( -- sum sumsq )
1.4       pazsan    189: \     \ gives the number of words in the current wordlist
                    190: \     \ and the sum of squares for the sublist lengths
1.2       anton     191: \     0 0
1.13      anton     192: \     hashtable Hashlen cells bounds DO
1.4       pazsan    193: \        0 i BEGIN
                    194: \            @ dup WHILE
                    195: \            swap 1+ swap
                    196: \        REPEAT
                    197: \        drop
                    198: \        swap over square +
                    199: \        >r + r>
                    200: \        1 cells
                    201: \    +LOOP ;
1.2       anton     202: 
                    203: \ : chisq ( -- n )
1.4       pazsan    204: \     \ n should have about the same size as Hashlen
                    205: \     countwl Hashlen 2 pick */ swap - ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>