Return to forth.c CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / kernel

Annotation of qemu/roms/openbios/kernel/forth.c, revision 1.1

1.1     ! root        1: /* tag: C implementation of all forth primitives,
        !             2:  * internal words, inner interpreter and such
        !             3:  *
        !             4:  * Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer
        !             5:  *
        !             6:  * See the file "COPYING" for further information about
        !             7:  * the copyright and warranty status of this work.
        !             8:  */
        !             9: 
        !            10: #include "config.h"
        !            11: #include "sysinclude.h"
        !            12: #include "kernel/stack.h"
        !            13: #include "kernel/kernel.h"
        !            14: #include "dict.h"
        !            15: 
        !            16: /*
        !            17:  * cross platform abstraction
        !            18:  */
        !            19: 
        !            20: #include "cross.h"
        !            21: 
        !            22: #ifndef FCOMPILER
        !            23: #include "libc/vsprintf.h"
        !            24: #else
        !            25: #include <stdarg.h>
        !            26: #endif
        !            27: 
        !            28: /*
        !            29:  * execution works as follows:
        !            30:  *  - PC is pushed on return stack
        !            31:  *  - PC is set to new CFA
        !            32:  *  - address pointed by CFA is executed by CPU
        !            33:  */
        !            34: 
        !            35: typedef void forth_word(void);
        !            36: 
        !            37: static forth_word * const words[];
        !            38: ucell PC;
        !            39: volatile int interruptforth = 0;
        !            40: 
        !            41: #define DEBUG_MODE_NONE 0
        !            42: #define DEBUG_MODE_STEP 1
        !            43: #define DEBUG_MODE_TRACE 2
        !            44: #define DEBUG_MODE_STEPUP 3
        !            45: 
        !            46: #define DEBUG_BANNER "\nStepper keys: <space>/<enter> Up Down Trace Rstack Forth\n"
        !            47: 
        !            48: /* Empty linked list of debug xts */
        !            49: struct debug_xt {
        !            50:     ucell xt_docol;
        !            51:     ucell xt_semis;
        !            52:     int mode;
        !            53:     struct debug_xt *next;
        !            54: };
        !            55: 
        !            56: static struct debug_xt debug_xt_eol = { (ucell)0, (ucell)0, 0, NULL};
        !            57: static struct debug_xt *debug_xt_list = &debug_xt_eol;
        !            58: 
        !            59: /* Static buffer for xt name */
        !            60: char xtname[MAXNFALEN];
        !            61: 
        !            62: #ifndef FCOMPILER
        !            63: /* instead of pointing to an explicit 0 variable we
        !            64:  * point behind the pointer.
        !            65:  */
        !            66: static ucell t[] = { 0, 0, 0, 0 };
        !            67: static ucell *trampoline = t;
        !            68: 
        !            69: /*
        !            70:  * Code Field Address (CFA) definitions (DOCOL and the like)
        !            71:  */
        !            72: 
        !            73: void forth_init(void)
        !            74: {
        !            75:     init_trampoline(trampoline);
        !            76: }
        !            77: #endif
        !            78: 
        !            79: #ifndef CONFIG_DEBUG_INTERPRETER
        !            80: #define dbg_interp_printk( a... )       do { } while(0)
        !            81: #else
        !            82: #define dbg_interp_printk( a... )       printk( a )
        !            83: #endif
        !            84: 
        !            85: #ifndef CONFIG_DEBUG_INTERNAL
        !            86: #define dbg_internal_printk( a... )     do { } while(0)
        !            87: #else
        !            88: #define dbg_internal_printk( a... )     printk( a )
        !            89: #endif
        !            90: 
        !            91: 
        !            92: void init_trampoline(ucell *tramp)
        !            93: {
        !            94:     tramp[0] = DOCOL;
        !            95:     tramp[1] = 0;
        !            96:     tramp[2] = target_ucell(pointer2cell(tramp) + 3 * sizeof(ucell));
        !            97:     tramp[3] = 0;
        !            98: }
        !            99: 
        !           100: static inline void processxt(ucell xt)
        !           101: {
        !           102:     void (*tokenp) (void);
        !           103: 
        !           104:     dbg_interp_printk("processxt: pc=%x, xt=%x\n", PC, xt);
        !           105:     tokenp = words[xt];
        !           106:     tokenp();
        !           107: }
        !           108: 
        !           109: static void docol(void)
        !           110: {                               /* DOCOL */
        !           111:     PUSHR(PC);
        !           112:     PC = read_ucell(cell2pointer(PC));
        !           113: 
        !           114:     dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
        !           115: }
        !           116: 
        !           117: static void semis(void)
        !           118: {
        !           119:     PC = POPR();
        !           120: }
        !           121: 
        !           122: static inline void next(void)
        !           123: {
        !           124:     PC += sizeof(ucell);
        !           125: 
        !           126:     dbg_interp_printk("next: PC is now %x\n", PC);
        !           127:     processxt(read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))));
        !           128: }
        !           129: 
        !           130: static inline void next_dbg(void);
        !           131: 
        !           132: int enterforth(xt_t xt)
        !           133: {
        !           134:     ucell *_cfa = (ucell*)cell2pointer(xt);
        !           135:     cell tmp;
        !           136: 
        !           137:     if (read_ucell(_cfa) != DOCOL) {
        !           138:         trampoline[1] = target_ucell(xt);
        !           139:         _cfa = trampoline;
        !           140:     }
        !           141: 
        !           142:     if (rstackcnt < 0) {
        !           143:         rstackcnt = 0;
        !           144:     }
        !           145: 
        !           146:     tmp = rstackcnt;
        !           147:     interruptforth = FORTH_INTSTAT_CLR;
        !           148: 
        !           149:     PUSHR(PC);
        !           150:     PC = pointer2cell(_cfa);
        !           151: 
        !           152:     while (rstackcnt > tmp && !(interruptforth & FORTH_INTSTAT_STOP)) {
        !           153:         if (debug_xt_list->next == NULL) {
        !           154:             while (rstackcnt > tmp && !interruptforth) {
        !           155:                 dbg_interp_printk("enterforth: NEXT\n");
        !           156:                 next();
        !           157:             }
        !           158:         } else {
        !           159:             while (rstackcnt > tmp && !interruptforth) {
        !           160:                 dbg_interp_printk("enterforth: NEXT_DBG\n");
        !           161:                 next_dbg();
        !           162:             }
        !           163:         }
        !           164: 
        !           165:         /* Always clear the debug mode change flag */
        !           166:         interruptforth = interruptforth & (~FORTH_INTSTAT_DBG);
        !           167:     }
        !           168: 
        !           169: #if 0
        !           170:     /* return true if we took an exception. The caller should normally
        !           171:      * handle exceptions by returning immediately since the throw
        !           172:      * is supposed to abort the execution of this C-code too.
        !           173:      */
        !           174: 
        !           175:     if (rstackcnt != tmp) {
        !           176:         printk("EXCEPTION DETECTED!\n");
        !           177:     }
        !           178: #endif
        !           179:     return rstackcnt != tmp;
        !           180: }
        !           181: 
        !           182: /* called inline thus a slightly different behaviour */
        !           183: static void lit(void)
        !           184: {                               /* LIT */
        !           185:     PC += sizeof(cell);
        !           186:     PUSH(read_ucell(cell2pointer(PC)));
        !           187:     dbg_interp_printk("lit: %x\n", read_ucell(cell2pointer(PC)));
        !           188: }
        !           189: 
        !           190: static void docon(void)
        !           191: {                               /* DOCON */
        !           192:     ucell tmp = read_ucell(cell2pointer(read_ucell(cell2pointer(PC)) + sizeof(ucell)));
        !           193:     PUSH(tmp);
        !           194:     dbg_interp_printk("docon: PC=%x, value=%x\n", PC, tmp);
        !           195: }
        !           196: 
        !           197: static void dovar(void)
        !           198: {                               /* DOVAR */
        !           199:     ucell tmp = read_ucell(cell2pointer(PC)) + sizeof(ucell);
        !           200:     PUSH(tmp);              /* returns address to variable */
        !           201:     dbg_interp_printk("dovar: PC: %x, %x\n", PC, tmp);
        !           202: }
        !           203: 
        !           204: static void dobranch(void)
        !           205: {                               /* unconditional branch */
        !           206:     PC += sizeof(cell);
        !           207:     PC += read_cell(cell2pointer(PC));
        !           208: }
        !           209: 
        !           210: static void docbranch(void)
        !           211: {                               /* conditional branch */
        !           212:     PC += sizeof(cell);
        !           213:     if (POP()) {
        !           214:         dbg_internal_printk("  ?branch: end loop\n");
        !           215:     } else {
        !           216:         dbg_internal_printk("  ?branch: follow branch\n");
        !           217:         PC += read_cell(cell2pointer(PC));
        !           218:     }
        !           219: }
        !           220: 
        !           221: 
        !           222: static void execute(void)
        !           223: {                               /* EXECUTE */
        !           224:     ucell address = POP();
        !           225:     dbg_interp_printk("execute: %x\n", address);
        !           226: 
        !           227:     PUSHR(PC);
        !           228:     trampoline[1] = target_ucell(address);
        !           229:     PC = pointer2cell(trampoline);
        !           230: }
        !           231: 
        !           232: /*
        !           233:  * call ( ... function-ptr -- ??? )
        !           234:  */
        !           235: static void call(void)
        !           236: {
        !           237: #ifdef FCOMPILER
        !           238:     printk("Sorry. Usage of Forth2C binding is forbidden during bootstrap.\n");
        !           239:     exit(1);
        !           240: #else
        !           241:     void (*funcptr) (void);
        !           242:     funcptr=(void *)cell2pointer(POP());
        !           243:     dbg_interp_printk("call: %x", funcptr);
        !           244:     funcptr();
        !           245: #endif
        !           246: }
        !           247: 
        !           248: /*
        !           249:  * sys-debug ( errno -- )
        !           250:  */
        !           251: 
        !           252: static void sysdebug(void)
        !           253: {
        !           254: #ifdef FCOMPILER
        !           255:     cell errorno=POP();
        !           256:     exception(errorno);
        !           257: #else
        !           258:     (void) POP();
        !           259: #endif
        !           260: }
        !           261: 
        !           262: static void dodoes(void)
        !           263: {                               /* DODOES */
        !           264:     ucell data = read_ucell(cell2pointer(PC)) + (2 * sizeof(ucell));
        !           265:     ucell word = read_ucell(cell2pointer(read_ucell(cell2pointer(PC)) + sizeof(ucell)));
        !           266: 
        !           267:     dbg_interp_printk("DODOES data=%x word=%x\n", data, word);
        !           268: 
        !           269:     PUSH(data);
        !           270:     PUSH(word);
        !           271: 
        !           272:     execute();
        !           273: }
        !           274: 
        !           275: static void dodefer(void)
        !           276: {
        !           277:     docol();
        !           278: }
        !           279: 
        !           280: static void dodo(void)
        !           281: {
        !           282:     cell startval, endval;
        !           283:     startval = POP();
        !           284:     endval = POP();
        !           285: 
        !           286:     PUSHR(endval);
        !           287:     PUSHR(startval);
        !           288: }
        !           289: 
        !           290: static void doisdo(void)
        !           291: {
        !           292:     cell startval, endval, offset;
        !           293: 
        !           294:     startval = POP();
        !           295:     endval = POP();
        !           296: 
        !           297:     PC += sizeof(cell);
        !           298: 
        !           299:     if (startval == endval) {
        !           300:         offset = read_cell(cell2pointer(PC));
        !           301:         PC += offset;
        !           302:     } else {
        !           303:         PUSHR(endval);
        !           304:         PUSHR(startval);
        !           305:     }
        !           306: }
        !           307: 
        !           308: static void doloop(void)
        !           309: {
        !           310:     cell offset, startval, endval;
        !           311: 
        !           312:     startval = POPR() + 1;
        !           313:     endval = POPR();
        !           314: 
        !           315:     PC += sizeof(cell);
        !           316: 
        !           317:     if (startval < endval) {
        !           318:         offset = read_cell(cell2pointer(PC));
        !           319:         PC += offset;
        !           320:         PUSHR(endval);
        !           321:         PUSHR(startval);
        !           322:     }
        !           323: 
        !           324: }
        !           325: 
        !           326: static void doplusloop(void)
        !           327: {
        !           328:     ucell high, low;
        !           329:     cell increment, startval, endval, offset;
        !           330: 
        !           331:     increment = POP();
        !           332: 
        !           333:     startval = POPR();
        !           334:     endval = POPR();
        !           335: 
        !           336:     low = (ucell) startval;
        !           337:     startval += increment;
        !           338: 
        !           339:     PC += sizeof(cell);
        !           340: 
        !           341:     if (increment >= 0) {
        !           342:         high = (ucell) startval;
        !           343:     } else {
        !           344:         high = low;
        !           345:         low = (ucell) startval;
        !           346:     }
        !           347: 
        !           348:     if (endval - (low + 1) >= high - low) {
        !           349:         offset = read_cell(cell2pointer(PC));
        !           350:         PC += offset;
        !           351: 
        !           352:         PUSHR(endval);
        !           353:         PUSHR(startval);
        !           354:     }
        !           355: }
        !           356: 
        !           357: /*
        !           358:  *  instance handling CFAs
        !           359:  */
        !           360: #ifndef FCOMPILER
        !           361: static ucell get_myself(void)
        !           362: {
        !           363:     static ucell *myselfptr = NULL;
        !           364:     if (myselfptr == NULL) {
        !           365:         myselfptr = (ucell*)cell2pointer(findword("my-self")) + 1;
        !           366:     }
        !           367:     ucell *myself = (ucell*)cell2pointer(*myselfptr);
        !           368:     return (myself != NULL) ? *myself : 0;
        !           369: }
        !           370: 
        !           371: static void doivar(void)
        !           372: {
        !           373:     ucell r, *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
        !           374:     ucell ibase = get_myself();
        !           375: 
        !           376:     dbg_interp_printk("ivar, offset: %d size: %d (ibase %d)\n", p[0], p[1], ibase );
        !           377: 
        !           378:     r = ibase ? ibase + p[0] : pointer2cell(&p[2]);
        !           379:     PUSH( r );
        !           380: }
        !           381: 
        !           382: static void doival(void)
        !           383: {
        !           384:     ucell r, *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
        !           385:     ucell ibase = get_myself();
        !           386: 
        !           387:     dbg_interp_printk("ivar, offset: %d size: %d\n", p[0], p[1] );
        !           388: 
        !           389:     r = ibase ? ibase + p[0] : pointer2cell(&p[2]);
        !           390:     PUSH( *(ucell *)cell2pointer(r) );
        !           391: }
        !           392: 
        !           393: static void doidefer(void)
        !           394: {
        !           395:     ucell *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
        !           396:     ucell ibase = get_myself();
        !           397: 
        !           398:     dbg_interp_printk("doidefer, offset: %d size: %d\n", p[0], p[1] );
        !           399: 
        !           400:     PUSHR(PC);
        !           401:     PC = ibase ? ibase + p[0] : pointer2cell(&p[2]);
        !           402:     PC -= sizeof(ucell);
        !           403: }
        !           404: #else
        !           405: static void noinstances(void)
        !           406: {
        !           407:     printk("Opening devices is not supported during bootstrap. Sorry.\n");
        !           408:     exit(1);
        !           409: }
        !           410: #define doivar   noinstances
        !           411: #define doival   noinstances
        !           412: #define doidefer noinstances
        !           413: #endif
        !           414: 
        !           415: /*
        !           416:  * $include / $encode-file
        !           417:  */
        !           418: #ifdef FCOMPILER
        !           419: static void
        !           420: string_relay(void (*func)(const char *))
        !           421: {
        !           422:     int len = POP();
        !           423:     char *name, *p = (char*)cell2pointer(POP());
        !           424:     name = malloc(len + 1);
        !           425:     memcpy(name, p, len);
        !           426:     name[len] = 0;
        !           427:     (*func)(name);
        !           428:     free(name);
        !           429: }
        !           430: #else
        !           431: #define string_relay(dummy) do { DROP(); DROP(); } while(0)
        !           432: #endif
        !           433: 
        !           434: static void
        !           435: do_include(void)
        !           436: {
        !           437:     string_relay(&include_file);
        !           438: }
        !           439: 
        !           440: static void
        !           441: do_encode_file( void )
        !           442: {
        !           443:     string_relay(&encode_file);
        !           444: }
        !           445: 
        !           446: /*
        !           447:  * Debug support functions
        !           448:  */
        !           449: 
        !           450: static
        !           451: int printf_console(const char *fmt, ...)
        !           452: {
        !           453:     cell tmp;
        !           454: 
        !           455:     char buf[512];
        !           456:     va_list args;
        !           457:     int i;
        !           458: 
        !           459:     va_start(args, fmt);
        !           460:     i = vsnprintf(buf, sizeof(buf), fmt, args);
        !           461:     va_end(args);
        !           462: 
        !           463:     /* Push to the Forth interpreter for console output */
        !           464:     tmp = rstackcnt;
        !           465: 
        !           466:     PUSH(pointer2cell(buf));
        !           467:     PUSH((int)strlen(buf));
        !           468:     trampoline[1] = findword("type");
        !           469: 
        !           470:     PUSHR(PC);
        !           471:     PC = pointer2cell(trampoline);
        !           472: 
        !           473:     while (rstackcnt > tmp) {
        !           474:         dbg_interp_printk("printf_console: NEXT\n");
        !           475:         next();
        !           476:     }
        !           477: 
        !           478:     return i;
        !           479: }
        !           480: 
        !           481: static
        !           482: int getchar_console(void)
        !           483: {
        !           484:     cell tmp;
        !           485: 
        !           486:     /* Push to the Forth interpreter for console output */
        !           487:     tmp = rstackcnt;
        !           488: 
        !           489:     trampoline[1] = findword("key");
        !           490: 
        !           491:     PUSHR(PC);
        !           492:     PC = pointer2cell(trampoline);
        !           493: 
        !           494:     while (rstackcnt > tmp) {
        !           495:         dbg_interp_printk("getchar_console: NEXT\n");
        !           496:         next();
        !           497:     }
        !           498: 
        !           499:     return POP();
        !           500: }
        !           501: 
        !           502: static void
        !           503: display_dbg_dstack(void)
        !           504: {
        !           505:     /* Display dstack contents between parentheses */
        !           506:     int i;
        !           507: 
        !           508:     if (dstackcnt == 0) {
        !           509:         printf_console(" ( Empty ) ");
        !           510:         return;
        !           511:     } else {
        !           512:         printf_console(" ( ");
        !           513:         for (i = 1; i <= dstackcnt; i++) {
        !           514:             if (i != 1) {
        !           515:                 printf_console(" ");
        !           516:             }
        !           517:             printf_console("%" FMT_CELL_x, dstack[i]);
        !           518:         }
        !           519:         printf_console(" ) ");
        !           520:     }
        !           521: }
        !           522: 
        !           523: static void
        !           524: display_dbg_rstack(void)
        !           525: {
        !           526:     /* Display rstack contents between parentheses */
        !           527:     int i;
        !           528: 
        !           529:     if (rstackcnt == 0) {
        !           530:         printf_console(" ( Empty ) ");
        !           531:         return;
        !           532:     } else {
        !           533:         printf_console("\nR: ( ");
        !           534:         for (i = 1; i <= rstackcnt; i++) {
        !           535:             if (i != 1) {
        !           536:                 printf_console(" ");
        !           537:             }
        !           538:             printf_console("%" FMT_CELL_x, rstack[i]);
        !           539:         }
        !           540:         printf_console(" ) \n");
        !           541:     }
        !           542: }
        !           543: 
        !           544: static int
        !           545: add_debug_xt(ucell xt)
        !           546: {
        !           547:     struct debug_xt *debug_xt_item;
        !           548: 
        !           549:     /* If the xt CFA isn't DOCOL then issue a warning and do nothing */
        !           550:     if (read_ucell(cell2pointer(xt)) != DOCOL) {
        !           551:         printf_console("\nprimitive words cannot be debugged\n");
        !           552:         return 0;
        !           553:     }
        !           554: 
        !           555:     /* If this xt is already in the list, do nothing but indicate success */
        !           556:     for (debug_xt_item = debug_xt_list; debug_xt_item->next != NULL;
        !           557:          debug_xt_item = debug_xt_item->next)
        !           558:         if (debug_xt_item->xt_docol == xt) {
        !           559:             return 1;
        !           560:         }
        !           561: 
        !           562:     /* We already have the CFA (PC) indicating the starting cell of
        !           563:        the word, however we also need the ending cell too (we cannot
        !           564:        rely on the rstack as it can be arbitrarily changed by a forth
        !           565:        word). Hence the use of findsemis() */
        !           566: 
        !           567:     /* Otherwise add to the head of the linked list */
        !           568:     debug_xt_item = malloc(sizeof(struct debug_xt));
        !           569:     debug_xt_item->xt_docol = xt;
        !           570:     debug_xt_item->xt_semis = findsemis(xt);
        !           571:     debug_xt_item->mode = DEBUG_MODE_NONE;
        !           572:     debug_xt_item->next = debug_xt_list;
        !           573:     debug_xt_list = debug_xt_item;
        !           574: 
        !           575:     /* Indicate debug mode change */
        !           576:     interruptforth |= FORTH_INTSTAT_DBG;
        !           577: 
        !           578:     /* Success */
        !           579:     return 1;
        !           580: }
        !           581: 
        !           582: static void
        !           583: del_debug_xt(ucell xt)
        !           584: {
        !           585:     struct debug_xt *debug_xt_item, *tmp_xt_item;
        !           586: 
        !           587:     /* Handle the case where the xt is at the head of the list */
        !           588:     if (debug_xt_list->xt_docol == xt) {
        !           589:         tmp_xt_item = debug_xt_list;
        !           590:         debug_xt_list = debug_xt_list->next;
        !           591:         free(tmp_xt_item);
        !           592: 
        !           593:         return;
        !           594:     }
        !           595: 
        !           596:     /* Otherwise find this xt in the linked list and remove it */
        !           597:     for (debug_xt_item = debug_xt_list; debug_xt_item->next != NULL;
        !           598:          debug_xt_item = debug_xt_item->next) {
        !           599:         if (debug_xt_item->next->xt_docol == xt) {
        !           600:             tmp_xt_item = debug_xt_item->next;
        !           601:             debug_xt_item->next = debug_xt_item->next->next;
        !           602:             free(tmp_xt_item);
        !           603:         }
        !           604:     }
        !           605: 
        !           606:     /* If the list is now empty, indicate debug mode change */
        !           607:     if (debug_xt_list->next == NULL) {
        !           608:         interruptforth |= FORTH_INTSTAT_DBG;
        !           609:     }
        !           610: }
        !           611: 
        !           612: static void
        !           613: do_source_dbg(struct debug_xt *debug_xt_item)
        !           614: {
        !           615:     /* Forth source debugger implementation */
        !           616:     char k, done = 0;
        !           617: 
        !           618:     /* Display current dstack */
        !           619:     display_dbg_dstack();
        !           620:     printf_console("\n");
        !           621: 
        !           622:     fstrncpy(xtname, lfa2nfa(read_ucell(cell2pointer(PC)) - sizeof(cell)), MAXNFALEN);
        !           623:     printf_console("%p: %s ", cell2pointer(PC), xtname);
        !           624: 
        !           625:     /* If in trace mode, we just carry on */
        !           626:     if (debug_xt_item->mode == DEBUG_MODE_TRACE) {
        !           627:         return;
        !           628:     }
        !           629: 
        !           630:     /* Otherwise in step mode, prompt for a keypress */
        !           631:     k = getchar_console();
        !           632: 
        !           633:     /* Only proceed if done is true */
        !           634:     while (!done) {
        !           635:         switch (k) {
        !           636: 
        !           637:         case ' ':
        !           638:         case '\n':
        !           639:             /* Perform a single step */
        !           640:             done = 1;
        !           641:             break;
        !           642: 
        !           643:         case 'u':
        !           644:         case 'U':
        !           645:             /* Up - unmark current word for debug, mark its caller for
        !           646:              * debugging and finish executing current word */
        !           647: 
        !           648:             /* Since this word could alter the rstack during its execution,
        !           649:              * we only know the caller when (semis) is called for this xt.
        !           650:              * Hence we mark the xt as a special DEBUG_MODE_STEPUP which
        !           651:              * means we run as normal, but schedule the xt for deletion
        !           652:              * at its corresponding (semis) word when we know the rstack
        !           653:              * will be set to its final parent value */
        !           654:             debug_xt_item->mode = DEBUG_MODE_STEPUP;
        !           655:             done = 1;
        !           656:             break;
        !           657: 
        !           658:         case 'd':
        !           659:         case 'D':
        !           660:             /* Down - mark current word for debug and step into it */
        !           661:             done = add_debug_xt(read_ucell(cell2pointer(PC)));
        !           662:             if (!done) {
        !           663:                 k = getchar_console();
        !           664:             }
        !           665:             break;
        !           666: 
        !           667:         case 't':
        !           668:         case 'T':
        !           669:             /* Trace mode */
        !           670:             debug_xt_item->mode = DEBUG_MODE_TRACE;
        !           671:             done = 1;
        !           672:             break;
        !           673: 
        !           674:         case 'r':
        !           675:         case 'R':
        !           676:             /* Display rstack */
        !           677:             display_dbg_rstack();
        !           678:             done = 0;
        !           679:             k = getchar_console();
        !           680:             break;
        !           681: 
        !           682:         case 'f':
        !           683:         case 'F':
        !           684:             /* Start subordinate Forth interpreter */
        !           685:             PUSHR(PC - sizeof(cell));
        !           686:             PC = findword("outer-interpreter") + sizeof(ucell);
        !           687: 
        !           688:             /* Save rstack position for when we return */
        !           689:             dbgrstackcnt = rstackcnt;
        !           690:             done = 1;
        !           691:             break;
        !           692: 
        !           693:         default:
        !           694:             /* Display debug banner */
        !           695:             printf_console(DEBUG_BANNER);
        !           696:             k = getchar_console();
        !           697:         }
        !           698:     }
        !           699: }
        !           700: 
        !           701: static void docol_dbg(void)
        !           702: {                               /* DOCOL */
        !           703:     struct debug_xt *debug_xt_item;
        !           704: 
        !           705:     PUSHR(PC);
        !           706:     PC = read_ucell(cell2pointer(PC));
        !           707: 
        !           708:     /* If current xt is in our debug xt list, display word name */
        !           709:     debug_xt_item = debug_xt_list;
        !           710:     while (debug_xt_item->next) {
        !           711:         if (debug_xt_item->xt_docol == PC) {
        !           712:             fstrncpy(xtname, lfa2nfa(PC - sizeof(cell)), MAXNFALEN);
        !           713:             printf_console("\n: %s ", xtname);
        !           714: 
        !           715:             /* Step mode is the default */
        !           716:             debug_xt_item->mode = DEBUG_MODE_STEP;
        !           717:         }
        !           718: 
        !           719:         debug_xt_item = debug_xt_item->next;
        !           720:     }
        !           721: 
        !           722:     dbg_interp_printk("docol_dbg: %s\n", cell2pointer(lfa2nfa(PC - sizeof(cell))));
        !           723: }
        !           724: 
        !           725: static void semis_dbg(void)
        !           726: {
        !           727:     struct debug_xt *debug_xt_item, *debug_xt_up = NULL;
        !           728: 
        !           729:     /* If current semis is in our debug xt list, disable debug mode */
        !           730:     debug_xt_item = debug_xt_list;
        !           731:     while (debug_xt_item->next) {
        !           732:         if (debug_xt_item->xt_semis == PC) {
        !           733:             if (debug_xt_item->mode != DEBUG_MODE_STEPUP) {
        !           734:                 /* Handle the normal case */
        !           735:                 fstrncpy(xtname, lfa2nfa(debug_xt_item->xt_docol - sizeof(cell)), MAXNFALEN);
        !           736:                 printf_console("\n[ Finished %s ] ", xtname);
        !           737: 
        !           738:                 /* Reset to step mode in case we were in trace mode */
        !           739:                 debug_xt_item->mode = DEBUG_MODE_STEP;
        !           740:             } else {
        !           741:                 /* This word requires execution of the debugger "Up"
        !           742:                  * semantics. However we can't do this here since we
        !           743:                  * are iterating through the debug list, and we need
        !           744:                  * to change it. So we do it afterwards.
        !           745:                  */
        !           746:                 debug_xt_up = debug_xt_item;
        !           747:             }
        !           748:         }
        !           749: 
        !           750:         debug_xt_item = debug_xt_item->next;
        !           751:     }
        !           752: 
        !           753:     /* Execute debugger "Up" semantics if required */
        !           754:     if (debug_xt_up) {
        !           755:         /* Only add the parent word if it is not within the trampoline */
        !           756:         if (rstack[rstackcnt] != (cell)pointer2cell(&trampoline[1])) {
        !           757:             del_debug_xt(debug_xt_up->xt_docol);
        !           758:             add_debug_xt(findxtfromcell(rstack[rstackcnt]));
        !           759: 
        !           760:             fstrncpy(xtname, lfa2nfa(findxtfromcell(rstack[rstackcnt]) - sizeof(cell)), MAXNFALEN);
        !           761:             printf_console("\n[ Up to %s ] ", xtname);
        !           762:         } else {
        !           763:             fstrncpy(xtname, lfa2nfa(findxtfromcell(debug_xt_up->xt_docol) - sizeof(cell)), MAXNFALEN);
        !           764:             printf_console("\n[ Finished %s (Unable to go up, hit trampoline) ] ", xtname);
        !           765: 
        !           766:             del_debug_xt(debug_xt_up->xt_docol);
        !           767:         }
        !           768: 
        !           769:         debug_xt_up = NULL;
        !           770:     }
        !           771: 
        !           772:     PC = POPR();
        !           773: }
        !           774: 
        !           775: static inline void next_dbg(void)
        !           776: {
        !           777:     struct debug_xt *debug_xt_item;
        !           778:     void (*tokenp) (void);
        !           779: 
        !           780:     PC += sizeof(ucell);
        !           781: 
        !           782:     /* If the PC lies within a debug range, run the source debugger */
        !           783:     debug_xt_item = debug_xt_list;
        !           784:     while (debug_xt_item->next) {
        !           785:         if (PC >= debug_xt_item->xt_docol && PC <= debug_xt_item->xt_semis &&
        !           786:             debug_xt_item->mode != DEBUG_MODE_STEPUP) {
        !           787:             do_source_dbg(debug_xt_item);
        !           788:         }
        !           789: 
        !           790:         debug_xt_item = debug_xt_item->next;
        !           791:     }
        !           792: 
        !           793:     dbg_interp_printk("next_dbg: PC is now %x\n", PC);
        !           794: 
        !           795:     /* Intercept DOCOL and SEMIS and redirect to debug versions */
        !           796:     if (read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))) == DOCOL) {
        !           797:         tokenp = docol_dbg;
        !           798:         tokenp();
        !           799:     } else if (read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))) == DOSEMIS) {
        !           800:         tokenp = semis_dbg;
        !           801:         tokenp();
        !           802:     } else {
        !           803:         /* Otherwise process as normal */
        !           804:         processxt(read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))));
        !           805:     }
        !           806: }
        !           807: 
        !           808: static void
        !           809: do_debug_xt(void)
        !           810: {
        !           811:     ucell xt = POP();
        !           812: 
        !           813:     /* Add to the debug list */
        !           814:     if (add_debug_xt(xt)) {
        !           815:         /* Display debug banner */
        !           816:         printf_console(DEBUG_BANNER);
        !           817: 
        !           818:         /* Indicate change to debug mode */
        !           819:         interruptforth |= FORTH_INTSTAT_DBG;
        !           820:     }
        !           821: }
        !           822: 
        !           823: static void
        !           824: do_debug_off(void)
        !           825: {
        !           826:     /* Empty the debug xt linked list */
        !           827:     while (debug_xt_list->next != NULL) {
        !           828:         del_debug_xt(debug_xt_list->xt_docol);
        !           829:     }
        !           830: }
        !           831: 
        !           832: /*
        !           833:  * Forth primitives needed to set up
        !           834:  * all the words described in IEEE1275-1994.
        !           835:  */
        !           836: 
        !           837: /*
        !           838:  *  dup         ( x -- x x )
        !           839:  */
        !           840: 
        !           841: static void fdup(void)
        !           842: {
        !           843:        const cell tmp = GETTOS();
        !           844:        PUSH(tmp);
        !           845: }
        !           846: 
        !           847: 
        !           848: /*
        !           849:  *  2dup        ( x1 x2 -- x1 x2 x1 x2 )
        !           850:  */
        !           851: 
        !           852: static void twodup(void)
        !           853: {
        !           854:        cell tmp = GETITEM(1);
        !           855:        PUSH(tmp);
        !           856:        tmp = GETITEM(1);
        !           857:        PUSH(tmp);
        !           858: }
        !           859: 
        !           860: 
        !           861: /*
        !           862:  *  ?dup        ( x -- 0 | x x )
        !           863:  */
        !           864: 
        !           865: static void isdup(void)
        !           866: {
        !           867:        const cell tmp = GETTOS();
        !           868:        if (tmp)
        !           869:                PUSH(tmp);
        !           870: }
        !           871: 
        !           872: 
        !           873: /*
        !           874:  *  over        ( x y -- x y x )
        !           875:  */
        !           876: 
        !           877: static void over(void)
        !           878: {
        !           879:        const cell tmp = GETITEM(1);
        !           880:        PUSH(tmp);
        !           881: }
        !           882: 
        !           883: 
        !           884: /*
        !           885:  *  2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
        !           886:  */
        !           887: 
        !           888: static void twoover(void)
        !           889: {
        !           890:        const cell tmp = GETITEM(3);
        !           891:        const cell tmp2 = GETITEM(2);
        !           892:        PUSH(tmp);
        !           893:        PUSH(tmp2);
        !           894: }
        !           895: 
        !           896: /*
        !           897:  *  pick        ( xu ... x1 x0 u -- xu ... x1 x0 xu )
        !           898:  */
        !           899: 
        !           900: static void pick(void)
        !           901: {
        !           902:        const cell u = POP();
        !           903:        if (dstackcnt >= u) {
        !           904:                ucell tmp = dstack[dstackcnt - u];
        !           905:                PUSH(tmp);
        !           906:        } else {
        !           907:                /* underrun */
        !           908:        }
        !           909: }
        !           910: 
        !           911: 
        !           912: /*
        !           913:  *  drop        ( x --  )
        !           914:  */
        !           915: 
        !           916: static void drop(void)
        !           917: {
        !           918:        POP();
        !           919: }
        !           920: 
        !           921: /*
        !           922:  *  2drop       ( x1 x2 --  )
        !           923:  */
        !           924: 
        !           925: static void twodrop(void)
        !           926: {
        !           927:        POP();
        !           928:        POP();
        !           929: }
        !           930: 
        !           931: 
        !           932: /*
        !           933:  *  nip         ( x1 x2 -- x2 )
        !           934:  */
        !           935: 
        !           936: static void nip(void)
        !           937: {
        !           938:        const cell tmp = POP();
        !           939:        POP();
        !           940:        PUSH(tmp);
        !           941: }
        !           942: 
        !           943: 
        !           944: /*
        !           945:  *  roll        ( xu ... x1 x0 u -- xu-1... x1 x0 xu )
        !           946:  */
        !           947: 
        !           948: static void roll(void)
        !           949: {
        !           950:        const cell u = POP();
        !           951:        if (dstackcnt >= u) {
        !           952:                int i;
        !           953:                const cell xu = dstack[dstackcnt - u];
        !           954:                for (i = dstackcnt - u; i < dstackcnt; i++) {
        !           955:                        dstack[i] = dstack[i + 1];
        !           956:                }
        !           957:                dstack[dstackcnt] = xu;
        !           958:        } else {
        !           959:                /* Stack underrun */
        !           960:        }
        !           961: }
        !           962: 
        !           963: 
        !           964: /*
        !           965:  *  rot         ( x1 x2 x3 -- x2 x3 x1 )
        !           966:  */
        !           967: 
        !           968: static void rot(void)
        !           969: {
        !           970:        const cell tmp = POP();
        !           971:        const cell tmp2 = POP();
        !           972:        const cell tmp3 = POP();
        !           973:        PUSH(tmp2);
        !           974:        PUSH(tmp);
        !           975:        PUSH(tmp3);
        !           976: }
        !           977: 
        !           978: 
        !           979: /*
        !           980:  *  -rot        ( x1 x2 x3 -- x3 x1 x2 )
        !           981:  */
        !           982: 
        !           983: static void minusrot(void)
        !           984: {
        !           985:        const cell tmp = POP();
        !           986:        const cell tmp2 = POP();
        !           987:        const cell tmp3 = POP();
        !           988:        PUSH(tmp);
        !           989:        PUSH(tmp3);
        !           990:        PUSH(tmp2);
        !           991: }
        !           992: 
        !           993: 
        !           994: /*
        !           995:  *  swap        ( x1 x2 -- x2 x1 )
        !           996:  */
        !           997: 
        !           998: static void swap(void)
        !           999: {
        !          1000:        const cell tmp = POP();
        !          1001:        const cell tmp2 = POP();
        !          1002:        PUSH(tmp);
        !          1003:        PUSH(tmp2);
        !          1004: }
        !          1005: 
        !          1006: 
        !          1007: /*
        !          1008:  *  2swap       ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
        !          1009:  */
        !          1010: 
        !          1011: static void twoswap(void)
        !          1012: {
        !          1013:        const cell tmp = POP();
        !          1014:        const cell tmp2 = POP();
        !          1015:        const cell tmp3 = POP();
        !          1016:        const cell tmp4 = POP();
        !          1017:        PUSH(tmp2);
        !          1018:        PUSH(tmp);
        !          1019:        PUSH(tmp4);
        !          1020:        PUSH(tmp3);
        !          1021: }
        !          1022: 
        !          1023: 
        !          1024: /*
        !          1025:  *  >r          ( x -- ) (R: -- x )
        !          1026:  */
        !          1027: 
        !          1028: static void tor(void)
        !          1029: {
        !          1030:        ucell tmp = POP();
        !          1031: #ifdef CONFIG_DEBUG_RSTACK
        !          1032:        printk("  >R: %x\n", tmp);
        !          1033: #endif
        !          1034:        PUSHR(tmp);
        !          1035: }
        !          1036: 
        !          1037: 
        !          1038: /*
        !          1039:  *  r>          ( -- x ) (R: x -- )
        !          1040:  */
        !          1041: 
        !          1042: static void rto(void)
        !          1043: {
        !          1044:        ucell tmp = POPR();
        !          1045: #ifdef CONFIG_DEBUG_RSTACK
        !          1046:        printk("  R>: %x\n", tmp);
        !          1047: #endif
        !          1048:        PUSH(tmp);
        !          1049: }
        !          1050: 
        !          1051: 
        !          1052: /*
        !          1053:  *  r@          ( -- x ) (R: x -- x )
        !          1054:  */
        !          1055: 
        !          1056: static void rfetch(void)
        !          1057: {
        !          1058:        PUSH(GETTORS());
        !          1059: }
        !          1060: 
        !          1061: 
        !          1062: /*
        !          1063:  *  depth       (  -- u )
        !          1064:  */
        !          1065: 
        !          1066: static void depth(void)
        !          1067: {
        !          1068:        const cell tmp = dstackcnt;
        !          1069:        PUSH(tmp);
        !          1070: }
        !          1071: 
        !          1072: 
        !          1073: /*
        !          1074:  *  depth!      ( ... u --  x1 x2 .. xu )
        !          1075:  */
        !          1076: 
        !          1077: static void depthwrite(void)
        !          1078: {
        !          1079:        ucell tmp = POP();
        !          1080:        dstackcnt = tmp;
        !          1081: }
        !          1082: 
        !          1083: 
        !          1084: /*
        !          1085:  *  rdepth      (  -- u )
        !          1086:  */
        !          1087: 
        !          1088: static void rdepth(void)
        !          1089: {
        !          1090:        const cell tmp = rstackcnt;
        !          1091:        PUSH(tmp);
        !          1092: }
        !          1093: 
        !          1094: 
        !          1095: /*
        !          1096:  *  rdepth!     ( u --  ) ( R: ... -- x1 x2 .. xu )
        !          1097:  */
        !          1098: 
        !          1099: static void rdepthwrite(void)
        !          1100: {
        !          1101:        ucell tmp = POP();
        !          1102:        rstackcnt = tmp;
        !          1103: }
        !          1104: 
        !          1105: 
        !          1106: /*
        !          1107:  *  +           ( nu1 nu2 -- sum )
        !          1108:  */
        !          1109: 
        !          1110: static void plus(void)
        !          1111: {
        !          1112:        cell tmp = POP() + POP();
        !          1113:        PUSH(tmp);
        !          1114: }
        !          1115: 
        !          1116: 
        !          1117: /*
        !          1118:  *  -           ( nu1 nu2 -- diff )
        !          1119:  */
        !          1120: 
        !          1121: static void minus(void)
        !          1122: {
        !          1123:        const cell nu2 = POP();
        !          1124:        const cell nu1 = POP();
        !          1125:        PUSH(nu1 - nu2);
        !          1126: }
        !          1127: 
        !          1128: 
        !          1129: /*
        !          1130:  *  *           ( nu1 nu2 -- prod )
        !          1131:  */
        !          1132: 
        !          1133: static void mult(void)
        !          1134: {
        !          1135:        const cell nu2 = POP();
        !          1136:        const cell nu1 = POP();
        !          1137:        PUSH(nu1 * nu2);
        !          1138: }
        !          1139: 
        !          1140: 
        !          1141: /*
        !          1142:  *  u*          ( u1 u2 -- prod )
        !          1143:  */
        !          1144: 
        !          1145: static void umult(void)
        !          1146: {
        !          1147:        const ucell tmp = (ucell) POP() * (ucell) POP();
        !          1148:        PUSH(tmp);
        !          1149: }
        !          1150: 
        !          1151: 
        !          1152: /*
        !          1153:  *  mu/mod      ( n1 n2 -- rem quot.l quot.h )
        !          1154:  */
        !          1155: 
        !          1156: static void mudivmod(void)
        !          1157: {
        !          1158:        const ucell b = POP();
        !          1159:        const ducell a = DPOP();
        !          1160: #ifdef NEED_FAKE_INT128_T
        !          1161:         if (a.hi != 0) {
        !          1162:             fprintf(stderr, "mudivmod called (0x%016llx %016llx / 0x%016llx)\n",
        !          1163:                     a.hi, a.lo, b);
        !          1164:             exit(-1);
        !          1165:         } else {
        !          1166:             ducell c;
        !          1167: 
        !          1168:             PUSH(a.lo % b);
        !          1169:             c.hi = 0;
        !          1170:             c.lo = a.lo / b;
        !          1171:             DPUSH(c);
        !          1172:         }
        !          1173: #else
        !          1174:        PUSH(a % b);
        !          1175:        DPUSH(a / b);
        !          1176: #endif
        !          1177: }
        !          1178: 
        !          1179: 
        !          1180: /*
        !          1181:  *  abs         ( n -- u )
        !          1182:  */
        !          1183: 
        !          1184: static void forthabs(void)
        !          1185: {
        !          1186:        const cell tmp = GETTOS();
        !          1187:        if (tmp < 0) {
        !          1188:                POP();
        !          1189:                PUSH(-tmp);
        !          1190:        }
        !          1191: }
        !          1192: 
        !          1193: 
        !          1194: /*
        !          1195:  *  negate      ( n1 -- n2 )
        !          1196:  */
        !          1197: 
        !          1198: static void negate(void)
        !          1199: {
        !          1200:        const cell tmp = POP();
        !          1201:        PUSH(-tmp);
        !          1202: }
        !          1203: 
        !          1204: 
        !          1205: /*
        !          1206:  *  max         ( n1 n2 -- n1|n2 )
        !          1207:  */
        !          1208: 
        !          1209: static void max(void)
        !          1210: {
        !          1211:        const cell tmp = POP();
        !          1212:        const cell tmp2 = POP();
        !          1213:        PUSH((tmp > tmp2) ? tmp : tmp2);
        !          1214: }
        !          1215: 
        !          1216: 
        !          1217: /*
        !          1218:  *  min         ( n1 n2 -- n1|n2 )
        !          1219:  */
        !          1220: 
        !          1221: static void min(void)
        !          1222: {
        !          1223:        const cell tmp = POP();
        !          1224:        const cell tmp2 = POP();
        !          1225:        PUSH((tmp < tmp2) ? tmp : tmp2);
        !          1226: }
        !          1227: 
        !          1228: 
        !          1229: /*
        !          1230:  *  lshift      ( x1 u -- x2 )
        !          1231:  */
        !          1232: 
        !          1233: static void lshift(void)
        !          1234: {
        !          1235:        const ucell u = POP();
        !          1236:        const ucell x1 = POP();
        !          1237:        PUSH(x1 << u);
        !          1238: }
        !          1239: 
        !          1240: 
        !          1241: /*
        !          1242:  *  rshift      ( x1 u -- x2 )
        !          1243:  */
        !          1244: 
        !          1245: static void rshift(void)
        !          1246: {
        !          1247:        const ucell u = POP();
        !          1248:        const ucell x1 = POP();
        !          1249:        PUSH(x1 >> u);
        !          1250: }
        !          1251: 
        !          1252: 
        !          1253: /*
        !          1254:  *  >>a         ( x1 u -- x2 ) ??
        !          1255:  */
        !          1256: 
        !          1257: static void rshifta(void)
        !          1258: {
        !          1259:        const cell u = POP();
        !          1260:        const cell x1 = POP();
        !          1261:        PUSH(x1 >> u);
        !          1262: }
        !          1263: 
        !          1264: 
        !          1265: /*
        !          1266:  *  and         ( x1 x2 -- x3 )
        !          1267:  */
        !          1268: 
        !          1269: static void and(void)
        !          1270: {
        !          1271:        const cell x1 = POP();
        !          1272:        const cell x2 = POP();
        !          1273:        PUSH(x1 & x2);
        !          1274: }
        !          1275: 
        !          1276: 
        !          1277: /*
        !          1278:  *  or          ( x1 x2 -- x3 )
        !          1279:  */
        !          1280: 
        !          1281: static void or(void)
        !          1282: {
        !          1283:        const cell x1 = POP();
        !          1284:        const cell x2 = POP();
        !          1285:        PUSH(x1 | x2);
        !          1286: }
        !          1287: 
        !          1288: 
        !          1289: /*
        !          1290:  *  xor         ( x1 x2 -- x3 )
        !          1291:  */
        !          1292: 
        !          1293: static void xor(void)
        !          1294: {
        !          1295:        const cell x1 = POP();
        !          1296:        const cell x2 = POP();
        !          1297:        PUSH(x1 ^ x2);
        !          1298: }
        !          1299: 
        !          1300: 
        !          1301: /*
        !          1302:  *  invert      ( x1 -- x2 )
        !          1303:  */
        !          1304: 
        !          1305: static void invert(void)
        !          1306: {
        !          1307:        const cell x1 = POP();
        !          1308:        PUSH(x1 ^ -1);
        !          1309: }
        !          1310: 
        !          1311: 
        !          1312: /*
        !          1313:  *  d+          ( d1 d2 -- d.sum )
        !          1314:  */
        !          1315: 
        !          1316: static void dplus(void)
        !          1317: {
        !          1318:        const dcell d2 = DPOP();
        !          1319:        const dcell d1 = DPOP();
        !          1320: #ifdef NEED_FAKE_INT128_T
        !          1321:         ducell c;
        !          1322: 
        !          1323:         if (d1.hi != 0 || d2.hi != 0) {
        !          1324:             fprintf(stderr, "dplus called (0x%016llx %016llx + 0x%016llx %016llx)\n",
        !          1325:                     d1.hi, d1.lo, d2.hi, d2.lo);
        !          1326:             exit(-1);
        !          1327:         }
        !          1328:         c.hi = 0;
        !          1329:         c.lo = d1.lo + d2.lo;
        !          1330:         DPUSH(c);
        !          1331: #else
        !          1332:        DPUSH(d1 + d2);
        !          1333: #endif
        !          1334: }
        !          1335: 
        !          1336: 
        !          1337: /*
        !          1338:  *  d-          ( d1 d2 -- d.diff )
        !          1339:  */
        !          1340: 
        !          1341: static void dminus(void)
        !          1342: {
        !          1343:        const dcell d2 = DPOP();
        !          1344:        const dcell d1 = DPOP();
        !          1345: #ifdef NEED_FAKE_INT128_T
        !          1346:         ducell c;
        !          1347: 
        !          1348:         if (d1.hi != 0 || d2.hi != 0) {
        !          1349:             fprintf(stderr, "dminus called (0x%016llx %016llx + 0x%016llx %016llx)\n",
        !          1350:                     d1.hi, d1.lo, d2.hi, d2.lo);
        !          1351:             exit(-1);
        !          1352:         }
        !          1353:         c.hi = 0;
        !          1354:         c.lo = d1.lo - d2.lo;
        !          1355:         DPUSH(c);
        !          1356: #else
        !          1357:        DPUSH(d1 - d2);
        !          1358: #endif
        !          1359: }
        !          1360: 
        !          1361: 
        !          1362: /*
        !          1363:  *  m*          ( ?? --  )
        !          1364:  */
        !          1365: 
        !          1366: static void mmult(void)
        !          1367: {
        !          1368:        const cell u2 = POP();
        !          1369:        const cell u1 = POP();
        !          1370: #ifdef NEED_FAKE_INT128_T
        !          1371:         ducell c;
        !          1372: 
        !          1373:         if (0) { // XXX How to detect overflow?
        !          1374:             fprintf(stderr, "mmult called (%016llx * 0x%016llx)\n", u1, u2);
        !          1375:             exit(-1);
        !          1376:         }
        !          1377:         c.hi = 0;
        !          1378:         c.lo = u1 * u2;
        !          1379:         DPUSH(c);
        !          1380: #else
        !          1381:        DPUSH((dcell) u1 * u2);
        !          1382: #endif
        !          1383: }
        !          1384: 
        !          1385: 
        !          1386: /*
        !          1387:  *  um*         ( u1 u2 -- d.prod )
        !          1388:  */
        !          1389: 
        !          1390: static void ummult(void)
        !          1391: {
        !          1392:        const ucell u2 = POP();
        !          1393:        const ucell u1 = POP();
        !          1394: #ifdef NEED_FAKE_INT128_T
        !          1395:         ducell c;
        !          1396: 
        !          1397:         if (0) { // XXX How to detect overflow?
        !          1398:             fprintf(stderr, "ummult called (%016llx * 0x%016llx)\n", u1, u2);
        !          1399:             exit(-1);
        !          1400:         }
        !          1401:         c.hi = 0;
        !          1402:         c.lo = u1 * u2;
        !          1403:         DPUSH(c);
        !          1404: #else
        !          1405:        DPUSH((ducell) u1 * u2);
        !          1406: #endif
        !          1407: }
        !          1408: 
        !          1409: 
        !          1410: /*
        !          1411:  *  @           ( a-addr -- x )
        !          1412:  */
        !          1413: 
        !          1414: static void fetch(void)
        !          1415: {
        !          1416:        const ucell *aaddr = (ucell *)cell2pointer(POP());
        !          1417:        PUSH(read_ucell(aaddr));
        !          1418: }
        !          1419: 
        !          1420: 
        !          1421: /*
        !          1422:  *  c@          ( addr -- byte )
        !          1423:  */
        !          1424: 
        !          1425: static void cfetch(void)
        !          1426: {
        !          1427:        const u8 *aaddr = (u8 *)cell2pointer(POP());
        !          1428:        PUSH(read_byte(aaddr));
        !          1429: }
        !          1430: 
        !          1431: 
        !          1432: /*
        !          1433:  *  w@          ( waddr -- w )
        !          1434:  */
        !          1435: 
        !          1436: static void wfetch(void)
        !          1437: {
        !          1438:        const u16 *aaddr = (u16 *)cell2pointer(POP());
        !          1439:        PUSH(read_word(aaddr));
        !          1440: }
        !          1441: 
        !          1442: 
        !          1443: /*
        !          1444:  *  l@          ( qaddr -- quad )
        !          1445:  */
        !          1446: 
        !          1447: static void lfetch(void)
        !          1448: {
        !          1449:        const u32 *aaddr = (u32 *)cell2pointer(POP());
        !          1450:        PUSH(read_long(aaddr));
        !          1451: }
        !          1452: 
        !          1453: 
        !          1454: /*
        !          1455:  *  !           ( x a-addr -- )
        !          1456:  */
        !          1457: 
        !          1458: static void store(void)
        !          1459: {
        !          1460:        const ucell *aaddr = (ucell *)cell2pointer(POP());
        !          1461:        const ucell x = POP();
        !          1462: #ifdef CONFIG_DEBUG_INTERNAL
        !          1463:        printk("!: %lx : %lx -> %lx\n", aaddr, read_ucell(aaddr), x);
        !          1464: #endif
        !          1465:        write_ucell(aaddr,x);
        !          1466: }
        !          1467: 
        !          1468: 
        !          1469: /*
        !          1470:  *  +!          ( nu a-addr -- )
        !          1471:  */
        !          1472: 
        !          1473: static void plusstore(void)
        !          1474: {
        !          1475:        const ucell *aaddr = (ucell *)cell2pointer(POP());
        !          1476:        const cell nu = POP();
        !          1477:        write_cell(aaddr,read_cell(aaddr)+nu);
        !          1478: }
        !          1479: 
        !          1480: 
        !          1481: /*
        !          1482:  *  c!          ( byte addr -- )
        !          1483:  */
        !          1484: 
        !          1485: static void cstore(void)
        !          1486: {
        !          1487:        const u8 *aaddr = (u8 *)cell2pointer(POP());
        !          1488:        const ucell byte = POP();
        !          1489: #ifdef CONFIG_DEBUG_INTERNAL
        !          1490:        printk("c!: %x = %x\n", aaddr, byte);
        !          1491: #endif
        !          1492:        write_byte(aaddr, byte);
        !          1493: }
        !          1494: 
        !          1495: 
        !          1496: /*
        !          1497:  *  w!          ( w waddr -- )
        !          1498:  */
        !          1499: 
        !          1500: static void wstore(void)
        !          1501: {
        !          1502:        const u16 *aaddr = (u16 *)cell2pointer(POP());
        !          1503:        const u16 word = POP();
        !          1504:        write_word(aaddr, word);
        !          1505: }
        !          1506: 
        !          1507: 
        !          1508: /*
        !          1509:  *  l!          ( quad qaddr -- )
        !          1510:  */
        !          1511: 
        !          1512: static void lstore(void)
        !          1513: {
        !          1514:        const u32 *aaddr = (u32 *)cell2pointer(POP());
        !          1515:        const u32 longval = POP();
        !          1516:        write_long(aaddr, longval);
        !          1517: }
        !          1518: 
        !          1519: 
        !          1520: /*
        !          1521:  *  =           ( x1 x2 -- equal? )
        !          1522:  */
        !          1523: 
        !          1524: static void equals(void)
        !          1525: {
        !          1526:        cell tmp = (POP() == POP());
        !          1527:        PUSH(-tmp);
        !          1528: }
        !          1529: 
        !          1530: 
        !          1531: /*
        !          1532:  *  >           ( n1 n2 -- greater? )
        !          1533:  */
        !          1534: 
        !          1535: static void greater(void)
        !          1536: {
        !          1537:        cell tmp = ((cell) POP() < (cell) POP());
        !          1538:        PUSH(-tmp);
        !          1539: }
        !          1540: 
        !          1541: 
        !          1542: /*
        !          1543:  *  <           ( n1 n2 -- less? )
        !          1544:  */
        !          1545: 
        !          1546: static void less(void)
        !          1547: {
        !          1548:        cell tmp = ((cell) POP() > (cell) POP());
        !          1549:        PUSH(-tmp);
        !          1550: }
        !          1551: 
        !          1552: 
        !          1553: /*
        !          1554:  *  u>          ( u1 u2 -- unsigned-greater? )
        !          1555:  */
        !          1556: 
        !          1557: static void ugreater(void)
        !          1558: {
        !          1559:        cell tmp = ((ucell) POP() < (ucell) POP());
        !          1560:        PUSH(-tmp);
        !          1561: }
        !          1562: 
        !          1563: 
        !          1564: /*
        !          1565:  *  u<          ( u1 u2 -- unsigned-less? )
        !          1566:  */
        !          1567: 
        !          1568: static void uless(void)
        !          1569: {
        !          1570:        cell tmp = ((ucell) POP() > (ucell) POP());
        !          1571:        PUSH(-tmp);
        !          1572: }
        !          1573: 
        !          1574: 
        !          1575: /*
        !          1576:  *  sp@         (  -- stack-pointer )
        !          1577:  */
        !          1578: 
        !          1579: static void spfetch(void)
        !          1580: {
        !          1581:        // FIXME this can only work if the stack pointer
        !          1582:        // is within range.
        !          1583:        ucell tmp = pointer2cell(&(dstack[dstackcnt]));
        !          1584:        PUSH(tmp);
        !          1585: }
        !          1586: 
        !          1587: 
        !          1588: /*
        !          1589:  *  move        ( src-addr dest-addr len -- )
        !          1590:  */
        !          1591: 
        !          1592: static void fmove(void)
        !          1593: {
        !          1594:        ucell count = POP();
        !          1595:        void *dest = (void *)cell2pointer(POP());
        !          1596:        const void *src = (const void *)cell2pointer(POP());
        !          1597:        memmove(dest, src, count);
        !          1598: }
        !          1599: 
        !          1600: 
        !          1601: /*
        !          1602:  *  fill        ( addr len byte -- )
        !          1603:  */
        !          1604: 
        !          1605: static void ffill(void)
        !          1606: {
        !          1607:        ucell value = POP();
        !          1608:        ucell count = POP();
        !          1609:        void *src = (void *)cell2pointer(POP());
        !          1610:        memset(src, value, count);
        !          1611: }
        !          1612: 
        !          1613: 
        !          1614: /*
        !          1615:  *  unaligned-w@  ( addr -- w )
        !          1616:  */
        !          1617: 
        !          1618: static void unalignedwordread(void)
        !          1619: {
        !          1620:        const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
        !          1621:        PUSH(unaligned_read_word(addr));
        !          1622: }
        !          1623: 
        !          1624: 
        !          1625: /*
        !          1626:  *  unaligned-w!  ( w addr -- )
        !          1627:  */
        !          1628: 
        !          1629: static void unalignedwordwrite(void)
        !          1630: {
        !          1631:        const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
        !          1632:        u16 w = POP();
        !          1633:        unaligned_write_word(addr, w);
        !          1634: }
        !          1635: 
        !          1636: 
        !          1637: /*
        !          1638:  *  unaligned-l@  ( addr -- quad )
        !          1639:  */
        !          1640: 
        !          1641: static void unalignedlongread(void)
        !          1642: {
        !          1643:        const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
        !          1644:        PUSH(unaligned_read_long(addr));
        !          1645: }
        !          1646: 
        !          1647: 
        !          1648: /*
        !          1649:  *  unaligned-l!  ( quad addr -- )
        !          1650:  */
        !          1651: 
        !          1652: static void unalignedlongwrite(void)
        !          1653: {
        !          1654:        unsigned char *addr = (unsigned char *) cell2pointer(POP());
        !          1655:        u32 l = POP();
        !          1656:        unaligned_write_long(addr, l);
        !          1657: }
        !          1658: 
        !          1659: /*
        !          1660:  *  here        (  -- dictionary-pointer )
        !          1661:  */
        !          1662: 
        !          1663: static void here(void)
        !          1664: {
        !          1665:        PUSH(pointer2cell(dict) + dicthead);
        !          1666: #ifdef CONFIG_DEBUG_INTERNAL
        !          1667:        printk("here: %x\n", pointer2cell(dict) + dicthead);
        !          1668: #endif
        !          1669: }
        !          1670: 
        !          1671: /*
        !          1672:  *  here!       ( new-dict-pointer -- )
        !          1673:  */
        !          1674: 
        !          1675: static void herewrite(void)
        !          1676: {
        !          1677:        ucell tmp = POP(); /* converted pointer */
        !          1678:        dicthead = tmp - pointer2cell(dict);
        !          1679: #ifdef CONFIG_DEBUG_INTERNAL
        !          1680:        printk("here!: new value: %x\n", tmp);
        !          1681: #endif
        !          1682: 
        !          1683:        if (dictlimit && dicthead >= dictlimit) {
        !          1684:            printk("Dictionary space overflow:"
        !          1685:                    " dicthead=" FMT_ucellx
        !          1686:                    " dictlimit=" FMT_ucellx
        !          1687:                    "\n",
        !          1688:                    dicthead, dictlimit);
        !          1689:        }
        !          1690: }
        !          1691: 
        !          1692: 
        !          1693: /*
        !          1694:  *   emit       ( char --  )
        !          1695:  */
        !          1696: 
        !          1697: static void emit(void)
        !          1698: {
        !          1699:        cell tmp = POP();
        !          1700: #ifndef FCOMPILER
        !          1701:        putchar(tmp);
        !          1702: #else
        !          1703:                put_outputbyte(tmp);
        !          1704: #endif
        !          1705: }
        !          1706: 
        !          1707: 
        !          1708: /*
        !          1709:  *   key?       (  -- pressed? )
        !          1710:  */
        !          1711: 
        !          1712: static void iskey(void)
        !          1713: {
        !          1714:        PUSH((cell) availchar());
        !          1715: }
        !          1716: 
        !          1717: 
        !          1718: /*
        !          1719:  *   key        (  -- char )
        !          1720:  */
        !          1721: 
        !          1722: static void key(void)
        !          1723: {
        !          1724:        while (!availchar());
        !          1725: #ifdef FCOMPILER
        !          1726:        PUSH(get_inputbyte());
        !          1727: #else
        !          1728:        PUSH(getchar());
        !          1729: #endif
        !          1730: }
        !          1731: 
        !          1732: 
        !          1733: /*
        !          1734:  *   ioc@       ( reg -- val )
        !          1735:  */
        !          1736: 
        !          1737: static void iocfetch(void)
        !          1738: {
        !          1739: #ifndef FCOMPILER
        !          1740:        cell reg = POP();
        !          1741:        PUSH(inb(reg));
        !          1742: #else
        !          1743:         (void)POP();
        !          1744:         PUSH(0);
        !          1745: #endif
        !          1746: }
        !          1747: 
        !          1748: 
        !          1749: /*
        !          1750:  *   iow@       ( reg -- val )
        !          1751:  */
        !          1752: 
        !          1753: static void iowfetch(void)
        !          1754: {
        !          1755: #ifndef FCOMPILER
        !          1756:        cell reg = POP();
        !          1757:        PUSH(inw(reg));
        !          1758: #else
        !          1759:         (void)POP();
        !          1760:         PUSH(0);
        !          1761: #endif
        !          1762: }
        !          1763: 
        !          1764: /*
        !          1765:  *   iol@       ( reg -- val )
        !          1766:  */
        !          1767: 
        !          1768: static void iolfetch(void)
        !          1769: {
        !          1770: #ifndef FCOMPILER
        !          1771:        cell reg = POP();
        !          1772:        PUSH(inl(reg));
        !          1773: #else
        !          1774:         (void)POP();
        !          1775:         PUSH(0);
        !          1776: #endif
        !          1777: }
        !          1778: 
        !          1779: 
        !          1780: /*
        !          1781:  *   ioc!       ( val reg --  )
        !          1782:  */
        !          1783: 
        !          1784: static void iocstore(void)
        !          1785: {
        !          1786: #ifndef FCOMPILER
        !          1787:        cell reg = POP();
        !          1788:        cell val = POP();
        !          1789: 
        !          1790:        outb(reg, val);
        !          1791: #else
        !          1792:         (void)POP();
        !          1793:         (void)POP();
        !          1794: #endif
        !          1795: }
        !          1796: 
        !          1797: 
        !          1798: /*
        !          1799:  *   iow!       ( val reg --  )
        !          1800:  */
        !          1801: 
        !          1802: static void iowstore(void)
        !          1803: {
        !          1804: #ifndef FCOMPILER
        !          1805:        cell reg = POP();
        !          1806:        cell val = POP();
        !          1807: 
        !          1808:        outw(reg, val);
        !          1809: #else
        !          1810:         (void)POP();
        !          1811:         (void)POP();
        !          1812: #endif
        !          1813: }
        !          1814: 
        !          1815: 
        !          1816: /*
        !          1817:  *   iol!       ( val reg --  )
        !          1818:  */
        !          1819: 
        !          1820: static void iolstore(void)
        !          1821: {
        !          1822: #ifndef FCOMPILER
        !          1823:        ucell reg = POP();
        !          1824:        ucell val = POP();
        !          1825: 
        !          1826:        outl(reg, val);
        !          1827: #else
        !          1828:         (void)POP();
        !          1829:         (void)POP();
        !          1830: #endif
        !          1831: }
        !          1832: 
        !          1833: /*
        !          1834:  *   i         ( -- i )
        !          1835:  */
        !          1836: 
        !          1837: static void loop_i(void)
        !          1838: {
        !          1839:        PUSH(rstack[rstackcnt]);
        !          1840: }
        !          1841: 
        !          1842: /*
        !          1843:  *   j         ( -- i )
        !          1844:  */
        !          1845: 
        !          1846: static void loop_j(void)
        !          1847: {
        !          1848:        PUSH(rstack[rstackcnt - 2]);
        !          1849: }
        !          1850: 
        !          1851: /* words[] is a function array of all native code functions used by
        !          1852:  * the dictionary, i.e. CFAs and primitives.
        !          1853:  * Any change here needs a matching change in the primitive word's
        !          1854:  * name list that is kept for bootstrapping in kernel/bootstrap.c
        !          1855:  *
        !          1856:  * NOTE: THIS LIST SHALL NOT CHANGE (EXCEPT MANDATORY ADDITIONS AT
        !          1857:  * THE END). ANY OTHER CHANGE WILL BREAK COMPATIBILITY TO OLDER
        !          1858:  * BINARY DICTIONARIES.
        !          1859:  */
        !          1860: static forth_word * const words[] = {
        !          1861:     /*
        !          1862:      * CFAs and special words
        !          1863:      */
        !          1864:     semis,
        !          1865:     docol,
        !          1866:     lit,
        !          1867:     docon,
        !          1868:     dovar,
        !          1869:     dodefer,
        !          1870:     dodoes,
        !          1871:     dodo,
        !          1872:     doisdo,
        !          1873:     doloop,
        !          1874:     doplusloop,
        !          1875:     doival,
        !          1876:     doivar,
        !          1877:     doidefer,
        !          1878: 
        !          1879:     /*
        !          1880:      * primitives
        !          1881:      */
        !          1882:     fdup,                   /* dup     */
        !          1883:     twodup,                 /* 2dup    */
        !          1884:     isdup,                  /* ?dup    */
        !          1885:     over,                   /* over    */
        !          1886:     twoover,                /* 2over   */
        !          1887:     pick,                   /* pick    */
        !          1888:     drop,                   /* drop    */
        !          1889:     twodrop,                /* 2drop   */
        !          1890:     nip,                    /* nip     */
        !          1891:     roll,                   /* roll    */
        !          1892:     rot,                    /* rot     */
        !          1893:     minusrot,               /* -rot    */
        !          1894:     swap,                   /* swap    */
        !          1895:     twoswap,                /* 2swap   */
        !          1896:     tor,                    /* >r      */
        !          1897:     rto,                    /* r>      */
        !          1898:     rfetch,                 /* r@      */
        !          1899:     depth,                  /* depth   */
        !          1900:     depthwrite,             /* depth!  */
        !          1901:     rdepth,                 /* rdepth  */
        !          1902:     rdepthwrite,            /* rdepth! */
        !          1903:     plus,                   /* +       */
        !          1904:     minus,                  /* -       */
        !          1905:     mult,                   /* *       */
        !          1906:     umult,                  /* u*      */
        !          1907:     mudivmod,               /* mu/mod  */
        !          1908:     forthabs,               /* abs     */
        !          1909:     negate,                 /* negate  */
        !          1910:     max,                    /* max     */
        !          1911:     min,                    /* min     */
        !          1912:     lshift,                 /* lshift  */
        !          1913:     rshift,                 /* rshift  */
        !          1914:     rshifta,                /* >>a     */
        !          1915:     and,                    /* and     */
        !          1916:     or,                     /* or      */
        !          1917:     xor,                    /* xor     */
        !          1918:     invert,                 /* invert  */
        !          1919:     dplus,                  /* d+      */
        !          1920:     dminus,                 /* d-      */
        !          1921:     mmult,                  /* m*      */
        !          1922:     ummult,                 /* um*     */
        !          1923:     fetch,                  /* @       */
        !          1924:     cfetch,                 /* c@      */
        !          1925:     wfetch,                 /* w@      */
        !          1926:     lfetch,                 /* l@      */
        !          1927:     store,                  /* !       */
        !          1928:     plusstore,              /* +!      */
        !          1929:     cstore,                 /* c!      */
        !          1930:     wstore,                 /* w!      */
        !          1931:     lstore,                 /* l!      */
        !          1932:     equals,                 /* =       */
        !          1933:     greater,                /* >       */
        !          1934:     less,                   /* <       */
        !          1935:     ugreater,               /* u>      */
        !          1936:     uless,                  /* u<      */
        !          1937:     spfetch,                /* sp@     */
        !          1938:     fmove,                  /* move    */
        !          1939:     ffill,                  /* fill    */
        !          1940:     emit,                   /* emit    */
        !          1941:     iskey,                  /* key?    */
        !          1942:     key,                    /* key     */
        !          1943:     execute,                /* execute */
        !          1944:     here,                   /* here    */
        !          1945:     herewrite,              /* here!   */
        !          1946:     dobranch,               /* dobranch     */
        !          1947:     docbranch,              /* do?branch    */
        !          1948:     unalignedwordread,      /* unaligned-w@ */
        !          1949:     unalignedwordwrite,     /* unaligned-w! */
        !          1950:     unalignedlongread,      /* unaligned-l@ */
        !          1951:     unalignedlongwrite,     /* unaligned-l! */
        !          1952:     iocfetch,               /* ioc@    */
        !          1953:     iowfetch,               /* iow@    */
        !          1954:     iolfetch,               /* iol@    */
        !          1955:     iocstore,               /* ioc!    */
        !          1956:     iowstore,               /* iow!    */
        !          1957:     iolstore,               /* iol!    */
        !          1958:     loop_i,                 /* i       */
        !          1959:     loop_j,                 /* j       */
        !          1960:     call,                   /* call    */
        !          1961:     sysdebug,               /* sys-debug */
        !          1962:     do_include,             /* $include */
        !          1963:     do_encode_file,         /* $encode-file */
        !          1964:     do_debug_xt,            /* (debug  */
        !          1965:     do_debug_off,           /* (debug-off) */
        !          1966: };

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.