5bf7a61bb3
The relevant changes for FreeBSD (excerpt from the release note):
* Newly implemented CORE EXT words: CASE, OF, ENDOF, and ENDCASE. Also
added FALLTHROUGH, which works like ENDOF but jumps to the instruction
just after the next OF.
* Bugfix: John-Hopkins locals syntax now accepts | and -- in the comment
(between the first -- and the }.)
* Bugfix: Changed vmGetWord0() to make Purify happier. The resulting
code is no slower, no larger, and slightly more robust.
915 lines
26 KiB
C
915 lines
26 KiB
C
/*******************************************************************
|
|
** t o o l s . c
|
|
** Forth Inspired Command Language - programming tools
|
|
** Author: John Sadler (john_sadler@alum.mit.edu)
|
|
** Created: 20 June 2000
|
|
** $Id: tools.c,v 1.11 2001/12/05 07:21:34 jsadler Exp $
|
|
*******************************************************************/
|
|
/*
|
|
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
|
|
** All rights reserved.
|
|
**
|
|
** Get the latest Ficl release at http://ficl.sourceforge.net
|
|
**
|
|
** I am interested in hearing from anyone who uses ficl. If you have
|
|
** a problem, a success story, a defect, an enhancement request, or
|
|
** if you would like to contribute to the ficl release, please
|
|
** contact me by email at the address above.
|
|
**
|
|
** L I C E N S E and D I S C L A I M E R
|
|
**
|
|
** Redistribution and use in source and binary forms, with or without
|
|
** modification, are permitted provided that the following conditions
|
|
** are met:
|
|
** 1. Redistributions of source code must retain the above copyright
|
|
** notice, this list of conditions and the following disclaimer.
|
|
** 2. Redistributions in binary form must reproduce the above copyright
|
|
** notice, this list of conditions and the following disclaimer in the
|
|
** documentation and/or other materials provided with the distribution.
|
|
**
|
|
** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
|
|
** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
|
** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
|
|
** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
|
** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
|
** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
|
** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
|
** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
|
** SUCH DAMAGE.
|
|
*/
|
|
|
|
/*
|
|
** NOTES:
|
|
** SEE needs information about the addresses of functions that
|
|
** are the CFAs of colon definitions, constants, variables, DOES>
|
|
** words, and so on. It gets this information from a table and supporting
|
|
** functions in words.c.
|
|
** colonParen doDoes createParen variableParen userParen constantParen
|
|
**
|
|
** Step and break debugger for Ficl
|
|
** debug ( xt -- ) Start debugging an xt
|
|
** Set a breakpoint
|
|
** Specify breakpoint default action
|
|
*/
|
|
|
|
/* $FreeBSD$ */
|
|
|
|
#ifdef TESTMAIN
|
|
#include <stdlib.h>
|
|
#include <stdio.h> /* sprintf */
|
|
#include <ctype.h>
|
|
#else
|
|
#include <stand.h>
|
|
#endif
|
|
#include <string.h>
|
|
#include "ficl.h"
|
|
|
|
|
|
#if 0
|
|
/*
|
|
** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
|
|
** for the STEP command. The rest are user programmable.
|
|
*/
|
|
#define nBREAKPOINTS 32
|
|
|
|
#endif
|
|
|
|
|
|
/**************************************************************************
|
|
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;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
** d e b u g P r o m p t
|
|
**************************************************************************/
|
|
static void debugPrompt(FICL_VM *pVM)
|
|
{
|
|
vmTextOut(pVM, "dbg> ", 0);
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
** i s A F i c l W o r d
|
|
** Vet a candidate pointer carefully to make sure
|
|
** it's not some chunk o' inline data...
|
|
** It has to have a name, and it has to look
|
|
** like it's in the dictionary address range.
|
|
** NOTE: this excludes :noname words!
|
|
**************************************************************************/
|
|
int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW)
|
|
{
|
|
|
|
if (!dictIncludes(pd, pFW))
|
|
return 0;
|
|
|
|
if (!dictIncludes(pd, pFW->name))
|
|
return 0;
|
|
|
|
if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link))
|
|
return 0;
|
|
|
|
if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0'))
|
|
return 0;
|
|
|
|
if (strlen(pFW->name) != pFW->nName)
|
|
return 0;
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
#if 0
|
|
static int isPrimitive(FICL_WORD *pFW)
|
|
{
|
|
WORDKIND wk = ficlWordClassify(pFW);
|
|
return ((wk != COLON) && (wk != DOES));
|
|
}
|
|
#endif
|
|
|
|
|
|
/**************************************************************************
|
|
f i n d E n c l o s i n g W o r d
|
|
** Given a pointer to something, check to make sure it's an address in the
|
|
** dictionary. If so, search backwards until we find something that looks
|
|
** like a dictionary header. If successful, return the address of the
|
|
** FICL_WORD found. Otherwise return NULL.
|
|
** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
|
|
**************************************************************************/
|
|
#define nSEARCH_CELLS 100
|
|
|
|
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;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
s e e
|
|
** TOOLS ( "<spaces>name" -- )
|
|
** Display a human-readable representation of the named word's definition.
|
|
** The source of the representation (object-code decompilation, source
|
|
** block, etc.) and the particular form of the display is implementation
|
|
** defined.
|
|
**************************************************************************/
|
|
/*
|
|
** 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, c.u);
|
|
}
|
|
else
|
|
sprintf(cp, "literal %ld (%#lx)", c.i, 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 )", pc->i, pc->u);
|
|
}
|
|
|
|
vmTextOut(pVM, pVM->pad, 1);
|
|
}
|
|
|
|
vmTextOut(pVM, ";", 1);
|
|
}
|
|
|
|
/*
|
|
** 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;
|
|
}
|
|
|
|
|
|
static void see(FICL_VM *pVM)
|
|
{
|
|
ficlTick(pVM);
|
|
seeXT(pVM);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
f i c l D e b u g X T
|
|
** debug ( xt -- )
|
|
** Given an xt of a colon definition or a word defined by DOES>, set the
|
|
** VM up to debug the word: push IP, set the xt as the next thing to execute,
|
|
** set a breakpoint at its first instruction, and run to the breakpoint.
|
|
** Note: the semantics of this word are equivalent to "step in"
|
|
**************************************************************************/
|
|
void ficlDebugXT(FICL_VM *pVM)
|
|
{
|
|
FICL_WORD *xt = stackPopPtr(pVM->pStack);
|
|
WORDKIND wk = ficlWordClassify(xt);
|
|
|
|
stackPushPtr(pVM->pStack, xt);
|
|
seeXT(pVM);
|
|
|
|
switch (wk)
|
|
{
|
|
case COLON:
|
|
case DOES:
|
|
/*
|
|
** Run the colon code and set a breakpoint at the next instruction
|
|
*/
|
|
vmExecute(pVM, xt);
|
|
vmSetBreak(pVM, &(pVM->pSys->bpStep));
|
|
break;
|
|
|
|
default:
|
|
vmExecute(pVM, xt);
|
|
break;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
s t e p I n
|
|
** FICL
|
|
** Execute the next instruction, stepping into it if it's a colon definition
|
|
** or a does> word. This is the easy kind of step.
|
|
**************************************************************************/
|
|
void stepIn(FICL_VM *pVM)
|
|
{
|
|
/*
|
|
** Do one step of the inner loop
|
|
*/
|
|
{
|
|
M_VM_STEP(pVM)
|
|
}
|
|
|
|
/*
|
|
** Now set a breakpoint at the next instruction
|
|
*/
|
|
vmSetBreak(pVM, &(pVM->pSys->bpStep));
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
s t e p O v e r
|
|
** FICL
|
|
** Execute the next instruction atomically. This requires some insight into
|
|
** the memory layout of compiled code. Set a breakpoint at the next instruction
|
|
** in this word, and run until we hit it
|
|
**************************************************************************/
|
|
void stepOver(FICL_VM *pVM)
|
|
{
|
|
FICL_WORD *pFW;
|
|
WORDKIND kind;
|
|
FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
|
|
assert(pStep);
|
|
|
|
pFW = *pVM->ip;
|
|
kind = ficlWordClassify(pFW);
|
|
|
|
switch (kind)
|
|
{
|
|
case COLON:
|
|
case DOES:
|
|
/*
|
|
** assume that the next cell holds an instruction
|
|
** set a breakpoint there and return to the inner interp
|
|
*/
|
|
pVM->pSys->bpStep.address = pVM->ip + 1;
|
|
pVM->pSys->bpStep.origXT = pVM->ip[1];
|
|
pVM->ip[1] = pStep;
|
|
break;
|
|
|
|
default:
|
|
stepIn(pVM);
|
|
break;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
s t e p - b r e a k
|
|
** FICL
|
|
** Handles breakpoints for stepped execution.
|
|
** Upon entry, bpStep contains the address and replaced instruction
|
|
** of the current breakpoint.
|
|
** Clear the breakpoint
|
|
** Get a command from the console.
|
|
** i (step in) - execute the current instruction and set a new breakpoint
|
|
** at the IP
|
|
** o (step over) - execute the current instruction to completion and set
|
|
** a new breakpoint at the IP
|
|
** g (go) - execute the current instruction and exit
|
|
** q (quit) - abort current word
|
|
** b (toggle breakpoint)
|
|
**************************************************************************/
|
|
void stepBreak(FICL_VM *pVM)
|
|
{
|
|
STRINGINFO si;
|
|
FICL_WORD *pFW;
|
|
FICL_WORD *pOnStep;
|
|
|
|
if (!pVM->fRestart)
|
|
{
|
|
assert(pVM->pSys->bpStep.address);
|
|
assert(pVM->pSys->bpStep.origXT);
|
|
/*
|
|
** Clear the breakpoint that caused me to run
|
|
** Restore the original instruction at the breakpoint,
|
|
** and restore the IP
|
|
*/
|
|
pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
|
|
*pVM->ip = pVM->pSys->bpStep.origXT;
|
|
|
|
/*
|
|
** If there's an onStep, do it
|
|
*/
|
|
pOnStep = ficlLookup(pVM->pSys, "on-step");
|
|
if (pOnStep)
|
|
ficlExecXT(pVM, pOnStep);
|
|
|
|
/*
|
|
** Print the name of the next instruction
|
|
*/
|
|
pFW = pVM->pSys->bpStep.origXT;
|
|
sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
|
|
#if 0
|
|
if (isPrimitive(pFW))
|
|
{
|
|
strcat(pVM->pad, " ( primitive )");
|
|
}
|
|
#endif
|
|
|
|
vmTextOut(pVM, pVM->pad, 1);
|
|
debugPrompt(pVM);
|
|
}
|
|
else
|
|
{
|
|
pVM->fRestart = 0;
|
|
}
|
|
|
|
si = vmGetWord(pVM);
|
|
|
|
if (!strincmp(si.cp, "i", si.count))
|
|
{
|
|
stepIn(pVM);
|
|
}
|
|
else if (!strincmp(si.cp, "g", si.count))
|
|
{
|
|
return;
|
|
}
|
|
else if (!strincmp(si.cp, "l", si.count))
|
|
{
|
|
FICL_WORD *xt;
|
|
xt = findEnclosingWord(pVM, (CELL *)(pVM->ip));
|
|
if (xt)
|
|
{
|
|
stackPushPtr(pVM->pStack, xt);
|
|
seeXT(pVM);
|
|
}
|
|
else
|
|
{
|
|
vmTextOut(pVM, "sorry - can't do that", 1);
|
|
}
|
|
vmThrow(pVM, VM_RESTART);
|
|
}
|
|
else if (!strincmp(si.cp, "o", si.count))
|
|
{
|
|
stepOver(pVM);
|
|
}
|
|
else if (!strincmp(si.cp, "q", si.count))
|
|
{
|
|
ficlTextOut(pVM, FICL_PROMPT, 0);
|
|
vmThrow(pVM, VM_ABORT);
|
|
}
|
|
else if (!strincmp(si.cp, "x", si.count))
|
|
{
|
|
/*
|
|
** Take whatever's left in the TIB and feed it to a subordinate ficlExec
|
|
*/
|
|
int ret;
|
|
char *cp = pVM->tib.cp + pVM->tib.index;
|
|
int count = pVM->tib.end - cp;
|
|
FICL_WORD *oldRun = pVM->runningWord;
|
|
|
|
ret = ficlExecC(pVM, cp, count);
|
|
|
|
if (ret == VM_OUTOFTEXT)
|
|
{
|
|
ret = VM_RESTART;
|
|
pVM->runningWord = oldRun;
|
|
vmTextOut(pVM, "", 1);
|
|
}
|
|
|
|
vmThrow(pVM, ret);
|
|
}
|
|
else
|
|
{
|
|
vmTextOut(pVM, "i -- step In", 1);
|
|
vmTextOut(pVM, "o -- step Over", 1);
|
|
vmTextOut(pVM, "g -- Go (execute to completion)", 1);
|
|
vmTextOut(pVM, "l -- List source code", 1);
|
|
vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
|
|
vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
|
|
debugPrompt(pVM);
|
|
vmThrow(pVM, VM_RESTART);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
b y e
|
|
** TOOLS
|
|
** Signal the system to shut down - this causes ficlExec to return
|
|
** VM_USEREXIT. The rest is up to you.
|
|
**************************************************************************/
|
|
static void bye(FICL_VM *pVM)
|
|
{
|
|
vmThrow(pVM, VM_USEREXIT);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
d i s p l a y S t a c k
|
|
** TOOLS
|
|
** Display the parameter stack (code for ".s")
|
|
**************************************************************************/
|
|
static void displayPStack(FICL_VM *pVM)
|
|
{
|
|
FICL_STACK *pStk = pVM->pStack;
|
|
int d = stackDepth(pStk);
|
|
int i;
|
|
CELL *pCell;
|
|
|
|
vmCheckStack(pVM, 0, 0);
|
|
|
|
if (d == 0)
|
|
vmTextOut(pVM, "(Stack Empty) ", 0);
|
|
else
|
|
{
|
|
pCell = pStk->base;
|
|
for (i = 0; i < d; i++)
|
|
{
|
|
vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
|
|
vmTextOut(pVM, " ", 0);
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
static void displayRStack(FICL_VM *pVM)
|
|
{
|
|
FICL_STACK *pStk = pVM->rStack;
|
|
int d = stackDepth(pStk);
|
|
int i;
|
|
CELL *pCell;
|
|
FICL_DICT *dp = vmGetDict(pVM);
|
|
|
|
vmCheckStack(pVM, 0, 0);
|
|
|
|
if (d == 0)
|
|
vmTextOut(pVM, "(Stack Empty) ", 0);
|
|
else
|
|
{
|
|
pCell = pStk->base;
|
|
for (i = 0; i < d; i++)
|
|
{
|
|
CELL c = *pCell++;
|
|
/*
|
|
** Attempt to find the word that contains the
|
|
** stacked address (as if it is part of a colon definition).
|
|
** If this works, print the name of the word. Otherwise print
|
|
** the value as a number.
|
|
*/
|
|
if (dictIncludes(dp, c.p))
|
|
{
|
|
FICL_WORD *pFW = findEnclosingWord(pVM, c.p);
|
|
if (pFW)
|
|
{
|
|
int offset = (CELL *)c.p - &pFW->param[0];
|
|
sprintf(pVM->pad, "%s+%d ", pFW->name, offset);
|
|
vmTextOut(pVM, pVM->pad, 0);
|
|
continue; /* no need to print the numeric value */
|
|
}
|
|
}
|
|
vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0);
|
|
vmTextOut(pVM, " ", 0);
|
|
}
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
f o r g e t - w i d
|
|
**
|
|
**************************************************************************/
|
|
static void forgetWid(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *pDict = vmGetDict(pVM);
|
|
FICL_HASH *pHash;
|
|
|
|
pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
|
|
hashForget(pHash, pDict->here);
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
f o r g e t
|
|
** TOOLS EXT ( "<spaces>name" -- )
|
|
** Skip leading space delimiters. Parse name delimited by a space.
|
|
** Find name, then delete name from the dictionary along with all
|
|
** words added to the dictionary after name. An ambiguous
|
|
** condition exists if name cannot be found.
|
|
**
|
|
** If the Search-Order word set is present, FORGET searches the
|
|
** compilation word list. An ambiguous condition exists if the
|
|
** compilation word list is deleted.
|
|
**************************************************************************/
|
|
static void forget(FICL_VM *pVM)
|
|
{
|
|
void *where;
|
|
FICL_DICT *pDict = vmGetDict(pVM);
|
|
FICL_HASH *pHash = pDict->pCompile;
|
|
|
|
ficlTick(pVM);
|
|
where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
|
|
hashForget(pHash, where);
|
|
pDict->here = PTRtoCELL where;
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
l i s t W o r d s
|
|
**
|
|
**************************************************************************/
|
|
#define nCOLWIDTH 8
|
|
static void listWords(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *dp = vmGetDict(pVM);
|
|
FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
|
|
FICL_WORD *wp;
|
|
int nChars = 0;
|
|
int len;
|
|
int y = 0;
|
|
unsigned i;
|
|
int nWords = 0;
|
|
char *cp;
|
|
char *pPad = pVM->pad;
|
|
|
|
for (i = 0; i < pHash->size; i++)
|
|
{
|
|
for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
|
|
{
|
|
if (wp->nName == 0) /* ignore :noname defs */
|
|
continue;
|
|
|
|
cp = wp->name;
|
|
nChars += sprintf(pPad + nChars, "%s", cp);
|
|
|
|
if (nChars > 70)
|
|
{
|
|
pPad[nChars] = '\0';
|
|
nChars = 0;
|
|
y++;
|
|
if(y>23) {
|
|
y=0;
|
|
vmTextOut(pVM, "--- Press Enter to continue ---",0);
|
|
getchar();
|
|
vmTextOut(pVM,"\r",0);
|
|
}
|
|
vmTextOut(pVM, pPad, 1);
|
|
}
|
|
else
|
|
{
|
|
len = nCOLWIDTH - nChars % nCOLWIDTH;
|
|
while (len-- > 0)
|
|
pPad[nChars++] = ' ';
|
|
}
|
|
|
|
if (nChars > 70)
|
|
{
|
|
pPad[nChars] = '\0';
|
|
nChars = 0;
|
|
y++;
|
|
if(y>23) {
|
|
y=0;
|
|
vmTextOut(pVM, "--- Press Enter to continue ---",0);
|
|
getchar();
|
|
vmTextOut(pVM,"\r",0);
|
|
}
|
|
vmTextOut(pVM, pPad, 1);
|
|
}
|
|
}
|
|
}
|
|
|
|
if (nChars > 0)
|
|
{
|
|
pPad[nChars] = '\0';
|
|
nChars = 0;
|
|
vmTextOut(pVM, pPad, 1);
|
|
}
|
|
|
|
sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total",
|
|
nWords, (long) (dp->here - dp->dict), dp->size);
|
|
vmTextOut(pVM, pVM->pad, 1);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
l i s t E n v
|
|
** Print symbols defined in the environment
|
|
**************************************************************************/
|
|
static void listEnv(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *dp = pVM->pSys->envp;
|
|
FICL_HASH *pHash = dp->pForthWords;
|
|
FICL_WORD *wp;
|
|
unsigned i;
|
|
int nWords = 0;
|
|
|
|
for (i = 0; i < pHash->size; i++)
|
|
{
|
|
for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
|
|
{
|
|
vmTextOut(pVM, wp->name, 1);
|
|
}
|
|
}
|
|
|
|
sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total",
|
|
nWords, (long) (dp->here - dp->dict), dp->size);
|
|
vmTextOut(pVM, pVM->pad, 1);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
e n v C o n s t a n t
|
|
** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set
|
|
** environment constants...
|
|
**************************************************************************/
|
|
static void envConstant(FICL_VM *pVM)
|
|
{
|
|
unsigned value;
|
|
|
|
#if FICL_ROBUST > 1
|
|
vmCheckStack(pVM, 1, 0);
|
|
#endif
|
|
|
|
vmGetWordToPad(pVM);
|
|
value = POPUNS();
|
|
ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
|
|
return;
|
|
}
|
|
|
|
static void env2Constant(FICL_VM *pVM)
|
|
{
|
|
unsigned v1, v2;
|
|
|
|
#if FICL_ROBUST > 1
|
|
vmCheckStack(pVM, 2, 0);
|
|
#endif
|
|
|
|
vmGetWordToPad(pVM);
|
|
v2 = POPUNS();
|
|
v1 = POPUNS();
|
|
ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
f i c l C o m p i l e T o o l s
|
|
** Builds wordset for debugger and TOOLS optional word set
|
|
**************************************************************************/
|
|
|
|
void ficlCompileTools(FICL_SYSTEM *pSys)
|
|
{
|
|
FICL_DICT *dp = pSys->dp;
|
|
assert (dp);
|
|
|
|
/*
|
|
** TOOLS and TOOLS EXT
|
|
*/
|
|
dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
|
|
dictAppendWord(dp, "bye", bye, FW_DEFAULT);
|
|
dictAppendWord(dp, "forget", forget, FW_DEFAULT);
|
|
dictAppendWord(dp, "see", see, FW_DEFAULT);
|
|
dictAppendWord(dp, "words", listWords, FW_DEFAULT);
|
|
|
|
/*
|
|
** Set TOOLS environment query values
|
|
*/
|
|
ficlSetEnv(pSys, "tools", FICL_TRUE);
|
|
ficlSetEnv(pSys, "tools-ext", FICL_FALSE);
|
|
|
|
/*
|
|
** Ficl extras
|
|
*/
|
|
dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
|
|
dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
|
|
dictAppendWord(dp, "env-constant",
|
|
envConstant, FW_DEFAULT);
|
|
dictAppendWord(dp, "env-2constant",
|
|
env2Constant, FW_DEFAULT);
|
|
dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT);
|
|
dictAppendWord(dp, "parse-order",
|
|
ficlListParseSteps,
|
|
FW_DEFAULT);
|
|
dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
|
|
dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
|
|
dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);
|
|
|
|
return;
|
|
}
|
|
|