int enterforth(xt_t xt)
{
ucell *_cfa = (ucell*)cell2pointer(xt);
cell tmp;
if (read_ucell(_cfa) != DOCOL) {
trampoline[1] = target_ucell(xt);
_cfa = trampoline;
}
if (rstackcnt < 0) {
rstackcnt = 0;
}
tmp = rstackcnt;
interruptforth = FORTH_INTSTAT_CLR;
PUSHR(PC);
PC = pointer2cell(_cfa);
while (rstackcnt > tmp && !(interruptforth & FORTH_INTSTAT_STOP)) {
if (debug_xt_list->next == NULL) {
while (rstackcnt > tmp && !interruptforth) {
dbg_interp_printk("enterforth: NEXT\n");
next();
}
} else {
while (rstackcnt > tmp && !interruptforth) {
dbg_interp_printk("enterforth: NEXT_DBG\n");
next_dbg();
}
}
/* Always clear the debug mode change flag */
interruptforth = interruptforth & (~FORTH_INTSTAT_DBG);
}
#if 0
/* return true if we took an exception. The caller should normally
* handle exceptions by returning immediately since the throw
* is supposed to abort the execution of this C-code too.
*/
if (rstackcnt != tmp) {
printk("EXCEPTION DETECTED!\n");
}
#endif
return rstackcnt != tmp;
}
static void docol(void)
{ /* DOCOL */
PUSHR(PC);
PC = read_ucell(cell2pointer(PC));
dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
}
static
int printf_console(const char *fmt, ...)
{
cell tmp;
char buf[512];
va_list args;
int i;
va_start(args, fmt);
i = vsnprintf(buf, sizeof(buf), fmt, args);
va_end(args);
/* Push to the Forth interpreter for console output */
tmp = rstackcnt;
PUSH(pointer2cell(buf));
PUSH((int)strlen(buf));
trampoline[1] = findword("type");
PUSHR(PC);
PC = pointer2cell(trampoline);
while (rstackcnt > tmp) {
dbg_interp_printk("printf_console: NEXT\n");
next();
}
return i;
}
static inline void next_dbg(void)
{
struct debug_xt *debug_xt_item;
void (*tokenp) (void);
PC += sizeof(ucell);
/* If the PC lies within a debug range, run the source debugger */
debug_xt_item = debug_xt_list;
while (debug_xt_item->next) {
if (PC >= debug_xt_item->xt_docol && PC <= debug_xt_item->xt_semis &&
debug_xt_item->mode != DEBUG_MODE_STEPUP) {
do_source_dbg(debug_xt_item);
}
debug_xt_item = debug_xt_item->next;
}
dbg_interp_printk("next_dbg: PC is now %x\n", PC);
/* Intercept DOCOL and SEMIS and redirect to debug versions */
if (read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))) == DOCOL) {
tokenp = docol_dbg;
tokenp();
} else if (read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))) == DOSEMIS) {
tokenp = semis_dbg;
tokenp();
} else {
/* Otherwise process as normal */
processxt(read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))));
}
}
static inline void next(void)
{
PC += sizeof(ucell);
dbg_interp_printk("next: PC is now %x\n", PC);
processxt(read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))));
}
static inline void processxt(ucell xt)
{
void (*tokenp) (void);
dbg_interp_printk("processxt: pc=%x, xt=%x\n", PC, xt);
tokenp = words[xt];
tokenp();
}
static void execute(void)
{ /* EXECUTE */
ucell address = POP();
dbg_interp_printk("execute: %x\n", address);
PUSHR(PC);
trampoline[1] = target_ucell(address);
PC = pointer2cell(trampoline);
}
static void doival(void)
{
ucell r, *p = (ucell *)(*(ucell *) PC + sizeof(ucell));
ucell ibase = get_myself();
dbg_interp_printk("ivar, offset: %d size: %d\n", p[0], p[1] );
r = ibase ? ibase + p[0] : (ucell)&p[2];
PUSH( *(ucell *)r );
}
static void doival(void)
{
ucell r, *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
ucell ibase = get_myself();
dbg_interp_printk("ivar, offset: %d size: %d\n", p[0], p[1] );
r = ibase ? ibase + p[0] : pointer2cell(&p[2]);
PUSH( *(ucell *)cell2pointer(r) );
}
static void doidefer(void)
{
ucell *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
ucell ibase = get_myself();
dbg_interp_printk("doidefer, offset: %d size: %d\n", p[0], p[1] );
PUSHR(PC);
PC = ibase ? ibase + p[0] : pointer2cell(&p[2]);
PC -= sizeof(ucell);
}
/*
* call ( ... function-ptr -- ??? )
*/
static void call(void)
{
#ifdef FCOMPILER
printk("Sorry. Usage of Forth2C binding is forbidden during bootstrap.\n");
exit(1);
#else
void (*funcptr) (void);
funcptr=(void *)cell2pointer(POP());
dbg_interp_printk("call: %x", funcptr);
funcptr();
#endif
}
static void dodoes(void)
{ /* DODOES */
ucell data = read_ucell(cell2pointer(PC)) + (2 * sizeof(ucell));
ucell word = read_ucell(cell2pointer(read_ucell(cell2pointer(PC)) + sizeof(ucell)));
dbg_interp_printk("DODOES data=%x word=%x\n", data, word);
PUSH(data);
PUSH(word);
execute();
}
static
int getchar_console(void)
{
cell tmp;
/* Push to the Forth interpreter for console output */
tmp = rstackcnt;
trampoline[1] = findword("key");
PUSHR(PC);
PC = pointer2cell(trampoline);
while (rstackcnt > tmp) {
dbg_interp_printk("getchar_console: NEXT\n");
next();
}
return POP();
}
static void docol_dbg(void)
{ /* DOCOL */
struct debug_xt *debug_xt_item;
PUSHR(PC);
PC = read_ucell(cell2pointer(PC));
/* If current xt is in our debug xt list, display word name */
debug_xt_item = debug_xt_list;
while (debug_xt_item->next) {
if (debug_xt_item->xt_docol == PC) {
fstrncpy(xtname, lfa2nfa(PC - sizeof(cell)), MAXNFALEN);
printf_console("\n: %s ", xtname);
/* Step mode is the default */
debug_xt_item->mode = DEBUG_MODE_STEP;
}
debug_xt_item = debug_xt_item->next;
}
dbg_interp_printk("docol_dbg: %s\n", cell2pointer(lfa2nfa(PC - sizeof(cell))));
}
/* called inline thus a slightly different behaviour */
static void lit(void)
{ /* LIT */
PC += sizeof(cell);
PUSH(read_ucell(cell2pointer(PC)));
dbg_interp_printk("lit: %x\n", read_ucell(cell2pointer(PC)));
}
static void docon(void)
{ /* DOCON */
ucell tmp = read_ucell(cell2pointer(read_ucell(cell2pointer(PC)) + sizeof(ucell)));
PUSH(tmp);
dbg_interp_printk("docon: PC=%x, value=%x\n", PC, tmp);
}
static void dovar(void)
{ /* DOVAR */
ucell tmp = read_ucell(cell2pointer(PC)) + sizeof(ucell);
PUSH(tmp); /* returns address to variable */
dbg_interp_printk("dovar: PC: %x, %x\n", PC, tmp);
}