kernel/internal.c

/* tag: internal words, inner interpreter and such
 *
 * Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer
 *
 * See the file "COPYING" for further information about
 * the copyright and warranty status of this work.
 */

/*
 * execution works as follows:
 *  - PC is pushed on return stack
 *  - PC is set to new CFA
 *  - address pointed by CFA is executed by CPU
 */

extern void * const words[];
ucell PC;
volatile int runforth = 0;

#ifdef FCOMPILER
extern ucell *trampoline;
#else
/* instead of pointing to an explicit 0 variable we
 * point behind the pointer.
 */
static ucell t[] = { DOCOL, 0, (ucell)(t+3), 0 };
static ucell *trampoline = t;
#endif

#ifndef CONFIG_DEBUG_INTERPRETER
#define dbg_interp_printk( a... )	do { } while(0)
#else
#define dbg_interp_printk( a... )	printk( a )
#endif

#ifndef CONFIG_DEBUG_INTERNAL
#define dbg_internal_printk( a... )	do { } while(0)
#else
#define dbg_internal_printk( a... )	printk( a )
#endif


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 docol(void)
{				/* DOCOL */
	PUSHR(PC);
	PC = read_ucell(cell2pointer(PC));

	dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
}

static void semis(void)
{
	PC = POPR();
}

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)))));
}

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;
	runforth = 1;

	PUSHR(PC);
	PC = pointer2cell(_cfa);
	while (rstackcnt > tmp && runforth) {
		dbg_interp_printk("enterforth: NEXT\n");
		next();
	}

#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;
}

/* 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);
}

static void dobranch(void)
{				/* unconditional branch */
	PC += sizeof(cell);
	PC += read_cell(cell2pointer(PC));
}

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 execute(void)
{				/* EXECUTE */
	ucell address = POP();
	dbg_interp_printk("execute: %x\n", address);

	PUSHR(PC);
	trampoline[1] = target_ucell(address);
	PC = pointer2cell(trampoline);
}

/*
 * 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 *)POP();
	dbg_interp_printk("call: %x", funcptr);
	funcptr();
#endif
}

/*
 * sys-debug ( errno -- )
 */

static void sysdebug(void)
{
#ifdef FCOMPILER
	cell errorno=POP();
	exception(errorno);
#else
        (void) POP();
#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 void dodefer(void)
{
	docol();
}

static void dodo(void)
{
	cell startval, endval;
	startval = POP();
	endval = POP();

	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);
	}
}

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 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);
	}
}

/*
 *  instance handling CFAs
 */
#ifndef FCOMPILER
static ucell get_myself(void)
{
        static ucell **myself = NULL;
	if( !myself )
		myself = (ucell**)findword("my-self") + 1;
	return (*myself && **myself) ? (ucell)**myself : 0;
}

static void doivar(void)
{
	ucell r, *p = (ucell *)(*(ucell *) PC + sizeof(ucell));
	ucell ibase = get_myself();

	dbg_interp_printk("ivar, offset: %d size: %d (ibase %d)\n", p[0], p[1], ibase );

	r = ibase ? ibase + p[0] : (ucell)&p[2];
	PUSH( r );
}

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 doidefer(void)
{
	ucell *p = (ucell *)(*(ucell *) 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] : (ucell)&p[2];
	PC -= sizeof(ucell);
}
#else
static void noinstances(void)
{
	printk("Opening devices is not supported during bootstrap. Sorry.\n");
	exit(1);
}
#define doivar   noinstances
#define doival   noinstances
#define doidefer noinstances
#endif
/*
 * $include / $encode-file
 */

#ifdef FCOMPILER
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 );
}
#else
#define	string_relay( dummy )	do { DROP(); DROP(); } while(0)
#endif

static void
do_include( void )
{
	string_relay( &include_file );
}

static void
do_encode_file( void )
{
	string_relay( &encode_file );
}