static void docol(void)
{ /* DOCOL */
PUSHR(PC);
PC = read_ucell(cell2pointer(PC));
dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
}
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 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 fmove(void)
{
ucell count = POP();
void *dest = (void *)cell2pointer(POP());
const void *src = (const void *)cell2pointer(POP());
memmove(dest, src, count);
}
static ucell get_myself(void)
{
static ucell *myselfptr = NULL;
if (myselfptr == NULL) {
myselfptr = (ucell*)cell2pointer(findword("my-self")) + 1;
}
ucell *myself = (ucell*)cell2pointer(*myselfptr);
return (myself != NULL) ? *myself : 0;
}
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 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 ffill(void)
{
ucell value = POP();
ucell count = POP();
void *src = (void *)cell2pointer(POP());
memset(src, value, count);
}
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;
}
static void doplusloop(void)
{
ucell high, low;
cell increment, startval, endval, offset;
increment = POP();
startval = POPR();
endval = POPR();
low = (ucell) startval;
startval += increment;
PC += sizeof(cell);
if (increment >= 0) {
high = (ucell) startval;
} else {
high = low;
low = (ucell) startval;
}
if (endval - (low + 1) >= high - low) {
offset = read_cell(cell2pointer(PC));
PC += offset;
PUSHR(endval);
PUSHR(startval);
}
}
void fstrncpy(char *dest, ucell src, unsigned int maxlen)
{
int len = fstrlen(src);
if (fstrlen(src) >= maxlen) len = maxlen - 1;
memcpy(dest, cell2pointer(src), len);
*(dest + len) = '\0';
}
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;
}
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 int fstrcmp(const char *s1, ucell fstr)
{
char *s2 = (char*)cell2pointer(fstr);
while (*s1) {
if ( to_lower(*(s1++)) != to_lower(*(s2++)) )
return -1;
}
return 0;
}
static void cstore(void)
{
const u8 *aaddr = (u8 *)cell2pointer(POP());
const ucell byte = POP();
#ifdef CONFIG_DEBUG_INTERNAL
printk("c!: %x = %x\n", aaddr, byte);
#endif
write_byte(aaddr, byte);
}
void init_program(void)
{
/* Get the value of load-base and use it to determine the correct loader
to use */
ucell addr;
feval("load-base");
addr = POP();
#ifdef CONFIG_LOADER_AOUT
if (is_aout((struct exec *)cell2pointer(addr))) {
aout_init_program();
return;
}
#endif
#ifdef CONFIG_LOADER_BOOTCODE
if (is_bootcode((char *)cell2pointer(addr))) {
bootcode_init_program();
return;
}
#endif
#ifdef CONFIG_LOADER_BOOTINFO
if (is_bootinfo((char *)cell2pointer(addr))) {
bootinfo_init_program();
return;
}
#endif
#ifdef CONFIG_LOADER_ELF
if (is_elf((Elf_ehdr *)cell2pointer(addr))) {
elf_init_program();
return;
}
#endif
#ifdef CONFIG_LOADER_FCODE
if (is_fcode((unsigned char *)cell2pointer(addr))) {
fcode_init_program();
return;
}
#endif
#ifdef CONFIG_LOADER_FORTH
if (is_forth((char *)cell2pointer(addr))) {
forth_init_program();
return;
}
#endif
#ifdef CONFIG_LOADER_XCOFF
if (is_xcoff((COFF_filehdr_t *)cell2pointer(addr))) {
xcoff_init_program();
return;
}
#endif
}
static void docbranch(void)
{ /* conditional branch */
PC += sizeof(cell);
if (POP()) {
dbg_internal_printk(" ?branch: end loop\n");
} else {
dbg_internal_printk(" ?branch: follow branch\n");
PC += read_cell(cell2pointer(PC));
}
}
static void
string_relay(void (*func)(const char *))
{
int len = POP();
char *name, *p = (char*)cell2pointer(POP());
name = malloc(len + 1);
memcpy(name, p, len);
name[len] = 0;
(*func)(name);
free(name);
}
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 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 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))));
}
/* ( addr -- size ) */
static void
grubfs_files_load( grubfs_info_t *mi )
{
char *buf = (char *)cell2pointer(POP());
int count, ret;
grubfile_t *file = mi->gfs->fd;
count = file->len;
ret = mi->gfs->fsys->read_func(buf, count);
file->pos = filepos;
RET( ret );
}
/* ( addr len -- actual ) */
static void
nvram_write( nvram_ibuf_t *nd )
{
int len = POP();
char *p = (char*)cell2pointer(POP());
int n=0;
while( nd->mark_lo < nvram.size && n < len ) {
nvram.data[nd->mark_lo++] = *p++;
n++;
}
PUSH(n);
DPRINTF("write %p %x -- %x\n", p, len, n );
}
/* ( buf len -- actlen ) */
static void
hfsp_files_read( hfsp_info_t *mi )
{
int count = POP();
char *buf = (char *)cell2pointer(POP());
hfsp_file_t *t = mi->hfspfile;
volume *vol = t->rec.tree->vol;
UInt32 blksize = vol->blksize;
hfsp_cat_file *file = &t->rec.record.u.file;
blockiter iter;
char buf2[blksize];
int act_count, curpos=0;
blockiter_init( &iter, vol, &file->data_fork, HFSP_EXTENT_DATA, file->id );
while( curpos + blksize < t->pos ) {
if( blockiter_next( &iter ) ) {
RET ( -1 );
return;
}
curpos += blksize;
}
act_count = 0;
while( act_count < count ){
UInt32 block = blockiter_curr(&iter);
int max = blksize, add = 0, size;
if( volume_readinbuf( vol, buf2, block ) )
break;
if( curpos < t->pos ){
add += t->pos - curpos;
max -= t->pos - curpos;
}
size = (count-act_count > max)? max : count-act_count;
memcpy( (char *)buf + act_count, &buf2[add], size );
curpos += blksize;
act_count += size;
if( blockiter_next( &iter ) )
break;
}
t->pos += act_count;
RET ( act_count );
}
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 doloop(void)
{
cell offset, startval, endval;
startval = POPR() + 1;
endval = POPR();
PC += sizeof(cell);
if (startval < endval) {
offset = read_cell(cell2pointer(PC));
PC += offset;
PUSHR(endval);
PUSHR(startval);
}
}
static void doisdo(void)
{
cell startval, endval, offset;
startval = POP();
endval = POP();
PC += sizeof(cell);
if (startval == endval) {
offset = read_cell(cell2pointer(PC));
PC += offset;
} else {
PUSHR(endval);
PUSHR(startval);
}
}
/* ( buf len -- actlen ) */
static void
grubfs_files_read( grubfs_info_t *mi )
{
int count = POP();
char *buf = (char *)cell2pointer(POP());
grubfile_t *file = mi->gfs->fd;
int ret;
filepos = file->pos;
filemax = file->len;
if (count > filemax - filepos)
count = filemax - filepos;
ret = mi->gfs->fsys->read_func(buf, count);
file->pos = filepos;
RET( ret );
}
