File:  [gforth] / gforth / hash.fs
Revision 1.11: download - view: text, annotated - select for diffs
Sun Jan 7 17:22:10 1996 UTC (28 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added more.fs for people with old terminals.
WORDS and SEE now now respect the terminal size.
a lot of reordering in the Makefile, approaching the GNU standards.
factored NAME>STRING out of many words.
use AC_DECL_SYS_SIGLIST test in configure.in.
removed emitcounter (it was not used anyway).
SYSTEM now unpreps and repreps the terminal.
fixed byg in prims2x.fs.
added NEEDS, ?CSP, !CSP.
rewrote ALIAS?.

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

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