/*
 * forth.c
 * 
 * Portable FORTH interpreter in C
 *
 * Author: Allan Pratt, Indiana University (iuvax!apratt)
 *         Spring, 1984
 * References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
 *         in the world...)
 *
 * This program is intended to be compact, portable, and pretty complete.
 * It is also intended to be in the public domain, and distribution should
 * include this notice to that effect.
 *
 * This file contains the support code for all interpreter functions.
 * the file prims.c contains code for the C-coded primitives, and the
 * file forth.h connects the two with definitions.
 *
 * The program nf.c generates a new forth.core file from the dictionary
 * forth.dict, using common.h to tie it together with this program.
 */
 

#include <stdio.h>
#ifndef AMIGA
#include <signal.h>
#endif

#include <ctype.h>	/* only for isxdigit */

#include "common.h"

#include "forth.h"

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

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

unsigned short csp, rsp, ip, w;
short *mem;
int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
int nobuf;
FILE *blockfile;
long bfilesize;
char *bfilename;	/* block file name (change with -f ) */
char *cfilename;	/* core file name  (change with -l ) */
char *sfilename;	/* save file name  (change with -s ) */

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

errexit(s,p1,p2)		/* An error occurred -- clean up (?) and
				   exit. */
{
    printf(s,p1,p2);
    printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
    fflush(stdout);
    memdump();
    puts("done.");
    exit(1);
}

Callot (n)			/* allot n words in the dictionary */
short n;
{
    unsigned newsize;

    mem[DP] += n;			/* move DP */
    if (mem[DP] + GULPFRQ > mem[LIMIT]) {	/* need space */
	newsize = mem[DP] + GULPSIZE;
	if (newsize > MAXMEM && MAXMEM)
		errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);
#ifdef AMIGA
    	/*
    	 * Fake realloc by doing a malloc and copy to the new area.
    	 * Since we are always just growing the area, this should work.
    	 * Note that this has the disadvantage of requiring at least 2N
	 * bytes to grow an area of N bytes.
    	 */
    	{
    		register char *new, *out;
    		register char *in = mem;
    		register int count = mem[LIMIT];
    		new = out = (short *) malloc ((char *)mem, newsize*sizeof(*mem));
		if (new == NULL)
			errexit("REALLOC FAILED\n");
    		while (count-- > 0) {
			*out++ = *in++;
		}
    		free (mem);
    		mem = new;
    	}
#else
	mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
	if (mem == NULL)
		errexit("REALLOC FAILED\n");
#endif	/* AMIGA */
	mem[LIMIT] = newsize;
    }
}

push(v)			/* push value v to cstack */
short v;
{
    if (csp <= TIB_END)
	errexit("PUSH TO FULL CALC. STACK\n");
    mem[--csp] = v;
}

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

rpush(v)
short v;
{
    if (rsp <= INITS0)
	errexit("PUSH TO FULL RETURN STACK");
    mem[--rsp] = v;
}

short rpop()
{
    if (rsp >= INITR0)
	errexit("POP FROM EMPTY RETURN STACK!");
    return (mem[rsp++]);
}

pkey()			/* (KEY) -- wait for a key & return it */
{
    int c;
    if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
    return(c);
}

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

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

next()			/* instruction processor: control goes here
				   almost right away, and cycles through here
				   until you leave. */

/* 
 * 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;
	
    while (1) {
	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 = mem[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 = mem[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(); 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;
	case TRON	:  tron(); break;
	case TROFF	:  troff(); break;
	case DOTRACE	:  dotrace(); break;
	case PRSLW	:  prslw(); break;
	case PSAVE	:  psave(); break;
	case PCOLD	:  pcold(); break;
	default		:  errexit("Bad execute-code %d\n",p); break;
	}
    }
}

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) mem[worka++]);
		putchar(')');
	}
	printf(" ip=%04x ",ip);

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

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

main(argc,argv)
int argc;
char *argv[];
{
	FILE *fp;
	unsigned short size;
	int i = 1;

	cfilename = COREFILE;	/* "forth.core" */
	bfilename = BLOCKFILE;	/* "forth.block" */
	sfilename = SAVEFILE;	/* "forth.newcore" */
	trace = debug = breakenable = nobuf = 0;

	while (i < argc) {
		if (*argv[i] == '-') {
			switch (*(argv[i]+1)) {
#ifdef TRACE
			case 'd':			/* -d[n] */
				debug = 1;	/* ...and fall through */
			case 't':			/* -t[n] */
				trace = TRUE;
				if (argv[i][2])
					tracedepth = (argv[i][2] - '0');
				else tracedepth = 0;
				break;
#else !TRACE
			case 'd':
			case 't':
				fprintf(stderr,
		"Must compile with TRACE defined for -t or -d\n");
				break;
#endif TRACE
			case 'c': if (++i == argc) usage(argv[0]);
				  cfilename = argv[i];		/* -c file */
				  break;
			case 's': if (++i == argc) usage(argv[0]);
				  sfilename = argv[i];		/* -s file */
				  break;
#ifdef BREAKPOINT
			case 'p': if (++i == argc) usage(argv[0]);
				  breakenable = TRUE;	/* -p xxxx */
				  breakpoint = xtoi(argv[i]);
				  break;
#else !BREAKPOINT
			case 'p': fprintf(stderr,
		"Must compile with BREAKPOINT defined for -p");
				  break;
#endif BREAKPOINT
			case 'b': if (++i == argc) usage();
				  bfilename = argv[i]; /* -b blockfile */
				  break;
			case 'n': nobuf = TRUE;
				  break;
			default: usage(argv[0]);
				 exit(1);
			}
		}
		else usage(argv[0]);		/* not a dash */
		i++;
	}

	if ((fp = fopen(cfilename,"r")) == NULL) {
		fprintf(stderr,"Forth: Could not open %s\n", cfilename);
		exit(1);
	}
	if (fread(&size, sizeof(size), 1, fp) != 1) {
		fprintf(stderr,"Forth: %s is empty.\n",cfilename);
		exit(1) ;
	}

	if ((mem = (short *)calloc(size, sizeof(*mem))) == NULL) {
		fprintf(stderr, "Forth: unable to malloc(%d,%d)\n",
			size, sizeof(*mem));
		exit(1);
	}

	mem[LIMIT] = size;

	if (fread(mem+1, sizeof(*mem), size-1, fp) != size-1) {
		fprintf(stderr, "Forth: not %d bytes on %s.\n",
			size, cfilename);
		exit(1);
	}

	fclose(fp);

	initsignals();

	getblockfile();

	if (!nobuf) setbuf(stdout,NULL);

	if (ip = mem[SAVEDIP]) {	/* if savedip != 0, that is */
		csp = mem[SAVEDSP];
		rsp = mem[SAVEDRP];
		puts("restarting a saved FORTH image");
	}
	else {
		ip = mem[COLDIP];	/* this is the ip passed from nf.c */
			/* ip now points to a word holding the CFA of COLD */
		rsp = INITR0;		/* initialize return stack */
		csp = INITS0;
	}
	next();
	/* never returns */
}

usage(s)
char *s;
{
	fprintf(stderr, "usage:\n");
	fprintf(stderr, "%s [-t[n]] [-d[n]] [-p xxxx] [-n]\n",s);
	fputs(stderr, "\t[-c corename] [-b blockname] [-s savename]\n");
	fputs(stderr, "Where:\n");
	fputs(stderr,
"-t[n]\t\tsets trace mode\n");
	fputs(stderr,
"-d[n]\t\tsets trace mode and debug mode (waits for newline)");
	fputs(stderr,
"\t\t[n] above sets stack depth to display. Single digit, 0-9. Default 0.\n");
	fputs(stderr,
"-p xxxx\t\tsets a breakpoint at xxxx (in hex), shows stack when reached\n");
	fputs(stderr,
"-n\t\tleaves stdout line-buffered\n");
	fprintf(stderr,
"-c corename\tuses corename as the core image (default %s without -c)\n",
		COREFILE);
	fprintf(stderr,
"-b blockname\tuses blockname as the blockfile (default %s without -b)\n",
		BLOCKFILE);
	fprintf(stderr,
"-s savename\tuses savename as the save-image file (default %s without -s)\n",
		SAVEFILE);
}

memdump()		/* dump core. */
{
	int i;	/* top of RAM */
	int temp, tempb, firstzero, nonzero;
	char chars[9], outline[80], tstr[6];
	FILE *dumpfile;

	dumpfile = fopen(DUMPFILE,"w");

	fprintf(dumpfile,
		"CSP = 0x%x  RSP = 0x%x  IP = 0x%x  W = 0x%x  DP = 0x%x\n",
		csp, rsp, ip, w, mem[DP]);

	for (temp = 0; temp < mem[LIMIT]; temp += 8) {
		nonzero = FALSE;
		sprintf(outline, "%04x:", temp);
		for (i=temp; i<temp+8; i++) {
			sprintf(tstr," %04x", (unsigned short)mem[i]);
			strcat(outline, tstr);
			tempb = mem[i] & 0x7f;
			if (tempb < 0x7f && tempb >= ' ')
				chars[i%8] = tempb;
			else
				chars[i%8] = '.';
			nonzero |= mem[i];
		}
		if (nonzero) {
			fprintf(dumpfile,"%s %s\n",outline,chars);
			firstzero = TRUE;
		}
		else if (firstzero) {
			fprintf(dumpfile, "----- ZERO ----\n");
			firstzero = FALSE;
		}
	}
	fclose(dumpfile);
}

/* here is where ctype.h is used */

xtoi(s)
char *s;
{				/*  convert hex ascii to integer */
    int temp = 0;

    while (isxdigit (*s)) {	/* first non-hex char ends */
	temp <<= 4;		/* mul by 16 */
	if (isupper (*s))
	    temp += (*s - 'A') + 10;
	else
	    if (islower (*s))
		temp += (*s - 'a') + 10;
	    else
		temp += (*s - '0');
	s++;
    }
    return temp;
}

/*
 * Interrupt (^C) handling: If the user hits ^C once, the next pqterm call
 * will return TRUE. If he hits ^C again before pqterm is called, there will
 * be a forced jump to ABORT next time we hit next(). If it is a primitive
 * that is caught in an infinite loop, this won't help any.
 */

sig_int()
{
	if (qtermflag) {		/* second time? */
		forceip = mem[ABORTIP];	/* checked each time through next */
		qtermflag = FALSE;
		trace = FALSE;		/* stop tracing; reset */
	}
	else qtermflag = TRUE;
}

initsignals()
{
#ifdef AMIGA
	/* just ignore it for now, maybe it will go away :-) */
#else
	signal(SIGINT,sig_int);
#endif
}

getblockfile()
{
	/* recall that opening with mode "a+" opens for reading and writing */
	/* with the pointer positioned at the end; this is so ftell returns */
	/* the size of the file.					    */

	if ((blockfile = fopen(bfilename, "a+")) == NULL)
		errexit("Can't open blockfile \"%s\"\n", bfilename);
	bfilesize = ftell(blockfile);

	printf("Block file has %d blocks.\n",(int) (bfilesize/1024) - 1);
}