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