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

			      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/prims.c

Description:	code for the primitive functions 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 <ctype.h>	/* used in "digit" */
#include "common.h"
#include "exec.h"
#include "prims.h"	/* macro primitives */
#include "memory.h"

/*
             ----------------------------------------------------
                            PRIMITIVE DEFINITIONS
             ----------------------------------------------------
*/

void zbranch(void)		/* add an offset (branch) if tos == 0 */
{
  if(pop() == 0) {
    ip += fth_mfetch(ip);
  } else {
    ip++;			/* else skip over the offset */
  }
}

void ploop(void)		/* (loop) -- loop control */
{
  short index, limit;
  index = rpop() + 1;
  limit = rpop();
  if(index < limit) {		/* if the new index < the limit */
    rpush(limit);		/* restore the limit */
    rpush(index);		/* and the index (incremented) */
    branch();			/* and go back to the top of the loop */
  } else {
    ip++;			/* skip over the offset, and exit, having */
  }				/* popped the limit & index */
}

void pploop(void)		/* (+loop) -- almost the same */
{
  short index, limit;
  index = rpop() + pop();	/* get index & add increment */
  limit = rpop();
  if(index < limit) {		/* if new index < limit */
    rpush(limit);		/* restore the limit */
    rpush(index);		/* restore the new index */
    branch();			/* and branch back to the top */
  } else {
    ip++;			/* skip over branch offset */
  }
}

void pdo(void)			/* (do): limit init -- [pushed to rstack] */
{
  swap();
  rpush(pop());
  rpush(pop());
}

void i(void)			/* copy top of return stack to cstack */
{
  short tmp;
  tmp = rpop();
  rpush(tmp);
  push(tmp);
}

void r(void)			/* this must be a primitive as well as I */
				/* because otherwise it always returns */
				/* its own address */
{
  i();
}

void digit(void)		/* digit: c -- FALSE or [v TRUE] */
{
  short c, base;		/* C is ASCII char, convert to val. BASE is
				   used for range checking */
  base = pop();
  c = pop();
  if (!isascii(c)) {
    push(FALSE);
    return;
  }
 				/* lc -> UC if necessary */
  if (islower(c)) {
    c = toupper(c);
  }

  if (c < '0' || (c > '9' && c < 'A') || c > 'Z') {
    push(FALSE);		/* not a digit */
  } else {			/* it is numeric or UC Alpha */
    if (c >= 'A') {
      c -= 7;			/* put A-Z right after 0-9 */
    }
    c -= '0';			/* now c is 0..35 */

    if (c >= base) {
      push(FALSE);		/* FALSE - not a digit */
    } else {			/* OKAY: push value, then TRUE */
      push(c);
      push(TRUE);
    }
  }
}

void pfind(void) /* WORD TOP -- xx FLAG, where TOP is NFA to start at;
		   WORD is the word to find; xx is PFA of found word;
		   yy is actual length of the word found;
		   FLAG is 1 if found. If not found, 0 alone is stacked. */
{
  unsigned short  worka, workb, workc, current, word, match;

  current = pop();
  word = pop();
  while (current) {		/* stop at end of dictionary */
	if (!((fth_mfetch(current) ^ fth_mfetch(word)) & 0x3f)) {
				/* match lengths & smudge */
	    worka = current + 1;/* point to the first letter */
	    workb = word + 1;
	    workc = fth_mfetch(word);	/* workc gets count */
	    match = TRUE;	/* initally true, for looping */
	    while (workc-- && match)
		match = ((fth_mfetch(worka++) & 0x7f) == (fth_mfetch(workb++) & 0x7f));
	    if (match) {	/* exited with match TRUE -- FOUND IT */
		push (worka + 2);		/* worka=LFA; push PFA */
		push (fth_mfetch(current));		/* push length byte */
		push (TRUE);			/* and TRUE flag */
		return;
	    }
	}
	/* failed to match */
	/* follow link field to next word */
	current = fth_mfetch(current + (fth_mfetch(current) & 0x1f) + 1);
    }
    push (FALSE);		/* current = 0; end of dict; not found */
}

void enclose(void)
{
	short delim, current, offset;

	delim = pop();
	current = pop();
	push (current);

	offset = -1;
	current--;
encl1:
	current++;
	offset++;
	if (fth_mfetch(current) == delim) goto encl1;

	push(offset);
	if (fth_mfetch(current) == 0) {
	  offset++;
	  push(offset);
	  offset--;
	  push(offset);
	  return;
	}

encl2:
	current++;
	offset++;
	if (fth_mfetch(current) == delim) goto encl4;
	if (fth_mfetch(current) != 0) goto encl2;

	/* fth_mfetch(current) is null.. */
	push (offset);
	push (offset);
	return;

encl4:	/* found the trailing delimiter */
	push (offset);
	offset++;
	push (offset);
	return;
}

void cmove(void)			/* cmove: source dest number -- */
{
  short source, dest, number;
  number = pop();
  dest = pop();
  source = pop();
  for ( ; number ; number-- ) fth_mstore(dest++, fth_mfetch(source++));
}

void fill(void)			/* fill: c dest number -- */
{
    short dest, number, c;
    number = pop();
    dest = pop();
    c = pop();

    fth_mstore(dest, c);		/* always at least one */
    if (number == 1) return;	/* return if only one */

    push (dest);		/* else push dest as source of cmove */
    push (dest + 1);		/* dest+1 as dest of cmove */
    push (number - 1);		/* number-1 as number of cmove */
    cmove();
}

void ustar(void)		/* u*: a b -- a*b.hi a*b.lo */
{
    unsigned short a, b;
    unsigned long c;
    a = (unsigned short)pop();
    b = (unsigned short)pop();
    c = a * b;

    /* (short) -1 is probably FFFF, which is just what we want */
    push ((unsigned short)(c & (short) -1));	      /* low word of product */
						     /* high word of product */
    push ((short)((c >> (8*sizeof(short))) & (short) -1));
}

void uslash(void)		/* u/: NUM.LO NUM.HI DENOM -- REM QUOT */
{
    unsigned short numhi, numlo, denom;
    unsigned short quot, remainder;	/* the longs below are to be sure the
					   intermediate computation is done
					   long; the results are short */
    denom = pop();
    numhi = pop();
    numlo = pop();
    quot = ((((unsigned long)numhi) << (8*sizeof(short))) 
				+ (unsigned long)numlo) 
					/ (unsigned long)denom;

    remainder = ((((unsigned long)numhi) << (8*sizeof(short))) 
				+ (unsigned long)numlo) 
					% (unsigned long)denom;

    push (remainder);
    push (quot);
}

void swap(void)				/* swap: a b -- b a */
{
    short a, b;
    b = pop();
    a = pop();
    push (b);
    push (a);
}

void rot(void)				/* rotate */
{
    short a, b, c;
    a = pop ();
    b = pop ();
    c = pop ();
    push (b);
    push (a);
    push (c);
}

void tfetch(void)			/* 2@: addr -- mem[addr+1] mem[addr] */
{
    unsigned short addr;
    addr = pop();
    push (fth_mfetch(addr + 1));
    push (fth_mfetch(addr));
}

void store(void)		/* !: val addr -- <set mem[addr] = val> */
{
    unsigned short tmp;
    tmp = pop();
    fth_mstore(tmp, pop());
}

void cstore(void)			/* C!: val addr --  */
{
    store();
}

void tstore(void)			/* 2!: val1 val2 addr -- 
				   mem[addr] = val2,
				   mem[addr+1] = val1 */
{
    unsigned short tmp;
    tmp = pop();
    fth_mstore(tmp, pop());
    fth_mstore(tmp + 1, pop());
}

void leave(void)		/* set the index = the limit of a DO */
{
    short tmp;
    rpop();			/* discard old index */
    tmp = rpop();		/* and push the limit as */
    rpush(tmp);			/* both the limit */
    rpush(tmp);			/* and the index */
}

void dplus(void)				/* D+: double-add */
{
    short ahi, alo, bhi, blo;
    long a, b;
    bhi = pop();
    blo = pop();
    ahi = pop();
    alo = pop();
    a = ((long)ahi << (8*sizeof(short))) + (long)alo;
    b = ((long)bhi << (8*sizeof(short))) + (long)blo;
    a = a + b;
    push ((unsigned short)(a & (short) -1));	/* sum lo */
    push ((short)(a >> (8*sizeof(short))));	/* sum hi */
}

void subtract(void)			/* -: a b -- (a-b) */
{
    short tmp;
    tmp = pop();
    push (pop() - tmp);
}

void dsubtract(void)			/* D-: double-subtract */
{
    short ahi, alo, bhi, blo;
    long a, b;
    bhi = pop();
    blo = pop();
    ahi = pop();
    alo = pop();
    a = ((long)ahi << (8*sizeof(short))) + (long)alo;
    b = ((long)bhi << (8*sizeof(short))) + (long)blo;
    a = a - b;
    push ((unsigned short)(a & (short) -1));	/* diff lo */
    push ((short)(a >> (8*sizeof(short))));	/* diff hi */
}

void dminus(void)		/* DMINUS: negate a double number */
{
    unsigned short ahi, alo;
    long a;
    ahi = pop();
    alo = pop();
    a = -(((long)ahi << (8*sizeof(short))) + (long)alo);
    push ((unsigned short)(a & (short) -1));		/* -a lo */
    push ((unsigned short)(a >> (8*sizeof(short)))); 	/* -a hi */
}

void over(void)			/* over: a b -- a b a */
{
    short a, b;
    b = pop();
    a = pop();
    push (a);
    push (b);
    push (a);
}

void dup(void)			/* dup: a -- a a */
{
    short a;
    a = pop();
    push (a);
    push (a);
}

void tdup(void)			/* 2dup: a b -- a b a b */
{
    short a, b;
    b = pop();
    a = pop();
    push (a);
    push (b);
    push (a);
    push (b);
}

void pstore(void)		/* +!: val addr -- <add val to mem[addr]> */
{
    short addr, val;
    addr = pop();
    val = pop();
    fth_mstore(addr, fth_mfetch(addr) + val);
}

void toggle(void)		/* toggle: addr bits -- <xor mem[addr]
				   with bits, store in mem[addr]> */
{
    short bits, addr;
    bits = pop();
    addr = pop();
    fth_mstore(addr, fth_mfetch(addr) ^ bits);
}

void less(void)
{
    short tmp;
    tmp = pop();
    push (pop() < tmp);
}

void pcold(void)
{
  int i;
  csp = INITS0;		/* initialize values */
  rsp = INITR0;
  /* copy USER_DEFAULTS area into UP area */
  push (USER_DEFAULTS);	/* source */
  push (UP);			/* dest */
  push (DEFS_SIZE);		/* count */
  cmove();			/* move! */
  for (i = 32; i < 48; i++) {
    fth_mstore(i, 0);
  }
				/* returns, executes ABORT */
}

/*
 * Implement primitive (R/W) 
 * ( BLKNO FLAG ADDR -- read if FLAG=1, write if FLAG = 0 )
 */
void prslw(void)
{
  int blkno, flag, addr;
  flag = pop();
  blkno = pop();
  addr = pop();
  if (flag == 0) {		/* write to block file */
    fth_blk_write(blkno, addr);
  } else {
    fth_blk_read(blkno, addr);
  }
}

#ifdef WANT_PRSLW
void prslw(void)
{
	int buffer, flag, addr, i, temp;
	int unwrittenflag = !TRUE;
	long fpos, ftell();
	char buf[1024];		/* holds data for xfer */

	flag = pop();
	buffer = pop();
	addr = pop();
	fpos = (long) (buffer * 1024);

					/* extend if necessary */
	if (fpos >= bfilesize) {
	    if (flag == 0) { 		/* write */
	      printf("Extending block file to %ld bytes\n", fpos + 1024);
		/* the "2" below is the fseek magic number for "beyond end" */
		fseek(blockfile, (fpos+1024) - bfilesize, 2);
		bfilesize = ftell(blockfile);
	    }
	    else {			/* reading unwritten data */
		unwrittenflag = TRUE;	/* will read all zeroes */
	    }
	}
	else {
		/* note that "0" below is fseek magic number for "relative to
		   beginning-of-file" */
		fseek(blockfile, fpos, 0);	/* seek to destination */
	}

	if (flag) {		/* read */
	    if (unwrittenflag) {	/* not written yet */
		for (i=0; i<1024; i++) fth_mstore(addr++, 0);	/* "read" nulls */
	    }
	    else {			/* does exist */
		if ((temp = fread (buf, sizeof(char), 1024, blockfile)) 
								!= 1024) {
			fprintf (stderr,
				"File read error %d reading buffer %d\n",
					temp, buffer);
			errexit("", 0, 0);
		}
		for (i=0; i<1024; i++) fth_mstore(addr++, buf[i]);
	    }
	}
	else {	/* write */
		for (i=0; i<1024; i++) buf[i] = fth_mfetch(addr++);
		if ((temp = fwrite (buf, sizeof(char), 1024, blockfile))
								 != 1024) {
			    fprintf(stderr,
				"File write error %d writing buffer %d\n",
					temp, buffer);
			    errexit("", 0, 0);
		}
	}
}
#endif

#ifdef WANT_PSAVE
void psave(void)
{
	FILE *fp;

	printf("\nSaving...");
	fflush(stdout);
	fth_mstore(SAVEDIP, ip);	/* save state */
	fth_mstore(SAVEDSP, csp);
	fth_mstore(SAVEDRP, rsp);

	if ((fp = fopen(sfilename,"w")) == NULL)  /* open for writing only */
		errexit("Can't open core file %s for writing\n", sfilename);
	if (fwrite(image, sizeof(*image), fth_mfetch(0), fp) != fth_mfetch(0))
		errexit("Write error on %s\n",sfilename);
	if (fclose(fp) == EOF)
		errexit("Close error on %s\n",sfilename);
	puts("Saved. Exit FORTH.");
	exit(0);
}
#endif
