--- gforth/hash.fs 1997/07/06 15:55:24 1.18 +++ gforth/hash.fs 2009/12/27 01:00:52 1.39 @@ -1,12 +1,12 @@ \ Hashed dictionaries 15jul94py -\ Copyright (C) 1995 Free Software Foundation, Inc. +\ Copyright (C) 1995,1998,2000,2003,2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,27 +15,32 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. -[IFUNDEF] e? : e? name 2drop false ; [THEN] +[IFUNDEF] erase +: erase ( addr len -- ) 0 fill ; +[THEN] -e? ec -[IF] +[IFUNDEF] allocate : reserve-mem here swap allot ; -\ ToDo: check memory space with unused \ move to a kernel/memory.fs [ELSE] : reserve-mem allocate throw ; [THEN] [IFUNDEF] hashbits -11 value hashbits +11 Value hashbits [THEN] 1 hashbits lshift Value Hashlen \ compute hash key 15jul94py +has? ec [IF] [IFUNDEF] hash +: hash ( addr len -- key ) + over c@ swap 1- IF swap char+ c@ + ELSE nip THEN + [ Hashlen 1- ] literal and ; +[THEN] [THEN] + [IFUNDEF] hash : hash ( addr len -- key ) hashbits (hashkey1) ; @@ -46,13 +51,14 @@ Variable revealed \ Memory handling 10oct94py -Variable HashPointer -Variable HashIndex -0 Value HashTable +AVariable HashPointer +Variable HashIndex \ Number of wordlists +Variable HashPop \ Number of words +0 AValue HashTable \ forward declarations -0 Value hashsearch-map -Defer hash-alloc +0 AValue hashsearch-map +Defer hash-alloc ( addr -- addr ) \ DelFix and NewFix are from bigFORTH 15jul94py @@ -69,7 +75,7 @@ Defer hash-alloc cells HashTable + ; : hash-find ( addr len wordlist -- nfa / false ) - >r 2dup r> bucket @ (hashfind) ; + >r 2dup r> bucket @ (hashlfind) ; \ hash vocabularies 16jul94py @@ -85,22 +91,23 @@ Defer hash-alloc ELSE lastlink! THEN - revealed on ; + revealed on 1 HashPop +! 0 hash-alloc drop ; : hash-reveal ( nfa wid -- ) 2dup (reveal) (reveal ; : inithash ( wid -- ) wordlist-extend - insRule @ >r insRule off hash-alloc 3 cells - dup + insRule @ >r insRule off 1 hash-alloc over ! 3 cells - + dup wordlist-id BEGIN @ dup WHILE 2dup swap (reveal REPEAT 2drop r> insRule ! ; : addall ( -- ) - voclink + HashPop off voclink BEGIN @ dup WHILE dup 0 wordlist-link - - dup wordlist-map @ hashsearch-map = + dup wordlist-map @ reveal-method @ ['] hash-reveal = IF inithash ELSE drop THEN REPEAT drop ; @@ -108,15 +115,24 @@ Defer hash-alloc HashTable Hashlen cells bounds DO I @ BEGIN dup WHILE - dup @ swap HashPointer DelFix - REPEAT I ! - cell +LOOP HashIndex off + dup @ swap HashPointer DelFix + REPEAT + I ! + cell +LOOP + HashIndex off voclink - BEGIN @ dup WHILE - dup 0 wordlist-link - - dup wordlist-map @ hashsearch-map = - IF 0 swap wordlist-extend ! ELSE drop THEN - REPEAT drop ; + BEGIN ( wordlist-link-addr ) + @ dup + WHILE ( wordlist-link ) + dup 0 wordlist-link - ( wordlist-link wid ) + dup wordlist-map @ hashsearch-map = + IF ( wordlist-link wid ) + 0 swap wordlist-extend ! + ELSE + drop + THEN + REPEAT + drop ; : rehashall ( wid -- ) drop revealed @ @@ -128,58 +144,68 @@ Defer hash-alloc IF inithash ELSE rehashall THEN ; -\ >rom ?! -align here ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A, -to hashsearch-map +: hashdouble ( -- ) + HashTable >r clearhash + 1 hashbits 1+ dup to hashbits lshift to hashlen + r> free >r 0 to HashTable + addall r> throw ; + +const Create (hashsearch-map) +' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A, +(hashsearch-map) to hashsearch-map \ hash allocate and vocabulary initialization 10oct94py -:noname ( hash-alloc ) ( addr -- addr ) +:noname ( n+ -- n ) HashTable 0= IF Hashlen cells reserve-mem TO HashTable HashTable Hashlen cells erase THEN - HashIndex @ over ! 1 HashIndex +! + HashIndex @ swap HashIndex +! HashIndex @ Hashlen >= - [ e? ec [IF] ] + [ [IFUNDEF] allocate ] ABORT" no more space in hashtable" [ [ELSE] ] - IF HashTable >r clearhash - 1 hashbits 1+ dup to hashbits lshift to hashlen - r> free >r 0 to HashTable - addall r> throw - THEN + HashPop @ hashlen 2* >= or + IF hashdouble THEN [ [THEN] ] ; is hash-alloc \ Hash-Find 01jan93py -e? cross 0= +has? cross 0= [IF] +: hash-wordlist ( wid -- ) + hashsearch-map swap wordlist-map ! ; : make-hash - hashsearch-map forth-wordlist cell+ ! + forth-wordlist hash-wordlist + environment-wordlist hash-wordlist + ['] Root >body hash-wordlist addall ; make-hash \ Baumsuche ist installiert. [ELSE] - hashsearch-map forth-wordlist cell+ ! + hashsearch-map forth-wordlist wordlist-map ! [THEN] \ for ec version display that vocabulary goes hashed : hash-cold ( -- ) -[ e? ec [IF] ] ." Hashing..." [ [THEN] ] +[ has? ec [IF] ] ." Hashing..." [ [THEN] ] HashPointer off 0 TO HashTable HashIndex off addall \ voclink \ BEGIN @ dup WHILE \ dup 0 wordlist-link - initvoc \ REPEAT drop -[ e? ec [IF] ] ." Done" cr [ [THEN] ] ; +[ has? ec [IF] ] ." Done" cr [ [THEN] ] ; -' hash-cold INIT8 chained +:noname ( -- ) + defers 'cold + hash-cold +; is 'cold : .words ( -- ) base @ >r hex HashTable Hashlen 0 DO cr i 2 .r ." : " dup i cells + BEGIN @ dup WHILE - dup cell+ @ head>string type space REPEAT drop + dup cell+ @ name>string type space REPEAT drop LOOP drop r> base ! ; \ \ this stuff is for evaluating the hash function @@ -203,3 +229,15 @@ e? cross 0= \ : chisq ( -- n ) \ \ n should have about the same size as Hashlen \ countwl Hashlen 2 pick */ swap - ; + +\ Create hashhist here $100 cells dup allot erase + +\ : .hashhist ( -- ) hashhist $100 cells erase +\ HashTable HashLen cells bounds +\ DO 0 I BEGIN @ dup WHILE swap 1+ swap REPEAT drop +\ 1 swap cells hashhist + +! +\ cell +LOOP +\ 0 0 $100 0 DO +\ hashhist I cells + @ dup IF +\ cr I 0 .r ." : " dup . THEN tuck I * + >r + r> +\ LOOP cr ." Total: " 0 .r ." /" . cr ;