/*
 * The crim1 engine
 * edrx 2000jul15
 * This is just a proof-of-concept implementation: easy to debug, not
 * optimized at all, and very small. It has only the code necessary to
 * run one simple example.
 * (find-es "crim" "compiling")
 */

#include <stdio.h>
typedef unsigned int   uint;
typedef unsigned char  uchar;
typedef unsigned short ushort;
typedef int (*funptr)();

ushort *RS; int *DS, *SS;
/* extern uchar _f0[]; */

int underflow[100];

ushort _RS0[100]; int _DS0[100], _SS0[100];

#define RDEPTH ((RS-_RS0)+1)
#define DDEPTH ((DS-_DS0)+1)
#define SDEPTH ((SS-_SS0)+1)
int DBG_BITS = -1;		/* print debug info at all states */
void DBG(char *statename, int bit);


/*
 * The engine itself.
 * Implements the primitives that can be #defined by:
 *	HPRIM'' COL	:
 *	HPRIM'  RSR
 *	HPRIM'  CON
 *	HPRIM'  TO
 *	HPRIM'  AT
 *	HPRIM'  C1
 *	HPRIM'  C2
 *	HPRIM'  C3
 *	SFPRIM'' EXIT	;
 *	SFPRIM'' PLUS	+
 *	SFPRIM'  2DUP
 *	SFPRIM'  DUP
 *	SFPRIM'  1
 *	FPRIM'  COUNT
 *	FPRIM'  TYPE
 *	FPRIM'  CR
 *	FPRIM'' STO	S>
 *	FPRIM'' TOS	>S
 *	FIPPRIM' RETURN
 *	FIPPRIM' RSREXIT
 * (But you can change FPRIM<->SFPRIM in some lines and the
 * preprocessor will take care of the details.)
 */
void engine(void) {
  ushort instr; uchar byte;
  funptr fun;

  goto head;

 forth: DBG("forth", 2);
  if (RS[0] >= FIP_LAST)	/* ip primitive? */
    goto run_forth_ip_primitive;
  byte = _f0[RS[0]]; RS[0]++;
  if (byte >= SF_LAST) {	/* one-byte instruction? */
    instr = SF_TO_F[255 - byte];
    goto run_forth_instr;
  } else {			/* it's a normal call */
    instr = (byte << 8) | _f0[RS[0]]; RS[0]++;
    goto run_forth_instr;
  }
  
 run_forth_instr:
  if (instr >= F_LAST)
    goto run_forth_primitive;
  
 run_forth_call:
  RS++; RS[0] = instr;
  goto head;
  
 run_forth_primitive:
  switch (instr) {
  case F_EXIT: RS--; goto forth;
  case F_PLUS: DS[-1]+=DS[0]; DS--; goto forth;
  case F_2DUP: DS[1]=DS[-1]; DS[2]=DS[0]; DS+=2; goto forth;
  case F_DUP: DS[1]=DS[0]; DS++; goto forth;
  case F_1: DS[1]=1; DS++; goto forth;
  case F_COUNT: DS[1]=*((uchar *)(DS[0]))++; DS++; goto forth;
  case F_TYPE: fwrite((void *)(DS[-1]), 1, DS[0], stdout); DS-=2; goto forth;
  case F_CR: printf("\n"); goto forth;
  case F_STO: DS[1]=SS[0]; DS++; SS--; goto forth;
  case F_TOS: SS[1]=DS[0]; SS++; DS--; goto forth;
  }

 run_forth_ip_primitive:
  instr = RS[0];
  switch (instr) {
  case FIP_RETURN: RS--; return;
  case FIP_RSREXIT: RS[0]=SS[0]-((int)_f0); SS--; goto forth;
  }

 head: DBG("head ", 1);
  byte = _f0[RS[0]]; RS[0]++;
  /* only the basic primitive heads at this moment
   * (find-fline "/usr/include/pwdb/pwdb_public.h" "int (*compare)")
   * (gdb "gdb ~/CRIM1/demo2")
   */
  switch (byte) {
  case H_COL: goto forth;
  case H_CON: DS[1]=*(int *)(_f0+RS[0]); DS++; RS--; goto forth;
  case H_TO: *(int *)(_f0+RS[0]+1)=DS[0]; DS--; RS--; goto forth;
  case H_AT: DS[1]=((int)_f0)+RS[0]+2; DS++; RS--; goto forth;
  case H_RSR: SS[1]=((int)_f0)+RS[-1]; SS++; RS[-1]=FIP_RSREXIT; goto head;
  case H_C1: fun=*(funptr *)(_f0+RS[0]);
    DS[0]=(*fun)(DS[0]); RS--; goto forth;
  case H_C2: fun=*(funptr *)(_f0+RS[0]);
    DS[-1]=(*fun)(DS[-1], DS[0]); DS--; RS--; goto forth;
  case H_C3: fun=*(funptr *)(_f0+RS[0]);
    DS[-2]=(*fun)(DS[-2], DS[-1], DS[0]); DS-=2; RS--; goto forth;
  }
}



/*
 * Debugging routines called by the engine.
 *
 */
void dbg_print_int(int x) {
  uint w = (uchar *)x - _f0;
  if (w<=0xFFFF)
    printf(" _f0+%x", w);
  else
    printf(" %x", x);
}
void DBG(char *statename, int bit) {
  int i;
  if ((bit&DBG_BITS)==0) return;
  printf("state=%s R::", statename);
  for (i=-RDEPTH+1; i<=0; ++i)
    printf(" %x", RS[i]);
  printf("\t S::");
  for (i=-SDEPTH+1; i<=0; ++i)
    dbg_print_int(SS[i]);
  printf("\t D::");
  for (i=-DDEPTH+1; i<=0; ++i)
    dbg_print_int(DS[i]);
  printf("\n");
}

/*
 * A demo...
 *
 */
extern uchar ADR_DEMO[];
main(int argc, char **argv) {
  if (argc>1) DBG_BITS = atoi(argv[1]);
  RS = _RS0 + 1;		/* depth 2 (RS[-1] is valid, RS[-2] isn't) */
  DS = _DS0 - 1;		/* depth 0 */
  SS = _SS0 - 1;		/* depth 0 */
  RS[-1] = FIP_RETURN;
  RS[0] = 0x1F;

  RS[0] = ADR_DEMO - _f0;
  engine();
  printf("Ok!\n");
}


/*
 * Random notes:
 * (find-es "anatocc" "nasm_crim1")
 *
 * (find-node "(libc)I/O on Streams")
 * (find-node "(libc)Block Input/Output")
 * (find-node "(libc)Standard Streams")
 *
 */