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