static void semis_dbg(void)
{
struct debug_xt *debug_xt_item, *debug_xt_up = NULL;
/* If current semis is in our debug xt list, disable debug mode */
debug_xt_item = debug_xt_list;
while (debug_xt_item->next) {
if (debug_xt_item->xt_semis == PC) {
if (debug_xt_item->mode != DEBUG_MODE_STEPUP) {
/* Handle the normal case */
fstrncpy(xtname, lfa2nfa(debug_xt_item->xt_docol - sizeof(cell)), MAXNFALEN);
printf_console("\n[ Finished %s ] ", xtname);
/* Reset to step mode in case we were in trace mode */
debug_xt_item->mode = DEBUG_MODE_STEP;
} else {
/* This word requires execution of the debugger "Up"
* semantics. However we can't do this here since we
* are iterating through the debug list, and we need
* to change it. So we do it afterwards.
*/
debug_xt_up = debug_xt_item;
}
}
debug_xt_item = debug_xt_item->next;
}
/* Execute debugger "Up" semantics if required */
if (debug_xt_up) {
/* Only add the parent word if it is not within the trampoline */
if (rstack[rstackcnt] != (cell)pointer2cell(&trampoline[1])) {
del_debug_xt(debug_xt_up->xt_docol);
add_debug_xt(findxtfromcell(rstack[rstackcnt]));
fstrncpy(xtname, lfa2nfa(findxtfromcell(rstack[rstackcnt]) - sizeof(cell)), MAXNFALEN);
printf_console("\n[ Up to %s ] ", xtname);
} else {
fstrncpy(xtname, lfa2nfa(findxtfromcell(debug_xt_up->xt_docol) - sizeof(cell)), MAXNFALEN);
printf_console("\n[ Finished %s (Unable to go up, hit trampoline) ] ", xtname);
del_debug_xt(debug_xt_up->xt_docol);
}
debug_xt_up = NULL;
}
PC = POPR();
}
static void docol(void)
{ /* DOCOL */
PUSHR(PC);
PC = read_ucell(cell2pointer(PC));
dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
}
static ucell findsemis_wordlist(ucell xt, ucell wordlist)
{
ucell tmplfa, nextlfa, nextcfa;
if (!wordlist)
return 0;
tmplfa = read_ucell(cell2pointer(wordlist));
nextcfa = lfa2cfa(tmplfa);
/* Catch the special case where the lfa of the word we
* want is the last word in the dictionary; in that case
* the end of the word is given by "here" - 1 */
if (nextcfa == xt)
return pointer2cell(dict) + dicthead - sizeof(cell);
while (tmplfa) {
/* Peek ahead and see if the next CFA in the list is the
* one we are searching for */
nextlfa = read_ucell(cell2pointer(tmplfa));
nextcfa = lfa2cfa(nextlfa);
/* If so, count back 1 cell from the current NFA */
if (nextcfa == xt)
return lfa2nfa(tmplfa) - sizeof(cell);
tmplfa = nextlfa;
}
return 0;
}
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))));
}
xt_t findword(const char *s1)
{
ucell tmplfa, len;
if (!last)
return 0;
tmplfa = read_ucell(last);
len = strlen(s1);
while (tmplfa) {
ucell nfa = lfa2nfa(tmplfa);
if (len == fstrlen(nfa) && !fstrcmp(s1, nfa)) {
return lfa2cfa(tmplfa);
}
tmplfa = read_ucell(cell2pointer(tmplfa));
}
return 0;
}
static void
do_source_dbg(struct debug_xt *debug_xt_item)
{
/* Forth source debugger implementation */
char k, done = 0;
/* Display current dstack */
display_dbg_dstack();
printf_console("\n");
fstrncpy(xtname, lfa2nfa(read_ucell(cell2pointer(PC)) - sizeof(cell)), MAXNFALEN);
printf_console("%p: %s ", cell2pointer(PC), xtname);
/* If in trace mode, we just carry on */
if (debug_xt_item->mode == DEBUG_MODE_TRACE) {
return;
}
/* Otherwise in step mode, prompt for a keypress */
k = getchar_console();
/* Only proceed if done is true */
while (!done) {
switch (k) {
case ' ':
case '\n':
/* Perform a single step */
done = 1;
break;
case 'u':
case 'U':
/* Up - unmark current word for debug, mark its caller for
* debugging and finish executing current word */
/* Since this word could alter the rstack during its execution,
* we only know the caller when (semis) is called for this xt.
* Hence we mark the xt as a special DEBUG_MODE_STEPUP which
* means we run as normal, but schedule the xt for deletion
* at its corresponding (semis) word when we know the rstack
* will be set to its final parent value */
debug_xt_item->mode = DEBUG_MODE_STEPUP;
done = 1;
break;
case 'd':
case 'D':
/* Down - mark current word for debug and step into it */
done = add_debug_xt(read_ucell(cell2pointer(PC)));
if (!done) {
k = getchar_console();
}
break;
case 't':
case 'T':
/* Trace mode */
debug_xt_item->mode = DEBUG_MODE_TRACE;
done = 1;
break;
case 'r':
case 'R':
/* Display rstack */
display_dbg_rstack();
done = 0;
k = getchar_console();
break;
case 'f':
case 'F':
/* Start subordinate Forth interpreter */
PUSHR(PC - sizeof(cell));
PC = findword("outer-interpreter") + sizeof(ucell);
/* Save rstack position for when we return */
dbgrstackcnt = rstackcnt;
done = 1;
break;
default:
/* Display debug banner */
printf_console(DEBUG_BANNER);
k = getchar_console();
}
}
}
