/************************************************************************** v m S e t B r e a k ** Set a breakpoint at the current value of IP by ** storing that address in a BREAKPOINT record **************************************************************************/ static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP) { FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break"); assert(pStep); pBP->address = pVM->ip; pBP->origXT = *pVM->ip; *pVM->ip = pStep; }
/******************************************************************* ** 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)); }
/************************************************************************** f i c l P a r s e P r e f i x ** This is the parse step for prefixes - it checks an incoming word ** to see if it starts with a prefix, and if so runs the corrseponding ** code against the remainder of the word and returns true. **************************************************************************/ int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si) { int i; FICL_HASH *pHash; FICL_WORD *pFW = ficlLookup(pVM->pSys, list_name); /* ** Make sure we found the prefix dictionary - otherwise silently fail ** If forth-wordlist is not in the search order, we won't find the prefixes. */ if (!pFW) return FICL_FALSE; pHash = (FICL_HASH *)(pFW->param[0].p); /* ** Walk the list looking for a match with the beginning of the incoming token */ for (i = 0; i < (int)pHash->size; i++) { pFW = pHash->table[i]; while (pFW != NULL) { int n; n = pFW->nName; /* ** If we find a match, adjust the TIB to give back the non-prefix characters ** and execute the prefix word. */ if (!strincmp(SI_PTR(si), pFW->name, (FICL_UNS)n)) { /* (sadler) fixed off-by-one error when the token has no trailing space in the TIB */ vmSetTibIndex(pVM, si.cp + n - pVM->tib.cp ); vmExecute(pVM, pFW); return (int)FICL_TRUE; } pFW = pFW->link; } } return FICL_FALSE; }
/************************************************************************** f i c l C o m p i l e P r e f i x ** Build prefix support into the dictionary and the parser ** Note: since prefixes always execute, they are effectively IMMEDIATE. ** If they need to generate code in compile state you must add ** this code explicitly. **************************************************************************/ void ficlCompilePrefix(FICL_SYSTEM *pSys) { FICL_DICT *dp = pSys->dp; FICL_HASH *pHash; FICL_HASH *pPrevCompile = dp->pCompile; #if (FICL_EXTENDED_PREFIX) FICL_WORD *pFW; #endif /* ** Create a named wordlist for prefixes to reside in... ** Since we're doing a special kind of search, make it ** a single bucket hashtable - hashing does not help here. */ pHash = dictCreateWordlist(dp, 1); pHash->name = list_name; dictAppendWord(dp, list_name, constantParen, FW_DEFAULT); dictAppendCell(dp, LVALUEtoCELL(pHash)); /* ** Put __tempbase in the forth-wordlist */ dictAppendWord(dp, "__tempbase", fTempBase, FW_DEFAULT); /* ** Temporarily make the prefix list the compile wordlist so that ** we can create some precompiled prefixes. */ dp->pCompile = pHash; dictAppendWord(dp, "0x", prefixHex, FW_DEFAULT); dictAppendWord(dp, "0d", prefixTen, FW_DEFAULT); #if (FICL_EXTENDED_PREFIX) pFW = ficlLookup(pSys, "\\"); if (pFW) { dictAppendWord(dp, "//", pFW->code, FW_DEFAULT); } #endif dp->pCompile = pPrevCompile; 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); }