Relay-Version: version B 2.10.3 alpha 4/15/85; site seismo.UUCP
Posting-Version: version B 2.10.2 9/3/84; site genrad.UUCP
Path: seismo!harvard!talcott!panda!genrad!sources-request
From: sources-request@genrad.UUCP
Newsgroups: mod.sources
Subject: C Forth (Part 3 of 3)
Message-ID: <869@genrad.UUCP>
Date: 24 May 85 14:13:06 GMT
Sender: john@genrad.UUCP
Lines: 2274
Approved: john@genrad.UUCP

This is posting three of three of a portable FORTH interpreter, written
entirely in C.  It has been successfully ported to a VAX 11/60 running
BSD 2.9, to EUNICE version 3 (I think), and the original machine, a VAX
11/780 running BSD 4.2.  When I mentioned in net.lang.forth (and elsewhere)
that I was writing this portable FORTH, several people asked that I post
the results of my labors. Well, here they are.

					-- Allan Pratt
			(after May 7:) APRATT.PA@XEROX.ARPA

            [moderator's note:  I have had no luck at all getting through
	     to this address.  There was a missing file in the original
             distribution: "forth.lex.h" which I have reconstructed
             (hopefully correctly).                    - John P. Nelson]

------------- cut here ----------------
: Run this shell script with "sh" not "csh"
PATH=:/bin:/usr/bin:/usr/ucb
export PATH
echo 'x - l2b.c'
sed 's/^X//' <<'//go.sysin dd *' >l2b.c
X/* usage: line2block < linefile > blockfile
 * takes a file (like one generated by block2line) of the form:
 *	<header line>
 *	< 16 screen lines >
 *	...
 * and produces a block file with exactly 64 characters on each line, having
 * removed the header lines. This file is suitable for use with FORTH as a
 * block file.
 */

#include <stdio.h>

main()
{
	int i;
	char buf[65];
	char *spaces =	/* 64 spaces, below */
	"                                                                ";
			/* 64 spaces, above */
	while (1) {
		gets(buf);			/* header line */
		for (i=0; i<16; i++) {
			if (gets(buf) == NULL) exit(0);
			printf("%s%s",buf,spaces+strlen(buf));
		}
	}
}
			
//go.sysin dd *
echo 'x - lex.yy.c'
sed 's/^X//' <<'//go.sysin dd *' >lex.yy.c
# include "stdio.h"
# define U(x) x
# define NLSTATE yyprevious=YYNEWLINE
# define BEGIN yybgin = yysvec + 1 +
# define INITIAL 0
# define YYLERR yysvec
# define YYSTATE (yyestate-yysvec-1)
# define YYOPTIM 1
# define YYLMAX 200
# define output(c) putc(c,yyout)
# define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10?(yylineno++,yytchar):yytchar)==EOF?0:yytchar)
# define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;}
# define yymore() (yymorfg=1)
# define ECHO fprintf(yyout, "%s",yytext)
# define REJECT { nstr = yyreject(); goto yyfussy;}
int yyleng; extern char yytext[];
int yymorfg;
extern char *yysptr, yysbuf[];
int yytchar;
XFILE *yyin ={stdin}, *yyout ={stdout};
extern int yylineno;
struct yysvf { 
	struct yywork *yystoff;
	struct yysvf *yyother;
	int *yystops;};
struct yysvf *yyestate;
extern struct yysvf yysvec[], *yybgin;
X/* LEX input for FORTH input file scanner */
X/* 
	Specifications are as follows:
	This file must be run through "sed" to change 
		yylex () {
	to
		TOKEN *yylex () {
	where the sed script is
		sed "s/yylex () {/TOKEN *yylex () {/" lex.yy.c

	Note that spaces have been included above so these lines won't be
	mangled by sed; in actuality, the two blanks surrounding () are
	removed.

	The function "yylex()" always returns a pointer to a structure:

	    struct tokenrec {
		int type;
		char *text;
	    }
	    #define TOKEN struct tokenrec

	where the type is a hint as to the word's type:
		DECIMAL for decimal literal		d+
		OCTAL for octal literal		0d*
		HEX for hex literal		0xd+ or 0Xd+
		C_BS for a literal Backspace	'\b'
		C_FF for a literal Form Feed	'\f'
		C_NL for a literal Newline	'\n'
		C_CR for a literal Carriage Return '\r'
		C_TAB for a literal Tab '\t'
		C_BSLASH for a literal backslash '\\'
		C_IT for an other character literal 'x' where x is possibly '
		STRING_LIT for a string literal (possibly containing \")
		COMMENT for a left-parenthesis (possibly beginning a comment)
		PRIM for "PRIM"
		CONST for "CONST"
		VAR for "VAR"
		USER for "USER"
		LABEL for "LABEL"
		COLON for ":"
		SEMICOLON for ";"
		SEMISTAR for ";*" (used to make words IMMEDIATE)
		NUL for the token {NUL}, which gets compiled as a null byte;
			this special interpretation takes place in the COLON
			code.
		LIT for the word "LIT" (treated like OTHER, except that
			no warning is generated when a literal follows this)
		OTHER for an other word not recognized above

	Note that this is just a hint: the meaning of any string of characters
	depends on the context.

*/
#include "forth.lex.h"
TOKEN token;
# define YYNEWLINE 10
TOKEN *yylex(){
int nstr; extern int yyprevious;
while((nstr = yylook()) >= 0)
yyfussy: switch(nstr){
case 0:
if(yywrap()) return(0); break;
case 1:
X/* whitespace -- keep looping */ ;
break;
case 2:
	{ token.type = DECIMAL; token.text = yytext;
					return &token; }
break;
case 3:
	{ token.type = OCTAL; token.text = yytext;
					return &token; }
break;
case 4:
	{ token.type = HEX; token.text = yytext;
					return &token; }
break;
case 5:
{ token.type = C_BS; token.text = yytext; return &token; }
break;
case 6:
{ token.type = C_FF; token.text = yytext; return &token; }
break;
case 7:
{ token.type = C_NL; token.text = yytext; return &token; }
break;
case 8:
{ token.type = C_CR; token.text = yytext; return &token; }
break;
case 9:
{ token.type = C_TAB; token.text = yytext; return &token; }
break;
case 10:
{ token.type = C_BSLASH; token.text = yytext; return &token; }
break;
case 11:
{ token.type = C_LIT; token.text = yytext; return &token; }
break;
case 12:
{ token.type = STRING_LIT; token.text = yytext; 
				return &token; }
break;
case 13:
	{ token.type = COMMENT; token.text = yytext;
				return &token; }
break;
case 14:
	{ token.type = PRIM; token.text = yytext;
				return &token; }
break;
case 15:
	{ token.type = CONST; token.text = yytext;
				return &token; }
break;
case 16:
	{ token.type = VAR; token.text = yytext;
				return &token; }
break;
case 17:
	{ token.type = USER; token.text = yytext;
				return &token; }
break;
case 18:
	{ token.type = LABEL; token.text = yytext;
				return &token; }
break;
case 19:
	{ token.type = COLON; token.text = yytext;
				return &token; }
break;
case 20:
	{ token.type = SEMICOLON; token.text = yytext;
				return &token; }
break;
case 21:
	{ token.type = SEMISTAR; token.text = yytext;
				return &token; }
break;
case 22:
	{ token.type = NUL; token.text = yytext;
				return &token; }
break;
case 23:
	{ token.type = LIT; token.text = yytext;
				return &token; }
break;
case 24:
{ token.type = OTHER; token.text = yytext;
				return &token; }
break;
case -1:
break;
default:
fprintf(yyout,"bad switch yylook %d",nstr);
} return(0); }
X/* end of yylex */
int yyvstop[] ={
0,

1,
0,

1,
0,

-24,
0,

1,
0,

-24,
0,

-24,
0,

-13,
-24,
0,

-24,
0,

-3,
-24,
0,

-2,
-24,
0,

-19,
-24,
0,

-20,
-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

24,
0,

24,
0,

-12,
-24,
0,

-24,
0,

-24,
0,

24,
0,

-24,
0,

13,
24,
0,

3,
24,
0,

-3,
-24,
0,

-24,
0,

2,
24,
0,

19,
24,
0,

20,
24,
0,

-21,
-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-12,
0,

12,
24,
0,

-12,
-24,
0,

-11,
-24,
0,

-11,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-24,
0,

-4,
-24,
0,

21,
24,
0,

-24,
0,

-24,
0,

-23,
-24,
0,

-24,
0,

-24,
0,

-16,
-24,
0,

-24,
0,

12,
0,

-12,
0,

12,
24,
0,

11,
24,
0,

11,
0,

-10,
-24,
0,

-5,
-24,
0,

-6,
-24,
0,

-7,
-24,
0,

-8,
-24,
0,

-9,
-24,
0,

4,
24,
0,

-24,
0,

-24,
0,

23,
24,
0,

-14,
-24,
0,

-17,
-24,
0,

16,
24,
0,

-24,
0,

12,
0,

10,
24,
0,

5,
24,
0,

6,
24,
0,

7,
24,
0,

8,
24,
0,

9,
24,
0,

-15,
-24,
0,

-18,
-24,
0,

14,
24,
0,

17,
24,
0,

-22,
-24,
0,

15,
24,
0,

18,
24,
0,

22,
24,
0,
0};
# define YYTYPE char
struct yywork { YYTYPE verify, advance; } yycrank[] ={
0,0,	0,0,	1,3,	0,0,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	1,4,	1,4,	
0,0,	4,4,	4,4,	0,0,	
4,4,	4,4,	7,26,	7,26,	
11,31,	11,31,	21,44,	21,44,	
0,0,	12,32,	12,32,	33,55,	
33,55,	0,0,	42,63,	42,63,	
0,0,	42,63,	42,63,	1,5,	
4,4,	46,66,	46,66,	0,0,	
1,6,	1,7,	22,45,	3,3,	
23,46,	24,47,	1,8,	48,68,	
49,69,	1,9,	1,10,	3,19,	
3,19,	42,63,	50,70,	2,6,	
2,7,	1,10,	12,33,	1,11,	
1,12,	2,8,	5,5,	51,71,	
6,23,	52,72,	1,3,	43,64,	
1,13,	35,57,	5,20,	5,20,	
6,24,	6,19,	2,11,	2,12,	
3,3,	1,14,	37,59,	38,60,	
18,40,	1,15,	13,34,	2,13,	
15,37,	16,38,	1,16,	1,17,	
34,56,	1,3,	3,3,	3,3,	
2,14,	9,27,	9,27,	5,21,	
2,15,	6,23,	3,3,	36,58,	
22,22,	2,16,	2,17,	10,30,	
10,30,	8,9,	8,10,	3,3,	
39,61,	5,5,	5,5,	6,23,	
6,23,	8,10,	14,3,	40,62,	
41,43,	5,5,	53,73,	6,23,	
28,27,	28,27,	14,19,	14,19,	
1,18,	43,43,	5,5,	56,75,	
6,23,	57,76,	3,3,	59,78,	
9,28,	9,28,	45,65,	45,65,	
58,77,	58,77,	60,79,	2,18,	
29,54,	29,54,	10,10,	10,10,	
62,81,	25,46,	65,43,	14,3,	
29,54,	5,5,	10,10,	6,23,	
75,89,	5,22,	76,90,	6,25,	
81,93,	29,54,	82,43,	28,28,	
28,28,	14,3,	14,3,	0,0,	
47,67,	47,67,	0,0,	47,67,	
47,67,	14,3,	61,80,	61,80,	
9,29,	64,82,	64,82,	0,0,	
17,3,	0,0,	14,35,	14,3,	
14,3,	14,3,	14,3,	14,3,	
17,19,	17,19,	14,36,	47,67,	
68,83,	68,83,	69,84,	69,84,	
70,85,	70,85,	71,86,	71,86,	
72,87,	72,87,	25,48,	73,88,	
73,88,	14,3,	78,91,	78,91,	
25,49,	79,92,	79,92,	0,0,	
25,50,	17,3,	14,3,	14,3,	
14,3,	14,3,	14,3,	14,3,	
25,51,	45,22,	89,94,	89,94,	
25,52,	0,0,	25,53,	17,3,	
17,3,	90,95,	90,95,	93,96,	
93,96,	0,0,	0,0,	17,3,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	20,41,	0,0,	
17,39,	17,3,	17,3,	17,3,	
17,3,	17,3,	20,41,	20,41,	
54,74,	54,74,	0,0,	0,0,	
0,0,	0,0,	0,0,	0,0,	
64,43,	0,0,	0,0,	0,0,	
0,0,	0,0,	0,0,	17,3,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	0,0,	20,42,	
17,3,	17,3,	17,3,	17,3,	
17,3,	17,3,	0,0,	0,0,	
0,0,	0,0,	0,0,	0,0,	
0,0,	20,41,	20,41,	54,54,	
54,54,	0,0,	0,0,	0,0,	
0,0,	20,41,	0,0,	54,54,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	20,41,	0,0,	
54,54,	0,0,	0,0,	0,0,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	0,0,	0,0,	
0,0,	0,0,	0,0,	0,0,	
0,0,	20,41,	0,0,	0,0,	
0,0,	20,43,	0,0,	0,0,	
0,0};
struct yysvf yysvec[] ={
0,	0,	0,
yycrank+-1,	0,		yyvstop+1,
yycrank+-16,	yysvec+1,	yyvstop+3,
yycrank+-42,	0,		yyvstop+5,
yycrank+4,	0,		yyvstop+7,
yycrank+-61,	0,		yyvstop+9,
yycrank+-63,	0,		yyvstop+11,
yycrank+-9,	yysvec+3,	yyvstop+13,
yycrank+-57,	yysvec+3,	yyvstop+16,
yycrank+-84,	yysvec+3,	yyvstop+18,
yycrank+-94,	yysvec+3,	yyvstop+21,
yycrank+-11,	yysvec+3,	yyvstop+24,
yycrank+-16,	yysvec+3,	yyvstop+27,
yycrank+-3,	yysvec+3,	yyvstop+30,
yycrank+-113,	0,		yyvstop+32,
yycrank+-2,	yysvec+3,	yyvstop+34,
yycrank+-2,	yysvec+3,	yyvstop+36,
yycrank+-175,	0,		yyvstop+38,
yycrank+-2,	yysvec+3,	yyvstop+40,
yycrank+0,	0,		yyvstop+42,
yycrank+-237,	0,		yyvstop+44,
yycrank+-13,	yysvec+3,	yyvstop+46,
yycrank+-8,	yysvec+5,	yyvstop+49,
yycrank+-5,	yysvec+3,	yyvstop+51,
yycrank+6,	0,		yyvstop+53,
yycrank+-106,	yysvec+3,	yyvstop+55,
yycrank+0,	0,		yyvstop+57,
yycrank+0,	0,		yyvstop+60,
yycrank+-111,	yysvec+3,	yyvstop+63,
yycrank+-92,	yysvec+3,	yyvstop+66,
yycrank+0,	0,		yyvstop+68,
yycrank+0,	0,		yyvstop+71,
yycrank+0,	0,		yyvstop+74,
yycrank+-18,	yysvec+3,	yyvstop+77,
yycrank+-10,	yysvec+3,	yyvstop+80,
yycrank+-3,	yysvec+3,	yyvstop+82,
yycrank+-15,	yysvec+3,	yyvstop+84,
yycrank+-5,	yysvec+3,	yyvstop+86,
yycrank+-10,	yysvec+3,	yyvstop+88,
yycrank+-26,	yysvec+3,	yyvstop+90,
yycrank+-30,	yysvec+3,	yyvstop+92,
yycrank+-24,	yysvec+20,	0,	
yycrank+21,	0,		yyvstop+94,
yycrank+-33,	yysvec+20,	0,	
yycrank+0,	0,		yyvstop+96,
yycrank+-125,	yysvec+5,	yyvstop+99,
yycrank+-28,	yysvec+3,	yyvstop+102,
yycrank+155,	0,		yyvstop+105,
yycrank+-8,	yysvec+3,	yyvstop+107,
yycrank+-9,	yysvec+3,	yyvstop+109,
yycrank+-15,	yysvec+3,	yyvstop+111,
yycrank+-24,	yysvec+3,	yyvstop+113,
yycrank+-26,	yysvec+3,	yyvstop+115,
yycrank+-79,	yysvec+3,	yyvstop+117,
yycrank+-239,	yysvec+3,	yyvstop+119,
yycrank+0,	0,		yyvstop+122,
yycrank+-44,	yysvec+3,	yyvstop+125,
yycrank+-60,	yysvec+3,	yyvstop+127,
yycrank+-127,	yysvec+3,	yyvstop+129,
yycrank+-54,	yysvec+3,	yyvstop+132,
yycrank+-56,	yysvec+3,	yyvstop+134,
yycrank+-161,	yysvec+3,	yyvstop+136,
yycrank+-68,	yysvec+3,	yyvstop+139,
yycrank+0,	0,		yyvstop+141,
yycrank+-164,	yysvec+20,	yyvstop+143,
yycrank+-54,	yysvec+20,	yyvstop+145,
yycrank+0,	0,		yyvstop+148,
yycrank+0,	0,		yyvstop+151,
yycrank+-179,	yysvec+3,	yyvstop+153,
yycrank+-181,	yysvec+3,	yyvstop+156,
yycrank+-183,	yysvec+3,	yyvstop+159,
yycrank+-185,	yysvec+3,	yyvstop+162,
yycrank+-187,	yysvec+3,	yyvstop+165,
yycrank+-190,	yysvec+3,	yyvstop+168,
yycrank+0,	0,		yyvstop+171,
yycrank+-68,	yysvec+3,	yyvstop+174,
yycrank+-78,	yysvec+3,	yyvstop+176,
yycrank+0,	0,		yyvstop+178,
yycrank+-193,	yysvec+3,	yyvstop+181,
yycrank+-196,	yysvec+3,	yyvstop+184,
yycrank+0,	0,		yyvstop+187,
yycrank+-31,	yysvec+3,	yyvstop+190,
yycrank+-66,	yysvec+20,	yyvstop+192,
yycrank+0,	0,		yyvstop+194,
yycrank+0,	0,		yyvstop+197,
yycrank+0,	0,		yyvstop+200,
yycrank+0,	0,		yyvstop+203,
yycrank+0,	0,		yyvstop+206,
yycrank+0,	0,		yyvstop+209,
yycrank+-209,	yysvec+3,	yyvstop+212,
yycrank+-216,	yysvec+3,	yyvstop+215,
yycrank+0,	0,		yyvstop+218,
yycrank+0,	0,		yyvstop+221,
yycrank+-218,	yysvec+3,	yyvstop+224,
yycrank+0,	0,		yyvstop+227,
yycrank+0,	0,		yyvstop+230,
yycrank+0,	0,		yyvstop+233,
0,	0,	0};
struct yywork *yytop = yycrank+329;
struct yysvf *yybgin = yysvec+1;
char yymatch[] ={
00  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
01  ,011 ,012 ,01  ,011 ,011 ,01  ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
011 ,01  ,'"' ,01  ,01  ,01  ,01  ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
'0' ,'1' ,'1' ,'1' ,'1' ,'1' ,'1' ,'1' ,
'8' ,'8' ,01  ,01  ,01  ,01  ,01  ,01  ,
01  ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
'X' ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
01  ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
'X' ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
0};
char yyextra[] ={
0,0,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,
1,0,0,0,0,0,0,0,
0};
X/*	ncform	4.1	83/08/11	*/

int yylineno =1;
# define YYU(x) x
# define NLSTATE yyprevious=YYNEWLINE
char yytext[YYLMAX];
struct yysvf *yylstate [YYLMAX], **yylsp, **yyolsp;
char yysbuf[YYLMAX];
char *yysptr = yysbuf;
int *yyfnd;
extern struct yysvf *yyestate;
int yyprevious = YYNEWLINE;
yylook(){
	register struct yysvf *yystate, **lsp;
	register struct yywork *yyt;
	struct yysvf *yyz;
	int yych;
	struct yywork *yyr;
# ifdef LEXDEBUG
	int debug;
# endif
	char *yylastch;
	/* start off machines */
# ifdef LEXDEBUG
	debug = 0;
# endif
	if (!yymorfg)
		yylastch = yytext;
	else {
		yymorfg=0;
		yylastch = yytext+yyleng;
		}
	for(;;){
		lsp = yylstate;
		yyestate = yystate = yybgin;
		if (yyprevious==YYNEWLINE) yystate++;
		for (;;){
# ifdef LEXDEBUG
			if(debug)fprintf(yyout,"state %d\n",yystate-yysvec-1);
# endif
			yyt = yystate->yystoff;
			if(yyt == yycrank){		/* may not be any transitions */
				yyz = yystate->yyother;
				if(yyz == 0)break;
				if(yyz->yystoff == yycrank)break;
				}
			*yylastch++ = yych = input();
		tryagain:
# ifdef LEXDEBUG
			if(debug){
				fprintf(yyout,"char ");
				allprint(yych);
				putchar('\n');
				}
# endif
			yyr = yyt;
			if ( (int)yyt > (int)yycrank){
				yyt = yyr + yych;
				if (yyt <= yytop && yyt->verify+yysvec == yystate){
					if(yyt->advance+yysvec == YYLERR)	/* error transitions */
						{unput(*--yylastch);break;}
					*lsp++ = yystate = yyt->advance+yysvec;
					goto contin;
					}
				}
# ifdef YYOPTIM
			else if((int)yyt < (int)yycrank) {		/* r < yycrank */
				yyt = yyr = yycrank+(yycrank-yyt);
# ifdef LEXDEBUG
				if(debug)fprintf(yyout,"compressed state\n");
# endif
				yyt = yyt + yych;
				if(yyt <= yytop && yyt->verify+yysvec == yystate){
					if(yyt->advance+yysvec == YYLERR)	/* error transitions */
						{unput(*--yylastch);break;}
					*lsp++ = yystate = yyt->advance+yysvec;
					goto contin;
					}
				yyt = yyr + YYU(yymatch[yych]);
# ifdef LEXDEBUG
				if(debug){
					fprintf(yyout,"try fall back character ");
					allprint(YYU(yymatch[yych]));
					putchar('\n');
					}
# endif
				if(yyt <= yytop && yyt->verify+yysvec == yystate){
					if(yyt->advance+yysvec == YYLERR)	/* error transition */
						{unput(*--yylastch);break;}
					*lsp++ = yystate = yyt->advance+yysvec;
					goto contin;
					}
				}
			if ((yystate = yystate->yyother) && (yyt= yystate->yystoff) != yycrank){
# ifdef LEXDEBUG
				if(debug)fprintf(yyout,"fall back to state %d\n",yystate-yysvec-1);
# endif
				goto tryagain;
				}
# endif
			else
				{unput(*--yylastch);break;}
		contin:
# ifdef LEXDEBUG
			if(debug){
				fprintf(yyout,"state %d char ",yystate-yysvec-1);
				allprint(yych);
				putchar('\n');
				}
# endif
			;
			}
# ifdef LEXDEBUG
		if(debug){
			fprintf(yyout,"stopped at %d with ",*(lsp-1)-yysvec-1);
			allprint(yych);
			putchar('\n');
			}
# endif
		while (lsp-- > yylstate){
			*yylastch-- = 0;
			if (*lsp != 0 && (yyfnd= (*lsp)->yystops) && *yyfnd > 0){
				yyolsp = lsp;
				if(yyextra[*yyfnd]){		/* must backup */
					while(yyback((*lsp)->yystops,-*yyfnd) != 1 && lsp > yylstate){
						lsp--;
						unput(*yylastch--);
						}
					}
				yyprevious = YYU(*yylastch);
				yylsp = lsp;
				yyleng = yylastch-yytext+1;
				yytext[yyleng] = 0;
# ifdef LEXDEBUG
				if(debug){
					fprintf(yyout,"\nmatch ");
					sprint(yytext);
					fprintf(yyout," action %d\n",*yyfnd);
					}
# endif
				return(*yyfnd++);
				}
			unput(*yylastch);
			}
		if (yytext[0] == 0  /* && feof(yyin) */)
			{
			yysptr=yysbuf;
			return(0);
			}
		yyprevious = yytext[0] = input();
		if (yyprevious>0)
			output(yyprevious);
		yylastch=yytext;
# ifdef LEXDEBUG
		if(debug)putchar('\n');
# endif
		}
	}
yyback(p, m)
	int *p;
{
if (p==0) return(0);
while (*p)
	{
	if (*p++ == m)
		return(1);
	}
return(0);
}
	/* the following are only used in the lex library */
yyinput(){
	return(input());
	}
yyoutput(c)
  int c; {
	output(c);
	}
yyunput(c)
   int c; {
	unput(c);
	}
//go.sysin dd *
echo 'x - nf.c'
sed 's/^X//' <<'//go.sysin dd *' >nf.c
X/* nf.c -- this program can be run to generate a new environment for the
 * FORTH interpreter forth.c. It takes the dictionary from the standard input.
 * Normally, this dictionary is in the file "forth.dict", so 
 *	nf < forth.dict
 * will do the trick.
 */

#include <stdio.h>
#include <ctype.h>
#include "common.h"
#include "forth.lex.h"		/* #defines for lexical analysis */

#define isoctal(c)	(c >= '0' && c <= '7')	/* augument ctype.h */

#define assert(c,s)	(!(c) ? failassert(s) : 1)
#define chklit()	(!prev_lit ? dictwarn("Qustionable literal") : 1)

#define LINK struct linkrec
#define CHAIN struct chainrec

struct chainrec {
    char chaintext[32];
    int defloc;				/* CFA or label loc */
    int chaintype;			/* 0=undef'd, 1=absolute, 2=relative */
    CHAIN *nextchain;
    LINK *firstlink;
};

struct linkrec {
    int loc;
    LINK *nextlink;
};

CHAIN firstchain;

#define newchain()	(CHAIN *)(calloc(1,sizeof(CHAIN)))
#define newlink()	(LINK *)(calloc(1,sizeof(LINK)))

CHAIN *find();
CHAIN *lastchain();
LINK *lastlink();

char *strcat();
char *calloc();

int dp = DPBASE;
int latest;

short mem[INITMEM];

XFILE *outf, *fopen();

main(argc, argv)
int argc;
char *argv[];
{
#ifdef DEBUG
	puts("Opening output file");
#endif DEBUG

    strcpy(firstchain.chaintext," ** HEADER **");
    firstchain.nextchain = NULL;
    firstchain.firstlink = NULL;

#ifdef DEBUG
    puts("call builddict");
#endif DEBUG
    builddict();
#ifdef DEBUG
    puts("Make FORTH and COLDIP");
#endif DEBUG
    mkrest();
#ifdef DEBUG
    puts("Call Buildcore");
#endif DEBUG
    buildcore();
#ifdef DEBUG
    puts("call checkdict");
#endif DEBUG
    checkdict();
#ifdef DEBUG
    puts("call writedict");
#endif DEBUG
    writedict();

    printf("%s: done.\n", argv[0]);
}

buildcore()			/* set up low core */
{
	mem[USER_DEFAULTS+0] = INITS0;			/* initial S0 */
	mem[USER_DEFAULTS+1] = INITR0;			/* initial R0 */
	mem[USER_DEFAULTS+2] = TIB_START;		/* initial TIB */
	mem[USER_DEFAULTS+3] = MAXWIDTH;		/* initial WIDTH */
	mem[USER_DEFAULTS+4] = 0;			/* initial WARNING */
	mem[USER_DEFAULTS+5] = dp;			/* initial FENCE */
	mem[USER_DEFAULTS+6] = dp;			/* initial DP */
	mem[USER_DEFAULTS+7] = instance("FORTH") + 3;	/* initial CONTEXT */

	mem[SAVEDIP] = 0;				/* not a saved FORTH */
}

builddict()			/* read the dictionary */
{
    int prev_lit = 0, lit_flag = 0;
    int temp;
    char s[256];
    TOKEN *token;

    while ((token = yylex()) != NULL) {	/* EOF returned as a null pointer */
#ifdef DEBUG
	printf("\ntoken: %s: %d ",token->text, token->type);
#endif DEBUG
	switch (token->type) {

	case PRIM:
#ifdef DEBUG
	    printf("primitive ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get the next word */
		dicterr("No word following PRIM");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if ((token == yylex()) == NULL)	/* get the value */
		dicterr("No value following PRIM <word>");
	    mkword(s,mkval(token));
	    break;

	case CONST:
#ifdef DEBUG
	    printf("constant ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get the word */
		dicterr("No word following CONST");
	    strcpy (s,token->text);		/* s holds word */
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if (!find("DOCON"))
		dicterr ("Constant definition before DOCON: %s",s);
				/* put the CF of DOCON into this word's CF */
	    mkword(s,(int)mem[instance("DOCON")]);
	    if ((token = yylex()) == NULL)	/* get the value */
		dicterr("No value following CONST <word>");
	    temp = mkval(token);

	    /* two special-case constants */
	    if (strcmp(s,"FIRST") == 0) temp = INITR0;
	    else if (strcmp(s,"LIMIT") == 0) temp = DPBASE;

	    comma(temp);
	    break;

	case VAR:
#ifdef DEBUG
	    printf("variable ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get the variable name */
		dicterr("No word following VAR");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if (!find("DOVAR"))
		dicterr("Variable declaration before DOVAR: %s",s);
	    mkword (s, (int)mem[instance("DOVAR")]);
	    if ((token = yylex()) == NULL)	/* get the value */
		dicterr("No value following VAR <word>");
	    comma(mkval(token));
	    break;

	case USER:
#ifdef DEBUG
	    printf("uservar ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get uservar name */
		dicterr("No name following USER");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if (!find("DOUSE"))
		dicterr("User variable declared before DOUSE: %s",s);
	    mkword (s, (int)mem[instance("DOUSE")]);
	    if ((token = yylex()) == NULL)	/* get the value */
		dicterr("No value following USER <word>");
	    comma(mkval(token));
	    break;

	case COLON:
#ifdef DEBUG
	    printf("colon def'n ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get name of word */
		dicterr("No word following : in definition");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s.\n",s);
#endif DEBUG
	    if (!find("DOCOL"))
		dicterr("Colon definition appears before DOCOL: %s",s);

	    if (token->type == NUL) {	/* special zero-named word */
		int here = dp;		/* new latest */
#ifdef DEBUG
		printf("NULL WORD AT 0x%04x\n");
#endif DEBUG
		comma(0xC1);
		comma(0x80);
		comma(latest);
		latest = here;
		comma((int)mem[instance("DOCOL")]);
	    }
	    else {
		mkword (s, (int)mem[instance("DOCOL")]);
	    }
	    break;

	case SEMICOLON:
#ifdef DEBUG
	    puts("end colon def'n");
#endif DEBUG
	    comma (instance(";S"));
	    break;

	case SEMISTAR:
#ifdef DEBUG
	    printf("end colon w/IMMEDIATE ");
#endif DEBUG
	    comma (instance (";S"));	/* compile cfA of ;S, not CF */
	    mem[latest] |= IMMEDIATE;	/* make the word immediate */
	    break;

	case STRING_LIT:
#ifdef DEBUG
	    printf("string literal ");
#endif DEBUG
	    strcpy(s,token->text);
	    mkstr(s);		/* mkstr compacts the string in place */
#ifdef DEBUG
	    printf("string=(%d) \"%s\" ",strlen(s),s);
#endif DEBUG
	    comma(strlen(s));
	    {
		char *stemp;
		stemp = s;
		while (*stemp) comma(*stemp++);
	    }
	    break;
	
	case COMMENT:
#ifdef DEBUG
	    printf("comment ");
#endif DEBUG
	    skipcomment();
	    break;

	case LABEL:
#ifdef DEBUG
	    printf("label: ");
#endif DEBUG
	    if ((token = yylex()) == NULL)
		dicterr("No name following LABEL");
#ifdef DEBUG
	    printf(".%s. ", token->text);
#endif DEBUG
	    define(token->text,2);	/* place in sym. table w/o compiling
					   anything into dictionary; 2 means
					   defining a label */
	    break;

	case LIT:
		lit_flag = 1;		/* and fall through to the rest */

	default:
	    if (find(token->text) != NULL) {	/* is word defined? */
#ifdef DEBUG
		printf("  normal: %s\n",token->text);
#endif DEBUG
	    	comma (instance (token->text));
		break;
	    }

	    /* else */
	    /* the literal types all call chklit(). This macro checks to
	       if the previous word was "LIT"; if not, it warns */
	    switch(token->type) {
	    case DECIMAL: chklit(); comma(mkdecimal(token->text)); break;
	    case HEX: chklit(); comma(mkhex(token->text)); break;
	    case OCTAL: chklit(); comma(mkoctal(token->text)); break;
	    case C_BS: chklit(); comma('\b'); break;
	    case C_FF: chklit(); comma('\f'); break;
	    case C_NL: chklit(); comma('\n'); break;
	    case C_CR: chklit(); comma('\r'); break;
	    case C_TAB: chklit(); comma('\t'); break;
	    case C_BSLASH: chklit(); comma(0x5c); break;  /* ASCII backslash */
	    case C_LIT: chklit(); comma(*((token->text)+1)); break;

	    default:
#ifdef DEBUG
		printf("forward reference");
#endif DEBUG
		comma (instance (token->text));		/* create an instance,
						to be resolved at definition */
	    }
	}
#ifdef DEBUG
	if (lit_flag) puts("expect a literal");
#endif DEBUG
	prev_lit = lit_flag;	/* to be used by chklit() next time */
	lit_flag = 0;
    }
}

comma(i)			/* put at mem[dp]; increment dp */
{
    mem[dp++] = (unsigned short)i;
    if (dp > INITMEM) dicterr("DICTIONARY OVERFLOW");
}

X/*
 * make a word in the dictionary.  the new word will have name *s, its CF
 * will contain v. Also, resolve any previously-unresolved references by
 * calling define()
 */

mkword(s, v)
char *s;
short v;
{
	int here, count = 0;
	char *olds;
	olds = s;		/* preserve this for resolving references */

#ifdef DEBUG
	printf("%s ",s);
#endif DEBUG

	here = dp;		/* hold this value to place length byte */

	while (*s) {		/* for each character */
		mem[++dp] = (unsigned short)*s;
		count++; s++;
	}

	if (count >= MAXWIDTH) dicterr("Input word name too long");

				/* set MSB on */
	mem[here] = (short)(count | 0x80);

	mem[dp++] |= 0x80;	/* set hi bit of last char in name */
	
	mem[dp++] = (short)latest;	/* the link field */

	latest = here;		/* update the link */

	mem[dp] = v;		/* code field; leave dp = CFA */

	define(olds,1);		/* place in symbol table. 1 == "not a label" */
	dp++;			/* now leave dp holding PFA */

	/* that's all. Now dp points (once again) to the first UNallocated
           spot in mem, and everybody's happy. */
}

mkrest()			/* Write out the word FORTH as a no-op with
				   DOCOL as CF, ;S as PF, followed by
				   0xA081, and latest in its PF.
				   Also, Put the CFA of ABORT at 
				   mem[COLDIP] */
{
	int temp;

	mem[COLDIP] = dp;	/* the cold-start IP is here, and the word
				   which will be executed is COLD */
	if ((mem[dp++] = instance("COLD")) == 0)
		dicterr("COLD must be defined to take control at startup");

	mem[ABORTIP] = dp;	/* the abort-start IP is here, and the word
				   which will be executed is ABORT */
	if ((mem[dp++] = instance("ABORT")) == 0)
		dicterr("ABORT must be defined to take control at interrupt");

	mkword("FORTH",mem[instance("DOCOL")]);
	comma(instance(";S"));
	comma(0xA081);	/* magic number for vocabularies */
	comma(latest);		/* NFA of last word in dictionary: FORTH */

	mem[LIMIT] = dp + 1024;
	if (mem[LIMIT] >= INITMEM) mem[LIMIT] = INITMEM-1;
}

writedict()			/* write memory to COREFILE and map 
			   	   to MAPFILE */
{
    FILE   *outfile;
    int     i, temp, tempb, firstzero, nonzero;
    char    chars[9], outline[80], tstr[6];

    outfile = fopen(MAPFILE,"w");

    for (temp = 0; temp < dp; temp += 8) {
	nonzero = FALSE;
	sprintf (outline, "%04x:", temp);
	for (i = temp; i < temp + 8; i++) {
	    sprintf (tstr, " %04x", (unsigned short) mem[i]);
	    strcat (outline, tstr);
	    tempb = mem[i] & 0x7f;
	    if (tempb < 0x7f && tempb >= ' ')
		chars[i % 8] = tempb;
	    else
		chars[i % 8] = '.';
	    nonzero |= mem[i];
	}
	if (nonzero) {
	    fprintf (outfile, "%s %s\n", outline, chars);
	    firstzero = TRUE;
	}
	else
	    if (firstzero) {
		fprintf (outfile, "----- ZERO ----\n");
		firstzero = FALSE;
	    }
    }
    fclose (outfile);


    printf ("Writing %s; DPBASE=%d; dp=%d\n", COREFILE, DPBASE, dp);

    if ((outf = fopen (COREFILE, "w")) == NULL) {
	printf ("nf: can't open %s for output.\n", COREFILE);
	exit (1);
    }

    if (fwrite (mem, sizeof (*mem), mem[LIMIT], outf) != mem[LIMIT]) {
	fprintf (stderr, "Error writing to %s\n", COREFILE);
	exit (1);
    }

    if (fclose (outf) == EOF) {
	fprintf (stderr, "Error closing %s\n", COREFILE);
	exit (1);
    }
}

mkval(t)			/* convert t->text to integer based on type */
TOKEN *t;
{
	char *s = t->text;
	int sign = 1;

	if (*s == '-') {
		sign = -1;
		s++;
	}

	switch (t->type) {
	case DECIMAL:
		return (sign * mkdecimal(s));
	case HEX:
		return (sign * mkhex(s));
	case OCTAL:
		return (sign * mkoctal(s));
	default:
		dicterr("Bad value following PRIM, CONST, VAR, or USER");
	}
}

mkhex(s)
char *s;
{				/*  convert hex ascii to integer */
    int     temp;
    temp = 0;

    s += 2;			/* skip over '0x' */
    while (isxdigit (*s)) {	/* first non-hex char ends */
	temp <<= 4;		/* mul by 16 */
	if (isupper (*s))
	    temp += (*s - 'A') + 10;
	else
	    if (islower (*s))
		temp += (*s - 'a') + 10;
	    else
		temp += (*s - '0');
	s++;
    }
    return temp;
}

mkoctal(s)
char *s;
{				/*  convert Octal ascii to integer */
    int     temp;
    temp = 0;

    while (isoctal (*s)) {	/* first non-octal char ends */
	temp = temp * 8 + (*s - '0');
	s++;
    }
    return temp;
}

mkdecimal(s)			/* convert ascii to decimal */
char *s;
{
	return (atoi(s));	/* alias */
}

dicterr(s,p1)
char *s;
int p1;		/* might be char * -- printf uses it */
{
    fprintf(stderr,s,p1);
    fprintf(stderr,"\nLast word defined was ");
    printword(latest);
X/*    fprintf(stderr, "; last word read was \"%s\"", token->text); */
    fprintf(stderr,"\n");
    exit(1);
}

dictwarn(s)		/* almost like dicterr, but don't exit */
char *s;
{
    fprintf(stderr,"\nWarning: %s\nLast word read was ",s);
    printword(latest);
    putc('\n',stderr);
}
    
printword(n)
int n;
{
    int count, tmp;
    count = mem[n] & 0x1f;
    for (n++;count;count--,n++) {
	tmp = mem[n] & ~0x80;		/* mask eighth bit off */
	if (tmp >= ' ' && tmp <= '~') putc(tmp, stderr);
    }
}

skipcomment()
{
    while(getchar() != ')');
}

mkstr(s)			/* modifies a string in place with escapes
				   compacted. Strips leading & trailing \" */
char *s;
{
    char *source;
    char *dest;

    source = dest = s;
    source++;			/* skip leading quote */
    while (*source != '"') {	/* string ends with unescaped \" */
	if (*source == '\\') {	/* literal next */
	    source++;
	}
	*dest++ = *source++;
    }
    *dest = '\0';
}

failassert(s)
char *s;
{
    puts(s);
    exit(1);
}

checkdict()			/* check for unresolved references */
{
    CHAIN *ch = &firstchain;

#ifdef DEBUG
    puts("\nCheck for unresolved references");
#endif DEBUG
    while (ch != NULL) {
#ifdef DEBUG
	printf("ch->chaintext = .%s. - ",ch->chaintext);
#endif DEBUG
	if ((ch->firstlink) != NULL) {
	    fprintf(stderr,"Unresolved forward reference: %s\n",ch->chaintext);
#ifdef DEBUG
	    puts("still outstanding");
#endif DEBUG
	}
#ifdef DEBUG
	else puts("clean.");
#endif DEBUG
	ch = ch->nextchain;
    }
}

    
X/********* structure-handling functions find(s), define(s,t), instance(s) **/

CHAIN *find(s)		/* returns a pointer to the chain named s */
char *s;
{
	CHAIN *ch;
	ch = &firstchain;
	while (ch != NULL) {
		if (strcmp (s, ch->chaintext) == 0) return ch;
		else ch = ch->nextchain;
	}
	return NULL;	/* not found */
}

X/* define must create a symbol table entry if none exists, with type t.
   if one does exist, it must have type 0 -- it is an error to redefine
   something at this stage. Change to type t, and fill in the outstanding
   instances, with the current dp if type=1, or relative if type=2. */

define(s,t)		/* define s at current dp */
char *s;
int t;
{
	CHAIN *ch;
	LINK *ln, *templn;

#ifdef DEBUG
	printf("define(%s,%d)\n",s,t);
#endif DEBUG

	if (t < 1 || t > 2)	/* range check */
		dicterr("Program error: type in define() not 1 or 2.");

	if ((ch = find(s)) != NULL) {		/* defined or instanced? */
		if (ch -> chaintype != 0)	/* already defined! */
			dicterr("Word already defined: %s",s);
		else {
#ifdef DEBUG
			printf("there are forward refs: ");
#endif DEBUG
			ch->chaintype = t;
			ch->defloc = dp;
		}
	}
	else {				/* must create a (blank) chain */
#ifdef DEBUG
		puts("no forward refs");
#endif DEBUG
		/* create a new chain, link it in, leave ch pointing to it */
		ch = ((lastchain() -> nextchain) = newchain());
		strcpy(ch->chaintext, s);
		ch->chaintype = t;
		ch->defloc = dp;	/* fill in for future references */
	}

	/* now ch points to the chain (possibly) containing forward refs */
	if ((ln = ch->firstlink) == NULL) return;	/* no links! */

	while (ln != NULL) {
#ifdef DEBUG
		printf("    Forward ref at 0x%x\n",ln->loc);
#endif DEBUG
		switch (ch->chaintype) {
		case 1: mem[ln->loc] = (short)dp;	/* absolute */
			break;
		case 2: mem[ln->loc] = (short)(dp - ln->loc);	/* relative */
			break;
		default: dicterr ("Bad type field in define()");
		}

		/* now skip to the next link & free this one */
		templn = ln;
		ln = ln->nextlink;
		free(templn);
	}
	ch->firstlink = NULL;	/* clean up that last pointer */
}

X/*
   instance must return a value to be compiled into the dictionary at
   dp, consistent with the symbol s: if s is undefined, it returns 0,
   and adds this dp to the chain for s (creating that chain if necessary).
   If s IS defined, it returns <s> (absolute) or (s-dp) (relative), 
   where <s> was the dp when s was defined.
*/

instance(s)
char *s;
{
	CHAIN *ch;
	LINK *ln;

#ifdef DEBUG
	printf("instance(%s):\n",s);
#endif DEBUG

	if ((ch = find(s)) == NULL) {	/* not defined yet at all */
#ifdef DEBUG
		puts("entirely new -- create a new chain");
#endif DEBUG
		/* create a new chain, link it in, leave ch pointing to it */
		ch = ((lastchain() -> nextchain) = newchain());

		strcpy(ch->chaintext, s);
		ln = newlink();		/* make its link */
		ch->firstlink = ln;
		ln->loc = dp;		/* store this location there */
		return 0;		/* all done */
	}
	else {
		switch(ch->chaintype) {
		case 0:			/* not defined yet */
#ifdef DEBUG
			puts("still undefined -- add a link");
#endif DEBUG
			/* create a new link, point the last link to it, and
			   fill in the loc field with the current dp */
			(lastlink(ch)->nextlink = newlink()) -> loc = dp;
			return 0;
		case 1:			/* absolute */
#ifdef DEBUG
			puts("defined absolute.");
#endif DEBUG
			return ch->defloc;
		case 2:			/* relative */
#ifdef DEBUG
			puts("defined relative.");
#endif DEBUG
			return ch->defloc - dp;
		default:
			dicterr("Program error: bad type for chain");
		}
	}
}

CHAIN *lastchain()	/* starting from firstchain, find the last chain */
{
	CHAIN *ch = &firstchain;
	while (ch->nextchain != NULL) ch = ch->nextchain;
	return ch;
}

LINK *lastlink(ch)	/* return the last link in the chain */
CHAIN *ch;		/* CHAIN MUST HAVE AT LEAST ONE LINK */
{
	LINK *ln = ch->firstlink;

	while (ln->nextlink != NULL) ln = ln->nextlink;
	return ln;
}

yywrap()	/* called by yylex(). returning 1 means "all finished" */
{
    return 1;
}
//go.sysin dd *
echo 'x - prims.c'
sed 's/^X//' <<'//go.sysin dd *' >prims.c
X/*
 * prims.c -- code for the primitive functions declared in forth.dict
 */

#include <stdio.h>
#include <ctype.h>	/* used in "digit" */
#include "common.h"
#include "forth.h"
#include "prims.h"	/* macro primitives */

X/*
             ----------------------------------------------------
                            PRIMITIVE DEFINITIONS
             ----------------------------------------------------
*/

zbranch()			/* add an offset (branch) if tos == 0 */
{
	if(pop() == 0) 
	    ip += mem[ip];
	else
	    ip++;		/* else skip over the offset */
}

ploop()				/* (loop) -- loop control */
{
	short index, limit;
	index = rpop()+1;
	if(index < (limit = rpop())) {   /* if the new index < the limit */
		rpush(limit);	/* restore the limit */
		rpush(index);	/* and the index (incremented) */
		branch();	/* and go back to the top of the loop */
	}
	else ip++;     		/* skip over the offset, and exit, having
				   popped the limit & index */
}

pploop()			/* (+loop) -- almost the same */
{
	short index, limit;
	index = rpop()+pop();		/* get index & add increment */
	if(index < (limit = rpop())) {	/* if new index < limit */
		rpush (limit);		/* restore the limit */
		rpush (index);		/* restore the new index */
		branch();		/* and branch back to the top */
	}
	else {
		ip++;		/* skip over branch offset */
	}
}

pdo()			/* (do): limit init -- [pushed to rstack] */
{
    swap();
    rpush (pop());
    rpush (pop());
}

i()			/* copy top of return stack to cstack */
{
    int tmp;
    tmp = rpop();
    rpush(tmp);
    push(tmp);
}

r()		/* this must be a primitive as well as I because otherwise it
		   always returns its own address */
{
    i();
}

digit()			/* digit: c -- FALSE or [v TRUE] */
{
    short c, base;		/* C is ASCII char, convert to val. BASE is
				   used for range checking */
    base = pop();
    c = pop();
    if (!isascii(c)) {
	push (FALSE);
	return;
    }
 				/* lc -> UC if necessary */
    if (islower(c)) c = toupper(c);

    if (c < '0' || (c > '9' && c < 'A') || c > 'Z') {
	push(FALSE);		/* not a digit */
    }
    else {			/* it is numeric or UC Alpha */
	if (c >= 'A') c -= 7;	/* put A-Z right after 0-9 */

	c -= '0';		/* now c is 0..35 */

	if (c >= base) {
	    push (FALSE);	/* FALSE - not a digit */
	}
	else {			/* OKAY: push value, then TRUE */
	    push (c);
	    push (TRUE);
	}
    }
}

pfind()		/* WORD TOP -- xx FLAG, where TOP is NFA to start at;
		   WORD is the word to find; xx is PFA of found word;
		   yy is actual length of the word found;
		   FLAG is 1 if found. If not found, 0 alone is stacked. */
{
    unsigned short  worka, workb, workc, current, word, match;

    current = pop ();
    word = pop ();
    while (current) {		/* stop at end of dictionary */
	if (!((mem[current] ^ mem[word]) & 0x3f)) {
				/* match lengths & smudge */
	    worka = current + 1;/* point to the first letter */
	    workb = word + 1;
	    workc = mem[word];	/* workc gets count */
	    match = TRUE;	/* initally true, for looping */
	    while (workc-- && match)
		match = ((mem[worka++] & 0x7f) == (mem[workb++] & 0x7f));
	    if (match) {	/* exited with match TRUE -- FOUND IT */
		push (worka + 2);		/* worka=LFA; push PFA */
		push (mem[current]);		/* push length byte */
		push (TRUE);			/* and TRUE flag */
		return;
	    }
	}
	/* failed to match */
	/* follow link field to next word */
	current = mem[current + (mem[current] & 0x1f) + 1];
    }
    push (FALSE);		/* current = 0; end of dict; not found */
}

enclose()
{
	int delim, current, offset;

	delim = pop();
	current = pop();
	push (current);

	offset = -1;
	current--;
encl1:
	current++;
	offset++;
	if (mem[current] == delim) goto encl1;

	push(offset);
	if (mem[current] == NULL) {
		offset++;
		push (offset);
		offset--;
		push (offset);
		return;
	}

encl2:
	current++;
	offset++;
	if (mem[current] == delim) goto encl4;
	if (mem[current] != NULL) goto encl2;

	/* mem[current] is null.. */
	push (offset);
	push (offset);
	return;

encl4:	/* found the trailing delimiter */
	push (offset);
	offset++;
	push (offset);
	return;
}

cmove()			/* cmove: source dest number -- */
{
    short source, dest, number, i;
    number = pop();
    dest = pop();
    source = pop();
    for ( ; number ; number-- ) mem[dest++] = mem[source++];
}

fill()			/* fill: c dest number -- */
{
    short dest, number, c;
    number = pop();
    dest = pop();
    c = pop();

    mem[dest] = c;		/* always at least one */
    if (number == 1) return;	/* return if only one */

    push (dest);		/* else push dest as source of cmove */
    push (dest + 1);		/* dest+1 as dest of cmove */
    push (number - 1);		/* number-1 as number of cmove */
    cmove();
}

ustar()				/* u*: a b -- a*b.hi a*b.lo */
{
    unsigned short a, b;
    unsigned long c;
    a = (unsigned short)pop();
    b = (unsigned short)pop();
    c = a * b;

    /* (short) -1 is probably FFFF, which is just what we want */
    push ((unsigned short)(c & (short) -1));	      /* low word of product */
						     /* high word of product */
    push ((short)((c >> (8*sizeof(short))) & (short) -1));
}

uslash()			/* u/: NUM.LO NUM.HI DENOM -- REM QUOT */
{
    unsigned short numhi, numlo, denom;
    unsigned short quot, remainder;	/* the longs below are to be sure the
					   intermediate computation is done
					   long; the results are short */
    denom = pop();
    numhi = pop();
    numlo = pop();
    quot = ((((unsigned long)numhi) << (8*sizeof(short))) 
				+ (unsigned long)numlo) 
					/ (unsigned long)denom;

    remainder = ((((unsigned long)numhi) << (8*sizeof(short))) 
				+ (unsigned long)numlo) 
					% (unsigned long)denom;

    push (remainder);
    push (quot);
}

swap()				/* swap: a b -- b a */
{
    short a, b;
    b = pop();
    a = pop();
    push (b);
    push (a);
}

rot()				/* rotate */
{
    short a, b, c;
    a = pop ();
    b = pop ();
    c = pop ();
    push (b);
    push (a);
    push (c);
}

tfetch()			/* 2@: addr -- mem[addr+1] mem[addr] */
{
    unsigned short addr;
    addr = pop();
    push (mem[addr + 1]);
    push (mem[addr]);
}

store()			/* !: val addr -- <set mem[addr] = val> */
{
    unsigned short tmp;
    tmp = pop();
    mem[tmp] = pop();
}

cstore()			/* C!: val addr --  */
{
    store();
}

tstore()			/* 2!: val1 val2 addr -- 
				   mem[addr] = val2,
				   mem[addr+1] = val1 */
{
    unsigned short tmp;
    tmp = pop();
    mem[tmp] = pop();
    mem[tmp+1] = pop();
}

leave()			/* set the index = the limit of a DO */
{
    int tmp;
    rpop();			/* discard old index */
    tmp = rpop();		/* and push the limit as */
    rpush(tmp);			/* both the limit */
    rpush(tmp);			/* and the index */
}

dplus()				/* D+: double-add */
{
    short ahi, alo, bhi, blo;
    long a, b;
    bhi = pop();
    blo = pop();
    ahi = pop();
    alo = pop();
    a = ((long)ahi << (8*sizeof(short))) + (long)alo;
    b = ((long)bhi << (8*sizeof(short))) + (long)blo;
    a = a + b;
    push ((unsigned short)(a & (short) -1));	/* sum lo */
    push ((short)(a >> (8*sizeof(short))));	/* sum hi */
}

subtract()			/* -: a b -- (a-b) */
{
    int tmp;
    tmp = pop();
    push (pop() - tmp);
}

dsubtract()			/* D-: double-subtract */
{
    short ahi, alo, bhi, blo;
    long a, b;
    bhi = pop();
    blo = pop();
    ahi = pop();
    alo = pop();
    a = ((long)ahi << (8*sizeof(short))) + (long)alo;
    b = ((long)bhi << (8*sizeof(short))) + (long)blo;
    a = a - b;
    push ((unsigned short)(a & (short) -1));	/* diff lo */
    push ((short)(a >> (8*sizeof(short))));	/* diff hi */
}

dminus()				/* DMINUS: negate a double number */
{
    unsigned short ahi, alo;
    long a;
    ahi = pop();
    alo = pop();
    a = -(((long)ahi << (8*sizeof(short))) + (long)alo);
    push ((unsigned short)(a & (short) -1));		/* -a lo */
    push ((unsigned short)(a >> (8*sizeof(short)))); 	/* -a hi */
}

over()				/* over: a b -- a b a */
{
    short a, b;
    b = pop();
    a = pop();
    push (a);
    push (b);
    push (a);
}

dup()				/* dup: a -- a a */
{
    short a;
    a = pop();
    push (a);
    push (a);
}

tdup()			/* 2dup: a b -- a b a b */
{
    short a, b;
    b = pop();
    a = pop();
    push (a);
    push (b);
    push (a);
    push (b);
}

pstore()			/* +!: val addr -- <add val to mem[addr]> */
{
    short addr, val;
    addr = pop();
    val = pop();
    mem[addr] += val;
}

toggle()			/* toggle: addr bits -- <xor mem[addr]
				   with bits, store in mem[addr]> */
{
    short bits, addr;
    bits = pop();
    addr = pop();
    mem[addr] ^= bits;
}

less()
{
    int tmp;
    tmp = pop();
    push (pop() < tmp);
}

pcold()
{
    csp = INITS0;		/* initialize values */
    rsp = INITR0;
	/* copy USER_DEFAULTS area into UP area */
    push (USER_DEFAULTS);	/* source */
    push (UP);			/* dest */
    push (DEFS_SIZE);		/* count */
    cmove();			/* move! */
				/* returns, executes ABORT */
}

prslw()
{
	int buffer, flag, addr, i, temp, unwrittenflag;
	long fpos, ftell();
	char buf[1024];		/* holds data for xfer */

	flag = pop();
	buffer = pop();
	addr = pop();
	fpos = (long) (buffer * 1024);

					/* extend if necessary */
	if (fpos >= bfilesize) {
	    if (flag == 0) { 		/* write */
		printf("Extending block file to %D bytes\n", fpos+1024);
		/* the "2" below is the fseek magic number for "beyond end" */
		fseek(blockfile, (fpos+1024) - bfilesize, 2);
		bfilesize = ftell(blockfile);
	    }
	    else {			/* reading unwritten data */
		unwrittenflag = TRUE;	/* will read all zeroes */
	    }
	}
	else {
		/* note that "0" below is fseek magic number for "relative to
		   beginning-of-file" */
		fseek(blockfile, fpos, 0);	/* seek to destination */
	}

	if (flag) {		/* read */
	    if (unwrittenflag) {	/* not written yet */
		for (i=0; i<1024; i++) mem[addr++] = 0;	/* "read" nulls */
	    }
	    else {			/* does exist */
		if ((temp = fread (buf, sizeof(char), 1024, blockfile)) 
								!= 1024) {
			fprintf (stderr,
				"File read error %d reading buffer %d\n",
					temp, buffer);
			errexit();
		}
		for (i=0; i<1024; i++) mem[addr++] = buf[i];
	    }
	}
	else {	/* write */
		for (i=0; i<1024; i++) buf[i] = mem[addr++];
		if ((temp = fwrite (buf, sizeof(char), 1024, blockfile))
								 != 1024) {
			    fprintf(stderr,
				"File write error %d writing buffer %d\n",
					temp, buffer);
			    errexit();
		}
	}
}

psave()
{
	FILE *fp;

	printf("\nSaving...");
	fflush(stdout);
	mem[SAVEDIP] = ip;	/* save state */
	mem[SAVEDSP] = csp;
	mem[SAVEDRP] = rsp;

	if ((fp = fopen(sfilename,"w")) == NULL)  /* open for writing only */
		errexit("Can't open core file %s for writing\n", sfilename);
	if (fwrite(mem, sizeof(*mem), mem[0], fp) != mem[0])
		errexit("Write error on %s\n",sfilename);
	if (fclose(fp) == EOF)
		errexit("Close error on %s\n",sfilename);
	puts("Saved. Exit FORTH.");
	exit(0);
}
//go.sysin dd *
echo 'x - prims.h'
sed 's/^X//' <<'//go.sysin dd *' >prims.h
X/* prims.h: This file defines inline primitives, which are called as functions
   from the big SWITCH in forth.c */

 				/* push mem[ip] to cstack */
#define lit() { push (mem[ip++]); }
			/* add an offset (this word) to ip */
#define branch() { ip += mem[ip]; }
			/* return a key from input */
#define key() { push(pkey()); }
		/* return TRUE if break key pressed */
#define qterminal() { pqterm(); }
				/* and: a b -- a & b */
#define and() { push (pop() & pop()); }
				/* or: a b -- a | b */
#define or() { push (pop() | pop()); }
				/* xor: a b -- a ^ b */
#define xor() { push (pop() ^ pop()); }
			/* sp@: push the stack pointer */
#define spfetch() { push (csp); }
			/* sp!: load initial value into SP */
#define spstore() { csp = mem[S0]; }
			/* rp@: fetch the return stack pointer */
#define rpfetch() { push (rsp); }
			/* rp!: load initial value into RP */
#define rpstore() { rsp = mem[R0]; }
			/* ;S: ends a colon definition. */
#define semis() { ip = rpop(); }
			/* @: addr -- mem[addr] */
#define fetch() { push (mem[pop()]); }
			/* C@: addr -- mem[addr] */
#define cfetch() { push (mem[pop()] & 0xff); }
			/* push to return stack */
#define tor() { rpush(pop()); }
			/* pop from return stack */
#define fromr() { push (rpop()); }
			/* 0=: a -- (a == 0) */
#define zeq() { push ( pop() == 0 ); }
			/* 0<: a -- (a < 0) */
#define zless() { push ( pop() < 0 ); }
			/* +: a b -- (a+b) */
#define plus() { push (pop () + pop ()); }
			/* MINUS: negate a number */
#define minus() { push (-pop()); }
				/* drop: a -- */
#define drop() { pop(); }
			/* DOCOL: push ip & start a thread */
#define docol() { rpush(ip); ip = w+1; }
			/* do a constant: push the value at mem[w+1] */
#define docon() { push (mem[w+1]); }
			/* do a variable: push (w+1) (the PFA) to the stack */
#define dovar() { push (w+1); }
		/* execute a user variable: add UP to the offset found in PF */
#define douse() { push (mem[w+1] + ORIGIN); }

#define allot() { Callot (pop()); }
				/* comparison tests */
#define equal() { push(pop() == pop()); }
				/* not equal */
#define noteq() { push (pop() != pop()); }
				/* DODOES -- not supported */
#define dodoes() { errexit("DOES> is not supported."); }
				/* DOVOC -- not supported */
#define dovoc() { errexit("VOCABULARIES are not supported."); }
				/* (BYE) -- exit with error code */
#define pbye() { exit(0); }
				/* TRON -- trace at pop() depth */
#define tron() { trace = TRUE; tracedepth = pop(); }
				/* TROFF -- stop tracing */
#define troff() { trace = 0; }
//go.sysin dd *