--- /dev/null
+/* 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) */
+};
Code Review / kvmfornfv.git / blobdiff