/*****************************************************************************

			      PilotForth

      Copyright (C) 1997, Ivan A. Curtis.  All rights reserved.

			       based on
C-FORTH: a portable, C-coded figFORTH interpreter by Allan Pratt April 1985.

This program may not be redistibuted in part or in whole without this Copyright
Message being included at the top of each file.

   This is free software, licensed under the GNU Public License V2.
		  See the file COPYING for details.

*******************************************************************************
*******************************************************************************

Filename:	Forth/exec.c

Description:	execution core of PilotForth

Update History:   (most recent first)
   I. Curtis  15-May-97 20:59 -- v0.1 Released.
   I. Curtis  30-Apr-97 21:14 -- Created.

******************************************************************************/
#pragma pack(2) 
#include "stdio.h"
#include <Common.h>
#include <System/SysAll.h>
#include <UI/UIAll.h>

#include "common.h"
#include "exec.h"
#include "prims.h"	/* macro-defined primitives */
#include "memory.h"

/* declare globals which are defined in forth.h */

unsigned short csp, rsp, ip, w;
short debug, qtermflag, forceip;

#ifdef TRACE
int trace, tracedepth;
#endif

#ifdef BREAKPOINT
int breakenable, breakpoint;
#endif

/*
             ----------------------------------------------------
                               SYSTEM FUNCTIONS
             ----------------------------------------------------
*/


/*
 * An error occurred -- clean up (?) and
 * exit
 */
void errexit(char *s, int p1, int p2)
{
    printf(s, p1, p2);
    printf("\nABORT FORTH!\n");
#ifdef WANT_MEMDUMP
    printf("Dumping to %s... ", DUMPFILE);
    fflush(stdout);
    memdump();
    puts("done.");
#endif
    ErrDisplay(s);
}

void push(short v)			/* push value v to cstack */
{
  if (csp <= TIB_END) {
    errexit("PUSH TO FULL CALC. STACK", 0, 0);
  }
  fth_mstore(--csp, v);
}

short pop(void)			/* pop a value from comp. stack, and return
				   it as the value of the function */
{
  if (csp >= INITS0) {
    puts("Empty Stack!");
    return 0;
  }
  return fth_mfetch(csp++);
}

void rpush(short v)
{
  if (rsp <= INITS0) {
    errexit("PUSH TO FULL RETURN STACK", 0, 0);
  }
  fth_mstore(--rsp, v);
}

short rpop(void)
{
  if (rsp >= INITR0)
    errexit("POP FROM EMPTY RETURN STACK!", 0, 0);
  return fth_mfetch(rsp++);
}

short pkey(void)		/* (KEY) -- wait for a key & return it */
{
  return 32;
}

void pqterm(void)			/* (?TERMINAL): 
					return true if BREAK has been hit */
{
  if (qtermflag) {
    push(TRUE);
    qtermflag = FALSE;	/* this influences ^C handling */
  } else {
    push(FALSE);
  }
}

void pemit(void)		/* (EMIT): c --	emit a character */
{
  /* printf("%c", pop() & 0x7f); */
  putchar(pop() & 0x7f);	/* stdout is unbuffered */
}

extern short waitkey;
extern short keypressed;

/* instruction processor: control goes here
   almost right away, and cycles through here
   until you leave. */
void next(void)
/* 
 * This is the big kabloona. What it does is load the value at mem[ip]
 * into w, increment ip, and invoke prim. number w. This implies that
 * mem[ip] is the CFA of a word. What's in the CF of a word is the number
 * of the primitive which should be executed. For a word written in FORTH,
 * that primitive is "docol", which pushes ip to the return stack, then
 * uses w+2 (the PFA of the word) as the new ip.  See "interp.doc" for
 * more.
 */

/*
 * There is an incredible hack going on here: the SPECIAL CASE mentioned in
 * the code is for the word EXECUTE, which must set W itself and jump INSIDE
 * the "next" loop, by-passing the first instruction. This has been made a
 * special case: if the primitive to execute is zero, the special case is
 * invoked, and the code for EXECUTE is put right in the NEXT loop. For this
 * reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
 */
{
  short p;

  if (waitkey) {
    if (keypressed != -1) {
      putchar(8);
      push(keypressed);
      keypressed = -1;
      waitkey = false;
    } else {
      return;
    }
  }

  if (forceip) {		/* force ip to this value -- used by sig_int */
    ip = forceip;
    forceip = FALSE;
  }
#ifdef TRACE
  if (trace) dotrace();
#endif TRACE

#ifdef BREAKPOINT
  if (breakenable && ip == breakpoint) dobreak();
#endif BREAKPOINT

  w = fth_mfetch(ip);
  ip++;
				/* w, mem, and ip are all global. W is now
				   a POINTER TO the primitive number to 
				   execute, and ip points to the NEXT thread to
				   follow. */

 next1:				/* This is for the SPECIAL CASE */
  p = fth_mfetch(w);		/* p is the actual number of the primitive */
  if (p == 0) {		/* SPECIAL CASE FOR EXECUTE! */
    w = pop();		/* see above for explanation */
    goto next1;
  }
  /* else */
  switch(p) {
  case LIT	:  lit(); break;
  case BRANCH	:  branch(); break;
  case ZBRANCH:  zbranch(); break;
  case PLOOP	:  ploop(); break;
  case PPLOOP	:  pploop(); break;
  case PDO	:  pdo(); break;
  case I	:  i(); break;
  case R	:  r(); break;
  case DIGIT	:  digit(); break;
  case PFIND	:  pfind(); break;
  case ENCLOSE:  enclose(); break;
  case KEY	:  /* key() */ putchar('_'); waitkey = true; break;
  case PEMIT	:  pemit(); break;
  case QTERMINAL	:  qterminal(); break;
  case CMOVE	:  cmove(); break;
  case USTAR	:  ustar(); break;
  case USLASH	:  uslash(); break;
  case AND	:  and(); break;
  case OR	:  or(); break;
  case XOR	:  xor(); break;
  case SPFETCH	:  spfetch(); break;
  case SPSTORE	:  spstore(); break;
  case RPFETCH	:  rpfetch(); break;
  case RPSTORE	:  rpstore(); break;
  case SEMIS	:  semis(); break;
  case LEAVE	:  leave(); break;
  case TOR	:  tor(); break;
  case FROMR	:  fromr(); break;
  case ZEQ	:  zeq(); break;
  case ZLESS	:  zless(); break;
  case PLUS	:  plus(); break;
  case DPLUS	:  dplus(); break;
  case MINUS	:  minus(); break;
  case DMINUS	:  dminus(); break;
  case OVER	:  over(); break;
  case DROP	:  drop(); break;
  case SWAP	:  swap(); break;
  case DUP	:  dup(); break;
  case TDUP	:  tdup(); break;
  case PSTORE	:  pstore(); break;
  case TOGGLE	:  toggle(); break;
  case FETCH	:  fetch(); break;
  case CFETCH	:  cfetch(); break;
  case TFETCH	:  tfetch(); break;
  case STORE	:  store(); break;
  case CSTORE	:  cstore(); break;
  case TSTORE	:  tstore(); break;
  case DOCOL	:  docol(); break;
  case DOCON	:  docon(); break;
  case DOVAR	:  dovar(); break;
  case DOUSE	:  douse(); break;
  case SUBTRACT	:  subtract(); break;
  case EQUAL	:  equal(); break;
  case NOTEQ	:  noteq(); break;
  case LESS	:  less(); break;
  case ROT	:  rot(); break;
    /*    case DODOES	:  dodoes(); break; */
    /*    case DOVOC	:  dovoc(); break; */
  case ALLOT	:  allot(); break;
    /*    case PBYE	:  pbye(); break; */
#ifdef TRACE
  case TRON	:  tron(); break;
  case TROFF	:  troff(); break;
  case DOTRACE	:  dotrace(); break;
#endif
  case PRSLW	:  prslw(); break;
#ifdef WANT_PSAVE
  case PSAVE	:  psave(); break;
#endif
  case PCOLD	:  pcold(); break;
  default:
    errexit("Bad execute-code %d\n", p, 0);
    break;
  }
}

#ifdef TRACE
dotrace()
{
	short worka, workb, workc;
	putchar('\n');
	if (tracedepth) {		/* show any stack? */
		printf("sp: %04x (", csp);
		worka = csp;
		for (workb = tracedepth; workb; workb--)
			printf("%04x ",(unsigned short) fth_mfetch(worka++));
		putchar(')');
	}
	printf(" ip=%04x ",ip);

	if (fth_mfetch(R0) - rsp < RS_SIZE && 
	    fth_mfetch(R0) - rsp > 0) /* if legal rsp */
	    for (worka = fth_mfetch(R0) - rsp; worka; worka--) { /* indent */
		putchar('>');
		putchar(' ');
	    }
	worka = fth_mfetch(ip) - 3; /* this is second-to-last letter, or
					   the count byte */
	while (!(fth_mfetch(worka) & 0x80)) worka--; /* skip back to count byte */
	workc = fth_mfetch(worka) & 0x2f;		/* workc is count value */
	worka++;
	while (workc--) putchar(fth_mfetch(worka++) & 0x7f);
	fflush(stdout);
	if (debug) {		/* wait for \n -- any other input will dump */
		char buffer[10];
		if (*gets(buffer) != '\0') {
#ifdef WANT_MEMDUMP
			printf("dumping core... ");
			fflush(stdout);
			memdump();
			puts("done.");
#endif
		}
	}
}
#endif

#ifdef BREAKPOINT
dobreak()
{
	int temp;
	puts("Breakpoint.");
	printf("Stack pointer = %x:\n",csp);
	for (temp = csp; temp < INITS0; temp++)
		printf("\t%04x", fth_mfetch(temp));
	putchar('\n');
}
#endif BREAKPOINT
