summaryrefslogtreecommitdiffstats
path: root/qemu/roms/openbios/kernel/forth.c
diff options
context:
space:
mode:
Diffstat (limited to 'qemu/roms/openbios/kernel/forth.c')
-rw-r--r--qemu/roms/openbios/kernel/forth.c1966
1 files changed, 0 insertions, 1966 deletions
diff --git a/qemu/roms/openbios/kernel/forth.c b/qemu/roms/openbios/kernel/forth.c
deleted file mode 100644
index 61dd70d31..000000000
--- a/qemu/roms/openbios/kernel/forth.c
+++ /dev/null
@@ -1,1966 +0,0 @@
-/* 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) */
-};