sys/boot/ficl/dict.c

   1 /*******************************************************************
   2 ** d i c t . c
   3 ** Forth Inspired Command Language - dictionary methods
   4 ** Author: John Sadler (john_sadler@alum.mit.edu)
   5 ** Created: 19 July 1997
   6 ** $Id: dict.c,v 1.14 2001/12/05 07:21:34 jsadler Exp $
   7 *******************************************************************/
   8 /*
   9 ** This file implements the dictionary -- FICL's model of
  10 ** memory management. All FICL words are stored in the
  11 ** dictionary. A word is a named chunk of data with its
  12 ** associated code. FICL treats all words the same, even
  13 ** precompiled ones, so your words become first-class
  14 ** extensions of the language. You can even define new
  15 ** control structures.
  16 **
  17 ** 29 jun 1998 (sadler) added variable sized hash table support
  18 */
  19 /*
  20 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
  21 ** All rights reserved.
  22 **
  23 ** Get the latest Ficl release at http://ficl.sourceforge.net
  24 **
  25 ** I am interested in hearing from anyone who uses ficl. If you have
  26 ** a problem, a success story, a defect, an enhancement request, or
  27 ** if you would like to contribute to the ficl release, please
  28 ** contact me by email at the address above.
  29 **
  30 ** L I C E N S E  and  D I S C L A I M E R
  31 **
  32 ** Redistribution and use in source and binary forms, with or without
  33 ** modification, are permitted provided that the following conditions
  34 ** are met:
  35 ** 1. Redistributions of source code must retain the above copyright
  36 **    notice, this list of conditions and the following disclaimer.
  37 ** 2. Redistributions in binary form must reproduce the above copyright
  38 **    notice, this list of conditions and the following disclaimer in the
  39 **    documentation and/or other materials provided with the distribution.
  40 **
  41 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  42 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  43 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  44 ** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  45 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  46 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  47 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  48 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  49 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  50 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  51 ** SUCH DAMAGE.
  52 */
  53
  54 /*
  55  * $FreeBSD: src/sys/boot/ficl/dict.c,v 1.13 2002/04/09 17:45:11 dcs Exp $
  56  * $DragonFly: src/sys/boot/ficl/dict.c,v 1.3 2003/11/10 06:08:33 dillon Exp $
  57  */
  58
  59 #ifdef TESTMAIN
  60 #include <stdio.h>
  61 #include <ctype.h>
  62 #else
  63 #include <stand.h>
  64 #endif
  65 #include <string.h>
  66 #include "ficl.h"
  67
  68 /* Dictionary on-demand resizing control variables */
  69 CELL dictThreshold;
  70 CELL dictIncrease;
  71
  72
  73 static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si);
  74
  75 /**************************************************************************
  76                         d i c t A b o r t D e f i n i t i o n
  77 ** Abort a definition in process: reclaim its memory and unlink it
  78 ** from the dictionary list. Assumes that there is a smudged
  79 ** definition in process...otherwise does nothing.
  80 ** NOTE: this function is not smart enough to unlink a word that
  81 ** has been successfully defined (ie linked into a hash). It
  82 ** only works for defs in process. If the def has been unsmudged,
  83 ** nothing happens.
  84 **************************************************************************/
  85 void dictAbortDefinition(FICL_DICT *pDict)
  86 {
  87     FICL_WORD *pFW;
  88     ficlLockDictionary(TRUE);
  89     pFW = pDict->smudge;
  90
  91     if (pFW->flags & FW_SMUDGE)
  92         pDict->here = (CELL *)pFW->name;
  93
  94     ficlLockDictionary(FALSE);
  95     return;
  96 }
  97
  98
  99 /**************************************************************************
 100                         a l i g n P t r
 101 ** Aligns the given pointer to FICL_ALIGN address units.
 102 ** Returns the aligned pointer value.
 103 **************************************************************************/
 104 void *alignPtr(void *ptr)
 105 {
 106 #if FICL_ALIGN > 0
 107     char *cp;
 108     CELL c;
 109     cp = (char *)ptr + FICL_ALIGN_ADD;
 110     c.p = (void *)cp;
 111     c.u = c.u & (~FICL_ALIGN_ADD);
 112     ptr = (CELL *)c.p;
 113 #endif
 114     return ptr;
 115 }
 116
 117
 118 /**************************************************************************
 119                         d i c t A l i g n
 120 ** Align the dictionary's free space pointer
 121 **************************************************************************/
 122 void dictAlign(FICL_DICT *pDict)
 123 {
 124     pDict->here = alignPtr(pDict->here);
 125 }
 126
 127
 128 /**************************************************************************
 129                         d i c t A l l o t
 130 ** Allocate or remove n chars of dictionary space, with
 131 ** checks for underrun and overrun
 132 **************************************************************************/
 133 int dictAllot(FICL_DICT *pDict, int n)
 134 {
 135     char *cp = (char *)pDict->here;
 136 #if FICL_ROBUST
 137     if (n > 0)
 138     {
 139         if ((unsigned)n <= dictCellsAvail(pDict) * sizeof (CELL))
 140             cp += n;
 141         else
 142             return 1;       /* dict is full */
 143     }
 144     else
 145     {
 146         n = -n;
 147         if ((unsigned)n <= dictCellsUsed(pDict) * sizeof (CELL))
 148             cp -= n;
 149         else                /* prevent underflow */
 150             cp -= dictCellsUsed(pDict) * sizeof (CELL);
 151     }
 152 #else
 153     cp += n;
 154 #endif
 155     pDict->here = PTRtoCELL cp;
 156     return 0;
 157 }
 158
 159
 160 /**************************************************************************
 161                         d i c t A l l o t C e l l s
 162 ** Reserve space for the requested number of cells in the
 163 ** dictionary. If nCells < 0 , removes space from the dictionary.
 164 **************************************************************************/
 165 int dictAllotCells(FICL_DICT *pDict, int nCells)
 166 {
 167 #if FICL_ROBUST
 168     if (nCells > 0)
 169     {
 170         if (nCells <= dictCellsAvail(pDict))
 171             pDict->here += nCells;
 172         else
 173             return 1;       /* dict is full */
 174     }
 175     else
 176     {
 177         nCells = -nCells;
 178         if (nCells <= dictCellsUsed(pDict))
 179             pDict->here -= nCells;
 180         else                /* prevent underflow */
 181             pDict->here -= dictCellsUsed(pDict);
 182     }
 183 #else
 184     pDict->here += nCells;
 185 #endif
 186     return 0;
 187 }
 188
 189
 190 /**************************************************************************
 191                         d i c t A p p e n d C e l l
 192 ** Append the specified cell to the dictionary
 193 **************************************************************************/
 194 void dictAppendCell(FICL_DICT *pDict, CELL c)
 195 {
 196     *pDict->here++ = c;
 197     return;
 198 }
 199
 200
 201 /**************************************************************************
 202                         d i c t A p p e n d C h a r
 203 ** Append the specified char to the dictionary
 204 **************************************************************************/
 205 void dictAppendChar(FICL_DICT *pDict, char c)
 206 {
 207     char *cp = (char *)pDict->here;
 208     *cp++ = c;
 209     pDict->here = PTRtoCELL cp;
 210     return;
 211 }
 212
 213
 214 /**************************************************************************
 215                         d i c t A p p e n d W o r d
 216 ** Create a new word in the dictionary with the specified
 217 ** name, code, and flags. Name must be NULL-terminated.
 218 **************************************************************************/
 219 FICL_WORD *dictAppendWord(FICL_DICT *pDict,
 220                           char *name,
 221                           FICL_CODE pCode,
 222                           UNS8 flags)
 223 {
 224     STRINGINFO si;
 225     SI_SETLEN(si, strlen(name));
 226     SI_SETPTR(si, name);
 227     return dictAppendWord2(pDict, si, pCode, flags);
 228 }
 229
 230
 231 /**************************************************************************
 232                         d i c t A p p e n d W o r d 2
 233 ** Create a new word in the dictionary with the specified
 234 ** STRINGINFO, code, and flags. Does not require a NULL-terminated
 235 ** name.
 236 **************************************************************************/
 237 FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
 238                            STRINGINFO si,
 239                            FICL_CODE pCode,
 240                            UNS8 flags)
 241 {
 242     FICL_COUNT len  = (FICL_COUNT)SI_COUNT(si);
 243     char *pName;
 244     FICL_WORD *pFW;
 245
 246     ficlLockDictionary(TRUE);
 247
 248     /*
 249     ** NOTE: dictCopyName advances "here" as a side-effect.
 250     ** It must execute before pFW is initialized.
 251     */
 252     pName         = dictCopyName(pDict, si);
 253     pFW           = (FICL_WORD *)pDict->here;
 254     pDict->smudge = pFW;
 255     pFW->hash     = hashHashCode(si);
 256     pFW->code     = pCode;
 257     pFW->flags    = (UNS8)(flags | FW_SMUDGE);
 258     pFW->nName    = (char)len;
 259     pFW->name     = pName;
 260     /*
 261     ** Point "here" to first cell of new word's param area...
 262     */
 263     pDict->here   = pFW->param;
 264
 265     if (!(flags & FW_SMUDGE))
 266         dictUnsmudge(pDict);
 267
 268     ficlLockDictionary(FALSE);
 269     return pFW;
 270 }
 271
 272
 273 /**************************************************************************
 274                         d i c t A p p e n d U N S
 275 ** Append the specified FICL_UNS to the dictionary
 276 **************************************************************************/
 277 void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u)
 278 {
 279     *pDict->here++ = LVALUEtoCELL(u);
 280     return;
 281 }
 282
 283
 284 /**************************************************************************
 285                         d i c t C e l l s A v a i l
 286 ** Returns the number of empty cells left in the dictionary
 287 **************************************************************************/
 288 int dictCellsAvail(FICL_DICT *pDict)
 289 {
 290     return pDict->size - dictCellsUsed(pDict);
 291 }
 292
 293
 294 /**************************************************************************
 295                         d i c t C e l l s U s e d
 296 ** Returns the number of cells consumed in the dicionary
 297 **************************************************************************/
 298 int dictCellsUsed(FICL_DICT *pDict)
 299 {
 300     return pDict->here - pDict->dict;
 301 }
 302
 303
 304 /**************************************************************************
 305                         d i c t C h e c k
 306 ** Checks the dictionary for corruption and throws appropriate
 307 ** errors.
 308 ** Input: +n number of ADDRESS UNITS (not Cells) proposed to allot
 309 **        -n number of ADDRESS UNITS proposed to de-allot
 310 **         0 just do a consistency check
 311 **************************************************************************/
 312 void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n)
 313 {
 314     if ((n >= 0) && (dictCellsAvail(pDict) * (int)sizeof(CELL) < n))
 315     {
 316         vmThrowErr(pVM, "Error: dictionary full");
 317     }
 318
 319     if ((n <= 0) && (dictCellsUsed(pDict) * (int)sizeof(CELL) < -n))
 320     {
 321         vmThrowErr(pVM, "Error: dictionary underflow");
 322     }
 323
 324     if (pDict->nLists > FICL_DEFAULT_VOCS)
 325     {
 326         dictResetSearchOrder(pDict);
 327         vmThrowErr(pVM, "Error: search order overflow");
 328     }
 329     else if (pDict->nLists < 0)
 330     {
 331         dictResetSearchOrder(pDict);
 332         vmThrowErr(pVM, "Error: search order underflow");
 333     }
 334
 335     return;
 336 }
 337
 338
 339 /**************************************************************************
 340                         d i c t C o p y N a m e
 341 ** Copy up to nFICLNAME characters of the name specified by si into
 342 ** the dictionary starting at "here", then NULL-terminate the name,
 343 ** point "here" to the next available byte, and return the address of
 344 ** the beginning of the name. Used by dictAppendWord.
 345 ** N O T E S :
 346 ** 1. "here" is guaranteed to be aligned after this operation.
 347 ** 2. If the string has zero length, align and return "here"
 348 **************************************************************************/
 349 static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si)
 350 {
 351     char *oldCP    = (char *)pDict->here;
 352     char *cp       = oldCP;
 353     char *name     = SI_PTR(si);
 354     int   i        = SI_COUNT(si);
 355
 356     if (i == 0)
 357     {
 358         dictAlign(pDict);
 359         return (char *)pDict->here;
 360     }
 361
 362     if (i > nFICLNAME)
 363         i = nFICLNAME;
 364
 365     for (; i > 0; --i)
 366     {
 367         *cp++ = *name++;
 368     }
 369
 370     *cp++ = '\0';
 371
 372     pDict->here = PTRtoCELL cp;
 373     dictAlign(pDict);
 374     return oldCP;
 375 }
 376
 377
 378 /**************************************************************************
 379                         d i c t C r e a t e
 380 ** Create and initialize a dictionary with the specified number
 381 ** of cells capacity, and no hashing (hash size == 1).
 382 **************************************************************************/
 383 FICL_DICT  *dictCreate(unsigned nCells)
 384 {
 385     return dictCreateHashed(nCells, 1);
 386 }
 387
 388
 389 FICL_DICT  *dictCreateHashed(unsigned nCells, unsigned nHash)
 390 {
 391     FICL_DICT *pDict;
 392     size_t nAlloc;
 393
 394     nAlloc =  sizeof (FICL_HASH) + nCells      * sizeof (CELL)
 395                                  + (nHash - 1) * sizeof (FICL_WORD *);
 396
 397     pDict = ficlMalloc(sizeof (FICL_DICT));
 398     assert(pDict);
 399     memset(pDict, 0, sizeof (FICL_DICT));
 400     pDict->dict = ficlMalloc(nAlloc);
 401     assert(pDict->dict);
 402
 403     pDict->size = nCells;
 404     dictEmpty(pDict, nHash);
 405     return pDict;
 406 }
 407
 408
 409 /**************************************************************************
 410                         d i c t C r e a t e W o r d l i s t
 411 ** Create and initialize an anonymous wordlist
 412 **************************************************************************/
 413 FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets)
 414 {
 415     FICL_HASH *pHash;
 416
 417     dictAlign(dp);
 418     pHash    = (FICL_HASH *)dp->here;
 419     dictAllot(dp, sizeof (FICL_HASH)
 420         + (nBuckets-1) * sizeof (FICL_WORD *));
 421
 422     pHash->size = nBuckets;
 423     hashReset(pHash);
 424     return pHash;
 425 }
 426
 427
 428 /**************************************************************************
 429                         d i c t D e l e t e
 430 ** Free all memory allocated for the given dictionary
 431 **************************************************************************/
 432 void dictDelete(FICL_DICT *pDict)
 433 {
 434     assert(pDict);
 435     ficlFree(pDict);
 436     return;
 437 }
 438
 439
 440 /**************************************************************************
 441                         d i c t E m p t y
 442 ** Empty the dictionary, reset its hash table, and reset its search order.
 443 ** Clears and (re-)creates the hash table with the size specified by nHash.
 444 **************************************************************************/
 445 void dictEmpty(FICL_DICT *pDict, unsigned nHash)
 446 {
 447     FICL_HASH *pHash;
 448
 449     pDict->here = pDict->dict;
 450
 451     dictAlign(pDict);
 452     pHash = (FICL_HASH *)pDict->here;
 453     dictAllot(pDict,
 454               sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *));
 455
 456     pHash->size = nHash;
 457     hashReset(pHash);
 458
 459     pDict->pForthWords = pHash;
 460     pDict->smudge = NULL;
 461     dictResetSearchOrder(pDict);
 462     return;
 463 }
 464
 465
 466 /**************************************************************************
 467                         d i c t H a s h S u m m a r y
 468 ** Calculate a figure of merit for the dictionary hash table based
 469 ** on the average search depth for all the words in the dictionary,
 470 ** assuming uniform distribution of target keys. The figure of merit
 471 ** is the ratio of the total search depth for all keys in the table
 472 ** versus a theoretical optimum that would be achieved if the keys
 473 ** were distributed into the table as evenly as possible.
 474 ** The figure would be worse if the hash table used an open
 475 ** addressing scheme (i.e. collisions resolved by searching the
 476 ** table for an empty slot) for a given size table.
 477 **************************************************************************/
 478 #if FICL_WANT_FLOAT
 479 void dictHashSummary(FICL_VM *pVM)
 480 {
 481     FICL_DICT *dp = vmGetDict(pVM);
 482     FICL_HASH *pFHash;
 483     FICL_WORD **pHash;
 484     unsigned size;
 485     FICL_WORD *pFW;
 486     unsigned i;
 487     int nMax = 0;
 488     int nWords = 0;
 489     int nFilled;
 490     double avg = 0.0;
 491     double best;
 492     int nAvg, nRem, nDepth;
 493
 494     dictCheck(dp, pVM, 0);
 495
 496     pFHash = dp->pSearch[dp->nLists - 1];
 497     pHash  = pFHash->table;
 498     size   = pFHash->size;
 499     nFilled = size;
 500
 501     for (i = 0; i < size; i++)
 502     {
 503         int n = 0;
 504         pFW = pHash[i];
 505
 506         while (pFW)
 507         {
 508             ++n;
 509             ++nWords;
 510             pFW = pFW->link;
 511         }
 512
 513         avg += (double)(n * (n+1)) / 2.0;
 514
 515         if (n > nMax)
 516             nMax = n;
 517         if (n == 0)
 518             --nFilled;
 519     }
 520
 521     /* Calc actual avg search depth for this hash */
 522     avg = avg / nWords;
 523
 524     /* Calc best possible performance with this size hash */
 525     nAvg = nWords / size;
 526     nRem = nWords % size;
 527     nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
 528     best = (double)nDepth/nWords;
 529
 530     sprintf(pVM->pad,
 531         "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%",
 532         size,
 533         (double)nFilled * 100.0 / size, nMax,
 534         avg,
 535         best,
 536         100.0 * best / avg);
 537
 538     ficlTextOut(pVM, pVM->pad, 1);
 539
 540     return;
 541 }
 542 #endif
 543
 544 /**************************************************************************
 545                         d i c t I n c l u d e s
 546 ** Returns TRUE iff the given pointer is within the address range of
 547 ** the dictionary.
 548 **************************************************************************/
 549 int dictIncludes(FICL_DICT *pDict, void *p)
 550 {
 551     return ((p >= (void *) &pDict->dict)
 552         &&  (p <  (void *)(&pDict->dict + pDict->size))
 553            );
 554 }
 555
 556 /**************************************************************************
 557                         d i c t L o o k u p
 558 ** Find the FICL_WORD that matches the given name and length.
 559 ** If found, returns the word's address. Otherwise returns NULL.
 560 ** Uses the search order list to search multiple wordlists.
 561 **************************************************************************/
 562 FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si)
 563 {
 564     FICL_WORD *pFW = NULL;
 565     FICL_HASH *pHash;
 566     int i;
 567     UNS16 hashCode   = hashHashCode(si);
 568
 569     assert(pDict);
 570
 571     ficlLockDictionary(1);
 572
 573     for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
 574     {
 575         pHash = pDict->pSearch[i];
 576         pFW = hashLookup(pHash, si, hashCode);
 577     }
 578
 579     ficlLockDictionary(0);
 580     return pFW;
 581 }
 582
 583
 584 /**************************************************************************
 585                         f i c l L o o k u p L o c
 586 ** Same as dictLookup, but looks in system locals dictionary first...
 587 ** Assumes locals dictionary has only one wordlist...
 588 **************************************************************************/
 589 #if FICL_WANT_LOCALS
 590 FICL_WORD *ficlLookupLoc(FICL_SYSTEM *pSys, STRINGINFO si)
 591 {
 592     FICL_WORD *pFW = NULL;
 593         FICL_DICT *pDict = pSys->dp;
 594     FICL_HASH *pHash = ficlGetLoc(pSys)->pForthWords;
 595     int i;
 596     UNS16 hashCode   = hashHashCode(si);
 597
 598     assert(pHash);
 599     assert(pDict);
 600
 601     ficlLockDictionary(1);
 602     /*
 603     ** check the locals dict first...
 604     */
 605     pFW = hashLookup(pHash, si, hashCode);
 606
 607     /*
 608     ** If no joy, (!pFW) --------------------------v
 609     ** iterate over the search list in the main dict
 610     */
 611     for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
 612     {
 613         pHash = pDict->pSearch[i];
 614         pFW = hashLookup(pHash, si, hashCode);
 615     }
 616
 617     ficlLockDictionary(0);
 618     return pFW;
 619 }
 620 #endif
 621
 622
 623 /**************************************************************************
 624                     d i c t R e s e t S e a r c h O r d e r
 625 ** Initialize the dictionary search order list to sane state
 626 **************************************************************************/
 627 void dictResetSearchOrder(FICL_DICT *pDict)
 628 {
 629     assert(pDict);
 630     pDict->pCompile = pDict->pForthWords;
 631     pDict->nLists = 1;
 632     pDict->pSearch[0] = pDict->pForthWords;
 633     return;
 634 }
 635
 636
 637 /**************************************************************************
 638                         d i c t S e t F l a g s
 639 ** Changes the flags field of the most recently defined word:
 640 ** Set all bits that are ones in the set parameter, clear all bits
 641 ** that are ones in the clr parameter. Clear wins in case the same bit
 642 ** is set in both parameters.
 643 **************************************************************************/
 644 void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr)
 645 {
 646     assert(pDict->smudge);
 647     pDict->smudge->flags |= set;
 648     pDict->smudge->flags &= ~clr;
 649     return;
 650 }
 651
 652
 653 /**************************************************************************
 654                         d i c t S e t I m m e d i a t e
 655 ** Set the most recently defined word as IMMEDIATE
 656 **************************************************************************/
 657 void dictSetImmediate(FICL_DICT *pDict)
 658 {
 659     assert(pDict->smudge);
 660     pDict->smudge->flags |= FW_IMMEDIATE;
 661     return;
 662 }
 663
 664
 665 /**************************************************************************
 666                         d i c t U n s m u d g e
 667 ** Completes the definition of a word by linking it
 668 ** into the main list
 669 **************************************************************************/
 670 void dictUnsmudge(FICL_DICT *pDict)
 671 {
 672     FICL_WORD *pFW = pDict->smudge;
 673     FICL_HASH *pHash = pDict->pCompile;
 674
 675     assert(pHash);
 676     assert(pFW);
 677     /*
 678     ** :noname words never get linked into the list...
 679     */
 680     if (pFW->nName > 0)
 681         hashInsertWord(pHash, pFW);
 682     pFW->flags &= ~(FW_SMUDGE);
 683     return;
 684 }
 685
 686
 687 /**************************************************************************
 688                         d i c t W h e r e
 689 ** Returns the value of the HERE pointer -- the address
 690 ** of the next free cell in the dictionary
 691 **************************************************************************/
 692 CELL *dictWhere(FICL_DICT *pDict)
 693 {
 694     return pDict->here;
 695 }
 696
 697
 698 /**************************************************************************
 699                         h a s h F o r g e t
 700 ** Unlink all words in the hash that have addresses greater than or
 701 ** equal to the address supplied. Implementation factor for FORGET
 702 ** and MARKER.
 703 **************************************************************************/
 704 void hashForget(FICL_HASH *pHash, void *where)
 705 {
 706     FICL_WORD *pWord;
 707     unsigned i;
 708
 709     assert(pHash);
 710     assert(where);
 711
 712     for (i = 0; i < pHash->size; i++)
 713     {
 714         pWord = pHash->table[i];
 715
 716         while ((void *)pWord >= where)
 717         {
 718             pWord = pWord->link;
 719         }
 720
 721         pHash->table[i] = pWord;
 722     }
 723
 724     return;
 725 }
 726
 727
 728 /**************************************************************************
 729                         h a s h H a s h C o d e
 730 **
 731 ** Generate a 16 bit hashcode from a character string using a rolling
 732 ** shift and add stolen from PJ Weinberger of Bell Labs fame. Case folds
 733 ** the name before hashing it...
 734 ** N O T E : If string has zero length, returns zero.
 735 **************************************************************************/
 736 UNS16 hashHashCode(STRINGINFO si)
 737 {
 738     /* hashPJW */
 739     UNS8 *cp;
 740     UNS16 code = (UNS16)si.count;
 741     UNS16 shift = 0;
 742
 743     if (si.count == 0)
 744         return 0;
 745
 746     /* changed to run without errors under Purify -- lch */
 747     for (cp = (UNS8 *)si.cp; si.count && *cp; cp++, si.count--)
 748     {
 749         code = (UNS16)((code << 4) + tolower(*cp));
 750         shift = (UNS16)(code & 0xf000);
 751         if (shift)
 752         {
 753             code ^= (UNS16)(shift >> 8);
 754             code ^= (UNS16)shift;
 755         }
 756     }
 757
 758     return (UNS16)code;
 759 }
 760
 761
 762
 763
 764 /**************************************************************************
 765                         h a s h I n s e r t W o r d
 766 ** Put a word into the hash table using the word's hashcode as
 767 ** an index (modulo the table size).
 768 **************************************************************************/
 769 void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW)
 770 {
 771     FICL_WORD **pList;
 772
 773     assert(pHash);
 774     assert(pFW);
 775
 776     if (pHash->size == 1)
 777     {
 778         pList = pHash->table;
 779     }
 780     else
 781     {
 782         pList = pHash->table + (pFW->hash % pHash->size);
 783     }
 784
 785     pFW->link = *pList;
 786     *pList = pFW;
 787     return;
 788 }
 789
 790
 791 /**************************************************************************
 792                         h a s h L o o k u p
 793 ** Find a name in the hash table given the hashcode and text of the name.
 794 ** Returns the address of the corresponding FICL_WORD if found,
 795 ** otherwise NULL.
 796 ** Note: outer loop on link field supports inheritance in wordlists.
 797 ** It's not part of ANS Forth - ficl only. hashReset creates wordlists
 798 ** with NULL link fields.
 799 **************************************************************************/
 800 FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode)
 801 {
 802     FICL_UNS nCmp = si.count;
 803     FICL_WORD *pFW;
 804     UNS16 hashIdx;
 805
 806     if (nCmp > nFICLNAME)
 807         nCmp = nFICLNAME;
 808
 809     for (; pHash != NULL; pHash = pHash->link)
 810     {
 811         if (pHash->size > 1)
 812             hashIdx = (UNS16)(hashCode % pHash->size);
 813         else            /* avoid the modulo op for single threaded lists */
 814             hashIdx = 0;
 815
 816         for (pFW = pHash->table[hashIdx]; pFW; pFW = pFW->link)
 817         {
 818             if ( (pFW->nName == si.count)
 819                 && (!strincmp(si.cp, pFW->name, nCmp)) )
 820                 return pFW;
 821 #if FICL_ROBUST
 822             assert(pFW != pFW->link);
 823 #endif
 824         }
 825     }
 826
 827     return NULL;
 828 }
 829
 830
 831 /**************************************************************************
 832                              h a s h R e s e t
 833 ** Initialize a FICL_HASH to empty state.
 834 **************************************************************************/
 835 void hashReset(FICL_HASH *pHash)
 836 {
 837     unsigned i;
 838
 839     assert(pHash);
 840
 841     for (i = 0; i < pHash->size; i++)
 842     {
 843         pHash->table[i] = NULL;
 844     }
 845
 846     pHash->link = NULL;
 847     pHash->name = NULL;
 848     return;
 849 }
 850
 851 /**************************************************************************
 852                     d i c t C h e c k T h r e s h o l d
 853 ** Verify if an increase in the dictionary size is warranted, and do it if
 854 ** so.
 855 **************************************************************************/
 856
 857 void dictCheckThreshold(FICL_DICT* dp)
 858 {
 859     if( dictCellsAvail(dp) < dictThreshold.u ) {
 860         dp->dict = ficlMalloc( dictIncrease.u * sizeof (CELL) );
 861         assert(dp->dict);
 862         dp->here = dp->dict;
 863         dp->size = dictIncrease.u;
 864         dictAlign(dp);
 865     }
 866 }
 867