/************************************************************************** d i s p l a y FS t a c k ** Display the parameter stack (code for "f.s") ** f.s ( -- ) **************************************************************************/ static void displayFStack(FICL_VM *pVM) { int d = stackDepth(pVM->fStack); int i; CELL *pCell; vmCheckFStack(pVM, 0, 0); vmTextOut(pVM, "F:", 0); if (d == 0) vmTextOut(pVM, "[0]", 0); else { ltoa(d, &pVM->pad[1], pVM->base); pVM->pad[0] = '['; strcat(pVM->pad,"] "); vmTextOut(pVM,pVM->pad,0); pCell = pVM->fStack->sp - d; for (i = 0; i < d; i++) { sprintf(pVM->pad,"%#f ",(*pCell++).f); vmTextOut(pVM,pVM->pad,0); } } }
/* ** Here's the outer part of the decompiler. It's ** just a big nested conditional that checks the ** CFA of the word to decompile for each kind of ** known word-builder code, and tries to do ** something appropriate. If the CFA is not recognized, ** just indicate that it is a primitive. */ static void seeXT(FICL_VM *pVM) { FICL_WORD *pFW; WORDKIND kind; pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); kind = ficlWordClassify(pFW); switch (kind) { case COLON: sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); vmTextOut(pVM, pVM->pad, 1); seeColon(pVM, pFW->param); break; case DOES: vmTextOut(pVM, "does>", 1); seeColon(pVM, (CELL *)pFW->param->p); break; case CREATE: vmTextOut(pVM, "create", 1); break; case VARIABLE: sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u); vmTextOut(pVM, pVM->pad, 1); break; #if FICL_WANT_USER case USER: sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u); vmTextOut(pVM, pVM->pad, 1); break; #endif case CONSTANT: sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u); vmTextOut(pVM, pVM->pad, 1); default: sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name); vmTextOut(pVM, pVM->pad, 1); break; } if (pFW->flags & FW_IMMEDIATE) { vmTextOut(pVM, "immediate", 1); } if (pFW->flags & FW_COMPILE) { vmTextOut(pVM, "compile-only", 1); } return; }
/* ** Ficl interface to getcwd ** Prints the current working directory using the VM's ** textOut method... */ static void ficlGetCWD(FICL_VM *pVM) { char *cp; cp = getcwd(NULL, 80); vmTextOut(pVM, cp, 1); free(cp); return; }
/* ** Ficl interface to chdir ** Gets a newline (or NULL) delimited string from the input ** and feeds it to chdir() ** Example: ** cd c:\tmp */ static void ficlChDir(FICL_VM *pVM) { FICL_STRING *pFS = (FICL_STRING *)pVM->pad; vmGetString(pVM, pFS, '\n'); if (pFS->count > 0) { int err = chdir(pFS->text); if (err) { vmTextOut(pVM, "Error: path not found", 1); vmThrow(pVM, VM_QUIT); } } else { vmTextOut(pVM, "Warning (chdir): nothing happened", 1); } return; }
/* ** This word lists the parse steps in order */ void ficlListParseSteps(FICL_VM *pVM) { int i; FICL_SYSTEM *pSys = pVM->pSys; assert(pSys); vmTextOut(pVM, "Parse steps:", 1); vmTextOut(pVM, "lookup", 1); for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) { if (pSys->parseList[i] != NULL) { vmTextOut(pVM, pSys->parseList[i]->name, 1); } else break; } return; }
static void displayCellNoPad(FICL_VM *pVM) { CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif c = stackPop(pVM->pStack); ltoa((c).i, pVM->pad, pVM->base); vmTextOut(pVM, pVM->pad, 0); return; }
/******************************************************************* ** Display a float in engineering format. ** fe. ( r -- ) *******************************************************************/ static void EDot(FICL_VM *pVM) { float f; #if FICL_ROBUST > 1 vmCheckFStack(pVM, 1, 0); #endif f = POPFLOAT(); sprintf(pVM->pad,"%#e ",f); vmTextOut(pVM, pVM->pad, 0); }
/* ** Ficl interface to system (ANSI) ** Gets a newline (or NULL) delimited string from the input ** and feeds it to system() ** Example: ** system rm -rf / ** \ ouch! */ static void ficlSystem(FICL_VM *pVM) { FICL_STRING *pFS = (FICL_STRING *)pVM->pad; vmGetString(pVM, pFS, '\n'); if (pFS->count > 0) { int err = system(pFS->text); if (err) { sprintf(pVM->pad, "System call returned %d", err); vmTextOut(pVM, pVM->pad, 1); vmThrow(pVM, VM_QUIT); } } else { vmTextOut(pVM, "Warning (system): nothing happened", 1); } return; }
/* ** 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; }
FICL_PLATFORM_EXTERN void ficlTextOut (ficlVm *vm, char *text, int fNewline) { vmTextOut(vm, text, fNewline); }
/* ** 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); }
/************************************************************************** ** d e b u g P r o m p t **************************************************************************/ static void debugPrompt(FICL_VM *pVM) { vmTextOut(pVM, "dbg> ", 0); }
static void ficlLoad(FICL_VM *pVM) { char cp[nLINEBUF]; char filename[nLINEBUF]; FICL_STRING *pFilename = (FICL_STRING *)filename; int nLine = 0; FILE *fp; int result; CELL id; struct stat buf; vmGetString(pVM, pFilename, '\n'); if (pFilename->count <= 0) { vmTextOut(pVM, "Warning (load): nothing happened", 1); return; } /* ** get the file's size and make sure it exists */ result = stat( pFilename->text, &buf ); if (result != 0) { vmTextOut(pVM, "Unable to stat file: ", 0); vmTextOut(pVM, pFilename->text, 1); vmThrow(pVM, VM_QUIT); } fp = fopen(pFilename->text, "r"); if (!fp) { vmTextOut(pVM, "Unable to open file ", 0); vmTextOut(pVM, pFilename->text, 1); vmThrow(pVM, VM_QUIT); } id = pVM->sourceID; pVM->sourceID.p = (void *)fp; /* feed each line to ficlExec */ while (fgets(cp, nLINEBUF, fp)) { int len = strlen(cp) - 1; nLine++; if (len <= 0) continue; result = ficlExecC(pVM, cp, len); if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT ) { pVM->sourceID = id; fclose(fp); vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine); break; } } /* ** Pass an empty line with SOURCE-ID == -1 to flush ** any pending REFILLs (as required by FILE wordset) */ pVM->sourceID.i = -1; ficlExec(pVM, ""); pVM->sourceID = id; fclose(fp); /* handle "bye" in loaded files. --lch */ if (result == VM_USEREXIT) vmThrow(pVM, VM_USEREXIT); return; }