kernel/forth.c

/* tag: C implementation of all forth primitives,
 * 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.
 */

#include "config.h"
#include "sysinclude.h"
#include "kernel/stack.h"
#include "kernel/kernel.h"
#include "dict.h"

/*
 * cross platform abstraction
 */

#include "cross.h"

#ifndef FCOMPILER
#include "libc/vsprintf.h"
#else
#include <stdarg.h>
#endif

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

typedef void forth_word(void);

static forth_word * const words[];
ucell PC;
volatile int interruptforth = 0;

#define DEBUG_MODE_NONE 0
#define DEBUG_MODE_STEP 1
#define DEBUG_MODE_TRACE 2
#define DEBUG_MODE_STEPUP 3

#define DEBUG_BANNER "\nStepper keys: <space>/<enter> Up Down Trace Rstack Forth\n"

/* Empty linked list of debug xts */
struct debug_xt {
    ucell xt_docol;
    ucell xt_semis;
    int mode;
    struct debug_xt *next;
};

static struct debug_xt debug_xt_eol = { (ucell)0, (ucell)0, 0, NULL};
static struct debug_xt *debug_xt_list = &debug_xt_eol;

/* Static buffer for xt name */
char xtname[MAXNFALEN];

#ifndef FCOMPILER
/* instead of pointing to an explicit 0 variable we
 * point behind the pointer.
 */
static ucell t[] = { 0, 0, 0, 0 };
static ucell *trampoline = t;

/*
 * Code Field Address (CFA) definitions (DOCOL and the like)
 */

void forth_init(void)
{
    init_trampoline(trampoline);
}
#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


void init_trampoline(ucell *tramp)
{
    tramp[0] = DOCOL;
    tramp[1] = 0;
    tramp[2] = target_ucell(pointer2cell(tramp) + 3 * sizeof(ucell));
    tramp[3] = 0;
}

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

static inline void next_dbg(void);

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

/* 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 *)cell2pointer(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 *myselfptr = NULL;
    if (myselfptr == NULL) {
        myselfptr = (ucell*)cell2pointer(findword("my-self")) + 1;
    }
    ucell *myself = (ucell*)cell2pointer(*myselfptr);
    return (myself != NULL) ? *myself : 0;
}

static void doivar(void)
{
    ucell r, *p = (ucell *)(*(ucell *) cell2pointer(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] : pointer2cell(&p[2]);
    PUSH( 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);
}
#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);
}

/*
 * Debug support functions
 */

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
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
display_dbg_dstack(void)
{
    /* Display dstack contents between parentheses */
    int i;

    if (dstackcnt == 0) {
        printf_console(" ( Empty ) ");
        return;
    } else {
        printf_console(" ( ");
        for (i = 1; i <= dstackcnt; i++) {
            if (i != 1) {
                printf_console(" ");
            }
            printf_console("%" FMT_CELL_x, dstack[i]);
        }
        printf_console(" ) ");
    }
}

static void
display_dbg_rstack(void)
{
    /* Display rstack contents between parentheses */
    int i;

    if (rstackcnt == 0) {
        printf_console(" ( Empty ) ");
        return;
    } else {
        printf_console("\nR: ( ");
        for (i = 1; i <= rstackcnt; i++) {
            if (i != 1) {
                printf_console(" ");
            }
            printf_console("%" FMT_CELL_x, rstack[i]);
        }
        printf_console(" ) \n");
    }
}

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
del_debug_xt(ucell xt)
{
    struct debug_xt *debug_xt_item, *tmp_xt_item;

    /* Handle the case where the xt is at the head of the list */
    if (debug_xt_list->xt_docol == xt) {
        tmp_xt_item = debug_xt_list;
        debug_xt_list = debug_xt_list->next;
        free(tmp_xt_item);

        return;
    }

    /* Otherwise find this xt in the linked list and remove it */
    for (debug_xt_item = debug_xt_list; debug_xt_item->next != NULL;
         debug_xt_item = debug_xt_item->next) {
        if (debug_xt_item->next->xt_docol == xt) {
            tmp_xt_item = debug_xt_item->next;
            debug_xt_item->next = debug_xt_item->next->next;
            free(tmp_xt_item);
        }
    }

    /* If the list is now empty, indicate debug mode change */
    if (debug_xt_list->next == NULL) {
        interruptforth |= FORTH_INTSTAT_DBG;
    }
}

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 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 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 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
do_debug_xt(void)
{
    ucell xt = POP();

    /* Add to the debug list */
    if (add_debug_xt(xt)) {
        /* Display debug banner */
        printf_console(DEBUG_BANNER);

        /* Indicate change to debug mode */
        interruptforth |= FORTH_INTSTAT_DBG;
    }
}

static void
do_debug_off(void)
{
    /* Empty the debug xt linked list */
    while (debug_xt_list->next != NULL) {
        del_debug_xt(debug_xt_list->xt_docol);
    }
}

/*
 * Forth primitives needed to set up
 * all the words described in IEEE1275-1994.
 */

/*
 *  dup         ( x -- x x )
 */

static void fdup(void)
{
	const cell tmp = GETTOS();
	PUSH(tmp);
}


/*
 *  2dup        ( x1 x2 -- x1 x2 x1 x2 )
 */

static void twodup(void)
{
	cell tmp = GETITEM(1);
	PUSH(tmp);
	tmp = GETITEM(1);
	PUSH(tmp);
}


/*
 *  ?dup        ( x -- 0 | x x )
 */

static void isdup(void)
{
	const cell tmp = GETTOS();
	if (tmp)
		PUSH(tmp);
}


/*
 *  over        ( x y -- x y x )
 */

static void over(void)
{
	const cell tmp = GETITEM(1);
	PUSH(tmp);
}


/*
 *  2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
 */

static void twoover(void)
{
	const cell tmp = GETITEM(3);
	const cell tmp2 = GETITEM(2);
	PUSH(tmp);
	PUSH(tmp2);
}

/*
 *  pick        ( xu ... x1 x0 u -- xu ... x1 x0 xu )
 */

static void pick(void)
{
	const cell u = POP();
	if (dstackcnt >= u) {
		ucell tmp = dstack[dstackcnt - u];
		PUSH(tmp);
	} else {
		/* underrun */
	}
}


/*
 *  drop        ( x --  )
 */

static void drop(void)
{
	POP();
}

/*
 *  2drop       ( x1 x2 --  )
 */

static void twodrop(void)
{
	POP();
	POP();
}


/*
 *  nip         ( x1 x2 -- x2 )
 */

static void nip(void)
{
	const cell tmp = POP();
	POP();
	PUSH(tmp);
}


/*
 *  roll        ( xu ... x1 x0 u -- xu-1... x1 x0 xu )
 */

static void roll(void)
{
	const cell u = POP();
	if (dstackcnt >= u) {
		int i;
		const cell xu = dstack[dstackcnt - u];
		for (i = dstackcnt - u; i < dstackcnt; i++) {
			dstack[i] = dstack[i + 1];
		}
		dstack[dstackcnt] = xu;
	} else {
		/* Stack underrun */
	}
}


/*
 *  rot         ( x1 x2 x3 -- x2 x3 x1 )
 */

static void rot(void)
{
	const cell tmp = POP();
	const cell tmp2 = POP();
	const cell tmp3 = POP();
	PUSH(tmp2);
	PUSH(tmp);
	PUSH(tmp3);
}


/*
 *  -rot        ( x1 x2 x3 -- x3 x1 x2 )
 */

static void minusrot(void)
{
	const cell tmp = POP();
	const cell tmp2 = POP();
	const cell tmp3 = POP();
	PUSH(tmp);
	PUSH(tmp3);
	PUSH(tmp2);
}


/*
 *  swap        ( x1 x2 -- x2 x1 )
 */

static void swap(void)
{
	const cell tmp = POP();
	const cell tmp2 = POP();
	PUSH(tmp);
	PUSH(tmp2);
}


/*
 *  2swap       ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
 */

static void twoswap(void)
{
	const cell tmp = POP();
	const cell tmp2 = POP();
	const cell tmp3 = POP();
	const cell tmp4 = POP();
	PUSH(tmp2);
	PUSH(tmp);
	PUSH(tmp4);
	PUSH(tmp3);
}


/*
 *  >r          ( x -- ) (R: -- x )
 */

static void tor(void)
{
	ucell tmp = POP();
#ifdef CONFIG_DEBUG_RSTACK
	printk("  >R: %x\n", tmp);
#endif
	PUSHR(tmp);
}


/*
 *  r>          ( -- x ) (R: x -- )
 */

static void rto(void)
{
	ucell tmp = POPR();
#ifdef CONFIG_DEBUG_RSTACK
	printk("  R>: %x\n", tmp);
#endif
	PUSH(tmp);
}


/*
 *  r@          ( -- x ) (R: x -- x )
 */

static void rfetch(void)
{
	PUSH(GETTORS());
}


/*
 *  depth       (  -- u )
 */

static void depth(void)
{
	const cell tmp = dstackcnt;
	PUSH(tmp);
}


/*
 *  depth!      ( ... u --  x1 x2 .. xu )
 */

static void depthwrite(void)
{
	ucell tmp = POP();
	dstackcnt = tmp;
}


/*
 *  rdepth      (  -- u )
 */

static void rdepth(void)
{
	const cell tmp = rstackcnt;
	PUSH(tmp);
}


/*
 *  rdepth!     ( u --  ) ( R: ... -- x1 x2 .. xu )
 */

static void rdepthwrite(void)
{
	ucell tmp = POP();
	rstackcnt = tmp;
}


/*
 *  +           ( nu1 nu2 -- sum )
 */

static void plus(void)
{
	cell tmp = POP() + POP();
	PUSH(tmp);
}


/*
 *  -           ( nu1 nu2 -- diff )
 */

static void minus(void)
{
	const cell nu2 = POP();
	const cell nu1 = POP();
	PUSH(nu1 - nu2);
}


/*
 *  *           ( nu1 nu2 -- prod )
 */

static void mult(void)
{
	const cell nu2 = POP();
	const cell nu1 = POP();
	PUSH(nu1 * nu2);
}


/*
 *  u*          ( u1 u2 -- prod )
 */

static void umult(void)
{
	const ucell tmp = (ucell) POP() * (ucell) POP();
	PUSH(tmp);
}


/*
 *  mu/mod      ( n1 n2 -- rem quot.l quot.h )
 */

static void mudivmod(void)
{
	const ucell b = POP();
	const ducell a = DPOP();
#ifdef NEED_FAKE_INT128_T
        if (a.hi != 0) {
            fprintf(stderr, "mudivmod called (0x%016llx %016llx / 0x%016llx)\n",
                    a.hi, a.lo, b);
            exit(-1);
        } else {
            ducell c;

            PUSH(a.lo % b);
            c.hi = 0;
            c.lo = a.lo / b;
            DPUSH(c);
        }
#else
	PUSH(a % b);
	DPUSH(a / b);
#endif
}


/*
 *  abs         ( n -- u )
 */

static void forthabs(void)
{
	const cell tmp = GETTOS();
	if (tmp < 0) {
		POP();
		PUSH(-tmp);
	}
}


/*
 *  negate      ( n1 -- n2 )
 */

static void negate(void)
{
	const cell tmp = POP();
	PUSH(-tmp);
}


/*
 *  max         ( n1 n2 -- n1|n2 )
 */

static void max(void)
{
	const cell tmp = POP();
	const cell tmp2 = POP();
	PUSH((tmp > tmp2) ? tmp : tmp2);
}


/*
 *  min         ( n1 n2 -- n1|n2 )
 */

static void min(void)
{
	const cell tmp = POP();
	const cell tmp2 = POP();
	PUSH((tmp < tmp2) ? tmp : tmp2);
}


/*
 *  lshift      ( x1 u -- x2 )
 */

static void lshift(void)
{
	const ucell u = POP();
	const ucell x1 = POP();
	PUSH(x1 << u);
}


/*
 *  rshift      ( x1 u -- x2 )
 */

static void rshift(void)
{
	const ucell u = POP();
	const ucell x1 = POP();
	PUSH(x1 >> u);
}


/*
 *  >>a         ( x1 u -- x2 ) ??
 */

static void rshifta(void)
{
	const cell u = POP();
	const cell x1 = POP();
	PUSH(x1 >> u);
}


/*
 *  and         ( x1 x2 -- x3 )
 */

static void and(void)
{
	const cell x1 = POP();
	const cell x2 = POP();
	PUSH(x1 & x2);
}


/*
 *  or          ( x1 x2 -- x3 )
 */

static void or(void)
{
	const cell x1 = POP();
	const cell x2 = POP();
	PUSH(x1 | x2);
}


/*
 *  xor         ( x1 x2 -- x3 )
 */

static void xor(void)
{
	const cell x1 = POP();
	const cell x2 = POP();
	PUSH(x1 ^ x2);
}


/*
 *  invert      ( x1 -- x2 )
 */

static void invert(void)
{
	const cell x1 = POP();
	PUSH(x1 ^ -1);
}


/*
 *  d+          ( d1 d2 -- d.sum )
 */

static void dplus(void)
{
	const dcell d2 = DPOP();
	const dcell d1 = DPOP();
#ifdef NEED_FAKE_INT128_T
        ducell c;

        if (d1.hi != 0 || d2.hi != 0) {
            fprintf(stderr, "dplus called (0x%016llx %016llx + 0x%016llx %016llx)\n",
                    d1.hi, d1.lo, d2.hi, d2.lo);
            exit(-1);
        }
        c.hi = 0;
        c.lo = d1.lo + d2.lo;
        DPUSH(c);
#else
	DPUSH(d1 + d2);
#endif
}


/*
 *  d-          ( d1 d2 -- d.diff )
 */

static void dminus(void)
{
	const dcell d2 = DPOP();
	const dcell d1 = DPOP();
#ifdef NEED_FAKE_INT128_T
        ducell c;

        if (d1.hi != 0 || d2.hi != 0) {
            fprintf(stderr, "dminus called (0x%016llx %016llx + 0x%016llx %016llx)\n",
                    d1.hi, d1.lo, d2.hi, d2.lo);
            exit(-1);
        }
        c.hi = 0;
        c.lo = d1.lo - d2.lo;
        DPUSH(c);
#else
	DPUSH(d1 - d2);
#endif
}


/*
 *  m*          ( ?? --  )
 */

static void mmult(void)
{
	const cell u2 = POP();
	const cell u1 = POP();
#ifdef NEED_FAKE_INT128_T
        ducell c;

        if (0) { // XXX How to detect overflow?
            fprintf(stderr, "mmult called (%016llx * 0x%016llx)\n", u1, u2);
            exit(-1);
        }
        c.hi = 0;
        c.lo = u1 * u2;
        DPUSH(c);
#else
	DPUSH((dcell) u1 * u2);
#endif
}


/*
 *  um*         ( u1 u2 -- d.prod )
 */

static void ummult(void)
{
	const ucell u2 = POP();
	const ucell u1 = POP();
#ifdef NEED_FAKE_INT128_T
        ducell c;

        if (0) { // XXX How to detect overflow?
            fprintf(stderr, "ummult called (%016llx * 0x%016llx)\n", u1, u2);
            exit(-1);
        }
        c.hi = 0;
        c.lo = u1 * u2;
        DPUSH(c);
#else
	DPUSH((ducell) u1 * u2);
#endif
}


/*
 *  @           ( a-addr -- x )
 */

static void fetch(void)
{
	const ucell *aaddr = (ucell *)cell2pointer(POP());
	PUSH(read_ucell(aaddr));
}


/*
 *  c@          ( addr -- byte )
 */

static void cfetch(void)
{
	const u8 *aaddr = (u8 *)cell2pointer(POP());
	PUSH(read_byte(aaddr));
}


/*
 *  w@          ( waddr -- w )
 */

static void wfetch(void)
{
	const u16 *aaddr = (u16 *)cell2pointer(POP());
	PUSH(read_word(aaddr));
}


/*
 *  l@          ( qaddr -- quad )
 */

static void lfetch(void)
{
	const u32 *aaddr = (u32 *)cell2pointer(POP());
	PUSH(read_long(aaddr));
}


/*
 *  !           ( x a-addr -- )
 */

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


/*
 *  +!          ( nu a-addr -- )
 */

static void plusstore(void)
{
	const ucell *aaddr = (ucell *)cell2pointer(POP());
	const cell nu = POP();
	write_cell(aaddr,read_cell(aaddr)+nu);
}


/*
 *  c!          ( byte addr -- )
 */

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


/*
 *  w!          ( w waddr -- )
 */

static void wstore(void)
{
	const u16 *aaddr = (u16 *)cell2pointer(POP());
	const u16 word = POP();
	write_word(aaddr, word);
}


/*
 *  l!          ( quad qaddr -- )
 */

static void lstore(void)
{
	const u32 *aaddr = (u32 *)cell2pointer(POP());
	const u32 longval = POP();
	write_long(aaddr, longval);
}


/*
 *  =           ( x1 x2 -- equal? )
 */

static void equals(void)
{
	cell tmp = (POP() == POP());
	PUSH(-tmp);
}


/*
 *  >           ( n1 n2 -- greater? )
 */

static void greater(void)
{
	cell tmp = ((cell) POP() < (cell) POP());
	PUSH(-tmp);
}


/*
 *  <           ( n1 n2 -- less? )
 */

static void less(void)
{
	cell tmp = ((cell) POP() > (cell) POP());
	PUSH(-tmp);
}


/*
 *  u>          ( u1 u2 -- unsigned-greater? )
 */

static void ugreater(void)
{
	cell tmp = ((ucell) POP() < (ucell) POP());
	PUSH(-tmp);
}


/*
 *  u<          ( u1 u2 -- unsigned-less? )
 */

static void uless(void)
{
	cell tmp = ((ucell) POP() > (ucell) POP());
	PUSH(-tmp);
}


/*
 *  sp@         (  -- stack-pointer )
 */

static void spfetch(void)
{
	// FIXME this can only work if the stack pointer
	// is within range.
	ucell tmp = pointer2cell(&(dstack[dstackcnt]));
	PUSH(tmp);
}


/*
 *  move        ( src-addr dest-addr len -- )
 */

static void fmove(void)
{
	ucell count = POP();
	void *dest = (void *)cell2pointer(POP());
	const void *src = (const void *)cell2pointer(POP());
	memmove(dest, src, count);
}


/*
 *  fill        ( addr len byte -- )
 */

static void ffill(void)
{
	ucell value = POP();
	ucell count = POP();
	void *src = (void *)cell2pointer(POP());
	memset(src, value, count);
}


/*
 *  unaligned-w@  ( addr -- w )
 */

static void unalignedwordread(void)
{
	const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
	PUSH(unaligned_read_word(addr));
}


/*
 *  unaligned-w!  ( w addr -- )
 */

static void unalignedwordwrite(void)
{
	const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
	u16 w = POP();
	unaligned_write_word(addr, w);
}


/*
 *  unaligned-l@  ( addr -- quad )
 */

static void unalignedlongread(void)
{
	const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
	PUSH(unaligned_read_long(addr));
}


/*
 *  unaligned-l!  ( quad addr -- )
 */

static void unalignedlongwrite(void)
{
	unsigned char *addr = (unsigned char *) cell2pointer(POP());
	u32 l = POP();
	unaligned_write_long(addr, l);
}

/*
 *  here        (  -- dictionary-pointer )
 */

static void here(void)
{
	PUSH(pointer2cell(dict) + dicthead);
#ifdef CONFIG_DEBUG_INTERNAL
	printk("here: %x\n", pointer2cell(dict) + dicthead);
#endif
}

/*
 *  here!       ( new-dict-pointer -- )
 */

static void herewrite(void)
{
	ucell tmp = POP(); /* converted pointer */
	dicthead = tmp - pointer2cell(dict);
#ifdef CONFIG_DEBUG_INTERNAL
	printk("here!: new value: %x\n", tmp);
#endif

	if (dictlimit && dicthead >= dictlimit) {
	    printk("Dictionary space overflow:"
	            " dicthead=" FMT_ucellx
	            " dictlimit=" FMT_ucellx
	            "\n",
	            dicthead, dictlimit);
	}
}


/*
 *   emit       ( char --  )
 */

static void emit(void)
{
	cell tmp = POP();
#ifndef FCOMPILER
	putchar(tmp);
#else
       	put_outputbyte(tmp);
#endif
}


/*
 *   key?       (  -- pressed? )
 */

static void iskey(void)
{
	PUSH((cell) availchar());
}


/*
 *   key        (  -- char )
 */

static void key(void)
{
	while (!availchar());
#ifdef FCOMPILER
	PUSH(get_inputbyte());
#else
	PUSH(getchar());
#endif
}


/*
 *   ioc@       ( reg -- val )
 */

static void iocfetch(void)
{
#ifndef FCOMPILER
	cell reg = POP();
	PUSH(inb(reg));
#else
        (void)POP();
        PUSH(0);
#endif
}


/*
 *   iow@       ( reg -- val )
 */

static void iowfetch(void)
{
#ifndef FCOMPILER
	cell reg = POP();
	PUSH(inw(reg));
#else
        (void)POP();
        PUSH(0);
#endif
}

/*
 *   iol@       ( reg -- val )
 */

static void iolfetch(void)
{
#ifndef FCOMPILER
	cell reg = POP();
	PUSH(inl(reg));
#else
        (void)POP();
        PUSH(0);
#endif
}


/*
 *   ioc!       ( val reg --  )
 */

static void iocstore(void)
{
#ifndef FCOMPILER
	cell reg = POP();
	cell val = POP();

	outb(val, reg);
#else
        (void)POP();
        (void)POP();
#endif
}


/*
 *   iow!       ( val reg --  )
 */

static void iowstore(void)
{
#ifndef FCOMPILER
	cell reg = POP();
	cell val = POP();

	outw(val, reg);
#else
        (void)POP();
        (void)POP();
#endif
}


/*
 *   iol!       ( val reg --  )
 */

static void iolstore(void)
{
#ifndef FCOMPILER
	ucell reg = POP();
	ucell val = POP();

	outl(val, reg);
#else
        (void)POP();
        (void)POP();
#endif
}

/*
 *   i         ( -- i )
 */

static void loop_i(void)
{
	PUSH(rstack[rstackcnt]);
}

/*
 *   j         ( -- i )
 */

static void loop_j(void)
{
	PUSH(rstack[rstackcnt - 2]);
}

/* words[] is a function array of all native code functions used by
 * the dictionary, i.e. CFAs and primitives.
 * Any change here needs a matching change in the primitive word's
 * name list that is kept for bootstrapping in kernel/bootstrap.c
 *
 * NOTE: THIS LIST SHALL NOT CHANGE (EXCEPT MANDATORY ADDITIONS AT
 * THE END). ANY OTHER CHANGE WILL BREAK COMPATIBILITY TO OLDER
 * BINARY DICTIONARIES.
 */
static forth_word * const words[] = {
    /*
     * CFAs and special words
     */
    semis,
    docol,
    lit,
    docon,
    dovar,
    dodefer,
    dodoes,
    dodo,
    doisdo,
    doloop,
    doplusloop,
    doival,
    doivar,
    doidefer,

    /*
     * primitives
     */
    fdup,                   /* dup     */
    twodup,                 /* 2dup    */
    isdup,                  /* ?dup    */
    over,                   /* over    */
    twoover,                /* 2over   */
    pick,                   /* pick    */
    drop,                   /* drop    */
    twodrop,                /* 2drop   */
    nip,                    /* nip     */
    roll,                   /* roll    */
    rot,                    /* rot     */
    minusrot,               /* -rot    */
    swap,                   /* swap    */
    twoswap,                /* 2swap   */
    tor,                    /* >r      */
    rto,                    /* r>      */
    rfetch,                 /* r@      */
    depth,                  /* depth   */
    depthwrite,             /* depth!  */
    rdepth,                 /* rdepth  */
    rdepthwrite,            /* rdepth! */
    plus,                   /* +       */
    minus,                  /* -       */
    mult,                   /* *       */
    umult,                  /* u*      */
    mudivmod,               /* mu/mod  */
    forthabs,               /* abs     */
    negate,                 /* negate  */
    max,                    /* max     */
    min,                    /* min     */
    lshift,                 /* lshift  */
    rshift,                 /* rshift  */
    rshifta,                /* >>a     */
    and,                    /* and     */
    or,                     /* or      */
    xor,                    /* xor     */
    invert,                 /* invert  */
    dplus,                  /* d+      */
    dminus,                 /* d-      */
    mmult,                  /* m*      */
    ummult,                 /* um*     */
    fetch,                  /* @       */
    cfetch,                 /* c@      */
    wfetch,                 /* w@      */
    lfetch,                 /* l@      */
    store,                  /* !       */
    plusstore,              /* +!      */
    cstore,                 /* c!      */
    wstore,                 /* w!      */
    lstore,                 /* l!      */
    equals,                 /* =       */
    greater,                /* >       */
    less,                   /* <       */
    ugreater,               /* u>      */
    uless,                  /* u<      */
    spfetch,                /* sp@     */
    fmove,                  /* move    */
    ffill,                  /* fill    */
    emit,                   /* emit    */
    iskey,                  /* key?    */
    key,                    /* key     */
    execute,                /* execute */
    here,                   /* here    */
    herewrite,              /* here!   */
    dobranch,               /* dobranch     */
    docbranch,              /* do?branch    */
    unalignedwordread,      /* unaligned-w@ */
    unalignedwordwrite,     /* unaligned-w! */
    unalignedlongread,      /* unaligned-l@ */
    unalignedlongwrite,     /* unaligned-l! */
    iocfetch,               /* ioc@    */
    iowfetch,               /* iow@    */
    iolfetch,               /* iol@    */
    iocstore,               /* ioc!    */
    iowstore,               /* iow!    */
    iolstore,               /* iol!    */
    loop_i,                 /* i       */
    loop_j,                 /* j       */
    call,                   /* call    */
    sysdebug,               /* sys-debug */
    do_include,             /* $include */
    do_encode_file,         /* $encode-file */
    do_debug_xt,            /* (debug  */
    do_debug_off,           /* (debug-off) */
};