home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / BEETLE / BEETLE.ZIP / Beetle / execute.c < prev    next >
Text File  |  1997-04-22  |  11KB  |  207 lines
  1. /* EXECUTE.C
  2.  
  3.     Vrsn  Date   Comment
  4.     ----|-------|---------------------------------------------------------------
  5.     0.00 24mar95 Code removed from step.c v0.21. See that file for earlier
  6.                  history. NEXTC introduced so that NEXT is not redefined. CHECKC
  7.                  and CHECKA debugged. lib.c. now included directly to facilitate
  8.                  address checking. Code to handle address exception moved to
  9.                  excepts.c. Added code to do exception on division by zero.
  10.     0.01 25mar95 Changed DIVZERO to put exception no. on stack itself.
  11.     0.02 17apr95 Changed EXECUTE and FEXECUTE in accordance with debugged
  12.                  specification. Debugged LINK.
  13.     0.03 18apr95 Changed number of LIB calls to 8.
  14.     0.04 28apr95 Debugged LSHIFT and RSHIFT.
  15.     0.05 21may96 Debugged THROW; optimised NEXTFF.
  16.     0.06 23may96 Redebugged THROW.
  17.     0.07 27may96 Added additional address check to DO.
  18.     0.08 18jun96 Changed LIB to call a function.
  19.     0.09 30mar97 Made CHECKC work with unaligned machine addresses, and
  20.                  USLASHMOD cast the remainder to UCELL rather than CELL.
  21.                  Changed limit on LIB calls to 12.
  22.  
  23.     Reuben Thomas
  24.  
  25.  
  26.     Perform one pass of the execution cycle. (This file is #included by step.c
  27.     and run.c, and is not compilable on its own.)
  28.  
  29. */
  30.  
  31.  
  32. #if CHECKED == 1
  33.     #define CHECKC(a) if ((UCELL)((BYTE *)(a) - M0) >= MEMORY) \
  34.                         { *(CELL *)(M0 + 12) = ADDRESS = (BYTE *)(a) - M0; \
  35.                         goto invadr; }
  36.     #define CHECKA(a) CHECKC(a); if (((BYTE *)(a) - M0) & 3) \
  37.                         { *(CELL *)(M0 + 12) = ADDRESS = (BYTE *)(a) - M0; \
  38.                         goto aliadr; }
  39.     #define NEXTC CHECKA(EP); NEXT
  40. #else
  41.     #define CHECKC(a)
  42.     #define CHECKA(a)
  43.     #define NEXTC NEXT
  44. #endif
  45.  
  46. #define DIVZERO(x) if (x == 0) { CHECKA(SP - 1); *--SP = -10; goto throw; }
  47.  
  48. {
  49.     CELL temp, i;
  50.  
  51.     I = (BYTE)A;  ARSHIFT(A, 8);
  52.     switch (I) {
  53.         case O_NEXT00:
  54.         case O_NEXTFF: NEXTC; break;
  55.         case O_DUP: CHECKA(SP - 1); CHECKA(SP); SP--; *SP = *(SP + 1); break;
  56.         case O_DROP: SP++; break;
  57.         case O_SWAP: CHECKA(SP); CHECKA(SP + 1); temp = *SP; *SP = *(SP + 1);
  58.             *(SP + 1) = temp; break;
  59.         case O_OVER: CHECKA(SP - 1); CHECKA(SP + 1); SP--; *SP = *(SP + 2);
  60.             break;
  61.         case O_ROT: CHECKA(SP); CHECKA(SP + 1); CHECKA(SP + 2);
  62.             temp = *(SP + 2); *(SP + 2) = *(SP + 1); *(SP + 1) = *SP;
  63.             *SP = temp; break;
  64.         case O_NROT: CHECKA(SP); CHECKA(SP + 1); CHECKA(SP + 2); temp = *SP;
  65.             *SP = *(SP + 1); *(SP + 1) = *(SP + 2); *(SP + 2) = temp; break;
  66.         case O_TUCK: CHECKA(SP - 1); CHECKA(SP); CHECKA(SP + 1); SP--;
  67.             *SP = *(SP + 1); *(SP + 1) = *(SP + 2); *(SP + 2) = *SP; break;
  68.         case O_NIP: CHECKA(SP); CHECKA(SP + 1); SP++; *SP = *(SP - 1); break;
  69.         case O_PICK: CHECKA(SP); CHECKA(SP + *SP + 1); *SP = *(SP + *SP + 1);
  70.             break;
  71.         case O_ROLL: CHECKA(SP); CHECKA(SP + *SP + 1); temp = *(SP + *SP + 1);
  72.             for (i = *SP; i > 0; i--) *(SP + i + 1) = *(SP + i); *++SP = temp;
  73.             break;
  74.         case O_QDUP: CHECKA(SP - 1); CHECKA(SP); if (*SP != 0)
  75.             { SP--; *SP = *(SP + 1); } break;
  76.         case O_TOR: CHECKA(RP - 1); CHECKA(SP); *--RP = *SP++; break;
  77.         case O_RFROM: CHECKA(SP - 1); CHECKA(RP); *--SP = *RP++; break;
  78.         case O_RFETCH: CHECKA(SP - 1); CHECKA(RP); *--SP = *RP; break;
  79.         case O_LESS: CHECKA(SP); CHECKA(SP + 1); SP++;
  80.             *SP = (*SP < *(SP - 1) ? B_TRUE : B_FALSE); break;
  81.         case O_GREATER: CHECKA(SP); CHECKA(SP + 1); SP++;
  82.             *SP = (*SP > *(SP - 1) ? B_TRUE : B_FALSE); break;
  83.         case O_EQUAL: CHECKA(SP); CHECKA(SP + 1); SP++;
  84.             *SP = (*SP == *(SP - 1) ? B_TRUE : B_FALSE); break;
  85.         case O_NEQUAL: CHECKA(SP); CHECKA(SP + 1); SP++;
  86.             *SP = (*SP != *(SP - 1) ? B_TRUE : B_FALSE); break;
  87.         case O_LESS0: CHECKA(SP); *SP = (*SP < 0 ? B_TRUE : B_FALSE); break;
  88.         case O_GREATER0: CHECKA(SP); *SP = (*SP > 0 ? B_TRUE : B_FALSE); break;
  89.         case O_EQUAL0: CHECKA(SP); *SP = (*SP == 0 ? B_TRUE : B_FALSE); break;
  90.         case O_NEQUAL0: CHECKA(SP); *SP = (*SP != 0 ? B_TRUE : B_FALSE); break;
  91.         case O_ULESS: CHECKA(SP); CHECKA(SP + 1); SP++;
  92.             *SP = ((UCELL)*SP < (UCELL)*(SP - 1) ? B_TRUE : B_FALSE); break;
  93.         case O_UGREATER: CHECKA(SP); CHECKA(SP + 1); SP++;
  94.             *SP = ((UCELL)*SP > (UCELL)*(SP - 1) ? B_TRUE : B_FALSE); break;
  95.         case O_ZERO: CHECKA(SP - 1); *--SP = 0; break;
  96.         case O_ONE: CHECKA(SP - 1); *--SP = 1; break;
  97.         case O_MONE: CHECKA(SP - 1); *--SP = -1; break;
  98.         case O_CELL: CHECKA(SP - 1); *--SP = CELL_W; break;
  99.         case O_MCELL: CHECKA(SP - 1); *--SP = -CELL_W; break;
  100.         case O_PLUS: CHECKA(SP); CHECKA(SP + 1); SP++; *SP += *(SP - 1); break;
  101.         case O_MINUS: CHECKA(SP); CHECKA(SP + 1); SP++; *SP -= *(SP - 1); break;
  102.         case O_SWAPMINUS: CHECKA(SP); CHECKA(SP + 1); SP++;
  103.             *SP = *(SP - 1) - *SP; break;
  104.         case O_PLUS1: CHECKA(SP); *SP += 1; break;
  105.         case O_MINUS1: CHECKA(SP); *SP -= 1; break;
  106.         case O_PLUSCELL: CHECKA(SP); *SP += CELL_W; break;
  107.         case O_MINUSCELL: CHECKA(SP); *SP -= CELL_W; break;
  108.         case O_STAR: CHECKA(SP); CHECKA(SP + 1); SP++; *SP *= *(SP - 1); break;
  109.         case O_SLASH: CHECKA(SP); CHECKA(SP + 1); DIVZERO(*SP); SP++;
  110.             *SP = DIV(*SP, *(SP - 1)); break;
  111.         case O_MOD: CHECKA(SP); CHECKA(SP + 1); DIVZERO(*SP); SP++;
  112.             *SP = MOD(*SP, *(SP - 1), temp); break;
  113.         case O_SLASHMOD: CHECKA(SP); CHECKA(SP + 1); DIVZERO(*SP);
  114.             temp = MOD(*(SP + 1), *SP, i);
  115.             *SP = DIV(*(SP + 1), *SP); *(SP + 1) = temp; break;
  116.         case O_USLASHMOD: CHECKA(SP); CHECKA(SP + 1); DIVZERO(*SP);
  117.             temp = (UCELL)*(SP + 1) % (UCELL)*SP;
  118.             *SP = (UCELL)*(SP + 1) / (UCELL)*SP; *(SP + 1) = (UCELL)temp; break;
  119.         case O_SSLASHREM: CHECKA(SP); CHECKA(SP + 1); DIVZERO(*SP);
  120.             temp = SMOD(*(SP + 1), *SP, i);
  121.             *SP = SDIV(*(SP + 1), *SP); *(SP + 1) = temp; break;
  122.         case O_SLASH2: CHECKA(SP); ARSHIFT(*SP, 1); break;
  123.         case O_CELLS: CHECKA(SP); *SP *= CELL_W; break;
  124.         case O_ABS: CHECKA(SP); if (*SP < 0) *SP = -*SP; break;
  125.         case O_NEGATE: CHECKA(SP); *SP = -*SP; break;
  126.         case O_MAX: CHECKA(SP); CHECKA(SP + 1); SP++;
  127.             *SP = (*(SP - 1) > *SP ? *(SP - 1) : *SP); break;
  128.         case O_MIN: CHECKA(SP); CHECKA(SP + 1); SP++;
  129.             *SP = (*(SP - 1) < *SP ? *(SP - 1) : *SP); break;
  130.         case O_INVERT: CHECKA(SP); *SP = ~*SP; break;
  131.         case O_AND: CHECKA(SP); CHECKA(SP + 1); SP++; *SP &= *(SP - 1); break;
  132.         case O_OR: CHECKA(SP); CHECKA(SP + 1); SP++; *SP |= *(SP - 1); break;
  133.         case O_XOR: CHECKA(SP); CHECKA(SP + 1); SP++; *SP ^= *(SP - 1); break;
  134.         case O_LSHIFT: CHECKA(SP); CHECKA(SP + 1); SP++;
  135.             *(SP - 1) < 32 ? (*SP <<= *(SP - 1)) : (*SP = 0); break;
  136.         case O_RSHIFT: CHECKA(SP); CHECKA(SP + 1); SP++;
  137.             *(SP - 1) < 32 ? (*SP = (CELL)((UCELL)(*SP) >> *(SP - 1))) :
  138.             (*SP = 0); break;
  139.         case O_LSHIFT1: CHECKA(SP); *SP <<= 1; break;
  140.         case O_RSHIFT1: CHECKA(SP); *SP = (CELL)((UCELL)(*SP) >> 1); break;
  141.         case O_FETCH: CHECKA(SP); CHECKA(*SP + M0); *SP = *(CELL *)(*SP + M0);
  142.             break;
  143.         case O_STORE: CHECKA(SP); CHECKA(SP + 1); CHECKA(*SP + M0);
  144.             *(CELL *)(*SP + M0) = *(SP + 1); SP += 2; break;
  145.         case O_CFETCH: CHECKA(SP); CHECKC(FLIP(*SP) + M0);
  146.             *SP = (CELL)*(FLIP(*SP) + M0); break;
  147.         case O_CSTORE: CHECKA(SP); CHECKA(SP + 1); CHECKC(FLIP(*SP) + M0);
  148.             *(FLIP(*SP) + M0) = (BYTE)*(SP + 1); SP += 2; break;
  149.         case O_PSTORE: CHECKA(SP); CHECKA(SP + 1); CHECKA(*SP + M0);
  150.             *(CELL *)(*SP + M0) += *(SP + 1); SP += 2; break;
  151.         case O_SPFETCH: CHECKA(SP - 1); SP--;
  152.             *SP = (CELL)((BYTE *)SP - M0) + CELL_W; break;
  153.            case O_SPSTORE: CHECKA(SP); SP = (CELL *)(*SP + M0); break;
  154.         case O_RPFETCH: CHECKA(SP - 1); *--SP = (CELL)((BYTE *)RP - M0); break;
  155.      case O_RPSTORE: CHECKA(SP); RP = (CELL *)(*SP++ + M0); break;
  156.      case O_BRANCH: CHECKA(EP); EP = (CELL *)(*EP + M0); NEXTC; break;
  157.      case O_BRANCHI: EP += A; NEXTC; break;
  158.      case O_QBRANCH: CHECKA(SP); CHECKA(EP); if (*SP++ == B_FALSE)
  159.          { EP = (CELL *)(*EP + M0); NEXTC; } else EP++; break;
  160.      case O_QBRANCHI: CHECKA(SP); if (*SP++ == B_FALSE) EP += A; NEXTC;
  161.          break;
  162.      case O_EXECUTE: CHECKA(RP - 1); CHECKA(SP);
  163.          *--RP = (CELL)((BYTE *)EP - M0); EP = (CELL *)(*SP++ + M0); NEXTC;
  164.          break;
  165.      case O_FEXECUTE: CHECKA(RP - 1); CHECKA(SP); CHECKA(*SP + M0);
  166.          *--RP = (CELL)((BYTE *)EP - M0);
  167.          EP = (CELL *)(*(CELL *)(*SP++ + M0) + M0); NEXTC; break;
  168.      case O_CALL: CHECKA(RP - 1); CHECKA(EP);
  169.          *--RP = (CELL)((BYTE *)EP - M0) + CELL_W; EP = (CELL *)(*EP + M0);
  170.          NEXTC; break;
  171.      case O_CALLI: CHECKA(RP - 1); *--RP = (CELL)((BYTE *)EP - M0); EP += A;
  172.          NEXTC; break;
  173.      case O_EXIT: CHECKA(RP); EP = (CELL *)(*RP++ + M0); NEXTC; break;
  174.      case O_DO: CHECKA(RP - 1); CHECKA(RP - 2); CHECKA(SP); CHECKA(SP + 1);
  175.          *--RP = *(SP + 1); *--RP = *SP++; SP++; break;
  176.      case O_LOOP: CHECKA(RP); CHECKA(RP + 1); CHECKA(EP); (*RP)++;
  177.          if (*RP == *(RP + 1)) { RP += 2; EP++; }
  178.          else { EP = (CELL *)(*EP + M0); NEXTC; } break;
  179.      case O_LOOPI: CHECKA(RP); CHECKA(RP + 1); (*RP)++; if (*RP == *(RP + 1))
  180.          RP += 2; else EP += A; NEXTC; break;
  181.      case O_PLOOP: CHECKA(RP); CHECKA(RP + 1); CHECKA(SP); CHECKA(EP);
  182.          temp = *RP - *(RP + 1); *RP += *SP++; if ((*RP - *(RP + 1)
  183.          ^ temp) < 0) { RP += 2; EP++; } else { EP = (CELL *)(*EP + M0);
  184.          NEXTC; } break;
  185.      case O_PLOOPI: CHECKA(RP); CHECKA(RP + 1); CHECKA(SP);
  186.          temp = *RP - *(RP + 1); *RP += *SP++; if ((*RP - *(RP + 1) ^ temp)
  187.          < 0) RP += 2; else EP += A; NEXTC; break;
  188.      case O_UNLOOP: RP += 2; break;
  189.      case O_J: CHECKA(SP - 1); CHECKA(RP + 2); *--SP = *(RP + 2); break;
  190.      case O_LITERAL: CHECKA(SP - 1); CHECKA(EP); *--SP = *EP++; break;
  191.      case O_LITERALI: CHECKA(SP - 1); *--SP = A; NEXTC; break;
  192. throw:    case O_THROW: *(CELL *)(M0 + 8) = BAD = (CELL)((BYTE *)EP - M0);
  193.             temp = (UCELL)*THROW; if ((UCELL)temp >= MEMORY
  194.             || (unsigned int)temp & 3) return -259;
  195.             EP = (CELL *)(temp + M0); NEXTC; break;
  196.      case O_HALT: CHECKA(SP); return (*SP++);
  197.      case O_CREATE: CHECKA(SP - 1); *--SP = (CELL)((BYTE *)EP - M0); break;
  198.      case O_LIB: CHECKA(SP); CHECKA(SP - 1); if ((UCELL)(*SP) > 12)
  199.          { *--SP = -257; goto throw; } else lib((UCELL)*SP++); break;
  200.      case O_OS: break;
  201.      case O_LINK: CHECKA(SP); LINK; break;
  202.      case O_RUN: break;
  203.      case O_STEP: break;
  204.         default: CHECKA(SP - 1); *--SP = -256; goto throw;
  205.     }
  206. }
  207.