/************************************************************************** g e t - c u r r e n t ** SEARCH ( -- wid ) ** Return wid, the identifier of the compilation word list. **************************************************************************/ static void getCurrent(FICL_VM *pVM) { ficlLockDictionary(TRUE); stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile); ficlLockDictionary(FALSE); return; }
/************************************************************************** s e t - o r d e r ** SEARCH ( widn ... wid1 n -- ) ** Set the search order to the word lists identified by widn ... wid1. ** Subsequently, word list wid1 will be searched first, and word list ** widn searched last. If n is zero, empty the search order. If n is minus ** one, set the search order to the implementation-defined minimum ** search order. The minimum search order shall include the words ** FORTH-WORDLIST and SET-ORDER. A system shall allow n to ** be at least eight. **************************************************************************/ static void setOrder(FICL_VM *pVM) { int i; int nLists = stackPopINT(pVM->pStack); FICL_DICT *dp = vmGetDict(pVM); if (nLists > FICL_DEFAULT_VOCS) { vmThrowErr(pVM, "set-order error: list would be too large"); } ficlLockDictionary(TRUE); if (nLists >= 0) { dp->nLists = nLists; for (i = nLists-1; i >= 0; --i) { dp->pSearch[i] = stackPopPtr(pVM->pStack); } } else { dictResetSearchOrder(dp); } ficlLockDictionary(FALSE); return; }
/************************************************************************** s e t - c u r r e n t ** SEARCH ( wid -- ) ** Set the compilation word list to the word list identified by wid. **************************************************************************/ static void setCurrent(FICL_VM *pVM) { FICL_HASH *pHash = stackPopPtr(pVM->pStack); FICL_DICT *pDict = vmGetDict(pVM); ficlLockDictionary(TRUE); pDict->pCompile = pHash; ficlLockDictionary(FALSE); return; }
/******************************************************************* ** Compile a floating point literal. *******************************************************************/ static void fliteralIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)"); #if FICL_ROBUST > 1 vmCheckFStack(pVM, 1, 0); #endif dictAppendCell(dp, LVALUEtoCELL(pfLitParen)); dictAppendCell(dp, stackPop(pVM->fStack)); }
/******************************************************************* ** Create a floating point constant. ** fconstant ( r -"name"- ) *******************************************************************/ static void Fconstant(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); #if FICL_ROBUST > 1 vmCheckFStack(pVM, 1, 0); #endif dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT); dictAppendCell(dp, stackPop(pVM->fStack)); }
/************************************************************************** d e f i n i t i o n s ** SEARCH ( -- ) ** Make the compilation word list the same as the first word list in the ** search order. Specifies that the names of subsequent definitions will ** be placed in the compilation word list. Subsequent changes in the search ** order will not affect the compilation word list. **************************************************************************/ static void definitions(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); assert(pDict); if (pDict->nLists < 1) { vmThrowErr(pVM, "DEFINITIONS error - empty search order"); } pDict->pCompile = pDict->pSearch[pDict->nLists-1]; return; }
/************************************************************************** > S E A R C H ** ficl ( wid -- ) ** Push wid onto the search order. Error if the search order is full. **************************************************************************/ static void searchPush(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); ficlLockDictionary(TRUE); if (dp->nLists > FICL_DEFAULT_VOCS) { vmThrowErr(pVM, ">search error: search order overflow"); } dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); ficlLockDictionary(FALSE); return; }
/************************************************************************** f i c l - w o r d l i s t ** SEARCH ( -- wid ) ** Create a new empty word list, returning its word list identifier wid. ** The new word list may be returned from a pool of preallocated word ** lists or may be dynamically allocated in data space. A system shall ** allow the creation of at least 8 new word lists in addition to any ** provided as part of the system. ** Notes: ** 1. ficl creates a new single-list hash in the dictionary and returns ** its address. ** 2. ficl-wordlist takes an arg off the stack indicating the number of ** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as ** : wordlist 1 ficl-wordlist ; **************************************************************************/ static void ficlWordlist(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); FICL_HASH *pHash; FICL_UNS nBuckets; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif nBuckets = stackPopUNS(pVM->pStack); pHash = dictCreateWordlist(dp, nBuckets); stackPushPtr(pVM->pStack, pHash); return; }
/************************************************************************** S E A R C H > ** ficl ( -- wid ) ** Pop wid off the search order. Error if the search order is empty **************************************************************************/ static void searchPop(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); int nLists; ficlLockDictionary(TRUE); nLists = dp->nLists; if (nLists == 0) { vmThrowErr(pVM, "search> error: empty search order"); } stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); ficlLockDictionary(FALSE); return; }
/************************************************************************** g e t - o r d e r ** SEARCH ( -- widn ... wid1 n ) ** Returns the number of word lists n in the search order and the word list ** identifiers widn ... wid1 identifying these word lists. wid1 identifies ** the word list that is searched first, and widn the word list that is ** searched last. The search order is unaffected. **************************************************************************/ static void getOrder(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); int nLists = pDict->nLists; int i; ficlLockDictionary(TRUE); for (i = 0; i < nLists; i++) { stackPushPtr(pVM->pStack, pDict->pSearch[i]); } stackPushUNS(pVM->pStack, nLists); ficlLockDictionary(FALSE); return; }
static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp) { FICL_WORD *pFW; FICL_DICT *pd = vmGetDict(pVM); int i; if (!dictIncludes(pd, (void *)cp)) return NULL; for (i = nSEARCH_CELLS; i > 0; --i, --cp) { pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL))); if (isAFiclWord(pd, pFW)) return pFW; } return NULL; }
/* ** Dump a tab delimited file that summarizes the contents of the ** dictionary hash table by hashcode... */ static void spewHash(FICL_VM *pVM) { FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; FICL_WORD *pFW; FILE *pOut; unsigned i; unsigned nHash = pHash->size; if (!vmGetWordToPad(pVM)) vmThrow(pVM, VM_OUTOFTEXT); pOut = fopen(pVM->pad, "w"); if (!pOut) { vmTextOut(pVM, "unable to open file", 1); return; } for (i=0; i < nHash; i++) { int n = 0; pFW = pHash->table[i]; while (pFW) { n++; pFW = pFW->link; } fprintf(pOut, "%d\t%d", i, n); pFW = pHash->table[i]; while (pFW) { fprintf(pOut, "\t%s", pFW->name); pFW = pFW->link; } fprintf(pOut, "\n"); } fclose(pOut); return; }
/* ** seeColon (for proctologists only) ** Walks a colon definition, decompiling ** on the fly. Knows about primitive control structures. */ static void seeColon(FICL_VM *pVM, CELL *pc) { char *cp; CELL *param0 = pc; FICL_DICT *pd = vmGetDict(pVM); FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)"); assert(pSemiParen); for (; pc->p != pSemiParen; pc++) { FICL_WORD *pFW = (FICL_WORD *)(pc->p); cp = pVM->pad; if ((void *)pc == (void *)pVM->ip) *cp++ = '>'; else *cp++ = ' '; cp += sprintf(cp, "%3d ", pc-param0); if (isAFiclWord(pd, pFW)) { WORDKIND kind = ficlWordClassify(pFW); CELL c; switch (kind) { case LITERAL: c = *++pc; if (isAFiclWord(pd, c.p)) { FICL_WORD *pLit = (FICL_WORD *)c.p; sprintf(cp, "%.*s ( %#lx literal )", pLit->nName, pLit->name, (unsigned long)c.u); } else sprintf(cp, "literal %ld (%#lx)", (long)c.i, (unsigned long)c.u); break; case STRINGLIT: { FICL_STRING *sp = (FICL_STRING *)(void *)++pc; pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; sprintf(cp, "s\" %.*s\"", sp->count, sp->text); } break; case CSTRINGLIT: { FICL_STRING *sp = (FICL_STRING *)(void *)++pc; pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; sprintf(cp, "c\" %.*s\"", sp->count, sp->text); } break; case IF: c = *++pc; if (c.i > 0) sprintf(cp, "if / while (branch %d)", pc+c.i-param0); else sprintf(cp, "until (branch %d)", pc+c.i-param0); break; case BRANCH: c = *++pc; if (c.i == 0) sprintf(cp, "repeat (branch %d)", pc+c.i-param0); else if (c.i == 1) sprintf(cp, "else (branch %d)", pc+c.i-param0); else sprintf(cp, "endof (branch %d)", pc+c.i-param0); break; case OF: c = *++pc; sprintf(cp, "of (branch %d)", pc+c.i-param0); break; case QDO: c = *++pc; sprintf(cp, "?do (leave %d)", (CELL *)c.p-param0); break; case DO: c = *++pc; sprintf(cp, "do (leave %d)", (CELL *)c.p-param0); break; case LOOP: c = *++pc; sprintf(cp, "loop (branch %d)", pc+c.i-param0); break; case PLOOP: c = *++pc; sprintf(cp, "+loop (branch %d)", pc+c.i-param0); break; default: sprintf(cp, "%.*s", pFW->nName, pFW->name); break; } } else /* probably not a word - punt and print value */ { sprintf(cp, "%ld ( %#lx )", (long)pc->i, (unsigned long)pc->u); } vmTextOut(pVM, pVM->pad, 1); } vmTextOut(pVM, ";", 1); }
/************************************************************************** f o r t h - w o r d l i s t ** SEARCH ( -- wid ) ** Return wid, the identifier of the word list that includes all standard ** words provided by the implementation. This word list is initially the ** compilation word list and is part of the initial search order. **************************************************************************/ static void forthWordlist(FICL_VM *pVM) { FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; stackPushPtr(pVM->pStack, pHash); return; }
void dictHashSummary(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); FICL_HASH *pFHash; FICL_WORD **pHash; unsigned size; FICL_WORD *pFW; unsigned i; int nMax = 0; int nWords = 0; int nFilled; double avg = 0.0; double best; int nAvg, nRem, nDepth; dictCheck(dp, pVM, 0); pFHash = dp->pSearch[dp->nLists - 1]; pHash = pFHash->table; size = pFHash->size; nFilled = size; for (i = 0; i < size; i++) { int n = 0; pFW = pHash[i]; while (pFW) { ++n; ++nWords; pFW = pFW->link; } avg += (double)(n * (n+1)) / 2.0; if (n > nMax) nMax = n; if (n == 0) --nFilled; } /* Calc actual avg search depth for this hash */ avg = avg / nWords; /* Calc best possible performance with this size hash */ nAvg = nWords / size; nRem = nWords % size; nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem; best = (double)nDepth/nWords; sprintf(pVM->pad, "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%", size, (double)nFilled * 100.0 / size, nMax, avg, best, 100.0 * best / avg); ficlTextOut(pVM, pVM->pad, 1); return; }