graspforth.c

graspForth is my humble attempt at a Forth-in-C that has the following goals: GCC ......... to su

	if(TOS!=0)
    	{ INC(IP); INC(SP); goto next;}
    IP = *(PTR)IP;
	INC(SP);
    goto next;

	
// -------------------------------- memory store------------------------------
store:
    // ! ( n addr -- )
    *(PTR)TOS = NOS;
    DINC(SP);
    goto next;

pstore:
    // +! ( n addr -- )
     *(PTR)TOS += NOS;
    DINC(SP);
    goto next;

fetch:
    // @ ( addr -- n )
    TOS = *(PTR)TOS;
    goto next;
    
cstore:
    // C! ( n addr -- )
    *(CPTR)TOS = (unsigned char)NOS;
    DINC(SP);
    goto next;

cfetch:
    // C@ ( addr -- n )
    TOS = *(CPTR)TOS;
    goto next;

// ----------------------------- return stack operations ---------------------    
rto:
    // >r ( n -- ) 
    DEC(RP); 		// make room on return stack
    TOR = TOS;
    INC(SP);		// pop stack
    goto next;
    
rfrom:
    // r> ( -- n) 
    DEC(SP); 		// make room on stack
    TOS = TOR;
    INC(RP);		// pop return stack
    goto next;
    
rfetch:
    // r@ ( -- n)  get copy of return stack 
    DEC(SP);		// make room
	TOS = TOR;
    goto next;
    
rpz:
	// rp0( -- n) get  pointer to bottom of return stack
	DEC(SP);		// make room
	TOS = R0;
	goto next;

rpfetch:
    // rp@ ( -- n)  get return stack pointer 
    DEC(SP);		// make room
	TOS = RP;
    goto next;

rpstore:
    // rp! ( n -- ) 
    RP  = TOS;
    INC(SP);		// pop stack 
    goto next;
	
// ------------------------------- param stack operations -------------------- 
swap:
  	// swap ( n m -- m n )
  	X = TOS;
  	TOS = NOS;
  	NOS = X;
  	goto next; 

drop:
    // drop ( n -- ) 
    INC(SP);
    goto next;

dup:
    // dup ( n -- n n) 
    DEC(SP);
    TOS = NOS;
    goto next;
    
qdup:
	// ?dup ( n -- n n | 0 )   Duplicate only if non zero
	if(TOS !=0)
	{ DEC(SP); TOS = NOS; }
	else
	{ TOS = 0; }
	goto next;

spz:
	// sp0 ( -- n) get  pointer to bottom of param stack
	DEC(SP);
    TOS = S0;
	goto next;
	
nip:
	// nip ( n m -- m)
	NOS = TOS;
	INC(SP);
	goto next;

spfetch:
    // sp@ ( -- n)  put stack pointer on stack  
	adr = SP;		// backup SP
    DEC(SP);		// make room
	TOS = adr;
    goto next;

spstore:
    // sp! ( n -- ) 
    SP  = TOS;
    goto next;

over:
	// over ( n1 n2 -- n1 n2 n1 )
	X = NOS;	// save n1
	DEC(SP);	// make room
	TOS = X;
	goto next;
	
rot:
	// rot ( n1 n2 n3 -- n2 n3 n1 )
	i = TOS;	// i=n3	
	INC(SP);	// pop stack
	j = NOS;	// j = n1
	NOS = TOS;
	TOS = i;
	DEC(SP);	// push stack
	TOS = j;
	goto next;

// ---------------------------------- IO--------------------------------------

qrx:
	// (?rx)  ( -- c T | F ) returns TRUE if char avail, FALSE otherwise
	DEC(SP);	// make room for flag
	if(kbhit()==0)
	{
		TOS = FFALSE;
		goto next;
	}
	DEC(SP);	// room for char
	NOS = getCharacter();
	TOS = TTRUE;
	goto next;


txstore:
	// (tx!) ( c -- ) send character to output device
	putCharacter(TOS);
	INC(SP);
	goto next;

// ------------------------------ arithmetic ---------------------------------
add:
	 // + ( n n -- n ) Add TOS to NOS 
	NOS = NOS + TOS;
	INC(SP);
    goto next;
    
sub:
    // - ( n n -- n ) Subtract TOS from NOS 
    NOS = NOS - TOS;
	INC(SP);
    goto next;
    
uadd:
	 // U+ ( n n -- n ) unsigned Add TOS to NOS 
	UNOS = UNOS + UTOS;
	INC(SP);
    goto next;
    
usub:
    // U- ( n n -- n ) unsigned Subtract TOS from NOS 
    UNOS = UNOS - UTOS;
	INC(SP);
    goto next;
    
mul:
	 // * ( n n -- n ) Multiply TOS and NOS 
    NOS = NOS * TOS;
	INC(SP);
    goto next;
    
div:
    // / ( n n -- n )Divide NOS by TOS 
    NOS = NOS / TOS;
	INC(SP);
    goto next;
    
umul:
	 // U* ( n n -- n ) unsigned Multiply TOS and NOS 
    UNOS = UNOS * UTOS;
	INC(SP);
    goto next;
    
udiv:
    // U/ ( n n -- n ) unsigned Divide NOS by TOS 
    UNOS = UNOS / UTOS;
	INC(SP);
    goto next;
    
muldiv:
	//  */ ( n1 n2 n3 -- n4 ) mutiply and divide (scale function)
	// (n1 x n2) /n3 long intermediate
	X = TOS;
	INC(SP);		// pop stack
	NOS = (INT) ((long)(TOS * NOS)/X);
	INC(SP);
	goto next;
	
umuldiv:
	//  U*/ ( n1 n2 n3 -- n4 ) unsigned mutiply and divide (scale function)
	// (n1 x n2) /n3 long intermediate
	X = UTOS;
	INC(SP);		// pop stack
	UNOS = (UINT) ((unsigned long)(UTOS * UNOS)/X);
	INC(SP);
	goto next;

twomul:
	// 2* ( n -- n )Mutiply TOS x 2
	TOS = TOS << 1;
	goto next;
	
twodiv:
	// 2/ ( n -- n ) Divide TOS by 2
	TOS = TOS >> 1;
	goto next; 
	
lshift:
	// LSHIFT ( n u -- n ) shift NOS left by TOS
	NOS = NOS << TOS;
	INC(SP);
	goto next;
	
rshift:
	// RSHIFT ( n u -- n ) shift NOS right by TOS
	NOS = NOS >> TOS;
	INC(SP);
	goto next;
	
zero:
	// 0 ( -- 0 ) leave constant zero on stack
	DEC(SP);
	TOS = 0;
	goto next;
	
one:
	// ( -- 1 ) leave constant 1 on stack
	DEC(SP);
	TOS = 1;
	goto next;
	
two:
	// ( -- 2 ) leave constant 2 on stack
	DEC(SP);
	TOS = 2;
	goto next;
	
three:
	// ( -- 3 ) leave constant 3 on stack
	DEC(SP);
	TOS = 3;
	goto next;
	
	
none:
	// ( -- -1 ) leave constant -1 on stack
	DEC(SP);
	TOS = -1;
	goto next;
	
ntwo:
	// ( -- -2 ) leave constant -2 on stack
	DEC(SP);
	TOS = -2;
	goto next;
	
nthree:
	// ( -- -3 ) leave constant -3 on stack
	DEC(SP);
	TOS = -3;
	goto next;
	
invert:
	// INVERT ( n -- n) 1's complement of TOS
	TOS = TOS ^ -1;
	goto next;
	
negate:
	// NEGATE ( n -- n ) 2's complement of TOS
	TOS = (TOS ^ -1) + 1;
	goto next;

mod:
	 // mod ( n n -- n ) signed divide NOS by TOS 
    NOS = NOS % TOS;
	INC(SP);
    goto next;

umod:
	 // umod ( n n -- n ) unsigned divide NOS by TOS 
    UNOS = UNOS % UTOS;
	INC(SP);
    goto next;
	
// --------------------------------- logical----------------------------------    

truee:
	// TRUE ( -- n ) returns TRUE
	INC(SP) ;		// make room
	TOS = TTRUE;
    goto next;
    
falsee:
	// FALSE( -- n ) returns FALSE
	INC(SP) ;		// make room
	TOS = FFALSE;
    goto next;
	
eq:
	// = ( n n -- n ) Returns true if equal
	NOS = (TOS == NOS) ? TTRUE : FFALSE ;
  	INC(SP) ;
    goto next;
    
zeq:
	// 0= ( n -- n ) Returns true if TOS = 0
	NOS = (TOS == 0) ? TTRUE : FFALSE ;
  	INC(SP) ;
    goto next;
	
lt:
	// < ( n n -- n ) If NOS < TOS return TRUE
	NOS = (NOS < TOS) ? TTRUE : FFALSE ;
	INC(SP) ;
 	goto next;

ult:
	// U< ( n n -- n )If unsigned NOS < TOS return TRUE
	NOS = (UNOS < UTOS) ? TTRUE : FFALSE ;
	INC(SP) ;
 	goto next; 	
zlt:
	// 0< ( n -- n )If TOS < 0 return TRUE
	TOS = (TOS < 0) ? TTRUE : FFALSE ;
 	goto next;
    
gt:
   // > ( n n -- n )If NOS > TOS return TRUE
   NOS = (NOS > TOS) ? TTRUE : FFALSE ;
   INC(SP) ;
    goto next;
    
within:
	//  WITHIN ( n l h  -- f ) TRUE if TOS within bounds
	X = TOS;		// save TOS
	INC(SP);		// pop
	NOS = (NOS >= TOS && NOS < X) ? TTRUE : FFALSE ;
	INC(SP);
	goto next;		
	
max:
	// MAX (n n -- n) return maximum
	NOS = (NOS > TOS) ? NOS : TOS ;
	INC(SP);
	goto next;	
	
min:
	// MIN (n n -- n) return minimum
	NOS = (NOS < TOS) ? NOS : TOS ;
	INC(SP);
	goto next;	
    
and:
    // AND ( n n -- n ) and TOS with NOS 
     NOS = NOS & TOS;
	 INC(SP);
    goto next;
    
or:
    // OR ( n n -- n ) or TOS and NOS 
    NOS = NOS | TOS;
	INC(SP);
    goto next;	    
    
xor:
    // XOR ( n n -- n ) xor TOS and NOS 
    NOS = NOS ^ TOS;
	INC(SP);
    goto next;	    
    
not:
	// NOT ( n -- n ) 
    TOS = !TOS;
    goto next;

// --------------------------------- dict search -------------------------------

nameq:
	// NAME?(a -- ca na | a F ) Find counted string at 'a' and return cfa and nfa, 
	//  or false.
	DEC(SP);		// make room on stack
	TOS = FFALSE;	// predict false ( -- a F )
	head = (HEADS *)(vfrth-2*CELL);		// start at end of dictionary, work back
	while(head->lfa |= 0)
	{ 
		badr = NOS;
		count = *badr++ & MASK;	// get count byte, mask lex bits, skip count
		if(count != (head->count & MASK))	// bail if count not equal
			 goto name1; 
		for(j=0;j<count;j++)
		{
			if(*badr++ != head->name[j])	// check each character
				goto name1;						// bail, not equal!
		}
		// Found name!
		NOS = (head->cfa);	
		TOS = (INT)&head->count;	// return address of count byte
		goto next;
name1:	head = head->lfa - 2*CELL; // next entry
	}
	goto next; 

// ------------------------- single index loop primitive ---------------------
donext:
	// doNEXT( -- ) Run time code for the single index loop.
	TOR -= 1;	// dec index
	if(TOR >= 0 )	//loop
	{
		IP = *(PTR)IP;
		goto next;
	}
	INC(RP);	// index < 0
	INC(IP);
	goto next;


    // NOTREACHED 
    return 0;
    
} // end of main