| \ ***************************************************************************** |
| \ * Copyright (c) 2004, 2008 IBM Corporation |
| \ * All rights reserved. |
| \ * This program and the accompanying materials |
| \ * are made available under the terms of the BSD License |
| \ * which accompanies this distribution, and is available at |
| \ * http://www.opensource.org/licenses/bsd-license.php |
| \ * |
| \ * Contributors: |
| \ * IBM Corporation - initial implementation |
| \ ****************************************************************************/ |
| |
| #ifdef HASH_DEBUG |
| 0 value from-hash |
| 0 value not-from-hash |
| 0 value hash-collisions |
| #endif |
| |
| clean-hash |
| |
| : hash-find ( str len head -- 0 | link ) |
| >r 2dup 2dup hash ( str len str len hash R: head ) |
| dup >r @ dup ( str len str len *hash *hash R: head hash ) |
| IF ( str len str len *hash R: head hash ) |
| link>name name>string string=ci ( str len true|false R: head hash ) |
| dup 0= |
| IF |
| #ifdef HASH_DEBUG |
| hash-collisions 1+ |
| to hash-collisions |
| #endif |
| THEN |
| ELSE |
| nip nip ( str len 0 R: head hash ) |
| THEN |
| IF \ hash found |
| 2drop r> @ r> drop ( *hash R: ) |
| #ifdef HASH_DEBUG |
| from-hash 1+ to from-hash |
| #endif |
| exit |
| THEN \ hash not found |
| r> r> swap >r ((find)) ( str len head R: hash=0 ) |
| dup |
| IF |
| #ifdef HASH_DEBUG |
| not-from-hash 1+ |
| to not-from-hash |
| #endif |
| dup r> ! ( link R: ) |
| ELSE |
| r> drop ( 0 R: ) |
| THEN |
| ; |
| |
| : hash-reveal hash off ; |
| |
| ' hash-reveal to (reveal) |
| ' hash-find to (find) |
| |
| #ifdef HASH_DEBUG |
| \ print out all entries in the hash table |
| : dump-hash-table ( -- ) |
| cr |
| hash-table hash-size 0 DO |
| dup @ dup 0<> IF |
| over . s" : " type link>name name>string type cr |
| ELSE |
| drop |
| THEN |
| cell+ |
| LOOP drop |
| s" hash-collisions: " type hash-collisions . cr |
| s" from-hash: " type from-hash . cr |
| s" not-from-hash: " type not-from-hash . cr |
| ; |
| #endif |
