graspforth.c

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

// 668 .  ( w -- ) Display an integer in free format, preceeded by a space.
		_DOCOL,BASE,FETCH,DOLIT,10,XOR,    //?decimal
		ZBRANCH,&cfa[678],
		UDOT,SEMI,			//no, display unsigned
/*678*/ STR,SPACE,TYPES,SEMI,   //yes, display signed
 
// 682 ?  ( a -- ) Display the contents in a memory cell.
		_DOCOL,FETCH,DOT,SEMI,      

// 686 	parse ( b u c -- b u delta ) Scan string delimited by c
//			Return found string and its offset.
		_DOCOL,TEMP,STORE,OVER,RTO,DUP,
		ZBRANCH,&cfa[763],
		DOLIT,1,SUB,TEMP,FETCH,BLANK,EQ,
		ZBRANCH,&cfa[724],
		RTO,
/*704*/	BLANK,OVER,CFETCH,        // skip leading blanks ONLY
		SUB,ZLT,INVERT,
		ZBRANCH,&cfa[723],
		DOLIT,1,ADD,
		DONEXT,&cfa[704],
		RFROM,DROP,DOLIT,0,DUP,SEMI,
/*723*/ RFROM,
/*724*/ OVER,SWAP,
		RTO,
/*727*/ TEMP,FETCH,OVER,CFETCH,SUB,    //scan for delimiter
		TEMP,FETCH,BLANK,EQ,
		ZBRANCH,&cfa[739],
		ZLT,
/*739*/ ZBRANCH,&cfa[750],
		DOLIT,1,ADD,
		DONEXT,&cfa[727],
		DUP,RTO,
		BRANCH,&cfa[757],
/*750*/ RFROM,DROP,DUP,
		DOLIT,1,ADD,RTO,
/*757*/ OVER,SUB,
		RFROM,RFROM,SUB,SEMI,
/*763*/ OVER,RFROM,SUB,SEMI,
 
// 767 PARSE ( c -- b u) Scan input stream and return counted string delimited by c.
		_DOCOL,RTO,TIB,IN,FETCH,ADD,    //current input buffer pointer
		NTIB,FETCH,IN,FETCH,SUB,			//remaining count
		RFROM,PARS,IN,PSTORE,SEMI,
 
// 783 .(  ( -- ) Output following string up to next ) .
		_DOCOL,DOLIT,')',PARSE,TYPES,SEMI,   
 
// 789 ( ( -- ) Ignore following string up to next ) . A comment.
		_DOCOL,DOLIT,')',PARSE,DDROP,SEMI,     
 
// 795 \ ( -- ) Ignore following text till the end of line.
		_DOCOL,NTIB,FETCH,IN,STORE,SEMI,
 
// 801 CHAR ( -- c ) Parse next word and return its first character.
		_DOCOL,BLANK,PARSE,DROP,CFETCH,SEMI,
 
// 807 TOKEN ( -- a  ) Parse a word from input stream and copy it to name dictionary.
		_DOCOL,BLANK,PARSE,DOLIT,31,MIN,
		NP,FETCH,OVER,SUB,CELLM,
		PACKS,SEMI,
 
// 820 WORD ( c -- a ) Parse a word from input stream and copy it to code dictionary.
		_DOCOL,PARSE,HERE,PACKS,SEMI,
 
// 825 NAME> ( na -- ca ) Return a code address given a name address.
		_DOCOL,CELLM,CELLM,FETCH,NOP,NOP,NOP,NOP,SEMI,
 
// 834 ^H ( bot eot cur -- bot eot cur ) Backup the cursor by one character.
		_DOCOL,RTO,OVER,RFROM,SWAP,OVER,XOR,
		ZBRANCH,&cfa[856],
		DOLIT,8,TECHO,ATEXEC,ONE,SUB,
		BLANK,TECHO,ATEXEC,
		DOLIT,8,TECHO,ATEXEC,
/*856*/SEMI,
 
// 857 TAP ( bot eot cur c -- bot eot cur ) Accept and echo the key stroke and bump the cursor.
		_DOCOL,DUP,TECHO,ATEXEC,
		OVER,CSTORE,ONE,ADD,SEMI,
 
// 866 kTAP ( bot eot cur c -- bot eot cur ) Process a key stroke, CR or backspace.
		_DOCOL,DUP,DOLIT,LINEFEED,XOR,
		ZBRANCH,&cfa[883],
		DOLIT,8,XOR,
		ZBRANCH,&cfa[881],
		BLANK,TAP,SEMI,
/*881*/ BKSP,SEMI,
/*883*/ DROP,SWAP,DROP,DUP,SEMI,
 
// 888 accept ( b u -- b u ) Accept characters to input buffer. 
//								Return with actual count.
		_DOCOL,OVER,ADD,OVER,
/*892*/ DDUP,XOR,
		ZBRANCH,&cfa[911],
		KEY,DUP,
		BLANK,DOLIT,127,WITHIN,
		ZBRANCH,&cfa[907],
		TAP,
		BRANCH,&cfa[909],
/*907*/ TTAP,ATEXEC,
/*909*/ BRANCH,&cfa[892],
/*911*/ DROP,OVER,SUB,SEMI,
 
// 915 EXPECT ( b u -- ) Accept input stream and store count in SPAN.
		_DOCOL,TEXPECT,ATEXEC,SPAN,STORE,DROP,SEMI,
 
// 922 QUERY ( -- ) Accept input stream to terminal input buffer.
		_DOCOL,TIB,DOLIT,80,TEXPECT,ATEXEC,NTIB,STORE,
		DROP,ZERO,IN,STORE,SEMI,
 
// 935 CATCH ( ca -- 0 | err# ) Execute word at ca and set up an error frame for it.
		_DOCOL,SPFETCH,RTO,HANDLER,FETCH,RTO,//save error frame
		RPFETCH,HANDLER,STORE,EXECUTE,//execute
		RFROM,HANDLER,STORE,//restore error frame
		RFROM,DROP,ZERO,SEMI,//no error
 
// 952 THROW ( err# -- err# ) Reset system to current local error frame,
		_DOCOL,HANDLER,FETCH,RPSTORE,//restore return stack
		RFROM,HANDLER,STORE,//restore handler frame
		RFROM,SWAP,RTO,SPSTORE,//restore data stack
		DROP,RFROM,SEMI,
 
// 966 doVAR    ( -- a ) Run time routine for CREATE.
		_DOCOL,RFROM,SEMI,

// 969 doVRAM    ( -- a ) Run time routine for VARIABLE & CONSTANT.
		_DOCOL,RFROM,FETCH,SEMI,
 
// 973 NULL$ ( -- a ) Return address of a null string with zero count.
		_DOCOL,DOVAR,     // emulate CREATE
        0,
		0x6f796f63,0x00006574,// DC.B  99,111,121,111,116,101 ENDIANESS?
 
// 978 ABORT  ( -- ) Reset data stack and jump to QUIT.
		_DOCOL,NULLS,THROW,
 
// 981 (abort") ( f -- ) Run time routine of ABORT" . Abort with a message.
		_DOCOL,ZBRANCH,&cfa[986],//text flag
		DOSTR,THROW,//pass error string
/*986*/ DOSTR,DROP,SEMI,        //drop error

// 989 $INTERPRET ( a -- ) Interpret a word. If failed, try to convert it to an integer.
		_DOCOL,NAMEQ,QDUP,        // ?defined
        ZBRANCH,&cfa[1005],
        CFETCH,DOLIT,COMPO,AND,    //?compile only lexicon bits
        //DROP,NOP,NOP,NOP,NOP,
        ABORQ,
        0x6f63200d, 0x6c69706d, 0x6e6f2065, 0x0000796c,  //13,' compile only'
        EXECUTE,SEMI,         //execute defined word
/*1005*/ TNUMBER,ATEXEC,        //convert a number
        ZBRANCH,&cfa[1010],
        SEMI,
/*1010*/ THROW,              //error

// 1011   [        ( -- ) Start the text interpreter.
		_DOCOL,DOLIT,INTERP,TEVAL,STORE,SEMI,

// 1017   .OK   ( -- ) Display 'ok' only while interpreting.
		_DOCOL,DOLIT,INTERP,TEVAL,FETCH,EQ,
        ZBRANCH,&cfa[1027],
        DOTQP,
        0x6b6f2003, //   3,' ok'
/*1027*/ CR,SEMI,

// 1029  ?STACK ( -- ) Abort if the data stack underflows.
		_DOCOL,DEPTH,ZLT,        //check only for underflow
        ABORQ,
        0x6e75200a, 0x66726564, 0x00776f6c, 	// 10,' underflow'
        NOP/*0*/, SEMI,

// 1038   EVAL ( -- ) Interpret the input stream.
		_DOCOL,
/*1039*/  TOKEN,DUP,CFETCH,        //?input stream empty
        ZBRANCH,&cfa[1049],
        TEVAL,ATEXEC,QSTACK,    //evaluate input, check stack
        BRANCH,&cfa[1039],
/*1049*/  DROP,TPROMPT,ATEXEC,SEMI,    //prompt

// 1053   PRESET ( -- ) Reset data stack pointer and the terminal input buffer.
		_DOCOL,SPZ,SPSTORE,
        DOLIT,TIB,NTIB,CELLP,STORE,SEMI,

// 1062    2!  ( d a -- ) Store the double integer to address a.
		_DOCOL,SWAP,OVER,STORE,
        CELLP,STORE,SEMI,

// 1069   2@  ( a -- d ) Fetch double integer from address a.
		_DOCOL,DUP,CELLP,FETCH,
        SWAP,FETCH,SEMI,
        
// 1076  xio  ( a a a -- ) Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT.
		_DOCOL,DOLIT,ACCEPT,TEXPECT,DSTORE,
        TECHO,DSTORE,SEMI,

// 1084  FILE ( -- ) Select I/O vectors for file download.
		_DOCOL,DOLIT,PACE,DOLIT,DROP,
        DOLIT,KTAP,XIO,SEMI,

//  1093  HAND ( -- )   Select I/O vectors for terminal interface.
		_DOCOL,DOLIT,DOTOK,DOLIT,EMIT,
        DOLIT,KTAP,XIO,SEMI,

// 1102   I/O  ( -- a ) Array to store default I/O vectors.
		_DOCOL,DOVAR,            //emulate CREATE
        _QRX,_TXSTORE,        // default I/O vectors

// 1106  CONSOLE  ( -- ) Initiate terminal interface.
		_DOCOL,ISLO,DFETCH,TQKEY,DSTORE,    //restore default I/O device
        HAND,SEMI,        //keyboard input

// 1113   QUIT ( -- ) Reset return stack pointer and start text interpreter.
		_DOCOL,RPZ,RPSTORE,        //reset return stack pointer
/*1116*/  LBRAC,            // start interpretation
/*1117*/  QUERY,           // get input
        DOLIT,EVAL,CATCH,QDUP,    //evaluate input
        ZBRANCH,&cfa[1117],        //continue till error
        TPROMPT,FETCH,RTO,        //save input device
        CONSOLE,NULLS,OVER,XOR,    //?display error message
        ZBRANCH,&cfa[1138],
        SPACE,COUNT,TYPES,    //error message
        DOTQP,
        0x203f2003, 	//    3,' ? '            ;error prompt
/*1138*/  RFROM,DOLIT,DOTOK,XOR,    //?file input
        ZBRANCH,&cfa[1147],
        DOLIT,ERR,EMIT,       //;file error, tell host
/*1147*/  PRESET,            //some cleanup
        BRANCH,&cfa[1116],

// 1150 2DUP ( n1 n2 -- n1 n2 n1 n2)
		_DOCOL,OVER,OVER,SEMI,
		
// 1154 NOP -- 
		_DOCOL,SEMI,
		
// 1156 TEMP ( -- a ) return address of temp variable
		_DOCOL,DOLIT,_TMP,SEMI,
 
// 1160   '  ( -- ca )Search context vocabularies for the next word in input stream.
		_DOCOL,TOKEN,NAMEQ,        //?defined
        ZBRANCH,&cfa[1166],
        SEMI,            			//yes, push code address
/*1166*/  THROW,            	//no, error

// 1167   ALLOT    ( n -- ) Allocate n bytes to the variable memory.
		_DOCOL,VP,PSTORE,SEMI,        //adjust code pointer

// 1171   ,    ( w -- ) Compile an integer into the code dictionary.
		_DOCOL,HERE,DUP,CELLP,        	//cell boundary
        CP,STORE,STORE,SEMI,    			//adjust code pointer and compile

// 1179   [COMPILE]    ( -- ; <string> ) Compile the next immediate word 
//														into code dictionary.
		_DOCOL,TICK,COMMA,SEMI,

// 1183   COMPILE ( -- ) Compile the next address in colon list to code dictionary.
		_DOCOL,RFROM,DUP,FETCH,COMMA,    //compile address
        CELLP,RTO,SEMI,        		//adjust return address

// 1191   LITERAL  ( w -- ) Compile tos to code dictionary as an integer literal.
		_DOCOL,COMPILE,DOLIT,COMMA,SEMI,

// 1196  $," ( -- ) Compile a literal string up to next " .
		_DOCOL,DOLIT,0x22,WORDD,        // '"' ,move string to code dictionary
        COUNT,ADD,ALIGNED,    //calculate aligned end of string
        CP,STORE,SEMI,        //adjust the code pointer

// 1206  RECURSE  ( -- ) Make the current word available for compilation.
		_DOCOL,LAST,FETCH,NAMET,COMMA,SEMI,

// 1212   FOR  ( -- a ) Start a FOR-NEXT loop structure in a colon definition.
		_DOCOL,COMPILE,RTO,HERE,SEMI,

// 1217  BEGIN    ( -- a ) Start an infinite or indefinite loop structure.
		_DOCOL,HERE,SEMI,

// 1220  NEXT ( a -- ) Terminate a FOR-NEXT loop structure.
		_DOCOL,COMPILE,DONEXT,COMMA,SEMI,

// 1225  UNTIL  ( a -- ) Terminate a BEGIN-UNTIL indefinite loop structure.
		_DOCOL,COMPILE,ZBRANCH,COMMA,SEMI,

// 1230  AGAIN ( a -- ) Terminate a BEGIN-AGAIN infinite loop structure.
		_DOCOL,COMPILE,BRANCH,COMMA,SEMI,

// 1235   IF  ( -- A ) Begin a conditional branch structure.
		_DOCOL,COMPILE,ZBRANCH,HERE,
        ZERO,COMMA,SEMI,

// 1242   AHEAD ( -- A ) Compile a forward branch instruction.
		_DOCOL,COMPILE,BRANCH,HERE,ZERO,COMMA,SEMI,

// 1249   REPEAT ( A a -- ) Terminate a BEGIN-WHILE-REPEAT indefinite loop.
		_DOCOL,AGAIN,HERE,SWAP,STORE,SEMI,

// 1255   THEN ( A -- ) Terminate a conditional branch structure.
		_DOCOL,HERE,SWAP,STORE,SEMI,

// 1260   AFT ( a -- a A ) Jump to THEN in a FOR-AFT-THEN-NEXT 
//									loop the first time through.
		_DOCOL,DROP,AHEAD,BEGIN,SWAP,SEMI,

// 1266   ELSE  ( A -- A ) Start the false clause in an IF-ELSE-THEN structure.
		_DOCOL,AHEAD,SWAP,THENN,SEMI,

// 1271   WHILE  ( a -- A a ) Conditional branch out of a BEGIN-WHILE-REPEAT loop.
		_DOCOL, IFF,SWAP,SEMI,

// 1275   ABORT" ( -- ; <string> ) Conditional abort with an error message.
		_DOCOL,COMPILE,ABORQ,STRCQ,SEMI,

// 1280   $"   ( -- ; <string> ) Compile an inline string literal.
		_DOCOL,COMPILE,STRQP,STRCQ,SEMI,

// 1285   ." ( -- ; <string> ) Compile an inline string literal to be typed out at run time.
		_DOCOL,COMPILE,DOTQP,STRCQ,SEMI,

// 1290   ?UNIQUE ( a -- a ) Display a warning message if the word already exists.
		_DOCOL,DUP,NAMEQ,       //?name exists
        ZBRANCH,&cfa[1301],
        DOTQP,            // redefinitions are OK
        0x65722007, 0x00666544, //  7,' reDef '  but the user should be warned
        OVER,COUNT,TYPES,    // just in case its not planned
/*1301*/  DROP,SEMI,

// 1303   $,n   ( na -- ) Build a new dictionary name using the string at na.
		_DOCOL,DUP,CFETCH,        //?null input
        ZBRANCH,&cfa[1327],
        UNIQUE,            //?redefinition
        DUP,LAST,STORE,        //save na for vocabulary link
        HERE,ALIGNED,SWAP,        //align code address
        CELLM,            //link address		
        CURRENT,FETCH,FETCH,OVER,STORE,  // save link to previous word
        CELLM,					
        DUP,NP,STORE,    //adjust name pointer 
        STORE,SEMI,        //save code pointer
/*1327*/  STRQP,
        0x616e2005, 0x0000656d, //   5,' name'        ;null input
        THROW,

// FORTH compiler

// 1331   $COMPILE  ( a -- ) Compile next word to code dictionary as a token or literal.
		_DOCOL,NAMEQ,QDUP,        //?defined
        ZBRANCH,&cfa[1346],
        CFETCH,DOLIT,IMEDD,AND,    //?immediate
        ZBRANCH,&cfa[1344],
        EXECUTE,SEMI,        //its immediate, execute
/*1344*/  COMMA,SEMI,        //its not immediate, compile
/*1346*/  TNUMBER,ATEXEC,        //try to convert to number
        ZBRANCH,&cfa[1352],
        LITERAL,SEMI,        //compile number as integer
/*1352*/  THROW,            //error

// 1353  OVERT  ( -- ) Link a new word into the current vocabulary.
		_DOCOL,LAST,FETCH,CURRENT,FETCH,STORE,SEMI,
// 1360  ;  ( -- ) Terminate a colon definition.
		_DOCOL,COMPILE,SEMI,LBRAC,OVERT,SEMI,

// 1366   ]  ( -- ) Start compiling the words in the input stream.
		_DOCOL,DOLIT,SCOMP,TEVAL,STORE,SEMI,

// 1372   :  ( -- ; <string> ) Start a new colon definition using next word as its name.
		_DOCOL,TOKEN,SNAME,DOLIT,_DOCOL,
        COMMA,RBRAC,SEMI,

// 1380  IMMEDIATE ( -- ) Make the last compiled word an immediate word.
		_DOCOL,DOLIT,IMEDD,LAST,FETCH,CFETCH,OR,
        LAST,FETCH,CSTORE,SEMI,

// 1391  COMPILE-ONLY ( -- ) Make the last compiled word a compile-only word.
		_DOCOL,DOLIT,COMPO,LAST,FETCH,CFETCH,OR,
        LAST,FETCH,CSTORE,SEMI,
 
 // Defining words
 

// 1402 HEADER  ( -- ; <string> ) Compile a new header.
		_DOCOL,TOKEN,SNAME,OVERT,
        DOLIT,_DOCOL,COMMA,SEMI,

// 1410  USER ( u -- ; <string> )Compile a new user variable.
		_DOCOL,HEADER,
        DOLIT,DOUSER,COMMA,
        COMMA,SEMI,

// 1417 CREATE ( -- ; <string> ) Compile a new dict entry without 
//	allocating code space. Added NOP for DOES> word use.
		_DOCOL,HEADER,COMPILE,NOP,
        COMPILE,DOVAR,SEMI,

// 1424 VARIABLE ( -- ; <string> ) Compile a new variable in RAM .
		_DOCOL,HEADER,
        DOLIT,DOVRAM,COMMA,
        VP,FETCH,COMMA,            //Store address of variable pointer
        TWO,VP,PSTORE,SEMI,  //increment the pointer

// 1436 CONSTANT ( u -- ; <string> ) Compile a constant in code space.
		_DOCOL,HEADER,
        DOLIT,DOVRAM,COMMA,
        COMMA,SEMI,

// Tools

// 1443 _TYPE ( b u -- ) Display a string. Filter non-printing characters.
		_DOCOL,RTO,					//start count down loop
        BRANCH,&cfa[1453],			//skip first pass
/*1447*/  DUP,CFETCH,TOCHAR,EMIT,    //display only printable
        ONE,ADD,					//increment address
/*1453*/  DONEXT,&cfa[1447],			//loop till done
        DROP,SEMI,

// 1457 dm+ ( a u -- a ) Dump u bytes from , leaving a+u on the stack.
		_DOCOL,OVER,DOLIT,4,UDOTR,    //display address
        SPACE,RTO,			//start count down loop
        BRANCH,&cfa[1473],	//skip first pass
/*1466*/  DUP,CFETCH,DOLIT,3,UDOTR,    //display numeric data
        ONE,ADD,			//increment address
/*1473*/  DONEXT,&cfa[1466],//loop till done
        SEMI,

// 1476 DUMP ( a u -- ) Dump u bytes from a, in a formatted manner.
		_DOCOL,BASE,FETCH,RTO,HEX,        //save radix, set hex
        DOLIT,16,DIV,				//change count to lines
        RTO,						//start count down loop
/*1485*/  CR,DOLIT,16,DDUP,DUMPP,    //display numeric
        ROT,ROT,
        DOLIT,2,SPACES,UTYPE,		//display printable characters
        NUFQ,INVERT,				//user control
        ZBRANCH,&cfa[1504],
        DONEXT,&cfa[1485],			//loop till done
        BRANCH,&cfa[1506],
/*1504*/  RFROM,DROP,				//cleanup loop stack, early exit
/*1506*/  DROP,RFROM,BASE,STORE,		//restore radix
        SEMI,

// 1511 .S ( -- ) Display the contents of the data stack.
		_DOCOL,CR,DEPTH,			//stack depth
        RTO,						//start count down loop
        BRANCH,&cfa[1520],			//skip first pass
/*1517*/  RFETCH,PICK,DOT,			//index stack, display contents
/*1520*/  DONEXT,&cfa[1517],		//loop till done
        DOTQP,
        0x733c2004, 0x00000070,		// 4,' <sp',0
        SEMI,

// 1526 !CSP ( -- ) Save stack pointer in CSP for error checking.
		_DOCOL,SPFETCH,CSP,STORE,SEMI,		//save pointer

// 1531 ?CSP ( -- ) Abort if stack pointer differs from that saved in CSP.
		_DOCOL,SPFETCH,CSP,FETCH,XOR,    //compare pointers
        ABORQ,            //abort if different
        0x61747306, 0x00736b63, // 6,'stacks',0
        SEMI,

// 1540  >NAME ( ca -- na | F ) Convert code address to a name address.
		_DOCOL,CURRENT,				//vocabulary link
/*1542*/  CELLP,FETCH,QDUP,			//check all vocabularies
        ZBRANCH,&cfa[1570],
        DDUP,