graspforth.c

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

//----------------------------------------------------------------------------
//
// graspForth 
//
//	A Gcc/Retargetable/fAst/Small/Portable ITC FORTH written in C.
//		Ver 0.80 (C) Copyright  Bernard Mentink ........ 2004
//		This code is released for free "personal" use, any commercial interest
//		should be directed to the following address:		
//		ebike-at-paradise-dot-net-dot-nz
//
//		Please keep this header intact.
// TODO:
//		Adapt in-line strings for ENDIAN'ess, at present single ENDIAN only.
//		Change NAME? to search all vocabs, currently only searches FORTH.
//		Need to add the DOES> construct word.
// KNOWN BUGS:
//		FILE causes a segfault
// ACKNOWLEDGEMENTS
//		eForth 1.0 by Bill Muench and C. H. Ting, 1990;
// 	Please send any improvements/bug fixes to the above address, I will 
//	incorporate and periodically publish a new release.

// --------------------------------- Includes --------------------------------

#include "linux.h"
#include "forthdef.h"

//--------------------------------  Defines ----------------------------------

#define TTRUE			-1
#define FFALSE  		 0
#define CELL			sizeof(INT)

#define COMPO		0x40			// lexicon compile only bit
#define IMEDD			0x80			// lexicon immediate bit
#define	MASK			0x1F			// mask above bits
#define ERR				27

// Size of kernel name field (fixed width, by necessecity)
#define NAME_S			11

// ------------------------------- typedef's ---------------------------------
//  NOTE: int and *int must be same size! 

typedef int INT;
typedef unsigned int UINT;
typedef int * PTR;
typedef unsigned int * UPTR;
typedef unsigned char *CPTR;

// The dictionary Structure.
// Note. Fixed name field for internal words, user words are variable width.
typedef struct {
	INT				cfa;	// code-field-address
	INT				lfa;	// link-field-address
	unsigned char	count;
	char			name[NAME_S];
} HEADS;

// ------------------------------ Virtual Machine Registers ------------------

#define IP		mem[0] 	// Instruction Pointer, address of current memory cell 
#define W		mem[1]	// Word Pointer, address of next code to execute 
#define R0	mem[2]	// Address of bottom of address stack 
#define S0	mem[3]	// Address of bottom of parameter stack 
#define RP	mem[4]	// RP and SP, return stack pointer and stack pointer 
#define SP	mem[5]
#define X		mem[6]	// Tempory register 

// -------------------------- System and User Variables ----------------------
// These are initialized in Main()

#define tqkey	mem[7]	// '?key
#define temit		mem[8]	// 'emit
#define texpect	mem[9]	// 'expect
#define ttap		mem[10]	// 'tap
#define techo	mem[11]	// 'echo
#define tprompt	mem[12]	// 'prompt
#define teval		mem[13]	// 'eval
#define tnumber mem[14]	// 'number
#define tboot		mem[15]	// 'boot
#define base		mem[16]	//	base
#define span		mem[17]	//  span
#define in			mem[18]	//	>in
#define ntib		mem[19]	//	#tib
#define	hld		mem[20]	//	hld
#define handler	mem[21]	//	handler
#define cp			mem[22]	//	cp
#define np			mem[23]	//	np
#define vp			mem[24]	//	vp
#define llast		mem[25]	//	last
#define vfrth		mem[26]	//	forth
#define context mem[27]  	// context pointer
										// vocab storage
#define context_end mem[35]
#define current	mem[36]	//	current link
										// vocab link
#define current_end mem[37]
#define tmp		mem[38]	
#define csp		mem[39]
#define up			mem[40]
#define user		mem[41]	//	user area 
#define	tib			mem[41+USER_S] 	// tib buffer 
#define vm		mem[41+USER_S+TIB_S]	// variable area
#define pad_start	mem[41+USER_S+TIB_S+VM_S]	// text buffer
#define pad_end		mem[41+USER_S+TIB_S+VM_S+PAD_S]	

// ----------------------------------------- Macros --------------------------

#define INC(x) 		(x += CELL)
#define DEC(x) 		(x -= CELL)
#define DDEC(x)	(x -= CELL*2)
#define DINC(x)		(x += CELL*2)
#define TOS			(*(PTR)SP)		// top of stack
#define UTOS		(*(UPTR)SP)		// top of stack
#define NOS			(*(PTR)(SP + CELL))	// next on stack
#define UNOS		(*(UPTR)(SP + CELL))	// next on stack
#define TOR			(*(PTR)RP)		// top of return stack 
#define FORTHWORDS static const INT
#define FORTHDICT  	static const HEADS

// ------------------------------------ Globals ------------------------------

INT mem[MEMSIZE];	// The VM memory 
 
 // --------------------------------------- Main -----------------------------

int main(void)
{
	INT *adr,*adr2;					
	unsigned char count,*badr;	// used by NAME?
	INT i,j;
	HEADS *head;

		// Initial values for system & user variables
	FORTHWORDS sys_var[] = {
		_QRX,_TXSTORE,/*accept*/0,/*KTAP*/0,_TXSTORE,
		/*DOTOK*/0,/*INTERP*/0,/*NUMBQ*/0,
		0,10,0,0,0,0,0,0,0,0,0,0
	};

// ---------------------------------- Kernel Primitives ----------------------
//  .. all "_words" are actual code address's		
	FORTHWORDS cfa [] = {
			_NEXT,_DOCOL,_SEMI,_DOLIT,_DOCON,_DOCASE,_EXECUTE,_ATEXEC,
			_BRANCH,_ZBRANCH,_STORE, _PSTORE,_FETCH,_CSTORE,_CFETCH,
			_RTO,_RFROM,_RFETCH,_RPZ,_RPFETCH,_RPSTORE,_SWAP,_DROP,_DUP,
			_QDUP,_SPZ,_NIP,_SPFETCH,_SPSTORE,_OVER,_ROT,_TXSTORE,_QRX,_ADD,
			_SUB,_UADD,_USUB,_MUL,_DIV,_UMUL,_UDIV,_MULDIV,_UMULDIV,_TWOMUL,
			_TWODIV,_LSHIFT,_RSHIFT,_ZERO,_ONE,_TWO,_THREE,_NONE,_NTWO,
			_NTHREE,_INVERT,_NEGATE,_MOD,_UMOD,_TRUEE,_FALSEE,
			_EQ,_ZEQ,_LT,_ULT,_ZLT,_GT,_WITHIN,_MAX,_MIN,_AND,_OR,_XOR,_NOT,
			_NAMEQ,_DONEXT,

// -------------------------------- Colon words ------------------------------ 
//  ..	all colon words (except cold) start with a _DOCOL word and
//					end in SEMI. Number is index into cfa array.

// -------------------------- Sytem & user variables--------------------------
// 75	TQKEY ( -- a)
			_DOCOL,DOLIT,_TQKEY,SEMI,
// 79 	TEMIT ( -- a)
			_DOCOL,DOLIT,_TEMIT,SEMI,
// 83	TEXPECT ( -- a)
			_DOCOL,DOLIT,_TEXPECT,SEMI,
// 87	TTAP ( -- a)
			_DOCOL,DOLIT,_TTAP,SEMI,
// 91	TECHO ( -- a)
			_DOCOL,DOLIT,_TECHO,SEMI,
// 95	TPROMPT ( -- a)
			_DOCOL,DOLIT,_TPROMPT,SEMI,
// 99	TEVAL ( -- a)
			_DOCOL,DOLIT,_TEVAL,SEMI,
// 103	TNUMBER ( -- a)
			_DOCOL,DOLIT,_TNUMBER,SEMI,
// 107	BASE ( -- a)
			_DOCOL,DOLIT,_BASE,SEMI,
// 111	SPAN ( -- a)
			_DOCOL,DOLIT,_SPAN,SEMI,
// 115	IN ( -- a)
			_DOCOL,DOLIT,_IN,SEMI,
// 119	NTIB ( -- a)
			_DOCOL,DOLIT,_NTIB,SEMI,
// 123	HLD ( -- a)
			_DOCOL,DOLIT,_HLD,SEMI,
// 127	HANDLER ( -- a)
			_DOCOL,DOLIT,_HANDLER,SEMI,
// 131	CP ( -- a)
			_DOCOL,DOLIT,_CP,SEMI,
// 135	NP ( -- a)
			_DOCOL,DOLIT,_NP,SEMI,
// 139	VP ( -- a)
			_DOCOL,DOLIT,_VP,SEMI,
// 143	LAST ( -- a)
			_DOCOL,DOLIT,_LAST,SEMI,
// 147	VFRTH ( -- a)
			_DOCOL,DOLIT,_VFRTH,SEMI,
// 151	CURRENT ( -- a)
			_DOCOL,DOLIT,_CURRENT/*_END*/,SEMI,
// 155	USER ( -- a)
			_DOCOL,DOLIT,_USER,SEMI,
// 159	TIB ( -- a)
			_DOCOL,DOLIT,_TIB,SEMI,

// ------------ High level Colon Words (psuedo forth) ------------------------

// 163 EMIT ( c -- ) Send a character to the output device.
			_DOCOL,TEMIT,ATEXEC,SEMI,

// 167 QKEY ( -- c T | F ) wait for key, FALSE if not ready
			_DOCOL,TQKEY,ATEXEC,SEMI,
			
// 171 KEY	( -- c )
			_DOCOL,
/*172*/	QKEY,ZBRANCH,&cfa[172],SEMI,
		
// 176  ABS    ( n -- n )   Return the absolute value of n
        	_DOCOL,DUP,ZLT,
        	ZBRANCH,&cfa[182],
        	NEGATE,
/*182*/	SEMI,
		
// 183 CELLP    ( a -- a ) Add cell size in byte to address.
        	_DOCOL,DOLIT,CELL,ADD,SEMI,	

// 188 CELLM    ( a -- a ) Subtract cell size in byte to address.
        	_DOCOL,DOLIT,0-CELL,ADD,SEMI,	
        	
// 193 CELLS    ( a -- a ) Multiply by cell size.
        	_DOCOL,DOLIT,CELL,MUL,SEMI,	
        	
// 198 ALIGNED  ( b -- a ) Align address to the cell boundary.
        	_DOCOL,DUP,DOLIT,CELL,
        	MOD,DUP,
        	ZBRANCH,&cfa[210],
        	DOLIT,CELL,SWAP,SUB,
/*210*/		ADD,SEMI,


// 212 BLANK ( -- 32 ) Return 32, the blank character.
			_DOCOL,DOLIT,32,SEMI,

// 216 >CHAR ( c -- c ) Filter non-printing characters.
			_DOCOL,DOLIT,0x7F,AND,DUP,		//mask msb
			BLANK,DOLIT,127,WITHIN,NOT,	//check for printable
			ZBRANCH,&cfa[231],
			DROP,DOLIT,0x5F,		//replace non-printables '_'
/*231*/	SEMI,


// 232 DEPTH ( -- n ) Return the depth of the data stack.
			_DOCOL,SPFETCH,SPZ,NOP,SWAP,SUB,
			DOLIT,CELL,DIV,SEMI,

// 242 PICK    ( +n -- w ) Copy the nth stack item to tos.
			_DOCOL,ONE,ADD,CELLS,
			SPFETCH,ADD,FETCH,SEMI,


// 250 COUNT ( b -- b +n ) Return count byte of a string and add 1 to byte address.
			_DOCOL,DUP,ONE,ADD,
			SWAP,CFETCH,SEMI,

// 257 HERE ( -- a ) Return the top of the code dictionary.
			_DOCOL,CP,FETCH,SEMI,

// 261 PAD ( -- a ) return address of text buffer
			_DOCOL,DOLIT,_PAD,SEMI,

// 265 CMOVE ( b1 b2 u -- ) Copy u bytes from b1 to b2.
			_DOCOL,RTO,
			BRANCH,&cfa[279],
/*269*/	RTO,DUP,CFETCH,
			RFETCH,CSTORE,
			ONE,ADD,
			RFROM,ONE,ADD,
/*279*/	DONEXT,&cfa[269],
			DDROP,SEMI,

// 283 FILL ( b u c -- ) Fill u bytes of character c to area beginning at b.
			_DOCOL,SWAP,RTO,SWAP,
			BRANCH,&cfa[293],
/*289*/	DDUP,CSTORE,ONE,ADD,
/*293*/	DONEXT,&cfa[289],
			DROP,SEMI,

// 297 -TRAILING ( b u -- b u ) Adjust the count to eliminate trailing white space.
			_DOCOL,RTO,
			BRANCH,&cfa[313],
/*301*/		BLANK,OVER,RFETCH,ADD,CFETCH,LT,
			ZBRANCH,&cfa[313],
			RFROM,ONE,ADD,SEMI,
/*313*/		DONEXT,&cfa[301],
			ZERO,SEMI,

// 317 PACK$    ( b u a -- a )
			_DOCOL,ALIGNED,DUP,RTO,		//strings only on cell boundary
			OVER,DUP,
			DOLIT,CELL,MOD,				//count mod cell
			SUB,OVER,ADD,
			ZERO,SWAP,STORE,			//null fill cell
			DDUP,CSTORE,ONE,ADD,			//save count
			SWAP,CMOVE,RFROM,SEMI,		//move string

// 340 DIGIT    ( u -- c ) Convert digit u to a character.
			_DOCOL,DOLIT,9,OVER,LT,
			DOLIT,7,AND,ADD,
			DOLIT,0x30,ADD,SEMI,

// 353 U/MOD UDIVMOD ( u1 u2 -- ur uq )division of u1 / u2 
//										returning rem & quot
			_DOCOL,OVER,OVER,	// (u1 u2 u1 u2 --)	
			UMOD,ROT,ROT,UDIV,SEMI,

// 361 EXTRACT    ( n base -- n c ) Extract the least significant digit from n.
			_DOCOL,UDIVMOD,
			SWAP,DIGIT,SEMI,

// 366 <# BDIGS ( -- ) Initiate the numeric output process.
			_DOCOL,PAD,HLD,STORE,SEMI,

// 371 HOLD ( c -- ) Insert a character into the numeric output string.
			_DOCOL,HLD,FETCH,ONE,SUB,
			DUP,HLD,STORE,CSTORE,SEMI,

// 381 # DIG ( u -- u ) Extract one digit from u and append the digit to output string.
			_DOCOL,BASE,FETCH,UDIVMOD,
			SWAP,DOLIT,9,OVER,
			LT,ZBRANCH,&cfa[395],DOLIT,7,ADD,
/*395*/	DOLIT,'0',ADD,HOLD,SEMI,

// 400 #S ( u -- 0 0 ) Convert u until all digits are added to the output string.
			_DOCOL,
/*401*/	DIG,DUP,
			ZBRANCH,&cfa[407],
			BRANCH,&cfa[401],
/*407*/ SEMI,

// 408 	SIGN    ( n -- ) Add a minus sign to the numeric output string.
		_DOCOL,ZLT,
        ZBRANCH,&cfa[415],
        DOLIT,'-',HOLD,
/*415*/ SEMI,

// 416 #> ( u -- b u ) Prepare the output string to be TYPE'd.
		_DOCOL,DROP,HLD,FETCH,
		PAD,OVER,SUB,SEMI,

// 424	str  ( w -- b u ) Convert a signed integer to a numeric string.
		_DOCOL,DUP,RTO,ABS,
        BDIGS,DIGS,RFROM,
        SIGN,EDIGS,SEMI,
  
// 434 `HEX  ( -- ) Use radix 16 as base for numeric conversions.
		_DOCOL,DOLIT,16,BASE,STORE,SEMI,

// 440 DECIMAL   ( -- ) Use radix 10 as base for numeric conversions.
		_DOCOL,DOLIT,10,BASE,STORE,SEMI,

// 446 DIGIT?  ( c base -- u t )Convert a character to its numeric value.
		_DOCOL,RTO,DOLIT,'0',SUB,
        DOLIT,9,OVER,LT,
        ZBRANCH,&cfa[465],
        DOLIT,7,SUB,
        DUP,DOLIT,10,LT,OR,
/*465*/  DUP,RFROM,ULT,SEMI,

// 469 DDROP ( n n -- ) drop two items off stack
	_DOCOL,DROP,DROP,SEMI,

// 473 NUMBER?    ( a -- n T | a F ) Convert a number string to integer. 
		_DOCOL,BASE,FETCH,RTO,ZERO,OVER,COUNT,
        OVER,CFETCH,DOLIT,'$',EQ,
        ZBRANCH,&cfa[496],
        HEX,SWAP,DOLIT,1,ADD,
        SWAP,DOLIT,1,SUB,
/*496*/  OVER,CFETCH,DOLIT,'-',EQ,RTO,       
        SWAP,RFETCH,SUB,SWAP,RFETCH,ADD,QDUP,
        ZBRANCH,&cfa[550],
        DOLIT,1,SUB,RTO,
/*515*/   DUP,RTO,CFETCH,BASE,FETCH,DIGITQ,
        ZBRANCH,&cfa[543],
        SWAP,BASE,FETCH,MUL,ADD,RFROM,
        DOLIT,1,ADD,
        DONEXT,&cfa[515],
        RFETCH,SWAP,DROP,
        ZBRANCH,&cfa[540],
        NEGATE,
/*540*/  SWAP,
        BRANCH,&cfa[549],
/*543*/  RFROM,RFROM,DDROP,DDROP,DOLIT,0,
/*549*/  DUP,
/*550*/  RFROM,DDROP,
        RFROM,BASE,STORE,SEMI,

// 556 CR ( -- ) Output a carriage return and a line feed.
		_DOCOL,DOLIT,'\r',EMIT,
        DOLIT,'\n',EMIT,SEMI,

// 564 NUF? ( -- t ) Return false if no input, else pause and if CR return true.
		_DOCOL,QKEY,DUP,
		ZBRANCH,&cfa[574],
		DDROP,KEY,DOLIT,LINEFEED,EQ,
/*574*/ SEMI,

// 575 PACE  ( -- ) Send a pace character for the file downloading process.
		_DOCOL,DOLIT,11,EMIT,SEMI,

// 580 SPACE    ( -- ) Send the blank character to the output device.
		_DOCOL,BLANK,EMIT,SEMI,

// 584 SPACES  ( +n -- ) Send n spaces to the output device.
		_DOCOL,ZERO,MAX,RTO,
          BRANCH,&cfa[591],
/*590*/   SPACE,
/*591*/  DONEXT,&cfa[590],
          SEMI,

// 594 TYPE  ( b u -- ) Output u characters from b.
		_DOCOL,RTO,
        BRANCH,&cfa[603],
/*598*/  DUP,CFETCH,EMIT,
        ONE,ADD,
/*603*/  DONEXT,&cfa[598],
        DROP,SEMI,
 
// 607 do$  ( -- a ) Return the address of a compiled string.
		_DOCOL,RFROM,RFETCH,RFROM,COUNT,ADD,
        ALIGNED,RTO,SWAP,RTO,SEMI,

// 618 $"|   ( -- a ) Run time routine compiled by $". 
//                       Return address of a compiled string.
		_DOCOL,DOSTR,SEMI,        // force a call to do$

// 621 ."|  ( -- ) Run time routine of ." . Output a compiled string.
		_DOCOL,DOSTR,COUNT,TYPES,SEMI,

// 626 .R  ( n +n -- ) Display an integer in a field of n columns, right justified.
		_DOCOL,RTO,STR,RFROM,OVER,SUB,
        SPACES,TYPES,SEMI,

// 635 U.R ( u +n -- ) Display an unsigned integer in n column, right justified.
		_DOCOL,RTO,BDIGS,DIGS,EDIGS,
        RFROM,OVER,SUB,
        SPACES,TYPES,SEMI,

// 646 U.  ( u -- ) Display an unsigned integer in free format.
		_DOCOL,BDIGS,DIGS,EDIGS,
        SPACE,TYPES,SEMI,
        
// 653 _TYPE    ( b u -- ) Display a string. Filter non-printing characters.
		_DOCOL,RTO,            	//start count down loop
        BRANCH,&cfa[664],      	//skip first pass
/*657*/  DUP,CFETCH,TOCHAR,EMIT,    //display only printable
        DOLIT,1,ADD,        		//increment address
/*664*/  DONEXT,&cfa[657],        //loop till done
        DROP,SEMI,