qemu/roms/openbios/kernel/forth.c

   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(val, reg);
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(val, reg);
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(val, reg);
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 };