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 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 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 void docol(void)
{ /* DOCOL */
PUSHR(PC);
PC = read_ucell(cell2pointer(PC));
dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
}
static int
add_debug_xt( ucell xt )
{
struct debug_xt *debug_xt_item;
/* If the xt CFA isn't DOCOL then issue a warning and do nothing */
if (read_ucell(cell2pointer(xt)) != DOCOL) {
printf_console("\nprimitive words cannot be debugged\n");
return 0;
}
/* If this xt is already in the list, do nothing but indicate success */
for (debug_xt_item = debug_xt_list; debug_xt_item->next != NULL; debug_xt_item = debug_xt_item->next)
if (debug_xt_item->xt_docol == xt)
return 1;
/* We already have the CFA (PC) indicating the starting cell of the word, however we also
need the ending cell too (we cannot rely on the rstack as it can be arbitrarily
changed by a forth word). Hence the use of findsemis() */
/* Otherwise add to the head of the linked list */
debug_xt_item = malloc(sizeof(struct debug_xt));
debug_xt_item->xt_docol = xt;
debug_xt_item->xt_semis = findsemis(xt);
debug_xt_item->mode = DEBUG_MODE_NONE;
debug_xt_item->next = debug_xt_list;
debug_xt_list = debug_xt_item;
/* Indicate debug mode change */
interruptforth |= FORTH_INTSTAT_DBG;
/* Success */
return 1;
}
ucell findxtfromcell_wordlist(ucell incell, ucell wordlist)
{
ucell tmplfa;
if (!wordlist)
return 0;
tmplfa = read_ucell(cell2pointer(wordlist));
while (tmplfa) {
if (tmplfa < incell)
return lfa2cfa(tmplfa);
tmplfa = read_ucell(cell2pointer(tmplfa));
}
return 0;
}
ucell load_dictionary(const char *data, ucell len)
{
u32 checksum=0;
const char *checksum_walk;
ucell *walk, *reloc_table;
dictionary_header_t *header=(dictionary_header_t *)data;
/* assertions */
if (len <= (sizeof(dictionary_header_t)) || strncmp(DICTID, data, 8))
return 0;
#ifdef CONFIG_DEBUG_DICTIONARY
dump_header(header);
#endif
checksum_walk=data;
while (checksum_walk<data+len) {
checksum+=read_long(checksum_walk);
checksum_walk+=sizeof(u32);
}
if(checksum) {
printk("Checksum invalid (%08x)!\n", checksum);
return 0;
}
data += sizeof(dictionary_header_t);
dicthead = target_long(header->length);
memcpy(dict, data, dicthead);
reloc_table=(ucell *)(data+dicthead);
#ifdef CONFIG_DEBUG_DICTIONARY
printk("\nmoving dictionary (%x bytes) to %x\n",
(ucell)dicthead, (ucell)dict);
printk("\ndynamic relocation...");
#endif
for (walk = (ucell *) dict; walk < (ucell *) (dict + dicthead);
walk++) {
int pos, bit, l;
l=(walk-(ucell *)dict);
pos=l/BITS;
bit=l&~(-BITS);
if (reloc_table[pos] & target_ucell((ucell)1ULL << bit)) {
// printk("%lx, pos %x, bit %d\n",*walk, pos, bit);
write_ucell(walk, read_ucell(walk)+pointer2cell(dict));
}
}
#ifdef CONFIG_DEBUG_DICTIONARY
printk(" done.\n");
#endif
last = (ucell *)(dict + target_ucell(header->last));
return -1;
}
static void store(void)
{
const ucell *aaddr = (ucell *)cell2pointer(POP());
const ucell x = POP();
#ifdef CONFIG_DEBUG_INTERNAL
printk("!: %lx : %lx -> %lx\n", aaddr, read_ucell(aaddr), x);
#endif
write_ucell(aaddr,x);
}
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)))));
}
}
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;
}
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;
}
ucell findxtfromcell(ucell incell)
{
ucell usesvocab = findword("vocabularies?") + sizeof(cell);
unsigned int i;
if (read_ucell(cell2pointer(usesvocab))) {
/* Vocabularies are in use, so search each one in turn */
ucell numvocabs = findword("#order") + sizeof(cell);
for (i = 0; i < read_ucell(cell2pointer(numvocabs)); i++) {
ucell vocabs = findword("vocabularies") + 2 * sizeof(cell);
ucell semis = findxtfromcell_wordlist(incell, read_cell(cell2pointer(vocabs + (i * sizeof(cell)))));
/* If we get a non-zero result, we found the xt in this vocab */
if (semis)
return semis;
}
} else {
/* Vocabularies not in use */
return findxtfromcell_wordlist(incell, read_ucell(last));
}
return 0;
}
static void fcreate(const char *word, ucell cfaval)
{
if (strlen(word) == 0) {
printk("WARNING: tried to create unnamed word.\n");
return;
}
writestring(word);
/* get us at least 1 byte for flags */
writebyte(0);
paddict(sizeof(cell));
/* set flags high bit. */
dict[dicthead - 1] = 128;
/* lfa and cfa */
writecell(read_ucell(latest));
*latest = target_ucell(pointer2cell(dict) + dicthead - sizeof(cell));
writecell(cfaval);
}
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))));
}
static void write_dictionary(const char *filename)
{
FILE *f;
unsigned char *write_data, *walk_data;
int write_len;
dictionary_header_t *header;
u32 checksum=0;
/*
* get memory for dictionary
*/
write_len = sizeof(dictionary_header_t)+dicthead+relocation_length*sizeof(cell);
write_data = malloc(write_len);
if(!write_data) {
printk("panic: can't allocate memory for output dictionary (%d"
" bytes\n", write_len);
exit(1);
}
memset(write_data, 0, write_len);
/*
* prepare dictionary header
*/
header = (dictionary_header_t *)write_data;
*header = (dictionary_header_t){
.signature = DICTID,
.version = 2,
.cellsize = sizeof(ucell),
#ifdef CONFIG_BIG_ENDIAN
.endianess = -1,
#else
.endianess = 0,
#endif
.checksum = 0,
.compression = 0,
.relocation = -1,
.length = target_ulong((uint32_t)dicthead),
.last = target_ucell((ucell)((unsigned long)last
- (unsigned long)dict)),
};
/*
* prepare dictionary data
*/
walk_data=write_data+sizeof(dictionary_header_t);
memcpy (walk_data, dict, dicthead);
/*
* prepare relocation data.
* relocation_address is zero when writing a dictionary core.
*/
if (relocation_address) {
#ifdef CONFIG_DEBUG_DICTIONARY
printk("writing %d reloc cells \n",relocation_length);
#endif
walk_data += dicthead;
memcpy(walk_data, relocation_address,
relocation_length*sizeof(cell));
/* free relocation information */
free(relocation_address);
relocation_address=NULL;
} else {
header->relocation=0;
}
/*
* Calculate Checksum
*/
walk_data=write_data;
while (walk_data<write_data+write_len) {
checksum+=read_long(walk_data);
walk_data+=sizeof(u32);
}
checksum=(u32)-checksum;
header->checksum=target_long(checksum);
if (verbose) {
dump_header(header);
}
f = fopen(filename, "w");
if (!f) {
printk("panic: can't write to dictionary '%s'.\n", filename);
exit(1);
}
fwrite(write_data, write_len, 1, f);
free(write_data);
fclose(f);
#ifdef CONFIG_DEBUG_DICTIONARY
printk("wrote dictionary to file %s.\n", filename);
#endif
}
/*
* Write dictionary as a list of ucell hex values to filename. Array
* header and end lines are not generated.
*
* Cells with relocations are output using the expression
* DICTIONARY_BASE + value.
*
* Define some helpful constants.
*/
static void write_dictionary_hex(const char *filename)
{
FILE *f;
ucell *walk;
f = fopen(filename, "w");
if (!f) {
printk("panic: can't write to dictionary '%s'.\n", filename);
exit(1);
}
for (walk = (ucell *)dict; walk < (ucell *)(dict + dicthead); walk++) {
int pos, bit, l;
ucell val;
l = (walk - (ucell *)dict);
pos = l / BITS;
bit = l & ~(-BITS);
val = read_ucell(walk);
if (relocation_address[pos] & target_ucell((ucell)1ULL << bit)) {
fprintf(f, "DICTIONARY_BASE + 0x%" FMT_CELL_x
",\n", val);
} else {
fprintf(f, "0x%" FMT_CELL_x",\n", val);
}
}
fprintf(f, "#define FORTH_DICTIONARY_LAST 0x%" FMT_CELL_x"\n",
(ucell)((unsigned long)last - (unsigned long)dict));
fprintf(f, "#define FORTH_DICTIONARY_END 0x%" FMT_CELL_x"\n",
(ucell)dicthead);
fclose(f);
#ifdef CONFIG_DEBUG_DICTIONARY
printk("wrote dictionary to file %s.\n", filename);
#endif
}
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();
}
}
}
static int interpret_source(char *fil)
{
FILE *f;
char tib[160];
cell num;
char *test;
const ucell SEMIS = (ucell)findword("(semis)");
const ucell LIT = (ucell)findword("(lit)");
const ucell DOBRANCH = (ucell)findword("dobranch");
if ((f = fopen_include(fil)) == NULL) {
printk("error while loading source file '%s'\n", fil);
errors++;
exit(1);
}
/* FIXME: We should read this file at
* once. No need to get it char by char
*/
while (!feof(f)) {
xt_t res;
parse_word(f, tib);
/* if there is actually no word, we continue right away */
if (strlen(tib) == 0) {
continue;
}
/* Checking for builtin words that are needed to
* bootstrap the forth base dictionary.
*/
if (!strcmp(tib, "(")) {
parse(f, tib, ')');
continue;
}
if (!strcmp(tib, "\\")) {
parse(f, tib, '\n');
continue;
}
if (!strcmp(tib, ":")) {
parse_word(f, tib);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("create colon word %s\n\n", tib);
#endif
fcreate(tib, DOCOL); /* see dict.h for DOCOL and other CFA ids */
*state = (ucell) (-1);
continue;
}
if (!strcmp(tib, ";")) {
#ifdef CONFIG_DEBUG_INTERPRETER
printk("finish colon definition\n\n");
#endif
writecell((cell)SEMIS);
*state = (ucell) 0;
reveal();
continue;
}
if (!strcasecmp(tib, "variable")) {
parse_word(f, tib);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("defining variable %s\n\n", tib);
#endif
buildvariable(tib, 0);
reveal();
continue;
}
if (!strcasecmp(tib, "constant")) {
parse_word(f, tib);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("defining constant %s\n\n", tib);
#endif
buildconstant(tib, POP());
reveal();
continue;
}
if (!strcasecmp(tib, "value")) {
parse_word(f, tib);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("defining value %s\n\n", tib);
#endif
buildconstant(tib, POP());
reveal();
continue;
}
if (!strcasecmp(tib, "defer")) {
parse_word(f, tib);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("defining defer word %s\n\n", tib);
#endif
builddefer(tib);
reveal();
continue;
}
if (!strcasecmp(tib, "include")) {
parse_word(f, tib);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("including file %s\n\n", tib);
#endif
interpret_source(tib);
continue;
}
if (!strcmp(tib, "[']")) {
xt_t xt;
parse_word(f, tib);
xt = findword(tib);
if (*state == 0) {
#ifdef CONFIG_DEBUG_INTERPRETER
printk
("writing address of %s to stack\n\n",
tib);
#endif
PUSH_xt(xt);
} else {
#ifdef CONFIG_DEBUG_INTERPRETER
printk("writing lit, addr(%s) to dict\n\n",
tib);
#endif
writecell(LIT); /* lit */
writecell((cell)xt);
}
continue;
/* we have no error detection here */
}
if (!strcasecmp(tib, "s\"")) {
int cnt;
cell loco;
cnt = parse(f, tib, '"');
#ifdef CONFIG_DEBUG_INTERPRETER
printk("compiling string %s\n", tib);
#endif
loco = dicthead + (6 * sizeof(cell));
writecell(LIT);
writecell(pointer2cell(dict) + loco);
writecell(LIT);
writecell((ucell)cnt);
writecell(DOBRANCH);
loco = cnt + sizeof(cell) - 1;
loco &= ~(sizeof(cell) - 1);
writecell(loco);
memcpy(dict + dicthead, tib, cnt);
dicthead += cnt;
paddict(sizeof(cell));
continue;
}
/* look if tib is in dictionary. */
/* should the dictionary be searched before the builtins ? */
res = findword(tib);
if (res) {
u8 flags = read_byte((u8*)cell2pointer(res) -
sizeof(cell) - 1);
#ifdef CONFIG_DEBUG_INTERPRETER
printk("%s is 0x%" FMT_CELL_x "\n", tib, (ucell) res);
#endif
if (!(*state) || (flags & 3)) {
#ifdef CONFIG_DEBUG_INTERPRETER
printk("executing %s, %" FMT_CELL_d
" (flags: %s %s)\n",
tib, res,
(flags & 1) ? "immediate" : "",
(flags & 2) ? "compile-only" : "");
#endif
PC = (ucell)res;
enterforth(res);
} else {
#ifdef CONFIG_DEBUG_INTERPRETER
printk("writing %s to dict\n\n", tib);
#endif
writecell((cell)res);
}
continue;
}
/* if not look if it's a number */
if (tib[0] == '-')
num = strtoll(tib, &test, read_ucell(base));
else
num = strtoull(tib, &test, read_ucell(base));
if (*test != 0) {
/* what is it?? */
printk("%s:%d: %s is not defined.\n\n", srcfilenames[cursrc - 1], srclines[cursrc - 1], tib);
errors++;
#ifdef CONFIG_DEBUG_INTERPRETER
continue;
#else
return -1;
#endif
}
if (*state == 0) {
#ifdef CONFIG_DEBUG_INTERPRETER
printk("pushed %" FMT_CELL_x " to stack\n\n", num);
#endif
PUSH(num);
} else {
#ifdef CONFIG_DEBUG_INTERPRETER
printk("writing lit, %" FMT_CELL_x " to dict\n\n", num);
#endif
writecell(LIT); /* lit */
writecell(num);
}
}
fclose(f);
cursrc--;
return 0;
}
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);
}
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);
}
/* 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 fetch(void)
{
const ucell *aaddr = (ucell *)cell2pointer(POP());
PUSH(read_ucell(aaddr));
}
