1 /*******************************************************************
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 *******************************************************************/
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.
17 ** 29 jun 1998 (sadler) added variable sized hash table support
20 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
21 ** All rights reserved.
23 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
30 ** L I C E N S E and D I S C L A I M E R
32 ** Redistribution and use in source and binary forms, with or without
33 ** modification, are permitted provided that the following conditions
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.
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
64 /* Dictionary on-demand resizing control variables */
69 static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si);
71 /**************************************************************************
72 d i c t A b o r t D e f i n i t i o n
73 ** Abort a definition in process: reclaim its memory and unlink it
74 ** from the dictionary list. Assumes that there is a smudged
75 ** definition in process...otherwise does nothing.
76 ** NOTE: this function is not smart enough to unlink a word that
77 ** has been successfully defined (ie linked into a hash). It
78 ** only works for defs in process. If the def has been unsmudged,
80 **************************************************************************/
81 void dictAbortDefinition(FICL_DICT *pDict)
84 ficlLockDictionary(TRUE);
87 if (pFW->flags & FW_SMUDGE)
88 pDict->here = (CELL *)pFW->name;
90 ficlLockDictionary(FALSE);
95 /**************************************************************************
97 ** Aligns the given pointer to FICL_ALIGN address units.
98 ** Returns the aligned pointer value.
99 **************************************************************************/
100 void *alignPtr(void *ptr)
105 cp = (char *)ptr + FICL_ALIGN_ADD;
107 c.u = c.u & (~FICL_ALIGN_ADD);
114 /**************************************************************************
116 ** Align the dictionary's free space pointer
117 **************************************************************************/
118 void dictAlign(FICL_DICT *pDict)
120 pDict->here = alignPtr(pDict->here);
124 /**************************************************************************
126 ** Allocate or remove n chars of dictionary space, with
127 ** checks for underrun and overrun
128 **************************************************************************/
129 int dictAllot(FICL_DICT *pDict, int n)
131 char *cp = (char *)pDict->here;
135 if ((unsigned)n <= dictCellsAvail(pDict) * sizeof (CELL))
138 return 1; /* dict is full */
143 if ((unsigned)n <= dictCellsUsed(pDict) * sizeof (CELL))
145 else /* prevent underflow */
146 cp -= dictCellsUsed(pDict) * sizeof (CELL);
151 pDict->here = PTRtoCELL cp;
156 /**************************************************************************
157 d i c t A l l o t C e l l s
158 ** Reserve space for the requested number of cells in the
159 ** dictionary. If nCells < 0 , removes space from the dictionary.
160 **************************************************************************/
161 int dictAllotCells(FICL_DICT *pDict, int nCells)
166 if (nCells <= dictCellsAvail(pDict))
167 pDict->here += nCells;
169 return 1; /* dict is full */
174 if (nCells <= dictCellsUsed(pDict))
175 pDict->here -= nCells;
176 else /* prevent underflow */
177 pDict->here -= dictCellsUsed(pDict);
180 pDict->here += nCells;
186 /**************************************************************************
187 d i c t A p p e n d C e l l
188 ** Append the specified cell to the dictionary
189 **************************************************************************/
190 void dictAppendCell(FICL_DICT *pDict, CELL c)
197 /**************************************************************************
198 d i c t A p p e n d C h a r
199 ** Append the specified char to the dictionary
200 **************************************************************************/
201 void dictAppendChar(FICL_DICT *pDict, char c)
203 char *cp = (char *)pDict->here;
205 pDict->here = PTRtoCELL cp;
210 /**************************************************************************
211 d i c t A p p e n d W o r d
212 ** Create a new word in the dictionary with the specified
213 ** name, code, and flags. Name must be NULL-terminated.
214 **************************************************************************/
215 FICL_WORD *dictAppendWord(FICL_DICT *pDict,
221 SI_SETLEN(si, strlen(name));
223 return dictAppendWord2(pDict, si, pCode, flags);
227 /**************************************************************************
228 d i c t A p p e n d W o r d 2
229 ** Create a new word in the dictionary with the specified
230 ** STRINGINFO, code, and flags. Does not require a NULL-terminated
232 **************************************************************************/
233 FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
238 FICL_COUNT len = (FICL_COUNT)SI_COUNT(si);
242 ficlLockDictionary(TRUE);
245 ** NOTE: dictCopyName advances "here" as a side-effect.
246 ** It must execute before pFW is initialized.
248 pName = dictCopyName(pDict, si);
249 pFW = (FICL_WORD *)pDict->here;
251 pFW->hash = hashHashCode(si);
253 pFW->flags = (UNS8)(flags | FW_SMUDGE);
254 pFW->nName = (char)len;
257 ** Point "here" to first cell of new word's param area...
259 pDict->here = pFW->param;
261 if (!(flags & FW_SMUDGE))
264 ficlLockDictionary(FALSE);
269 /**************************************************************************
270 d i c t A p p e n d U N S
271 ** Append the specified FICL_UNS to the dictionary
272 **************************************************************************/
273 void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u)
275 *pDict->here++ = LVALUEtoCELL(u);
280 /**************************************************************************
281 d i c t C e l l s A v a i l
282 ** Returns the number of empty cells left in the dictionary
283 **************************************************************************/
284 int dictCellsAvail(FICL_DICT *pDict)
286 return pDict->size - dictCellsUsed(pDict);
290 /**************************************************************************
291 d i c t C e l l s U s e d
292 ** Returns the number of cells consumed in the dicionary
293 **************************************************************************/
294 int dictCellsUsed(FICL_DICT *pDict)
296 return pDict->here - pDict->dict;
300 /**************************************************************************
302 ** Checks the dictionary for corruption and throws appropriate
304 ** Input: +n number of ADDRESS UNITS (not Cells) proposed to allot
305 ** -n number of ADDRESS UNITS proposed to de-allot
306 ** 0 just do a consistency check
307 **************************************************************************/
308 void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n)
310 if ((n >= 0) && (dictCellsAvail(pDict) * (int)sizeof(CELL) < n))
312 vmThrowErr(pVM, "Error: dictionary full");
315 if ((n <= 0) && (dictCellsUsed(pDict) * (int)sizeof(CELL) < -n))
317 vmThrowErr(pVM, "Error: dictionary underflow");
320 if (pDict->nLists > FICL_DEFAULT_VOCS)
322 dictResetSearchOrder(pDict);
323 vmThrowErr(pVM, "Error: search order overflow");
325 else if (pDict->nLists < 0)
327 dictResetSearchOrder(pDict);
328 vmThrowErr(pVM, "Error: search order underflow");
335 /**************************************************************************
336 d i c t C o p y N a m e
337 ** Copy up to nFICLNAME characters of the name specified by si into
338 ** the dictionary starting at "here", then NULL-terminate the name,
339 ** point "here" to the next available byte, and return the address of
340 ** the beginning of the name. Used by dictAppendWord.
342 ** 1. "here" is guaranteed to be aligned after this operation.
343 ** 2. If the string has zero length, align and return "here"
344 **************************************************************************/
345 static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si)
347 char *oldCP = (char *)pDict->here;
349 char *name = SI_PTR(si);
350 int i = SI_COUNT(si);
355 return (char *)pDict->here;
368 pDict->here = PTRtoCELL cp;
374 /**************************************************************************
376 ** Create and initialize a dictionary with the specified number
377 ** of cells capacity, and no hashing (hash size == 1).
378 **************************************************************************/
379 FICL_DICT *dictCreate(unsigned nCells)
381 return dictCreateHashed(nCells, 1);
385 FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash)
390 nAlloc = sizeof (FICL_HASH) + nCells * sizeof (CELL)
391 + (nHash - 1) * sizeof (FICL_WORD *);
393 pDict = ficlMalloc(sizeof (FICL_DICT));
395 memset(pDict, 0, sizeof (FICL_DICT));
396 pDict->dict = ficlMalloc(nAlloc);
399 pDict->size = nCells;
400 dictEmpty(pDict, nHash);
405 /**************************************************************************
406 d i c t C r e a t e W o r d l i s t
407 ** Create and initialize an anonymous wordlist
408 **************************************************************************/
409 FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets)
414 pHash = (FICL_HASH *)dp->here;
415 dictAllot(dp, sizeof (FICL_HASH)
416 + (nBuckets-1) * sizeof (FICL_WORD *));
418 pHash->size = nBuckets;
424 /**************************************************************************
426 ** Free all memory allocated for the given dictionary
427 **************************************************************************/
428 void dictDelete(FICL_DICT *pDict)
436 /**************************************************************************
438 ** Empty the dictionary, reset its hash table, and reset its search order.
439 ** Clears and (re-)creates the hash table with the size specified by nHash.
440 **************************************************************************/
441 void dictEmpty(FICL_DICT *pDict, unsigned nHash)
445 pDict->here = pDict->dict;
448 pHash = (FICL_HASH *)pDict->here;
450 sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *));
455 pDict->pForthWords = pHash;
456 pDict->smudge = NULL;
457 dictResetSearchOrder(pDict);
462 /**************************************************************************
463 d i c t H a s h S u m m a r y
464 ** Calculate a figure of merit for the dictionary hash table based
465 ** on the average search depth for all the words in the dictionary,
466 ** assuming uniform distribution of target keys. The figure of merit
467 ** is the ratio of the total search depth for all keys in the table
468 ** versus a theoretical optimum that would be achieved if the keys
469 ** were distributed into the table as evenly as possible.
470 ** The figure would be worse if the hash table used an open
471 ** addressing scheme (i.e. collisions resolved by searching the
472 ** table for an empty slot) for a given size table.
473 **************************************************************************/
475 void dictHashSummary(FICL_VM *pVM)
477 FICL_DICT *dp = vmGetDict(pVM);
488 int nAvg, nRem, nDepth;
490 dictCheck(dp, pVM, 0);
492 pFHash = dp->pSearch[dp->nLists - 1];
493 pHash = pFHash->table;
497 for (i = 0; i < size; i++)
509 avg += (double)(n * (n+1)) / 2.0;
517 /* Calc actual avg search depth for this hash */
520 /* Calc best possible performance with this size hash */
521 nAvg = nWords / size;
522 nRem = nWords % size;
523 nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
524 best = (double)nDepth/nWords;
527 "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%",
529 (double)nFilled * 100.0 / size, nMax,
534 ficlTextOut(pVM, pVM->pad, 1);
540 /**************************************************************************
541 d i c t I n c l u d e s
542 ** Returns TRUE iff the given pointer is within the address range of
544 **************************************************************************/
545 int dictIncludes(FICL_DICT *pDict, void *p)
547 return ((p >= (void *) &pDict->dict)
548 && (p < (void *)(&pDict->dict + pDict->size))
552 /**************************************************************************
554 ** Find the FICL_WORD that matches the given name and length.
555 ** If found, returns the word's address. Otherwise returns NULL.
556 ** Uses the search order list to search multiple wordlists.
557 **************************************************************************/
558 FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si)
560 FICL_WORD *pFW = NULL;
563 UNS16 hashCode = hashHashCode(si);
567 ficlLockDictionary(1);
569 for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
571 pHash = pDict->pSearch[i];
572 pFW = hashLookup(pHash, si, hashCode);
575 ficlLockDictionary(0);
580 /**************************************************************************
581 f i c l L o o k u p L o c
582 ** Same as dictLookup, but looks in system locals dictionary first...
583 ** Assumes locals dictionary has only one wordlist...
584 **************************************************************************/
586 FICL_WORD *ficlLookupLoc(FICL_SYSTEM *pSys, STRINGINFO si)
588 FICL_WORD *pFW = NULL;
589 FICL_DICT *pDict = pSys->dp;
590 FICL_HASH *pHash = ficlGetLoc(pSys)->pForthWords;
592 UNS16 hashCode = hashHashCode(si);
597 ficlLockDictionary(1);
599 ** check the locals dict first...
601 pFW = hashLookup(pHash, si, hashCode);
604 ** If no joy, (!pFW) --------------------------v
605 ** iterate over the search list in the main dict
607 for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
609 pHash = pDict->pSearch[i];
610 pFW = hashLookup(pHash, si, hashCode);
613 ficlLockDictionary(0);
619 /**************************************************************************
620 d i c t R e s e t S e a r c h O r d e r
621 ** Initialize the dictionary search order list to sane state
622 **************************************************************************/
623 void dictResetSearchOrder(FICL_DICT *pDict)
626 pDict->pCompile = pDict->pForthWords;
628 pDict->pSearch[0] = pDict->pForthWords;
633 /**************************************************************************
634 d i c t S e t F l a g s
635 ** Changes the flags field of the most recently defined word:
636 ** Set all bits that are ones in the set parameter, clear all bits
637 ** that are ones in the clr parameter. Clear wins in case the same bit
638 ** is set in both parameters.
639 **************************************************************************/
640 void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr)
642 assert(pDict->smudge);
643 pDict->smudge->flags |= set;
644 pDict->smudge->flags &= ~clr;
649 /**************************************************************************
650 d i c t S e t I m m e d i a t e
651 ** Set the most recently defined word as IMMEDIATE
652 **************************************************************************/
653 void dictSetImmediate(FICL_DICT *pDict)
655 assert(pDict->smudge);
656 pDict->smudge->flags |= FW_IMMEDIATE;
661 /**************************************************************************
662 d i c t U n s m u d g e
663 ** Completes the definition of a word by linking it
664 ** into the main list
665 **************************************************************************/
666 void dictUnsmudge(FICL_DICT *pDict)
668 FICL_WORD *pFW = pDict->smudge;
669 FICL_HASH *pHash = pDict->pCompile;
674 ** :noname words never get linked into the list...
677 hashInsertWord(pHash, pFW);
678 pFW->flags &= ~(FW_SMUDGE);
683 /**************************************************************************
685 ** Returns the value of the HERE pointer -- the address
686 ** of the next free cell in the dictionary
687 **************************************************************************/
688 CELL *dictWhere(FICL_DICT *pDict)
694 /**************************************************************************
696 ** Unlink all words in the hash that have addresses greater than or
697 ** equal to the address supplied. Implementation factor for FORGET
699 **************************************************************************/
700 void hashForget(FICL_HASH *pHash, void *where)
708 for (i = 0; i < pHash->size; i++)
710 pWord = pHash->table[i];
712 while ((void *)pWord >= where)
717 pHash->table[i] = pWord;
724 /**************************************************************************
725 h a s h H a s h C o d e
727 ** Generate a 16 bit hashcode from a character string using a rolling
728 ** shift and add stolen from PJ Weinberger of Bell Labs fame. Case folds
729 ** the name before hashing it...
730 ** N O T E : If string has zero length, returns zero.
731 **************************************************************************/
732 UNS16 hashHashCode(STRINGINFO si)
736 UNS16 code = (UNS16)si.count;
742 /* changed to run without errors under Purify -- lch */
743 for (cp = (UNS8 *)si.cp; si.count && *cp; cp++, si.count--)
745 code = (UNS16)((code << 4) + tolower(*cp));
746 shift = (UNS16)(code & 0xf000);
749 code ^= (UNS16)(shift >> 8);
750 code ^= (UNS16)shift;
760 /**************************************************************************
761 h a s h I n s e r t W o r d
762 ** Put a word into the hash table using the word's hashcode as
763 ** an index (modulo the table size).
764 **************************************************************************/
765 void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW)
772 if (pHash->size == 1)
774 pList = pHash->table;
778 pList = pHash->table + (pFW->hash % pHash->size);
787 /**************************************************************************
789 ** Find a name in the hash table given the hashcode and text of the name.
790 ** Returns the address of the corresponding FICL_WORD if found,
792 ** Note: outer loop on link field supports inheritance in wordlists.
793 ** It's not part of ANS Forth - ficl only. hashReset creates wordlists
794 ** with NULL link fields.
795 **************************************************************************/
796 FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode)
798 FICL_UNS nCmp = si.count;
802 if (nCmp > nFICLNAME)
805 for (; pHash != NULL; pHash = pHash->link)
808 hashIdx = (UNS16)(hashCode % pHash->size);
809 else /* avoid the modulo op for single threaded lists */
812 for (pFW = pHash->table[hashIdx]; pFW; pFW = pFW->link)
814 if ( (pFW->nName == si.count)
815 && (!strincmp(si.cp, pFW->name, nCmp)) )
818 assert(pFW != pFW->link);
827 /**************************************************************************
829 ** Initialize a FICL_HASH to empty state.
830 **************************************************************************/
831 void hashReset(FICL_HASH *pHash)
837 for (i = 0; i < pHash->size; i++)
839 pHash->table[i] = NULL;
847 /**************************************************************************
848 d i c t C h e c k T h r e s h o l d
849 ** Verify if an increase in the dictionary size is warranted, and do it if
851 **************************************************************************/
853 void dictCheckThreshold(FICL_DICT* dp)
855 if( dictCellsAvail(dp) < dictThreshold.u ) {
856 dp->dict = ficlMalloc( dictIncrease.u * sizeof (CELL) );
859 dp->size = dictIncrease.u;