Return to search-order.fs CVS log

Up to [gforth] / gforth

added an experimental hash table (search/order.fs)
allowed the user to select caps-stored names or even case-
sensitive search.
Made gforth.texi compilable.

    1: \ search order wordset                                 14may93py
    2: 
    3: $10 constant maxvp
    4: Variable vp
    5:   0 A, 0 A,   0 A, 0 A,   0 A, 0 A,   0 A, 0 A, 
    6:   0 A, 0 A,   0 A, 0 A,   0 A, 0 A,   0 A, 0 A, 
    7: 
    8: : get-current  ( -- wid )  current @ ;
    9: : set-current  ( wid -- )  current ! ;
   10: 
   11: : context ( -- addr )  vp dup @ cells + ;
   12: : definitions  ( -- )  context @ current ! ;
   13: 
   14: \ hash search                                          29may94py
   15: 
   16: \ uses a direct hash mapped cache --- idea from Heinz Schnitter
   17: 
   18: : hashkey ( addr count -- key )
   19:   swap c@ toupper 3 * + $3F and ; \ gives a simple hash key
   20: 
   21: Variable hits
   22: Variable fails
   23: 
   24: : hash-find  ( addr count wid -- nfa / false )
   25:   >r  2dup hashkey
   26:   cells r@ 3 cells + @ +           \ hashed addr
   27:   dup @
   28:   IF  >r r@ @ cell+ c@ over =
   29:       IF  2dup r@ @ cell+ char+ capscomp 0=
   30:           IF  2drop r> @ rdrop  1 hits +!  EXIT  THEN  THEN
   31:       r>
   32:   THEN  r> swap >r @ (f83casefind)  dup
   33:   IF  dup r@ !  THEN  rdrop  1 fails +! ;
   34: 
   35: : hash-reveal ( -- )
   36:   last?
   37:   IF  dup cell+ count hashkey cells
   38:       current @ 3 cells + @ + !
   39:       (reveal)
   40:   THEN ;
   41: 
   42: : clear-hash ( wid -- )  3 cells + @ $40 cells erase ;
   43: 
   44: Create hashsearch
   45:   ' hash-find A,  ' hash-reveal A,  ' clear-hash A,
   46: 
   47: \ for testing
   48: 
   49: : .hash ( wid -- )  3 cells + @ ?dup 0= ?EXIT  cr
   50:   8 0 DO
   51:           8 0 DO  dup I J 8 * + cells + @ dup
   52: 	          IF    cell+ count $1F and tuck 10 min type
   53: 		        10 swap - spaces
   54: 		  ELSE  drop  10 spaces  THEN
   55: 	  LOOP
   56:   LOOP  drop ;
   57: 
   58: \ wordlist Vocabulary also previous                    14may93py
   59: 
   60: AVariable voclink
   61: 
   62: : wordlist  ( -- wid )
   63:   here  0 A, hashsearch A, voclink @ A,
   64:   here cell+ A,  here $40 cells dup allot erase
   65:   dup 2 cells + voclink ! ;
   66: 
   67: : Vocabulary ( -- ) Create wordlist drop  DOES> context ! ;
   68: 
   69: : also  ( -- )
   70:   context @ vp @ 1+ dup maxvp > abort" Vocstack full"
   71:   vp ! context ! ;
   72: 
   73: : previous ( -- )  vp @ 1- dup 0= abort" Vocstack empty" vp ! ;
   74: 
   75: \ vocabulary find                                      14may93py
   76: 
   77: : (vocfind)  ( addr count wid -- nfa2|false )
   78:     \ !! generalize this to be independent of vp
   79:     drop 1 vp @
   80:     DO  2dup vp I cells + @ (search-wordlist) dup
   81: 	IF  nip nip
   82: 	    UNLOOP EXIT
   83: 	THEN  drop
   84:     -1 +LOOP
   85:     2drop false ;
   86: 
   87: 0 value locals-wordlist
   88: 
   89: : (localsvocfind)  ( addr count wid -- nfa2|false )
   90:     \ !! use generalized (vocfind)
   91:     drop locals-wordlist
   92:     IF 2dup locals-wordlist (search-wordlist) dup
   93: 	IF nip nip
   94: 	    EXIT
   95: 	THEN drop
   96:     THEN
   97:     0 (vocfind) ;
   98: 
   99: \ In the kernal the dictionary search works on only one wordlist.
  100: \ The following stuff builds a thing that looks to the kernal like one
  101: \ wordlist, but when searched it searches the whole search order
  102: \  (including locals)
  103: 
  104: \ this is the wordlist-map of the dictionary
  105: Create vocsearch
  106:        ' (localsvocfind) A, ' (reveal) A,  ' drop A,
  107: 
  108: \ Only root                                            14may93py
  109: 
  110: wordlist \ the wordlist structure
  111: vocsearch over cell+ A! \ patch the map into it
  112: 
  113: Vocabulary Forth
  114: Vocabulary Root
  115: 
  116: : Only  vp off  also Root also definitions ;
  117: 
  118: \ set initial search order                             14may93py
  119: 
  120: Forth-wordlist @ ' Forth >body A!
  121: 
  122: Only Forth also definitions
  123: 
  124: search A! \ our dictionary search order becomes the law
  125: 
  126: ' Forth >body AConstant Forth-wordlist
  127: 
  128: \ get-order set-order                                  14may93py
  129: 
  130: : get-order  ( -- wid1 .. widn n )
  131:   vp @ 0 ?DO  vp cell+ I cells + @  LOOP  vp @ ;
  132: 
  133: : set-order  ( wid1 .. widn n / -1 -- )
  134:   dup -1 = IF  drop Only exit  THEN  dup vp !
  135:   ?dup IF  1- FOR  vp cell+ I cells + !  NEXT  THEN ;
  136: 
  137: : seal ( -- )  context @ 1 set-order ;
  138: 
  139: \ words visible in roots                               14may93py
  140: 
  141: : .name ( name -- ) name>string type space ;
  142: : words  cr 0 context @
  143:   BEGIN  @ dup  WHILE  2dup cell+ c@ $1F and 2 + dup >r +
  144:          &79 >  IF  cr nip 0 swap  THEN
  145:          dup .name space r> rot + swap  REPEAT 2drop ;
  146: 
  147: : body> ( data -- cfa )  0 >body - ;
  148: 
  149: : .voc  body> >name .name ;
  150: : order  1 vp @  DO  vp I cells + @ .voc  -1 +LOOP  2 spaces
  151:   current @ .voc ;
  152: : vocs   voclink  BEGIN  @ dup @  WHILE  dup 2 cells - .voc  REPEAT  drop ;
  153: 
  154: Root definitions
  155: 
  156: ' words Alias words
  157: ' Forth Alias Forth
  158: 
  159: Forth definitions