From:	HENRY::IN%"cic%CSNET-SH.ARPA%relay.cs.net@rca.com" 29-AUG-1986 19:08
To:	EVERHART%ARISIA%rca.com@CSNET-RELAY.ARPA
Subj:	cforth/Part2 FORTH INTERPRETER IN C (Part 2 of 3)

Date: Tue, 30 Apr 85 15:19:04 est
From: mit-eddie!ihnp4!purdue!iuvax!apratt (Allan Pratt)
Subject: FORTH INTERPRETER IN C (Part 2 of 3)

: Run this shell script with "sh" not "csh"
PATH=:/bin:/usr/bin:/usr/ucb
export PATH
echo 'x - Makefile'
sed 's/^X//' <<'//go.sysin dd *' >Makefile
test:		forth.core forth

forth:		forth.o prims.o
		cc -o forth forth.o prims.o

forth.o:	forth.c common.h forth.h prims.h
		cc -c forth.c

prims.o:	prims.c forth.h prims.h
		cc -c prims.c

all:		forth forth.core l2b b2l

nf:		nf.o lex.yy.o
		cc -o nf nf.o lex.yy.o

nf.o:		nf.c forth.lex.h common.h
		cc -c nf.c

lex.yy.o:	lex.yy.c forth.lex.h
		cc -c lex.yy.c

lex.yy.c:	forth.lex
		lex forth.lex
		rm -f lex.tmp
		sed "s/yylex(){/TOKEN *yylex(){/" lex.yy.c > lex.tmp
		mv -f lex.tmp lex.yy.c

forth.core:	nf forth.dict
		nf < forth.dict

# l2b: convert a line file to a block file. Usage: l2b < linefile > blockfile
l2b:		l2b.c
		cc -o l2b l2b.c

# b2l: convert a block file to a line file. Usage: b2l < blockfile > linefile
b2l:		b2l.c
		cc -o b2l b2l.c

# forth.line and forth.block are not included here, because you can't tell
# which one is more recent. To make one from the other, use b2l and l2b.
//go.sysin dd *
echo 'x - b2l.c'
sed 's/^X//' <<'//go.sysin dd *' >b2l.c
X/* usage: block2line < blockfile > linefile
 * takes a block file from stdin and makes a cr-delimited file to stdout
 * with 64 characters per line, 16 lines per screen
 */

#include <stdio.h>

main()
{
	int i, j, screen;
	char buf[64];	/* max line size */

	while(1) {
	    printf("------------------ SCREEN %d ------------------\n",
			screen++);
	    for (i=0; i<16; i++) {
		if (fread(buf,sizeof(char),64,stdin) < 64) exit(0);
		j = 63;
		while (buf[j] == ' ' && j >= 0) j--;
		if (j >= 0) fwrite(buf,sizeof(char),j+1,stdout);
		putchar('\n');
	    }
	}
}
//go.sysin dd *
echo 'x - common.h'
sed 's/^X//' <<'//go.sysin dd *' >common.h
X/*
 * This is common.h -- the defines which are common to both nf.c and forth.c.
 * These include the name of the SAVEFILE (the file which nf.c creates,
 * and the default image which f.c loads), and all those boundaries for
 * memory areas, like UP, USER_DEFAULTS, etc.
 */

X/*
 * NOTE THAT THIS FORTH IMPLENTATION REQUIRES int TO BE TWICE THE SIZE OF short
 */

#define TRUE 1
#define FALSE 0

X/*
   TWEAKING: define TRACE to allow tracing, BREAKPOINT to allow breakpoints.
   Each of these takes up time in the inner interpreter, so if you are
   not debugging, take them out. Without TRACE, the DOTRACE primitive will
   still work, but the TRON primitive will have no effect.
*/

#define TRACE
#define BREAKPOINT

X/* external files */

#define COREFILE "forth.core"	/* used for input to f.c, output from nf.c */
#define DICTFILE "forth.dict"	/* used for input to nf.c */
#define MAPFILE "forth.map"	/* used for dump-output from nf.c */
#define DUMPFILE "forth.dump"	/* used for dump-output from f.c */
#define BLOCKFILE "forth.block"	/* used for block i/o */
#define SAVEFILE "forth.newcore"	/* used by (SAVE) primitive */

X/* MEMORY ALLOCATION CONSTANTS */

X/* Set INITMEM to the size of the largest FORTH model you want nf to create.
   This can be just barely enough (within GULPFRQ words) to hold the initial 
   FORTH image, or it can be the maximum size you will ever want. Somewhere in
   between is best, so you don't fragment memory with realloc() calls right
   away. */

#define INITMEM (13*1024)	/* 13K holds the distribution forth.dict */
  
X/* set MAXMEM to the MOST MEMORY YOU EVER WANT ALLOCATED TO FORTH. FORTH will
   never allocate more than MAXMEM*sizeof(short) for the FORTH memory image.
   Note that other functions, like open, read, and write, allocate memory
   transparent to the forth system. MAXMEM will not affect these. Also,
   note that realloc is used to grow the FORTH image, and LARGE CHUNKS of
   fragmented memory can result. If you want to keep a tight rein on things,
   set MAXMEM to the same number as INITMEM, and the FORTH memory image will
   be fixed at that many SHORTs, with no later allocations, and therefore
   no fragmenting.
	A value of 0 for MAXMEM means "allocate as much as you want" -- 
   useful on virtual-memory machines. Also note that each malloc and realloc
   is checked for success (of course), so MAXMEM is truly a maximal limit.
	NOTE THAT MODELS OF GREATER THAN 32K MAY CRASH BECAUSE OF SIGNED
   VALUES. THIS HAS NOT BEEN ADEQUATELY TESTED.
*/

#define MAXMEM 0

X/* set NSCR to the number of disk blocks from you want to keep in FORTH memory
   at any time. If your disks are fast enough, you might want a low number
   like 3. If you have lots of memory, you might want something like 10.
   In any case, this number MUST BE AT LEAST 2. */

#define NSCR 5	/* MUST BE AT LEAST 2 */

X/* end of implementation-dependent DEFINEs. */

X/* define bits for the first byte of each word */
#define MSB 0x80		/* says this is first byte */
#define IMMEDIATE 0x40		/* Says this word is immediate */
#define SMUDGE 0x20		/* on = you can't find this word */

#define MAXWIDTH 0x20		/* Maximum length of a word */

#define KBBUFF 1024		/* one disk-quantum */
#define US 32			/* words needed for user variables */
#define CO (KBBUFF+4)
				/* size of a disk buffer w/4 words overhead */
#define NBUF NSCR		/* number of disk buffers, at 1 to a screen */

X/* Memory Management boundaries -- each name refers to the FIRST location of
   the indicated field Some fields are nested, and I have tried to show the
   nesting nature in the defines. */

#define ORIGIN 0		/* the Origin of this system is zero */
#define ORIG ORIGIN		/* another word for ORIGIN */
#define SCRATCHSIZE 16		/* From ORIGIN to ORIGIN+SCRATCHSIZE is scratch
				   space which is saved across saves: see the
				   definition of this space below */
#define USER_DEFAULTS (ORIGIN+SCRATCHSIZE)	/* 16 */
				/* start of user variable initial-values space
				   -- it's DEFS-SIZE bytes long */
#define DEFS_SIZE 8		/* words in the USER DEFAULTS area */
#define UP (USER_DEFAULTS+DEFS_SIZE)	/* User var space, US bytes long */
#define TIB_START (UP+US)	/* Terminal input buffer, same size as a
				   disk buffer (KBBUFF words), starts after
				   user variables */
#define TIB_END (TIB_START + KBBUFF)
#define CS_SIZE 128		/* words in the Computation Stack */
#define RS_SIZE 256		/* words in the Return Stack */
#define INITS0 (TIB_START+KBBUFF+CS_SIZE) /* c. stack grows down CSS words,
				   bangs into end of TIB */
#define INITR0 (INITS0+RS_SIZE)	/* Return stack grows down RSS words, bangs
				   into INITS0. */
#define BUF1 INITR0		/* buffers start right after r. stack */
#define DPBASE (BUF1+(NBUF*CO))	/* Dictionary starts just past last buffer */

X/* low-core definitions */
#define LIMIT 0			/* mem[LIMIT] tells the size of core */
#define COLDIP 1		/* mem[COLDIP] holds the CFA of ABORT */
		/* you can set ip=mem[COLDIP] and call next() to start */

X/* these locations define the warm-start machine state: if you save the FORTH
   memory image, then restart it, execution will start up with these values.
   This save/restore system is not implemented, so leave mem[SAVEDIP] = 0. */

#define SAVEDIP 2		/* mem[SAVEDIP] = 0 for newly-generated
				   systems, or the IP for a saved system */
#define SAVEDSP 3		/* restored when SAVEDIP != 0 */
#define SAVEDRP 4		/* ditto */

#define ABORTIP 5		/* need this to recover from ^C */
//go.sysin dd *
echo 'x - forth.c'
sed 's/^X//' <<'//go.sysin dd *' >forth.c
X/*
 * forth.c
 * 
 * Portable FORTH interpreter in C
 *
 * Author: Allan Pratt, Indiana University (iuvax!apratt)
 *         Spring, 1984
 * References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
 *         in the world...)
 *
 * This program is intended to be compact, portable, and pretty complete.
 * It is also intended to be in the public domain, and distribution should
 * include this notice to that effect.
 *
 * This file contains the support code for all interpreter functions.
 * the file prims.c contains code for the C-coded primitives, and the
 * file forth.h connects the two with definitions.
 *
 * The program nf.c generates a new forth.core file from the dictionary
 * forth.dict, using common.h to tie it together with this program.
 */
 

#include <stdio.h>
#include <signal.h>
#include <ctype.h>	/* only for isxdigit */

#include "common.h"

#include "forth.h"

#include "prims.h"	/* macro-defined primitives */

X/* declare globals which are defined in forth.h */

unsigned short csp, rsp, ip, w;
short *mem;
int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
int nobuf;
XFILE *blockfile;
long bfilesize;
char *bfilename;	/* block file name (change with -f ) */
char *cfilename;	/* core file name  (change with -l ) */
char *sfilename;	/* save file name  (change with -s ) */

X/*
             ----------------------------------------------------
                               SYSTEM FUNCTIONS
             ----------------------------------------------------
*/

errexit(s,p1,p2)		/* An error occurred -- clean up (?) and
				   exit. */
{
    printf(s,p1,p2);
    printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
    fflush(stdout);
    memdump();
    puts("done.");
    exit(1);
}

Callot (n)			/* allot n words in the dictionary */
short n;
{
    unsigned newsize;

    mem[DP] += n;			/* move DP */
    if (mem[DP] + GULPFRQ > mem[LIMIT]) {	/* need space */
	newsize = mem[DP] + GULPSIZE;
	if (newsize > MAXMEM && MAXMEM)
		errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);

	mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
	if (mem == NULL)
		errexit("REALLOC FAILED\n");
	mem[LIMIT] = newsize;
    }
}

push(v)			/* push value v to cstack */
short v;
{
    if (csp <= TIB_END)
	errexit("PUSH TO FULL CALC. STACK\n");
    mem[--csp] = v;
}

short pop()			/* pop a value from comp. stack, and return
				   it as the value of the function */
{
    if (csp >= INITS0) {
	puts("Empty Stack!");
	return 0;
    }
    return (mem[csp++]);
}

rpush(v)
short v;
{
    if (rsp <= INITS0)
	errexit("PUSH TO FULL RETURN STACK");
    mem[--rsp] = v;
}

short rpop()
{
    if (rsp >= INITR0)
	errexit("POP FROM EMPTY RETURN STACK!");
    return (mem[rsp++]);
}

pkey()			/* (KEY) -- wait for a key & return it */
{
    int c;
    if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
    return(c);
}

pqterm()			/* (?TERMINAL): 
					return true if BREAK has been hit */
{
	if (qtermflag) {
		push(TRUE);
		qtermflag = FALSE;	/* this influences ^C handling */
	}
	else push(FALSE);
}

pemit()				/* (EMIT): c --	emit a character */
{
    putchar(pop() & 0x7f);	/* stdout is unbuffered */
}

next()			/* instruction processor: control goes here
				   almost right away, and cycles through here
				   until you leave. */

X/* 
 * This is the big kabloona. What it does is load the value at mem[ip]
 * into w, increment ip, and invoke prim. number w. This implies that
 * mem[ip] is the CFA of a word. What's in the CF of a word is the number
 * of the primitive which should be executed. For a word written in FORTH,
 * that primitive is "docol", which pushes ip to the return stack, then
 * uses w+2 (the PFA of the word) as the new ip.  See "interp.doc" for
 * more.
 */

X/*
 * There is an incredible hack going on here: the SPECIAL CASE mentioned in
 * the code is for the word EXECUTE, which must set W itself and jump INSIDE
 * the "next" loop, by-passing the first instruction. This has been made a
 * special case: if the primitive to execute is zero, the special case is
 * invoked, and the code for EXECUTE is put right in the NEXT loop. For this
 * reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
 */
{
    short p;
	
    while (1) {
	if (forceip) {		/* force ip to this value -- used by sig_int */
		ip = forceip;
		forceip = FALSE;
	}
#ifdef TRACE
	if (trace) dotrace();
#endif TRACE

#ifdef BREAKPOINT
	if (breakenable && ip == breakpoint) dobreak();
#endif BREAKPOINT

	w = mem[ip];
	ip++;
				/* w, mem, and ip are all global. W is now
				   a POINTER TO the primitive number to 
				   execute, and ip points to the NEXT thread to
				   follow. */

next1:				/* This is for the SPECIAL CASE */
	p = mem[w];		/* p is the actual number of the primitive */
	if (p == 0) {		/* SPECIAL CASE FOR EXECUTE! */
	    w = pop();		/* see above for explanation */
	    goto next1;
	}
	/* else */
	switch(p) {
	case LIT	:  lit(); break;
	case BRANCH	:  branch(); break;
	case ZBRANCH	:  zbranch(); break;
	case PLOOP	:  ploop(); break;
	case PPLOOP	:  pploop(); break;
	case PDO	:  pdo(); break;
	case I		:  i(); break;
	case R		:  r(); break;
	case DIGIT	:  digit(); break;
	case PFIND	:  pfind(); break;
	case ENCLOSE	:  enclose(); break;
	case KEY	:  key(); break;
	case PEMIT	:  pemit(); break;
	case QTERMINAL	:  qterminal(); break;
	case CMOVE	:  cmove(); break;
	case USTAR	:  ustar(); break;
	case USLASH	:  uslash(); break;
	case AND	:  and(); break;
	case OR		:  or(); break;
	case XOR	:  xor(); break;
	case SPFETCH	:  spfetch(); break;
	case SPSTORE	:  spstore(); break;
	case RPFETCH	:  rpfetch(); break;
	case RPSTORE	:  rpstore(); break;
	case SEMIS	:  semis(); break;
	case LEAVE	:  leave(); break;
	case TOR	:  tor(); break;
	case FROMR	:  fromr(); break;
	case ZEQ	:  zeq(); break;
	case ZLESS	:  zless(); break;
	case PLUS	:  plus(); break;
	case DPLUS	:  dplus(); break;
	case MINUS	:  minus(); break;
	case DMINUS	:  dminus(); break;
	case OVER	:  over(); break;
	case DROP	:  drop(); break;
	case SWAP	:  swap(); break;
	case DUP	:  dup(); break;
	case TDUP	:  tdup(); break;
	case PSTORE	:  pstore(); break;
	case TOGGLE	:  toggle(); break;
	case FETCH	:  fetch(); break;
	case CFETCH	:  cfetch(); break;
	case TFETCH	:  tfetch(); break;
	case STORE	:  store(); break;
	case CSTORE	:  cstore(); break;
	case TSTORE	:  tstore(); break;
	case DOCOL	:  docol(); break;
	case DOCON	:  docon(); break;
	case DOVAR	:  dovar(); break;
	case DOUSE	:  douse(); break;
	case SUBTRACT	:  subtract(); break;
	case EQUAL	:  equal(); break;
	case NOTEQ	:  noteq(); break;
	case LESS	:  less(); break;
	case ROT	:  rot(); break;
	case DODOES	:  dodoes(); break;
	case DOVOC	:  dovoc(); break;
	case ALLOT	:  allot(); break;
	case PBYE	:  pbye(); break;
	case TRON	:  tron(); break;
	case TROFF	:  troff(); break;
	case DOTRACE	:  dotrace(); break;
	case PRSLW	:  prslw(); break;
	case PSAVE	:  psave(); break;
	case PCOLD	:  pcold(); break;
	default		:  errexit("Bad execute-code %d\n",p); break;
	}
    }
}

dotrace()
{
	short worka, workb, workc;
	putchar('\n');
	if (tracedepth) {		/* show any stack? */
		printf("sp: %04x (", csp);
		worka = csp;
		for (workb = tracedepth; workb; workb--)
			printf("%04x ",(unsigned short) mem[worka++]);
		putchar(')');
	}
	printf(" ip=%04x ",ip);

	if (mem[R0]-rsp < RS_SIZE && mem[R0] - rsp > 0) /* if legal rsp */
	    for (worka = mem[R0]-rsp; worka; worka--) { /* indent */
		putchar('>');
		putchar(' ');
	    }
	worka = mem[ip] - 3;		/* this is second-to-last letter, or
					   the count byte */
	while (!(mem[worka] & 0x80)) worka--;	/* skip back to count byte */
	workc = mem[worka] & 0x2f;		/* workc is count value */
	worka++;
	while (workc--) putchar(mem[worka++] & 0x7f);
	fflush(stdout);
	if (debug) {		/* wait for \n -- any other input will dump */
		char buffer[10];
		if (*gets(buffer) != '\0') {
			printf("dumping core... ");
			fflush(stdout);
			memdump();
			puts("done.");
		}
	}
}

#ifdef BREAKPOINT
dobreak()
{
	int temp;
	puts("Breakpoint.");
	printf("Stack pointer = %x:\n",csp);
	for (temp = csp; temp < INITS0; temp++)
		printf("\t%04x",mem[temp]);
	putchar('\n');
}
#endif BREAKPOINT

main(argc,argv)
int argc;
char *argv[];
{
	FILE *fp;
	unsigned short size;
	int i = 1;

	cfilename = COREFILE;	/* "forth.core" */
	bfilename = BLOCKFILE;	/* "forth.block" */
	sfilename = SAVEFILE;	/* "forth.newcore" */
	trace = debug = breakenable = nobuf = 0;

	while (i < argc) {
		if (*argv[i] == '-') {
			switch (*(argv[i]+1)) {
#ifdef TRACE
			case 'd':			/* -d[n] */
				debug = 1;	/* ...and fall through */
			case 't':			/* -t[n] */
				trace = TRUE;
				if (argv[i][2])
					tracedepth = (argv[i][2] - '0');
				else tracedepth = 0;
				break;
#else !TRACE
			case 'd':
			case 't':
				fprintf(stderr,
		"Must compile with TRACE defined for -t or -d\n");
				break;
#endif TRACE
			case 'c': if (++i == argc) usage(argv[0]);
				  cfilename = argv[i];		/* -c file */
				  break;
			case 's': if (++i == argc) usage(argv[0]);
				  sfilename = argv[i];		/* -s file */
				  break;
#ifdef BREAKPOINT
			case 'p': if (++i == argc) usage(argv[0]);
				  breakenable = TRUE;	/* -p xxxx */
				  breakpoint = xtoi(argv[i]);
				  break;
#else !BREAKPOINT
			case 'p': fprintf(stderr,
		"Must compile with BREAKPOINT defined for -p");
				  break;
#endif BREAKPOINT
			case 'b': if (++i == argc) usage();
				  bfilename = argv[i]; /* -b blockfile */
				  break;
			case 'n': nobuf = TRUE;
				  break;
			default: usage(argv[0]);
				 exit(1);
			}
		}
		else usage(argv[0]);		/* not a dash */
		i++;
	}

	if ((fp = fopen(cfilename,"r")) == NULL) {
		fprintf(stderr,"Forth: Could not open %s\n", cfilename);
		exit(1);
	}
	if (fread(&size, sizeof(size), 1, fp) != 1) {
		fprintf(stderr,"Forth: %s is empty.\n",cfilename);
		exit(1) ;
	}

	if ((mem = (short *)calloc(size, sizeof(*mem))) == NULL) {
		fprintf(stderr, "Forth: unable to malloc(%d,%d)\n",
			size, sizeof(*mem));
		exit(1);
	}

	mem[LIMIT] = size;

	if (fread(mem+1, sizeof(*mem), size-1, fp) != size-1) {
		fprintf(stderr, "Forth: not %d bytes on %s.\n",
			size, cfilename);
		exit(1);
	}

	fclose(fp);

	initsignals();

	getblockfile();

	if (!nobuf) setbuf(stdout,NULL);

	if (ip = mem[SAVEDIP]) {	/* if savedip != 0, that is */
		csp = mem[SAVEDSP];
		rsp = mem[SAVEDRP];
		puts("restarting a saved FORTH image");
	}
	else {
		ip = mem[COLDIP];	/* this is the ip passed from nf.c */
			/* ip now points to a word holding the CFA of COLD */
		rsp = INITR0;		/* initialize return stack */
		csp = INITS0;
	}
	next();
	/* never returns */
}

usage(s)
char *s;
{
	fprintf(stderr, "usage:\n");
	fprintf(stderr, "%s [-t[n]] [-d[n]] [-p xxxx] [-n]\n",s);
	fputs(stderr, "\t[-c corename] [-b blockname] [-s savename]\n");
	fputs(stderr, "Where:\n");
	fputs(stderr,
"-t[n]\t\tsets trace mode\n");
	fputs(stderr,
"-d[n]\t\tsets trace mode and debug mode (waits for newline)");
	fputs(stderr,
"\t\t[n] above sets stack depth to display. Single digit, 0-9. Default 0.\n");
	fputs(stderr,
"-p xxxx\t\tsets a breakpoint at xxxx (in hex), shows stack when reached\n");
	fputs(stderr,
"-n\t\tleaves stdout line-buffered\n");
	fprintf(stderr,
"-c corename\tuses corename as the core image (default %s without -c)\n",
		COREFILE);
	fprintf(stderr,
"-b blockname\tuses blockname as the blockfile (default %s without -b)\n",
		BLOCKFILE);
	fprintf(stderr,
"-s savename\tuses savename as the save-image file (default %s without -s)\n",
		SAVEFILE);
}

memdump()		/* dump core. */
{
	int i;	/* top of RAM */
	int temp, tempb, firstzero, nonzero;
	char chars[9], outline[80], tstr[6];
	FILE *dumpfile;

	dumpfile = fopen(DUMPFILE,"w");

	fprintf(dumpfile,
		"CSP = 0x%x  RSP = 0x%x  IP = 0x%x  W = 0x%x  DP = 0x%x\n",
		csp, rsp, ip, w, mem[DP]);

	for (temp = 0; temp < mem[LIMIT]; 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(dumpfile,"%s %s\n",outline,chars);
			firstzero = TRUE;
		}
		else if (firstzero) {
			fprintf(dumpfile, "----- ZERO ----\n");
			firstzero = FALSE;
		}
	}
	fclose(dumpfile);
}

X/* here is where ctype.h is used */

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

    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;
}

X/*
 * Interrupt (^C) handling: If the user hits ^C once, the next pqterm call
 * will return TRUE. If he hits ^C again before pqterm is called, there will
 * be a forced jump to ABORT next time we hit next(). If it is a primitive
 * that is caught in an infinite loop, this won't help any.
 */

sig_int()
{
	if (qtermflag) {		/* second time? */
		forceip = mem[ABORTIP];	/* checked each time through next */
		qtermflag = FALSE;
		trace = FALSE;		/* stop tracing; reset */
	}
	else qtermflag = TRUE;
}

initsignals()
{
	signal(SIGINT,sig_int);
}

getblockfile()
{
	/* recall that opening with mode "a+" opens for reading and writing */
	/* with the pointer positioned at the end; this is so ftell returns */
	/* the size of the file.					    */

	if ((blockfile = fopen(bfilename, "a+")) == NULL)
		errexit("Can't open blockfile \"%s\"\n", bfilename);
	bfilesize = ftell(blockfile);

	printf("Block file has %d blocks.\n",(int) (bfilesize/1024) - 1);
}
//go.sysin dd *
echo 'x - forth.dict'
sed 's/^X//' <<'//go.sysin dd *' >forth.dict
PRIM EXECUTE		0	( cfa -- <execute word> )
PRIM LIT		1	( push the next value to the stack )
PRIM BRANCH		2	( branch by offset in next word )
PRIM 0BRANCH		3	( branch if zero by off. in next word )
PRIM (LOOP)		4	( end of a <DO> )
PRIM (+LOOP)		5	( inc -- <end of a <DO> w/increment != 1 )
PRIM (DO)		6	( limit init -- <begin a DO loop> )
PRIM I			7	( get loop index <R> )
PRIM DIGIT		8	( c -- DIGIT 1 | 0 <convert digit> )
PRIM (FIND)		9	( s -- s 0 | s NFA 1 <find word s> )
PRIM ENCLOSE		10	( addr c -- addr next first last <not quite> )
PRIM KEY		11	( -- c <get next char from input> )
PRIM (EMIT)		12	( c -- <put char to output> )
PRIM ?TERMINAL		13	( see if op. interrupted <like w/^C> )
PRIM CMOVE		14	( src dest count -- <move words>)
PRIM U*			15	( unsigned multiply )
PRIM U/			16	( unsigned divide )
PRIM AND		17	( a b -- a&b )
PRIM OR			18	( a b -- a|b )
PRIM XOR		19	( a b -- a%b )
PRIM SP@		20	( -- sp )
PRIM SP!		21	( -- <store empty value to sp> )
PRIM RP@		22	( -- rp )
PRIM RP!		23	( -- <store empty value to rp> )
PRIM ;S			24	( -- <pop r stack <end colon def'n>> )
PRIM LEAVE		25	( -- <set index = limit for a loop> )
PRIM >R			26	( a -- <push a to r stack> )
PRIM R>			27	( -- a <pop a from r stack )
PRIM 0=			28	( a -- !a <logical not> )
PRIM 0<			29	( a -- a<0 )
PRIM +			30	( a b -- a+b )
PRIM D+			31	( ahi alo bhi blo -- a+bhi a+blo )
PRIM MINUS		32	( a -- -a )
PRIM DMINUS		33	( ahi alo -- <-a>hi <-a>lo )
PRIM OVER		34	( a b -- a b a )
PRIM DROP		35	( a -- )
PRIM SWAP		36	( a b -- b a )
PRIM DUP		37	( a -- a a )
PRIM 2DUP		38	( a b -- a b a b )
PRIM +!			39	( val addr -- < *addr += val > )
PRIM TOGGLE		40	( addr mask -- <*addr %= mask> )
PRIM @			41	( addr -- *addr )
PRIM C@			42	( addr -- *addr )
PRIM 2@			43	( addr -- *addr+1 *addr )
PRIM !			44	( val addr -- <*addr = val> )
PRIM C!			45	( val addr -- <*addr = val> )
PRIM 2!			46	( bhi blo addr -- <*addr=blo, *addr+1=bhi )
PRIM DOCOL		47	( goes into CF of : definitions )
PRIM DOCON		48	( goes into CF of constants )
PRIM DOVAR		49	( goes into CF of variables )
PRIM DOUSE		50	( goes into CF of user variables )
PRIM -			51	( a b -- a-b )
PRIM =			52	( a b -- a==b)
PRIM !=			53	( a b -- a!=b)
PRIM <			54	( a b -- a<b )
PRIM ROT		55	( a b c -- c a b )
PRIM DODOES		56	( place holder; this value goes into CF )
PRIM DOVOC		57
PRIM R			58	( same as I, but must be a primitive )
PRIM ALLOT		59	( primitive because of mem. management )
PRIM (BYE)		60	( executes exit <pop[]>; )
PRIM TRON		61	( depth -- trace to this depth )
PRIM TROFF		62	( stop tracing )
PRIM DOTRACE		63	( trace once )
PRIM (R/W)		64	( BUFFER FLAG ADDR -- read if flag=1, write/0 )
PRIM (SAVE)		65	( Save current environment )
PRIM (COLD)		66

( end of primitives )

CONST 0 0
CONST 1 1
CONST 2 2
CONST 3 3
CONST -1 -1
CONST BL 32		( A SPACE, OR BLANK )
CONST C/L 64
CONST B/BUF 1024
CONST B/SCR 1
CONST #BUFF 5		( IMPLEMENTATION DEPENDENT )

CONST WORDSIZE 1	( EXTENSION: WORDSIZE IS THE NUMBER OF BYTES IN A WORD.
			  USUALLY, THIS IS TWO, BUT WITH PSEUDO-MEMORY
			  ADDRESSED AS AN ARRAY OF WORDS, IT'S ONE. )

CONST FIRST 0		( ADDRESS OF THE FIRST BUFFER AND END OF BUFFER SPACE )
CONST LIMIT 0		( the reader fills these in with INITR0 and DPBASE )

USER S0		24
USER R0		25
USER TIB	26
USER WIDTH	27
USER WARNING	28
USER FENCE	29
USER DP		30
USER VOC-LINK	31
USER BLK	32
USER IN		33
USER ERRBLK	34
USER ERRIN	35
USER OUT	36
USER SCR	37
USER OFFSET	38
USER CONTEXT	39
USER CURRENT	40
USER STATE	41
USER BASE	42
USER DPL	43
USER FLD	44
USER CSP	45
USER R#		46
USER HLD	47

VAR USE 0		( These two are filled in by COLD )
VAR PREV 0		( to the same as the constant FIRST )
CONST SEC/BLK 1

: EMIT
  (EMIT)
  1 OUT +! ;

: CR
  LIT 13 EMIT
  LIT 10 EMIT
  0 OUT ! ;

: NOP ;	( DO-NOTHING )

: +ORIGIN ;	( ADD ORIGIN OF SYSTEM; IN THIS CASE, 0 )

: 1+
  1 + ;

: 2+
  2 + ;

: 1-
  1 - ;

: ++		( ADDR -- <INCREMENTS VAL AT ADDR> )
  1 SWAP +! ;	( MY OWN EXTENSION )

: --		( ADDR -- <DECREMENTS VAL AT ADDR> )
  -1 SWAP +! ;	( MY OWN EXTENSION )

: HERE		( -- DP )
  DP @ ;

: ,		( V -- <PLACES V AT DP AND INCREMENTS DP>)
  HERE !
  WORDSIZE ALLOT ;	( CHANGE FROM MODEL FOR WORDSIZE )

: C,		( C -- <COMPILE A CHARACTER. SAME AS , WHEN WORDSIZE=1> )
  HERE C!
  1 ALLOT ;

: U<		( THIS IS TRICKY. )
	2DUP XOR 0<	( SIGNS DIFFERENT? )
	0BRANCH U1	( NO: GO TO U1 )
	DROP 0< 0=	( YES; ANSWER IS [SECOND > 0] )
	BRANCH U2	( SKIP TO U2 <END OF WORD> )
LABEL U1
	- 0<	( SIGNS ARE THE SAME. JUST SUBTRACT
		  AND TEST NORMALLY )
LABEL U2
	;

: >		( CHEAP TRICK )
  SWAP < ;

: <>		( NOT-EQUAL )
  != ;

: SPACE		( EMIT A SPACE )
  BL EMIT
;

: -DUP		( V -- V | V V <DUPLICATE IF V != 0> )
  DUP
  0BRANCH DDUP1	( SKIP TO END IF IT WAS ZERO )
  DUP
LABEL DDUP1
;

: TRAVERSE	( A DIR -- A <TRAVERSE A WORD FROM NFA TO LFA
		  <DIR = 1> OR LFA TO NFA <DIR = -1> )
	SWAP
LABEL T1
	OVER	( BEGIN )
	+
	LIT 0x7F OVER C@ <	( HIGH BIT CLEAR? )
	0BRANCH T1		( UNTIL )
	SWAP DROP ;

: LATEST		( NFA OF LAST WORD DEFINED )
  CURRENT @ @ ;

: LFA			( GO FROM PFA TO LFA )
  2 - ;			( 2 IS WORDSIZE*2 )

: CFA			( GO FROM PFA TO CFA )
  WORDSIZE - ;

: NFA			( GO FROM PFA TO NFA )
  3 -			( NOW AT LAST CHAR )
  -1 TRAVERSE ;		( 3 IS WORDSIZE*3 )

: PFA			( GO FROM NFA TO PFA )
  1 TRAVERSE		( NOW AT LAST CHAR )
  3 + ;			( 3 IS WORDSIZE*3 )

: !CSP			( SAVE CSP AT USER VAR CSP )
  SP@ CSP ! ;

: (ABORT)
  ABORT
;

: ERROR			( N -- <ISSUE ERROR #N> )
  WARNING @ 0<		( WARNING < 0 MEANS <ABORT> )
  0BRANCH E1
  (ABORT)		( IF )
LABEL E1
  HERE COUNT TYPE (.") "?"	( THEN )
  MESSAGE
  SP!			( EMPTY THE STACK )
  BLK @ -DUP		( IF LOADING, STORE IN & BLK )
  0BRANCH E2
  ERRBLK ! IN @ ERRIN !	( IF )
LABEL E2
  QUIT			( THEN )
;

: ?ERROR		( F N -- <IF F, DO ERROR #N> )
  SWAP
  0BRANCH QERR1
  ERROR			( IF <YOU CAN'T RETURN FROM ERROR> )
LABEL QERR1
  DROP			( THEN )
;

: ?COMP			( GIVE ERR#17 IF NOT COMPILING )
  STATE @ 0= LIT 17 ?ERROR
;

: ?EXEC			( GIVE ERR#18 IF NOT EXECUTING )
  STATE @ LIT 18 ?ERROR
;

: ?PAIRS		( GIVE ERR#19 IF PAIRS DON'T MATCH )
  - LIT 19 ?ERROR
;

: ?CSP			( GIVE ERR#20 IF CSP & SP DON'T MATCH )
  SP@ CSP @ - LIT 20 ?ERROR
;

: ?LOADING		( GIVE ERR#21 IF NOT LOADING )
  BLK @ 0= LIT 22 ?ERROR
;

: COMPILE		( COMPILE THE CFA OF THE NEXT WORD TO DICT )
  ?COMP
  R> DUP		( GET OUR RETURN ADDRESS )
  WORDSIZE + >R		( SKIP NEXT; ORIG. ADDR STILL ON TOS )
  @ ,
;

: [			( BEGIN EXECUTING )
  0 STATE !
;*

: ]			( END EXECUTING )
  LIT 0xC0 STATE !
;*

: SMUDGE		( TOGGLE COMPLETION BIT OF LATEST WORD )
  LATEST		( WHEN THIS BIT=1, WORD CAN'T BE FOUND )
  LIT 0x20 TOGGLE
;

: :
			( DEFINE A WORD )
  ?EXEC
  !CSP
  CURRENT @ CONTEXT !
  CREATE ]		( MAKE THE WORD HEADER AND BEGIN COMPILING )
  (;CODE) DOCOL
;*

: ;			( END A DEFINITION )
  ?CSP			( CHECK THAT WE'RE DONE )
  COMPILE ;S		( PLACE ;S AT THE END )
  SMUDGE [		( MAKE THE WORD FINDABLE AND BEGIN INTERPRETING )
;*

: CONSTANT
  CREATE SMUDGE ,
  (;CODE) DOCON
;

: VARIABLE
  CONSTANT
  (;CODE) DOVAR
;

: USER
  CONSTANT
  (;CODE) DOUSE
;

: HEX			( GO TO HEXADECIMAL BASE )
  LIT 0x10 BASE ! ;

: DECIMAL		( GO TO DECIMAL BASE )
  LIT 0x0A BASE !
;

: ;CODE				( unused without an assembler )
  ?CSP COMPILE (;CODE) [ NOP	( "ASSEMBLER" might go where nop is )
;*

: (;CODE)			( differs from the normal def'n )
  R> @ @ LATEST PFA CFA !
;

: <BUILDS		( UNSURE )
  0 CONSTANT ;		( NOTE CONSTANT != CONST )

: DOES>			( UNSURE )
  R> LATEST PFA !
  (;CODE) DODOES
;

: COUNT			( ADDR -- ADDR+1 COUNT )
  DUP 1+ SWAP C@ ;	( CONVERTS THE <STRING> ADDR TO A FORM SUITABLE
			  FOR "TYPE" )

: TYPE
  -DUP
  0BRANCH TYPE1
  OVER + SWAP		( GET START .. END ADDRS )
  (DO)
LABEL TYPE2
    I C@ EMIT
  (LOOP) TYPE2
  BRANCH TYPE3
LABEL TYPE1
  DROP
LABEL TYPE3
;

: -TRAILING		( addr count -- addr count <count adjusted to
			  exclude trailing blanks> )
  DUP 0 (DO)		( DO )
LABEL TRAIL1
    OVER OVER + 1 - C@ BL -
    0BRANCH TRAIL2
    LEAVE BRANCH TRAIL3	( IF )
LABEL TRAIL2
    1 -			( ELSE )
LABEL TRAIL3
  (LOOP) TRAIL1		( THEN LOOP )
;

: (.")			( PRINT A COMPILED STRING )
  R COUNT
  DUP 1+ R> + >R TYPE
;

: ."			( COMPILE A STRING IF COMPILING,
			  OR PRINT A STRING IF INTERPRETING )
  LIT '"'
  STATE @
  0BRANCH QUOTE1
  COMPILE (.") WORD HERE C@ 1+ ALLOT	( IF )
  BRANCH QUOTE2
LABEL QUOTE1
  WORD HERE COUNT TYPE			( ELSE )
LABEL QUOTE2
;*					( THEN )

: EXPECT		( MODIFIED EXPECT lets UNIX input editing & echoing )
			( change EMIT to DROP below if not -echo )
  OVER + OVER		( start of input buffer is on top of stack )
  DUP 0 SWAP C!		( smack a zero at the start to catch empty lines )
  (DO)			( above is an added departure <read "hack"> )
LABEL EXPEC1
    KEY
			( Comment this region out if using stty cooked )
    DUP LIT 8 = 0BRANCH EXPEC2
    DROP DUP I = DUP R> 2 - + >R 0BRANCH EXPEC6
    LIT 7 BRANCH EXPEC7
LABEL EXPEC6
    LIT 8		( output for backspace )
LABEL EXPEC7
    BRANCH EXPEC3
			( End of region to comment out for stty cooked )
LABEL EXPEC2
    DUP LIT '\n' = 0BRANCH EXPEC4	( IF )
    LEAVE DROP BL 0 BRANCH EXPEC5
LABEL EXPEC4				( ELSE )
    DUP
LABEL EXPEC5				( THEN )
    I C! 0 I 1+ !
LABEL EXPEC3
    EMIT		( use DROP here for stty echo, EMIT for -echo )
    (LOOP) EXPEC1
    DROP
;

: QUERY
  TIB @			( ADDRESS OF BUFFER )
  B/BUF			( SIZE OF BUFFER )
  EXPECT		( GET A LINE )
  0 IN !		( PREPARE FOR INTERPRET )
;

: {NUL}			( THIS GETS TRANSLATED INTO A SINGLE NULL BYTE )
  BLK @
  0BRANCH NULL1
  BLK ++ 0 IN !		( IF )
  BLK @ B/SCR 1 - AND 0=
  0BRANCH NULL2
  ?EXEC
  R>			( IF )
  DROP
LABEL NULL2
  BRANCH NULL3		( ENDIF ELSE )
LABEL NULL1
  R> DROP
LABEL NULL3		( ENDIF )
;*

: FILL			( START COUNT VALUE -- <FILL COUNT WORDS, FROM START,
			  WITH VALUE )
  SWAP -DUP
  0BRANCH FILL1
  SWAP ROT SWAP OVER C!	( IF <NON-NULL COUNT> )
  DUP 1+ ROT 1 -
  CMOVE
  BRANCH FILL2
LABEL FILL1
  DROP DROP
LABEL FILL2
;

: ERASE			( START COUNT -- <ZERO OUT MEMORY> )
  0 FILL
;

: BLANKS		( START COUNT -- <FILL WITH BLANKS> )
  BL FILL
;

: HOLD			( C -- <PLACE C AT --HLD> )
  HLD -- HLD @ C!
;

: PAD			( -- ADDR <OF PAD SPACE> )
  HERE LIT 0x44 +
;

: WORD			( C -- <GET NEXT WORD TO END OF DICTIONARY,
			  DELIMITED WITH C OR NULL )
		( LOADING PART OF THIS IS COMMENTED OUT )
  BLK @ -DUP
  0BRANCH W1
  	BLOCK		( IF loading )
  	BRANCH W2 
LABEL W1
	TIB @		( ELSE )
LABEL W2		( ENDIF )
  IN @ + SWAP ENCLOSE	( GET THE WORD )
  HERE LIT 0x22 BLANKS	( BLANK SPACE AFTER WORD )
  IN +! OVER - >R R HERE C! + HERE 1+ R> CMOVE
;

: (NUMBER)
LABEL NUM1
  1+
  DUP >R C@ BASE @ DIGIT
  0BRANCH NUM2		( WHILE )
  SWAP BASE @ U* DROP
  ROT BASE @ U* D+
  DPL @ 1+
  0BRANCH NUM3
  DPL ++		( IF )
LABEL NUM3
  R>			( ENDIF )
  BRANCH NUM1		( REPEAT )
LABEL NUM2
  R>
;

: NUMBER
  0 0 ROT DUP 1+ C@
  LIT '-' = DUP >R + -1
LABEL N1		( BEGIN )
  DPL ! (NUMBER) DUP C@ BL !=
  0BRANCH N2		( WHILE )
  DUP C@ LIT '0' != 0 ?ERROR 0	( . )
  BRANCH N1		( REPEAT )
LABEL N2
  DROP R>
  0BRANCH N3		( IF )
  DMINUS
LABEL N3		( ENDIF )
;

: -FIND
  BL WORD ( HERE CONTEXT @ @ <FIND> DUP 0= 0BRANCH FIND1 DROP )
  HERE LATEST (FIND)
( LABEL FIND1 )
;

: ID.			( NFA -- <PRINT ID OF A WORD > )
  PAD LIT 0x5F BLANKS
  DUP PFA LFA OVER - PAD SWAP CMOVE
  PAD COUNT LIT 0x1F AND TYPE SPACE
;

: CREATE		( MAKE A HEADER FOR THE NEXT WORD )
  -FIND
  0BRANCH C1
  DROP NFA ID. LIT 4 MESSAGE SPACE	( NOT UNIQUE )
LABEL C1
  HERE DUP C@ WIDTH @ MIN 1+ ALLOT	( MAKE ROOM )
  DUP LIT 0xA0 TOGGLE			( MAKE IT UNFINDABLE )
  HERE 1 - LIT 0x80 TOGGLE		( SET HI BIT )
  LATEST ,			( DO LF )
  CURRENT @ !			( UPDATE FOR LATEST )
  LIT 999 ,			( COMPILE ILLEGAL VALUE TO CODE FIELD )
;

: [COMPILE]		( COMPILE THE NEXT WORD, EVEN IF IT'S IMMEDIATE )
  -FIND 0= 0 ?ERROR DROP CFA ,
;*

: LITERAL
  STATE @
  0BRANCH L1
  COMPILE LIT ,
LABEL L1
;*

: DLITERAL
  STATE @
  0BRANCH D1
  SWAP LITERAL LITERAL
LABEL D1
;*

: ?STACK		( ERROR IF STACK OVERFLOW OR UNDERFLOW )
  S0 @ SP@ U< 1 ?ERROR	( SP > S0 MEANS UNDERFLOW )
  SP@ TIB @ U< LIT 7 ?ERROR  ( SP < R0 MEANS OVERFLOW: THIS IS IMPLEMENTATION-
				DEPENDENT; I KNOW THAT THE CS IS JUST 
				ABOVE THE TIB. )
;

: INTERPRET
LABEL I1
  -FIND			( BEGIN )
  0BRANCH I2
  STATE @ <		( IF )
  0BRANCH I3
  CFA ,			( IF )
  BRANCH I4
LABEL I3
  CFA EXECUTE		( ELSE )
LABEL I4
  ?STACK		( ENDIF )
  BRANCH I5
LABEL I2
  HERE NUMBER DPL @ 1+
  0BRANCH I6
  DLITERAL		( IF )
  BRANCH I7
LABEL I6
  DROP LITERAL		( ELSE )
LABEL I7
  ?STACK		( ENDIF ENDIF )
LABEL I5
  BRANCH I1		( AGAIN )
;

: IMMEDIATE		( MAKE MOST-RECENT WORD IMMEDIATE )
  LATEST LIT 0x40 TOGGLE
;

( *** These are commented out because we don't handle vocabularies ***

: VOCABULARY
  <BUILDS LIT 0xA081 ,
  CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
  WORDSIZE + CONTEXT !
;

: DEFINITIONS
  CONTEXT @ CURRENT !
;
*** End of commenting-out *** )

: (		( COMMENT )
  LIT ')'	( CLOSING PAREN )
  WORD
;*

: QUIT
  0 BLK ! [
LABEL Q1
  RP! CR QUERY INTERPRET	( BEGIN )
  STATE @ 0=
  0BRANCH Q2
  (.") "OK"			( IF )
LABEL Q2
  BRANCH Q1			( ENDIF AGAIN )
;

: ABORT
  SP! DECIMAL ?STACK CR
  .CPU				( PRINT THE GREETING )
  ( FORTH )
  QUIT
;

: COLD
  (COLD)
  VOC-LINK @ CONTEXT !		( INITIALIZE CONTEXT )
  CONTEXT @ CURRENT !		( MAKE CONTEXT CURRENT )
  FIRST USE !
  FIRST PREV !
  EMPTY-BUFFERS
  1 WARNING !			( USE SCREEN 4 FOR ERROR MESSAGES )
  ABORT
;

: WARM
  EMPTY-BUFFERS
  ABORT
;

: S->D
  DUP 0<
  0BRANCH S2D1
  -1			( HIGH WORD IS ALL 1S )
  BRANCH S2D2
LABEL S2D1
  0
LABEL S2D2
;

: +-
  0<
  0BRANCH PM1
  MINUS
LABEL PM1
;

: D+-
  0<
  0BRANCH DPM1
  DMINUS
LABEL DPM1
;

: ABS
  DUP +-
;

: DABS
  DUP D+-
;

: MIN
  2DUP >
  0BRANCH MIN1
  SWAP
LABEL MIN1
  DROP
;

: MAX
  2DUP <
  0BRANCH MAX1
  SWAP
LABEL MAX1
  DROP
;

( MATH STUFF )

: M*
  2DUP XOR >R ABS SWAP ABS U* R> D+-
;

: M/
  OVER >R >R DABS R ABS U/
  R> R XOR +- SWAP
  R> +- SWAP
;

: *		( MULTIPLY, OF COURSE )
  M* DROP
;

: /MOD
  >R S->D R> M/
;

: /			( DIVIDE <AND CONQUOR> )
  /MOD SWAP DROP
;

: MOD
  /MOD DROP
;

: */MOD
  >R M* R> M/
;

: */
  */MOD
  SWAP DROP
;

: M/MOD
  >R 0 R U/ R> SWAP >R U/ R>
;

( END OF MATH STUFF )

: (LINE)		( LINE SCR -- ADDR C/L )
  >R C/L B/BUF */MOD R> B/SCR * + BLOCK +
  C/L
;

: .LINE			( LINE SCR -- )
  (LINE) -TRAILING TYPE
;

: MESSAGE
  WARNING @ 0BRANCH MSG1
  -DUP 0BRANCH MSG2		( message # 0 is no message at all )
  LIT 4 OFFSET @ B/SCR / - .LINE SPACE ( messages are on screen 4 )
  BRANCH MSG2
LABEL MSG1
  (.") "MSG # " .
LABEL MSG2
;

( DISK-ORIENTED WORDS )

: +BUF
  LIT 1028			( 1K PLUS 4 BYTES OVERHEAD, CO from defines )
  + DUP LIMIT = 0BRANCH P1
  DROP FIRST
LABEL P1
  DUP PREV @ -
;

: UPDATE 			( MARK BUFFER AS MODIFIED )
  PREV @ @ LIT 0X8000 OR PREV @ !
;

: EMPTY-BUFFERS
  FIRST LIMIT OVER - ERASE
;

: BUFFER
  USE @ DUP >R
LABEL BUF1
  +BUF 0BRANCH BUF1		( LOOP UNTIL +BUF RETURNS NONZERO )
  USE ! R @ 0< 0BRANCH BUF2	( SEE IF IT'S DIRTY <sign bit is dirty bit> )
  R 2+ R @ LIT 0X7FFF AND 0 R/W	( WRITE THIS DIRTY BUFFER )
LABEL BUF2
  R !
  R PREV !
  R> 2+
;

: BLOCK
  OFFSET @ + >R PREV @ DUP @ R - DUP +
  0BRANCH BLOCK1
LABEL BLOCK2
  +BUF 0=
  0BRANCH BLOCK3
  DROP R BUFFER DUP R 1 R/W 2 -
LABEL BLOCK3
  DUP @ R - DUP + 0= 0BRANCH BLOCK2
  DUP PREV ! 
LABEL BLOCK1
  R> DROP 2+
;

: R/W				( ADDR F BUFNO -- read if F=1, write if 0 )
  (R/W)
  
;

: FLUSH
  #BUFF 1+ 0 (DO) 
LABEL FLUSH1
  	0 BUFFER DROP 
  (LOOP) FLUSH1
;

: LOAD
  BLK @ >R IN @ >R 0 IN !
  B/SCR * BLK !
  INTERPRET
  R> IN ! R> BLK !
;

: -->
  (.") "--> "
  ?LOADING 0 IN ! B/SCR BLK @ OVER MOD - BLK +!
;*

: '
  -FIND 0= 0 ?ERROR DROP LITERAL
;*

: FORGET
  CURRENT @ CONTEXT @ - LIT 24 ?ERROR
  ' DUP FENCE @ < LIT 21 ?ERROR
  DUP NFA DP ! LFA @ CONTEXT @ !
;

( COMPILING WORDS )

: BACK
  HERE - ,
;

: BEGIN
  ?COMP HERE 1
;*

: ENDIF
  ?COMP 2 ?PAIRS HERE OVER - SWAP !
;*

: THEN
  ENDIF
;*

: DO
  COMPILE (DO) HERE LIT 3
;*

: LOOP
  LIT 3 ?PAIRS COMPILE (LOOP) BACK
;*

: +LOOP
  LIT 3 ?PAIRS ?COMP COMPILE (+LOOP) BACK
;*

: UNTIL
  1 ?PAIRS COMPILE 0BRANCH BACK
;*

: END
  UNTIL
;*

: AGAIN
  ?COMP
  1 ?PAIRS COMPILE BRANCH BACK
;*

: REPEAT
  ?COMP
  >R >R AGAIN R> R> 2 -
  ENDIF
;*

: IF
  COMPILE 0BRANCH HERE 0 , 2
;*

: ELSE
  2 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 ENDIF 2
;*

: WHILE
  IF 2+
;*

: SPACES
  0 MAX -DUP 0BRANCH SPACES1
  0 (DO) 
LABEL SPACES2
  	SPACE 
  (LOOP) SPACES2
LABEL SPACES1
;

: <#
  PAD HLD !
;

: #>
  DROP DROP HLD @ PAD OVER -
;

: SIGN
  ROT 0< 0BRANCH SIGN1
  LIT '-'  HOLD
LABEL SIGN1
;

: #
  BASE @ M/MOD ROT LIT 9 OVER < 0BRANCH #1
  LIT 7 +		( 7 is offset to make 'A' come after '9')
LABEL #1
  LIT '0' + HOLD
;

: #S
LABEL #S1
  # 2DUP OR 0= 0BRANCH #S1
;

: D.R
  >R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE
;

: .R
  >R S->D R> D.R
;

: D.
  0 D.R SPACE
;

: .
  S->D D.
;

: ?
  @ .
;

: U.
  0 D.
;

: VLIST
  C/L 1+ OUT !  CONTEXT @ @
LABEL VLIST1			( BEGIN )
  OUT @ C/L > 0BRANCH VLIST2	( IF )
  CR
LABEL VLIST2			( THEN )
  DUP ID. SPACE PFA LFA @
  DUP 0= ?TERMINAL OR 0BRANCH VLIST1	( UNTIL )
  DROP
;

: .CPU
  (.") "C-CODED FORTH INTERPRETER"	( special string handling )
;

: BYE
  CR (.") "EXIT FORTH" CR
  0 (BYE)
;

: LIST
  DECIMAL CR
  DUP SCR ! (.") "SCR # " .
  LIT 16 0 (DO)
LABEL LIST1
    CR I 3 .R SPACE
    I SCR @ .LINE
    ?TERMINAL 0BRANCH LIST2
      LEAVE
LABEL LIST2
  (LOOP) LIST1
  CR
;

: CASE
  ?COMP CSP @ !CSP LIT 4
;*

: OF
  ?COMP LIT 4 ?PAIRS
  COMPILE OVER COMPILE = COMPILE 0BRANCH 
  HERE 0 ,
  COMPILE DROP
  LIT 5
;*

: ENDOF
  ?COMP
  LIT 5 ?PAIRS
  COMPILE BRANCH
  HERE 0 ,
  SWAP 2 ENDIF LIT 4
;*

: ENDCASE
  ?COMP
  LIT 4 ?PAIRS
  COMPILE DROP
LABEL ENDC1			( BEGIN )
  SP@ CSP @ != 0BRANCH ENDC2	( WHILE )
  2 ENDIF
  BRANCH ENDC1			( REPEAT )
LABEL ENDC2
  CSP !
;*

: \			( REMAINER OF THE LINE IS A COMMENT )
  ?LOADING
  IN @ C/L / 1+ C/L * IN !
;*

: ALIAS		( usage: ALIAS NEW OLD; makes already-compiled references )
		( to OLD refer to NEW. Restrictions: OLD must have been a )
		( colon-definition, and it must not have been of the form )
		( { : OLD ; } where the first word of the PFA is ;S .     )
  ' CFA
  ' DUP
  2 - @ LIT DOCOL != LIT 27 ?ERROR	( ERROR IF NOT A COLON DEFINITION )
  DUP @	LIT ;S = LIT 28 ?ERROR		( MAKE SURE ;S IS NOT THE FIRST WORD )
  DUP >R ! LIT ;S R> 2+ !
;

: REFORTH		( GET & EXECUTE ONE FORTH LINE <PERHAPS A NUMBER> )
  IN @ >R BLK @ >R
  0 IN ! 0 BLK !
  QUERY INTERPRET
  R> BLK ! R> IN !
;


( The vocabulary word FORTH will be compiled after the dictionary is read,
  with a pointer to the last word in the dictionary, which will be itself. )
//go.sysin dd *
echo 'x - forth.h'
sed 's/^X//' <<'//go.sysin dd *' >forth.h
X/*
 * forth.h -- define function numbers for primitives, and other constants,
 * externals, and globals used in forth.c and prims.c
 */

#define EXECUTE		0
#define LIT		1
#define BRANCH		2
#define ZBRANCH		3
#define PLOOP		4
#define PPLOOP		5
#define PDO		6
#define I		7
#define R		58
#define DIGIT		8
#define PFIND		9
#define ENCLOSE		10
#define KEY		11
#define PEMIT		12
#define QTERMINAL	13
#define CMOVE		14
#define USTAR		15
#define USLASH		16
#define AND		17
#define OR		18
#define XOR		19
#define SPFETCH		20
#define SPSTORE		21
#define RPFETCH		22
#define RPSTORE		23
#define SEMIS		24
#define LEAVE		25
#define TOR		26
#define FROMR		27
#define ZEQ		28
#define ZLESS		29
#define PLUS		30
#define DPLUS		31
#define MINUS		32
#define DMINUS		33
#define OVER		34
#define DROP		35
#define SWAP		36
#define DUP		37
#define TDUP		38
#define PSTORE		39
#define TOGGLE		40
#define FETCH		41
#define CFETCH		42
#define TFETCH		43
#define STORE		44
#define CSTORE		45
#define TSTORE		46
#define DOCOL		47
#define DOCON		48
#define DOVAR		49
#define DOUSE		50
#define SUBTRACT	51
#define EQUAL		52
#define NOTEQ		53
#define LESS		54
#define ROT		55
#define DODOES		56
#define DOVOC		57
X/* 58 is above */
#define ALLOT		59
#define PBYE		60
#define TRON		61
#define TROFF		62
#define DOTRACE		63
#define PRSLW		64
#define PSAVE		65
#define PCOLD		66

X/* memory */
#define GULPFRQ		256	/* if mem[LIMIT] - dp < GULPFRQ, then get */
#define GULPSIZE	1024	/* a block of GULPSIZE words		  */

X/*
 * User variables and other locations
 */

#define S0	UP+0		/* csp when stack is empty */
#define R0	UP+1		/* rsp when r stack is empty */
#define TIB	UP+2		/* Terminal Input Buffer location */
#define WIDTH	UP+3		/* screen width */
#define WARNING	UP+4		/* print messages? */
#define FENCE	UP+5		/* can not forget below this mark */
#define DP	UP+6		/* points to first unallocated word */
#define VOCLINK UP+7		/* vocabulary link */

char *calloc(), *realloc(), *gets();
long lseek();

X/* GLOBALS */

X/* STACK POINTERS are registers of our FORTH machine. They, like everything
   else, point into memory (mem[]). They are read by sp@ and rp@, set by sp!
   and rp!. They are initialized by COLD. */

extern unsigned short csp;
extern unsigned short rsp;

X/* This variable is all-important. It will be set to the top of the 
   data area by sbrk, and more memory will be allocated. All memory is
   addressed as a subscript to this address -- mem[0] is the first memory 
   element, mem[1] is second, and so on. 
*/

extern short *mem;	/* points to the number of bytes in mem[0], as read
			   from COREFILE at startup */

X/* two more machine registers: the interpretive pointer */
extern unsigned short ip;	/* for an explanation of these, look in */
extern unsigned short w;	/* interp.doc */

extern int trace, debug;	/* global for tracing in next() */
extern int tracedepth, breakenable, breakpoint, qtermflag, forceip, nobuf;
extern FILE *blockfile;
extern long bfilesize;
extern char *bfilename;
extern char *cfilename;
extern char *sfilename;
//go.sysin dd *
echo 'x - forth.lex'
sed 's/^X//' <<'//go.sysin dd *' >forth.lex
%{
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.

*/
%}

decimal	[0-9]
hex	[0-9A-Fa-f]
octal	[0-7]
white	[ \t\n\r\f]
tail	/{white}

%{
#include "forth.lex.h"
TOKEN token;
%}

%%
{white}*	/* whitespace -- keep looping */ ;

-?[1-9]{decimal}*{tail}		{ token.type = DECIMAL; token.text = yytext;
					return &token; }
-?0{octal}*{tail}		{ token.type = OCTAL; token.text = yytext;
					return &token; }
-?0[xX]{hex}+{tail}		{ token.type = HEX; token.text = yytext;
					return &token; }

\'\\b\'{tail}	{ token.type = C_BS; token.text = yytext; return &token; }
\'\\f\'{tail}	{ token.type = C_FF; token.text = yytext; return &token; }
\'\\n\'{tail}	{ token.type = C_NL; token.text = yytext; return &token; }
\'\\r\'{tail}	{ token.type = C_CR; token.text = yytext; return &token; }
\'\\t\'{tail}	{ token.type = C_TAB; token.text = yytext; return &token; }
\'\\\\\'{tail}	{ token.type = C_BSLASH; token.text = yytext; return &token; }
\'.\'{tail}	{ token.type = C_LIT; token.text = yytext; return &token; }

\"(\\\"|[^"])*\"{tail}	{ token.type = STRING_LIT; token.text = yytext; 
				return &token; }

"("{tail}		{ token.type = COMMENT; token.text = yytext;
				return &token; }

"PRIM"{tail}		{ token.type = PRIM; token.text = yytext;
				return &token; }

"CONST"{tail}		{ token.type = CONST; token.text = yytext;
				return &token; }

"VAR"{tail}		{ token.type = VAR; token.text = yytext;
				return &token; }

"USER"{tail}		{ token.type = USER; token.text = yytext;
				return &token; }

"LABEL"{tail}		{ token.type = LABEL; token.text = yytext;
				return &token; }

":"{tail}		{ token.type = COLON; token.text = yytext;
				return &token; }

";"{tail}		{ token.type = SEMICOLON; token.text = yytext;
				return &token; }

";*"{tail}		{ token.type = SEMISTAR; token.text = yytext;
				return &token; }

"{NUL}"{tail}		{ token.type = NUL; token.text = yytext;
				return &token; }

"LIT"{tail}		{ token.type = LIT; token.text = yytext;
				return &token; }

[^ \n\t\r\f]+{tail}	{ token.type = OTHER; token.text = yytext;
				return &token; }
%%
//go.sysin dd *
echo 'x - forth.lex.h'
sed 's/^X//' <<'//go.sysin dd *' >forth.lex.h
X/* this is my best effort at a reconstruction of this file - it was not
**  included with the distribution, and I cannot reach the author via
**   electronic mail!
** John Nelson  (decvax!genrad!john)  [moderator, mod.sources]
*/

struct tokenrec {
    int type;
    char *text;
};

#define TOKEN struct tokenrec

TOKEN *yylex();

#define DECIMAL		1
#define OCTAL		2
#define HEX		3
#define C_BS		4
#define C_FF		5
#define C_NL		6
#define C_CR		7
#define C_TAB		8
#define C_BSLASH	9
#define C_LIT		10
#define STRING_LIT	11
#define COMMENT		12
#define PRIM		13
#define CONST		14
#define VAR		15
#define USER		16
#define LABEL		17
#define COLON		18
#define SEMICOLON	19
#define SEMISTAR	20
#define NUL		21
#define LIT		22
#define OTHER		23
//go.sysin dd *
echo 'x - forth.line'
sed 's/^X//' <<'//go.sysin dd *' >forth.line
------------------ SCREEN 0 ------------------


================================================================
||      C-CODED FIG-FORTH for UNIX* systems by ALLAN PRATT    ||
||                                                            ||
||      INCLUDES \ COMMENTS,                                  ||
||               CASE..OF..ENDOF..ENDCASE                     ||
||               UNTHREAD, EDITOR                             ||
||               REFORTH,                                     ||
||               "ALIAS NEW OLD"                              ||
||      AND OTHER NICE THINGS.                                ||
|| ( * UNIX is a trademark of Bell Labs )                     ||
================================================================



------------------ SCREEN 1 ------------------
( UNTHREAD VERSION 2 / SCREEN 1 OF 3 )
: DOQUOTE                       \ AFTER (.")
  34 EMIT WORDSIZE + DUP C@ OVER 1+ SWAP TYPE
  34 EMIT SPACE DUP C@ + 1+ ;

: DOLIT         \ AFTER LIT, BRANCHES, AND (LOOP)S
  WORDSIZE + DUP @ . WORDSIZE + ;




-->




------------------ SCREEN 2 ------------------
( UNTHREAD VERSION 2 / SCREEN 2 OF 3 )
: DOWORD        \ MAIN UNTHREADER
  DUP @ WORDSIZE + DUP NFA ID.  CASE
    ' LIT       OF DOLIT        ENDOF
    ' 0BRANCH   OF DOLIT        ENDOF
    ' BRANCH    OF DOLIT        ENDOF
    ' (LOOP)    OF DOLIT        ENDOF
    ' (+LOOP)   OF DOLIT        ENDOF
    ' (.")      OF DOQUOTE      ENDOF
    ' ;S        OF DROP 0       ENDOF \ LEAVE 0
    DUP         OF WORDSIZE +   ENDOF \ DEFAULT
  ENDCASE ;

-->


------------------ SCREEN 3 ------------------
( UNTHREAD VERSION 2 / SCREEN 3 OF 3 )
: UNTHREAD      \ USAGE: UNTHREAD WORD
  [COMPILE] ' DUP CFA @
  ' DOWORD CFA @ <> 27 ?ERROR   \ NOT THREADED
  CR ." : " DUP NFA ID. SPACE
  BEGIN
    DOWORD
    OUT @ C/L > IF CR THEN
    -DUP WHILE
  REPEAT ;

CR ." UNTHREAD READY"

;S


------------------ SCREEN 4 ------------------
( ERROR MESSAGES )
EMPTY STACK


ISN'T UNIQUE


XFULL STACK







C-CODED figFORTH by ALLAN PRATT / APRIL 1985
------------------ SCREEN 5 ------------------
MSG # 16
MUST BE COMPILING
MUST BE EXECUTING
UNMATCHED STRUCTURES
DEFINITION NOT FINISHED
WORD IS PROTECTED BY FENCE
MUST BE LOADING

CONTEXT ISN'T CURRENT


ALIAS: NOT A COLON DEFINITION
ALIAS: CAN'T ALIAS A NULL WORD



------------------ SCREEN 6 ------------------
X." LOADING EDITOR FOR VT100" CR

: CLS                        \ clear screen and home cursor
  27 EMIT ." [2J" 27 EMIT ." [H"
;

: LOCATE   \ 0 16 LOCATE positions cursor at line 16, column 0
  27 EMIT 91 EMIT 1+ 1 .R 59 EMIT 1+ 1 .R 72 EMIT ;

: STANDOUT                   \ This can be a null word
  27 EMIT ." [7m" ;

: STANDEND                   \ This can be a null word, too.
  27 EMIT ." [m" ;

;S   \ CONTINUE LOADING EDITOR
------------------ SCREEN 7 ------------------
X." LOADING EDITOR FOR ADM5" CR

: CLS 26 EMIT ;

: LOCATE
  27 EMIT 61 EMIT
  32 + EMIT 32 + EMIT ;


: STANDOUT
  27 EMIT 71 EMIT ;

: STANDEND
  27 EMIT 71 EMIT ;

;S   \ continue loading editor
------------------ SCREEN 8 ------------------
( Reserved for more terminals; set the name of the terminal
  as a constant in screen 10 )
;S













------------------ SCREEN 9 ------------------
( Reserved for more terminals. Set the name of the terminal
  as a constant in screen 10 )
;S













------------------ SCREEN 10 ------------------
( EDITOR -- SCREEN 1 OF 19 -- VARIABLES )
DECIMAL
0 VARIABLE ROW          0 VARIABLE COL
0 VARIABLE EDIT-SCR     0 VARIABLE SCREEN-IS-MODIFIED
0 VARIABLE MUST-UPDATE  0 VARIABLE LAST-KEY-STRUCK
0 VARIABLE CURSOR-IS-DIRTY

0 VARIABLE KEYMAP  WORDSIZE 255 *  ALLOT
           KEYMAP  WORDSIZE 256 *  ERASE

0 VARIABLE SCR-BUFFER B/BUF B/SCR * WORDSIZE - ALLOT

( TERMINAL CONSTANTS -- VALUE IS SCREEN NUMBER TO LOAD )
6 CONSTANT VT100   7 CONSTANT ADM5

-->
------------------ SCREEN 11 ------------------
( EDITOR -- SCREEN 2 OF 19 -- SCREEN STUFF )

CR ." ENTER THE TYPE OF TERMINAL YOU ARE USING. TYPE ONE OF:"
CR ."      VT100   ADM5" CR   \ list the constants from scr 10

REFORTH          \ this word gets & interprets one line.
LOAD             \ load the right screen; VT100 = 6, ADM5 = 7

: EXIT-EDIT
  0 16 LOCATE QUIT ;
: ABORT-EDIT
  0 15 LOCATE MESSAGE ;

: BIND-ADDR          ( C -- ADDR where binding is stored )
  WORDSIZE * KEYMAP + ;
-->
------------------ SCREEN 12 ------------------
( EDITOR -- SCREEN 3 OF 19 -- I/O )

: ^EMIT        ( OUTPUT W/ESC AND ^ )
  DUP 127 > IF ." ESC-" 128 - THEN
  DUP 32  < IF ." ^" 64 + THEN
  EMIT ;

: BACK-WRAP     ( DECR EDIT SCR. AND PUT CURSOR AT BOTTOM )
  EDIT-SCR -- C/L 1- COL ! 15     ROW ! 1 MUST-UPDATE ! ;
: FORWARD-WRAP  ( INCR EDIT SCR. AND PUT CURSOR AT TOP )
  EDIT-SCR ++ 0 COL ! 0 ROW ! 1 MUST-UPDATE ! ;
: ED-KEY       ( INPUT W/ESC FOR HI BIT )
  KEY DUP 27 = IF DROP KEY 128 + THEN
  DUP LAST-KEY-STRUCK ! ;

-->
------------------ SCREEN 13 ------------------
( EDITOR -- SCREEN 4 OF 19 -- BINDING WORDS )
: (BIND)         ( CFA K -- STORES INTO KEYMAP )
  BIND-ADDR !
;

: BIND-TO-KEY    ( "BIND-TO-KEY NAME" ASKS FOR KEY )
  [COMPILE] ' CFA
  ." KEY: " ED-KEY DUP ^EMIT SPACE
  (BIND) ;

: DESCRIBE-KEY
  ." KEY: " ED-KEY DUP ^EMIT SPACE
  BIND-ADDR @ -DUP IF NFA ID.
                        ELSE ." SELF-INSERT"
                        THEN SPACE ;
-->
------------------ SCREEN 14 ------------------
( EDITOR -- SCREEN 5 OF 19 -- PRIMITIVE OPS )

: PREV-LINE ROW @      IF ROW -- 1 CURSOR-IS-DIRTY !
                       ELSE BACK-WRAP THEN ;
: NEXT-LINE ROW @ 15 < IF ROW ++ 1 CURSOR-IS-DIRTY !
                       ELSE FORWARD-WRAP THEN ;
: BEGINNING-OF-LINE 0 COL ! 1 CURSOR-IS-DIRTY ! ;
: END-OF-LINE      C/L 1- COL ! 1 CURSOR-IS-DIRTY ! ;
: EDIT-CR NEXT-LINE BEGINNING-OF-LINE ;
: PREV-CHAR COL @ IF COL -- 1 CURSOR-IS-DIRTY !
                  ELSE END-OF-LINE PREV-LINE
                  THEN ;
: NEXT-CHAR COL @ C/L 1- < IF COL ++ 1 CURSOR-IS-DIRTY !
                           ELSE EDIT-CR
                           THEN ;
-->
------------------ SCREEN 15 ------------------
( EDITOR -- SCREEN 6 OF 19 -- MORE LOW-LEVEL )
: THIS-CHAR
  ROW @ EDIT-SCR @ (LINE) DROP COL @ + ;

: PUT-CHAR THIS-CHAR C! 1 MUST-UPDATE ! ;

: INSERT-CHAR PUT-CHAR NEXT-CHAR ;

: SELF-INSERT
  LAST-KEY-STRUCK @ DUP THIS-CHAR C! EMIT
  NEXT-CHAR
;

DECIMAL -->


------------------ SCREEN 16 ------------------
( EDITOR -- SCREEN  7 OF 19 -- DISPLAY STUFF )
HEX
: SHOWSCR         ( N -- SHOWS SCREEN N )
   CLS
   0 10 LOCATE STANDOUT ." SCREEN " DUP . STANDEND
   10 0 DO
        0 I LOCATE
           I OVER .LINE
        LOOP DROP ;

: REDRAW EDIT-SCR @ SHOWSCR ;

: ?REDRAW
  MUST-UPDATE @ IF REDRAW 0 MUST-UPDATE !
                          1 CURSOR-IS-DIRTY ! THEN ;
DECIMAL -->
------------------ SCREEN 17 ------------------
( EDITOR -- SCREEN  8 OF 19 -- EXECUTE-KEY )

: EXECUTE-KEY        ( K -- EXECUTE THE KEY )
  WORDSIZE * KEYMAP + @ -DUP IF
                           EXECUTE
                        ELSE
                           SELF-INSERT
                        THEN
;
: ?PLACE-CURSOR
  CURSOR-IS-DIRTY @ IF
    COL @ ROW @ LOCATE
    0 CURSOR-IS-DIRTY !
  THEN
;
-->
------------------ SCREEN 18 ------------------
( EDITOR -- SCREEN  9 OF 19 -- TOP-LEVEL )
: TOP-LEVEL
  BEGIN
    ?REDRAW ?PLACE-CURSOR ED-KEY EXECUTE-KEY
  AGAIN
;


: EDIT
  EDIT-SCR ! CLS
  0 ROW ! 0 COL ! 1 MUST-UPDATE !
  TOP-LEVEL
;


-->
------------------ SCREEN 19 ------------------
( EDITOR -- SCREEN 10 OF 19 -- HIGH-LEVEL KEY WORDS )

: UPDATE-SCR                 ( BOUND TO ^U )
  EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
    I BLOCK DROP UPDATE
  LOOP ;


: NEXT-SCR                   ( ^C and ESC-C )
  EDIT-SCR ++   1 MUST-UPDATE !
;

: PREV-SCR                   ( ^R and ESC-R )
  EDIT-SCR @ 0= IF EDIT-SCR ++ THEN
  EDIT-SCR --   1 MUST-UPDATE ! ;
-->
------------------ SCREEN 20 ------------------
( EDITOR -- SCREEN 11 OF 19 -- HIGH-LEVEL )
HEX
: TAB-KEY        ( INCREMENT TO NEXT TAB STOP )
  COL @ 8 + F8 AND DUP C/L < IF COL ! THEN ;

DECIMAL

: REEDIT         ( RESTART EDITING )
  EDIT-SCR @ EDIT ;

: ERRCONV
  ERRBLK @ DUP B/SCR / SWAP B/SCR MOD DUP +
  ERRIN @ C/L @ / + ;
: ERREDIT ERRCONV ROW ! EDIT-SCR ! BEGINNING-OF-LINE
  1 MUST-UPDATE ! CLS TOP-LEVEL ;
-->
------------------ SCREEN 21 ------------------
( EDITOR -- SCREEN 12 OF 19 -- )

: UPDATE-AND-FLUSH
  UPDATE-SCR FLUSH ;

: DEL-TO-END-OF-LINE
  COL @ ROW @ EDIT-SCR @  ( SAVE THESE )
  C/L COL @ DO BL INSERT-CHAR LOOP
  EDIT-SCR ! ROW ! COL !  ( RESTORE SAVED VALUES )
;





-->
------------------ SCREEN 22 ------------------
( EDITOR -- SCREEN 13 OF 19 -- MORE HIGH-LEVEL )

: CLEAR-SCREEN
  EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
     I BLOCK B/BUF BLANKS
  LOOP
  1 MUST-UPDATE !
;

: DESCRIBE-BINDINGS     ( SHOWS ALL BINDINGS )
  256 0 DO              ( INTERESTING ONES, ANYWAY )
    I BIND-ADDR @
    -DUP IF CR I ^EMIT SPACE NFA ID. THEN
    ?TERMINAL IF LEAVE THEN
  LOOP CR ;
-->
------------------ SCREEN 23 ------------------
( EDITOR -- SCREEN 14 OF 19 -- WORD MOVEMENT )
: NEXT-WORD
  THIS-CHAR C@ BL = IF PREV-CHAR THEN   ( BUG FIX )
  BEGIN NEXT-CHAR THIS-CHAR C@ BL = UNTIL
  BEGIN NEXT-CHAR THIS-CHAR C@ BL <> UNTIL ;

: PREV-WORD
  BEGIN PREV-CHAR THIS-CHAR C@ BL <> UNTIL
  BEGIN PREV-CHAR THIS-CHAR C@ BL = UNTIL
  NEXT-CHAR ;





-->
------------------ SCREEN 24 ------------------
( EDITOR -- SCREEN 15 OF 19 -- BUFFER CONTROL )
: TO-BUFFER             ( COPY FROM HERE TO BUFFER )
  EDIT-SCR @ 16 0 DO
    I OVER (LINE) I C/L * SCR-BUFFER + SWAP CMOVE
  LOOP DROP
;

: FROM-BUFFER           ( COPY FROM BUFFER TO HERE )
  EDIT-SCR @ 16 0 DO
    I OVER (LINE) DROP I C/L * SCR-BUFFER + SWAP C/L CMOVE
  LOOP DROP 1 MUST-UPDATE !
;



-->
------------------ SCREEN 25 ------------------
( EDITOR -- SCREEN 16 OF 19 -- MORE BUFFERS )
: SCR-COPY      ( SRC DEST -- COPIES A SCREEN )
  EDIT-SCR @ ROT ROT    ( OLD IS THIRD )
  SWAP EDIT-SCR ! TO-BUFFER     ( OLD IS SECOND/DEST IS FIRST )
  EDIT-SCR ! FROM-BUFFER UPDATE-SCR
  EDIT-SCR !
;

: QUOTE-NEXT
  ED-KEY INSERT-CHAR
;

: EXECUTE-FORTH-LINE
  0 17 LOCATE 27 EMIT 84 EMIT REFORTH
  1 MUST-UPDATE ! TOP-LEVEL ;
-->
------------------ SCREEN 26 ------------------
( EDITOR -- SCREEN 17 OF 19 -- )














-->
------------------ SCREEN 27 ------------------
( EDITOR -- SCREEN 18 OF 19 -- INITIALIZE BINDINGS )

  ' PREV-LINE CFA 11 (BIND)  ( ^K )
  ' NEXT-LINE CFA 10 (BIND)  ( ^J )
  ' PREV-CHAR CFA  8 (BIND)  ( ^H )
  ' NEXT-CHAR CFA 12 (BIND)  ( ^L )
  ' NEXT-SCR  CFA  3 (BIND)  ( ^C )
  ' PREV-SCR  CFA 18 (BIND)  ( ^R )
  ' EXIT-EDIT CFA 209 (BIND)  ( ESC-Q )
  ' EDIT-CR   CFA 13 (BIND)  ( ^M )
  ' TAB-KEY   CFA  9 (BIND)  ( ^I )
  ' UPDATE-SCR CFA 21 (BIND) ( ^U )
  ' NEXT-WORD CFA  6 (BIND)  ( ^F )
  ' PREV-WORD CFA  1 (BIND)  ( ^A )
  ' UPDATE-AND-FLUSH CFA 198 (BIND) ( ESC-F )
-->
------------------ SCREEN 28 ------------------
( EDITOR -- SCREEN 19 OF 19 -- MORE BINDINGS )

  ' DEL-TO-END-OF-LINE CFA 25 (BIND)  ( ^Y )
  ' PREV-CHAR CFA 19 (BIND)     ( ^S )
  ' PREV-LINE CFA 5 (BIND)      ( ^E )
  ' NEXT-LINE CFA 24 (BIND)     ( ^X )
  ' NEXT-CHAR CFA 4 (BIND)      ( ^D )
  ' TO-BUFFER CFA 190 (BIND)    ( ESC-> )
  ' FROM-BUFFER CFA 188 (BIND)  ( ESC-< )
  ' NEXT-SCREEN CFA 195 (BIND)  ( ESC-C )
  ' PREV-SCREEN CFA 210 (BIND)  ( ESC-R )
  ' QUOTE-NEXT CFA 16 (BIND)    ( ^P )
  ' EXECUTE-FORTH-LINE CFA 155 (BIND) ( ESC-ESC )

CR ." EDITOR READY "
;S
------------------ SCREEN 29 ------------------
//go.sysin dd *
