/* * The crim1 engine * edrx 2000aug23 * 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 "frames.h" struct frame *frames, frame2; ushort frame1n; int frame_gc_type; 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); void frame2to1(void); /* * The engine itself. * Implements the primitives that can be #defined by: * * Hprims COL RSR CON TO AT C1 C2 C3 * SFprims EXIT PLUS DUP 2DUP 1 SWAP DROP STORE FETCH * Fprims COUNT TYPE CR STO TOS SGOBBLE1 SGOBBLE2 SGOBBLE4 WSTORE WFETCH * Fprims SBRANCH S0BRANCH C SRANGE FRAME1N FRAMENTOADR FRAME2ADR 2BECOMES1 * Fprims PRINTFRAMES * FIPprims RETURN RSREXIT * * (You can move primitives between the "Fprims" and "SFprims" groups * and the preprocessor will take care of the details.) */ void engine(void) { ushort instr, tmp; uchar byte, c1, c2; int itmp; 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_DUP: DS[1]=DS[0]; DS++; goto forth; case F_2DUP: DS[1]=DS[-1]; DS[2]=DS[0]; DS+=2; goto forth; case F_SWAP: itmp=DS[-1]; DS[-1]=DS[0]; DS[0]=itmp; goto forth; case F_DROP: 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; case F_SGOBBLE1: DS[1]=*((uchar *)(SS[0]))++; DS++; goto forth; case F_SGOBBLE2: DS[1]=*((ushort *)(SS[0]))++; DS++; goto forth; case F_SGOBBLE4: DS[1]=*((int *)(SS[0]))++; DS++; goto forth; case F_STORE: *((int *)(DS[0]))=DS[-1]; DS-=2; goto forth; case F_FETCH: DS[0]=*((int *)(DS[0])); goto forth; case F_WSTORE: *((ushort *)(DS[0]))=DS[-1]; DS-=2; goto forth; case F_WFETCH: DS[0]=*((ushort *)(DS[0])); goto forth; case F_SBRANCH: SS[0]=(int)_f0+*((ushort *)(SS[0])); goto forth; case F_S0BRANCH: tmp=*((ushort *)(SS[0]))++; if(DS[0]==0) SS[0]=(int)_f0+tmp; DS--; goto forth; case F_C: DS[1]=0; DS[2]=*(frame1.pos); DS+=2; goto forth; case F_SRANGE: c1=*((uchar *)(SS[0]))++; c2=*((uchar *)(SS[0]))++; if(c1<=DS[0] && DS[0]<=c2) DS[-1]=-1; goto forth; case F_FRAME1N: DS[1]=(int)frame1n; DS++; goto forth; case F_FRAMENTOADR: DS[0]=(int)(frames+DS[0]); goto forth; case F_FRAME2ADR: DS[1]=(int)&frame2; DS++; goto forth; case F_PRINTFRAMES: printframes(); goto forth; case F_2BECOMES1: frame2to1(); goto forth; default: printf("bad forth_primitive: %04x\n", instr); 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; default: printf("bad forth_ip_primitive: %04x\n", instr); 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; default: printf("bad head: %02x\n", byte); } } /* * Debugging routines called by the engine. * */ int ndbgs=0; /* for GDB */ 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; ndbgs++; /* if (RS[0]<0x116) return; */ if ((bit&DBG_BITS)==0) return; /* printf(" %03x %s\n", RS[0], statename); 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... * (find-fline "frames.c" "\nmain(int argc") */ extern uchar ADR_DEMO[], ADR_BIGFAIL[]; struct frame frame0 = {ADR_BIGFAIL, "1234.", 0, 0, 0, 0, 0}; void adjust_SF_TO_F(void) { ushort *fp=SF_TO_F; void **ap=(void *)SF_TO_ADR; for(; *fp!=0; ++fp) if (*fp==1) *fp=(int)(*ap++)-(int)_f0; } main(int argc, char **argv) { struct frame framespace[1000]; frames = framespace; frame1n = 0; memcpy(frames+0, &frame0, sizeof(struct frame)); memcpy(&frame2, &frame0, sizeof(struct frame)); printframes = ll_printframes; printframes = twod_printframes; adjust_SF_TO_F(); 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") * * (find-fline "demo3a.engine.c") * (find-node "(gdb)Set Breaks" "`break ... if COND'") * (progn (gdb "gdb demo3b") (gdbk-mode)) # # br engine # br DBG if (frame2.fail!=0) # br demo3b.engine.c:176 # display frame1n # display frame2 # br demo3b.engine.c:166 # br DBG if (ndbgs>=473) # display frame2.ip-_f0 # display /x DS[0] # br DBG if (ndbgs>=233) set args 0 br DBG if (RS[0]==0x1c0) display ndbgs run # cont # cont # cont # cont br DBG if (RS[0]==0x14) p DBG_BITS=-1 # (progn (eeg-bounded) (gdb "gdb demo3b") (gdbk-mode)) # cd ~/CRIM1; make clean; make CFLAGS=-g demo3b cd ~/CRIM1; expect -c 'spawn demo3b 0; expect eof' |& l -S cd ~/CRIM1; l demo3b.{tf,lst,engine.c} */