pez.c

/*
   Pez
   Main Interpreter and Compiler

   See doc/CREDITS for information about the authors.
   This program is in the public domain.
*/

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#include <sys/types.h>
#include <stdio.h>
#include <ctype.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <fcntl.h>
#include <time.h>
#include <sys/time.h>
#include <regex.h>
#include <limits.h>
#include <gc/gc.h>
#include <lightning.h>

#ifdef ALIGNMENT
#include <memory.h>
#endif

#ifdef Macintosh
/* Macintoshes need 32K segments, else barfage ensues */
#pragma segment seg2a
#endif				//Macintosh

/*  Subpackage configuration.  If INDIVIDUALLY is defined, the inclusion
	of subpackages is based on whether their compile-time tags are
	defined.  Otherwise, we automatically enable all the subpackages.  */

// TODO:  These are all going away.  Some of them to config.h, and the rest to
// be made into initialization flags for interpreters (which, of course, depends
// on interpreter instances being implemented first).
#ifndef INDIVIDUALLY

#define ARRAY			// Array subscripting words
#define BREAK			// Asynchronous break facility
#define COMPILERW		// Compiler-writing words
#define CONIO			// Interactive console I/O
#define DEFFIELDS		// Definition field access for words
#define EVALUATE		// The EVALUATE primitive
#define FILEIO			// File I/O primitives
#define MATH			// Math functions
#define MEMMESSAGE		// Print message for stack/heap errors
#define PROLOGUE		// Prologue processing and auto-init
#define SYSTEM			// System command function
#define FFI			// Foreign function interface
#define PROCESS			// Process-level facilities

#define BOUNDS_CHECK		// For the stack, heap, return stack, and arrays
#define UNRESTRICTED_POINTERS	// Pointers anywhere, not just inside the heap.
#define MATH_CHECK		// x/0 errors.
#define COMPILATION_SAFETY	// The Compiling macro.
#define TRACE			// Execution tracing
#define WALKBACK		// Walkback trace
#define WORDSUSED		// Logging of words used and unused


#endif				// !INDIVIDUALLY

#include "pezdef.h"

#ifdef MATH
#include <math.h>
#endif

// Macro for defining primitives that push constant values:
#define PUSH_CONSTANT(fname, constant) prim fname(pez_instance *p) { So(1);\
	Push = (pez_stackitem)constant; }

/* Implicit functions (work for all numeric types). */
#ifdef abs
#undef abs
#endif
#define abs(x)		((x) < 0    ? -(x) : (x))
#define max(a,b)	((a) >  (b) ? (a) : (b))
#define min(a,b)	((a) <= (b) ? (a) : (b))
#define unit_scale(a)	((a) >= 1 ? 1 : ((a) % ((a) - 1)))

/*  Globals imported  */

/*  Data types  */

typedef enum { False = 0, True = 1 } Boolean;

#define Truth -1L	// Stack value for truth
#define Falsity 0L	// Stack value for falsity

/*
	Utility definition to get an array's element count (at compile time, and
	provided that you're in the same scope as the declaration).   For
	example:

		int  arr[] = {1,2,3,4,5};
		...
		printf("%d", ELEMENTS(arr));

	would print a five.  ELEMENTS("abc") can also be used to tell how many
	bytes are in a string constant INCLUDING THE TRAILING NULL.
*/

#define ELEMENTS(array) (sizeof(array)/sizeof((array)[0]))

#define output_stream p->output_stk[p->output_idx]
#define input_stream p->input_stk[p->input_idx]

#ifdef COPYRIGHT
#ifndef HIGHC
#ifndef lint
static
#endif
#endif
char copyright[] = "PEZ: This program is in the public domain.";
#endif

/*
   The following static cells save the compile addresses of words
   generated by the compiler.  They are looked up immediately after
   the dictionary is created.  This makes the compiler much faster
   since it doesn't have to look up internally-reference words, and,
   far more importantly, keeps it from being spoofed if a user redefines
   one of the words generated by the compiler.
*/
static pez_stackitem s_exit, s_lit, s_flit, s_strlit, s_dotparen,
	s_qbranch, s_branch, s_xdo, s_xqdo, s_xloop, s_pxloop, s_abortq;

/*  Forward functions  */

STATIC void exword(pez_instance *p, pez_dictword *dw),
	trouble(pez_instance *p, char *kind);
#ifdef MATH_CHECK
STATIC void notcomp(pez_instance *p), divzero(pez_instance *p);
#endif
#ifdef WALKBACK
STATIC void pwalkback(pez_instance *p);
#endif

/*  ALLOC  --  Allocate memory and error upon exhaustion.  */
static char *alloc(unsigned long size)
{
	char *cp = (char *)GC_MALLOC(size);

	if(cp == NULL) {
		fprintf(stderr, "\n\nOut of memory!  %lu bytes requested.\n",
			size);
		abort();
	}
	return cp;
}

/*
	Given the input stream, try to assemble a string
	in the token buffer.  These strings allow escaped characters.
*/
Boolean get_quoted_string(pez_instance *p, char **strbuf, char token_buffer[])
{
	Boolean valid_string = True;
	int toklen = 0;
	char *sp = *strbuf;
	char *tp = token_buffer;

	sp++;
	while(True) {
		char c = *sp++;

		if(c == '"') {
			sp++;
			*tp++ = 0;
			break;
		} else if(!c) {
			valid_string = False;
			*tp++ = 0;
			break;
		}
		if(c == '\\') {
			c = *sp++;
			if(!c) {
				valid_string = False;
				break;
			}
			// TODO:  lookup table.
			switch (c) {
			case 'b': c = '\b';
				break;
			case 'n': c = '\n';
				break;
			case 'r': c = '\r';
				break;
			case 't': c = '\t';
				break;
			case 'v': c = '\v';
				break;
			default:
				break;
			}
		}
		if(toklen < TOK_BUF_SZ - 1) {
			*tp++ = c;
			toklen++;
		} else {
			valid_string = False;
		}
	}
	*strbuf = sp;
	if(!valid_string) {
#ifdef MEMMESSAGE
		fprintf(stderr, "\nRunaway string: %s\n", token_buffer);
#endif
		p->evalstat = PEZ_RUNSTRING;
	}
	return valid_string;
}

/*
	Given the input stream and an opening delimiter, determine
	the appropriate closing delimiter and try to assemble a string
	in the token buffer.
	These strings don't give no never mind about no escapes
*/
Boolean get_delimited_string(pez_instance *p, char **strbuf,
		char token_buffer[])
{
	Boolean valid_string = True;
	int toklen = 0;
	char *sp = *strbuf;
	char *tp = token_buffer;
	char close_delim;

	sp++;
	switch (*sp) {
		case '{' : close_delim = '}'; break;
		case '(' : close_delim = ')'; break;
		case '[' : close_delim = ']'; break;
		case '<' : close_delim = '>'; break;
		default : close_delim = *sp; break;
	}

	sp++;
	while(True) {
		char c = *sp++;

		if(c == close_delim) {
			sp++;
			*tp++ = 0;
			break;
		} else if(!c) {
			valid_string = False;
			*tp++ = 0;
			break;
		}

		if(toklen < TOK_BUF_SZ - 1) {
			*tp++ = c;
			toklen++;
		} else {
			valid_string = False;
		}
	}
	*strbuf = sp;
	if(!valid_string) {
#ifdef MEMMESSAGE
		fprintf(stderr, "\nRunaway string: %s\n", token_buffer);
#endif
		p->evalstat = PEZ_RUNSTRING;
	}
	return valid_string;
}

/*
	Scan a token from the input stream and return its type.
	It works something like this:
		- If the last input string left open an inline comment, try to
		close it.  Failing that, pass the buck by returning TokNull.
		- We're not in a comment, so drive right on by any whitespace.
		- See if a string is about to happen.  This is signified by
		either a double quote or the backslash char.  A backslash causes
		the very next char to be used as the string delimiter, with
		support for the usual paired delimiters.
		     "I am string." \{ Hear me roar.} \/LA LA LA/ puts puts puts
		- If not a string, scan on until whitespace or string end.
		- Next, we have to decide what to do with the token.  It might
		be a comment opener, either rest-of-line or open-close flavor.
		- The token might be a number, as signified by a digit or minus
		sign for its first char.  Try to sscanf it to a TokInt or a
		TokReal.
		- If not otherwise identified, we have a word.
*/
static int lex(pez_instance *p, char **cp, char token_buffer[])
{
	char *scanp = *cp;

	while(True) {
		char *tp = token_buffer;
		int toklen = 0;

		// handle rudely interrupted comments
		if(p->comment) {
			while(*scanp != ')') {
				if(*scanp == 0) {
					*cp = scanp;
					return TokNull;
				}
				scanp++;
			}
			scanp++;
			p->comment = Falsity;
		}

		while(isspace(*scanp))	// Say NO to leading blanks
			scanp++;

		if(*scanp == '"') {
			Boolean valid_string =
				get_quoted_string(p, &scanp, token_buffer);
			*cp = --scanp;
			return valid_string ? TokString : TokNull;
		} else if(*scanp == '\\') { // Arbitrary string delimitation
			Boolean valid_string =
				get_delimited_string(p, &scanp, token_buffer);
			*cp = --scanp;
			return valid_string ? TokString : TokNull;
		} else {

			// Scan the next raw token
			while(True) {
				char c = *scanp++;

				if(!c || isspace(c)) {
					*tp++ = 0;
					break;
				}
				if(toklen < TOK_BUF_SZ - 1) {
					*tp++ = c;
					toklen++;
				}
			}
		}
		*cp = --scanp;

		if(!token_buffer[0])
			return TokNull;

		/* If token is a comment to end of line character, discard
		 * the rest of the line and return null for this token
		 * request. */
		if(strcmp(token_buffer, "#") == 0 ||
				strcmp(token_buffer, "#!") == 0) {
			while(*scanp)
				scanp++;
			*cp = scanp;
			return TokNull;
		}

		/* If this token is a comment open delimiter, set to
		   ignore all characters until the matching comment close
		   delimiter. */
		if(strcmp(token_buffer, "(") == 0) {
			while(*scanp) {
				if(*scanp == ')')
					break;
				scanp++;
			}
			if(*scanp == ')') {
				scanp++;
				continue;
			}
			p->comment = Truth;
			*cp = scanp;
			return TokNull;
		}

		/* See if the token is a number. */

		if(isdigit(token_buffer[0]) || token_buffer[0] == '-') {
			char tc;
			char *tcp;

#ifdef USE_SSCANF
			if(sscanf(token_buffer, "%li%c", &tokint, &tc) == 1)
				return TokInt;
#else
			p->tokint = strtoul(token_buffer, &tcp, 0);
			if(*tcp == 0) {
				return TokInt;
			}
#endif
			if(sscanf(token_buffer, "%lf%c",
						&p->tokreal, &tc) == 1) {
				return TokReal;
			}
		}
		return TokWord;
	}
}

/*  LOOKUP  --	Look up token in the dictionary.  */

static pez_dictword *lookup(pez_instance *p, char *tkname)
{
	pez_dictword *dw = p->dict;

	while(dw != NULL) {
		if(!(dw->wname[0] & WORDHIDDEN) &&
		   (strcasecmp(dw->wname + 1, tkname) == 0)) {
#ifdef WORDSUSED
			*(dw->wname) |= WORDUSED;	// Mark this word used
#endif
			break;
		}
		dw = dw->wnext;
	}
	return dw;
}

/* Gag me with a spoon!  Does no compiler but Turbo support
   #if defined(x) || defined(y) ?? */
#ifdef EXPORT
#define FgetspNeeded
#endif
#ifdef FILEIO
#ifndef FgetspNeeded
#define FgetspNeeded
#endif
#endif

#ifdef FgetspNeeded

/*  Portable database version of FGETS.  This reads the next line into a buffer
 *  a la fgets().  A line is delimited by either a carriage return or a line
 *  feed, optionally followed by the other character of the pair.  The string is
 *  always null terminated, and limited to the length specified - 1 (excess
 *  characters on the line are discarded.  The string is returned, or NULL if
 *  end of file is encountered and no characters were stored.  No end of line
 *  character is stored in the string buffer.
 */
Exported char *pez_fgetsp(pez_instance *p, char *s, int n, FILE *stream)
{
	int i = 0, ch;

	while(True) {
		ch = getc(stream);
		if(ch == EOF) {
			if(i == 0)
				return NULL;
			break;
		}
		if(ch == '\r') {
			ch = getc(stream);
			if(ch != '\n')
				ungetc(ch, stream);
			break;
		}
		if(ch == '\n') {
			ch = getc(stream);
			if(ch != '\r')
				ungetc(ch, stream);
			break;
		}
		if(i < (n - 1))
			s[i++] = ch;
	}
	s[i] = 0;
	return s;
}
#endif				// FgetspNeeded

/*  PEZ_MEMSTAT  --  Print memory usage summary.  */

#ifdef MEMSTAT
void pez_memstat(pez_instance *p)
{
	static char fmt[] = "   %-12s %6ld\t%6ld\t%6ld\t%3ld\n";

	printf("\n\t\t\t Memory Usage Summary\n\n"
	       "\t\t\t\t Current   Maximum\tItems\t Percent\n"
	       "  Memory Area\t usage\t used\tallocated   in use \n");

	printf(fmt, "Stack",
		   ((long)(p->stk - p->stack)),
		   ((long)(p->stackmax - p->stack)),
		   p->stklen, (100L * (p->stk - p->stack)) / p->stklen);
	printf(fmt, "Return stack",
		   ((long)(p->rstk - p->rstack)),
		   ((long)(p->rstackmax - p->rstack)),
		   p->rstklen, (100L * (p->rstk - p->rstack)) / p->rstklen);
	printf(fmt, "Heap",
		   ((long)(p->hptr - p->heap)),
		   ((long)(p->heapmax - p->heap)),
		   p->heaplen, (100L * (p->hptr - p->heap)) / p->heaplen);
}
#endif				// MEMSTAT

/*  Primitive implementing functions.  */

/*  ENTER  --  Enter word in dictionary.  */

static void enter(pez_instance *p, char *tkname)
{
	if(p->redef && (lookup(p, tkname) != NULL))
		fprintf(stderr, "\n%s isn't unique.\n", tkname);
	// Allocate name buffer
	p->createword->wname = alloc(((unsigned int)strlen(tkname) + 2));
	p->createword->wname[0] = 0;	// Clear flags
	strcpy(p->createword->wname + 1, tkname);// Copy token to name buffer
	p->createword->wnext = p->dict;	// Chain rest of dictionary to word
	p->dict = p->createword;	// Put word at head of dictionary
}

#ifdef Keyhit

/*  KBQUIT  --	If this system allows detecting key presses, handle
		the pause, resume, and quit protocol for the word
		listing facilities.  */

static Boolean kbquit()
{
	int key;

	if((key = Keyhit()) != 0) {
		printf("\nPress RETURN to stop, any other key to continue: ");
		while((key = Keyhit()) == 0);
		if(key == '\r' || (key == '\n'))
			return True;
	}
	return False;
}
#endif				// Keyhit

static void print_regex_error(int code, regex_t *rx)
{
	char buf[1024];
	regerror(code, rx, buf, 1024);
	fprintf(stderr, "Regex error:  %s\n", buf);
	fflush(stderr);
}


/*  Primitive word definitions.  */

#ifdef COMPILATION_SAFETY
#define Compiling
#else
#define Compiling if (state == Falsity) {notcomp(p); return;}
#endif
#define Compconst(x) Ho(1); Hstore = (pez_stackitem)(x)
#define Skipstring p->ip += *((char *)p->ip)

/*
   ( a b -- a+b )
   Adds the two numbers at the top of the stack.
*/
prim P_plus(pez_instance *p)
{
	Sl(2);
	S1 += S0;
	Pop;
}

/*
   ( a b -- a-b )
   Subtracts the number at the top of the stack from the next number on the
   stack.
*/
prim P_minus(pez_instance *p)
{
	Sl(2);
	S1 -= S0;
	Pop;
}

/*
   ( a b -- a*b )
   Multiplies the two numbers at the top of the stack.
*/
prim P_times(pez_instance *p)
{
	Sl(2);
	S1 *= S0;
	Pop;
}

/*
   ( a b -- a/b )
   Divides the second number on the stack by the first.
*/
prim P_div(pez_instance *p)
{
	Sl(2);
#ifdef MATH_CHECK
	if(S0 == 0) {
		divzero(p);
		return;
	}
#endif
	S1 /= S0;
	Pop;
}

/*
   ( a b -- a%b )
   The remainder of the second number on the stack divided by the first.
*/
prim P_mod(pez_instance *p)
{
	Sl(2);
#ifdef MATH_CHECK
	if(S0 == 0) {
		divzero(p);
		return;
	}
#endif
	S1 %= S0;
	Pop;
}

/*
   ( a b -- a/b a%b )
   Divides the second number on the stack by the first, returning the quotient
   and the remainder.
*/
prim P_divmod(pez_instance *p)
{
	pez_stackitem quot;

	Sl(2);
#ifdef MATH_CHECK
	if(S0 == 0) {
		divzero(p);
		return;
	}
#endif
	quot = S1 / S0;
	S1 %= S0;
	S0 = quot;
}

/*
   ( a b -- min )
   Returns the minimum of the top two numbers on the stack.
*/
prim P_min(pez_instance *p)
{
	Sl(2);
	S1 = min(S1, S0);
	Pop;
}

/*
   ( a b -- max )
   Returns the maximum of the top two numbers on the stack.
*/
prim P_max(pez_instance *p)
{
	Sl(2);
	S1 = max(S1, S0);
	Pop;
}

/*
   ( a -- -a )
   Negates the top number on the stack.
*/
prim P_neg(pez_instance *p)
{
	Sl(1);
	S0 = -S0;
}

/*
   ( a -- abs(a) )
   Returns the absolute value of the top number on the stack.
*/
prim P_abs(pez_instance *p)
{
	Sl(1);
	S0 = abs(S0);
}

/*
   ( a b -- a=b )
   Tests the top two numbers on the stack for equality.
*/
prim P_equal(pez_instance *p)
{
	Sl(2);
	S1 = (S1 == S0) ? Truth : Falsity;
	Pop;
}

/*
   ( a b -- a<>b )
   Returns true iff the top two numbers on the stack are unequal.
*/
prim P_unequal(pez_instance *p)
{
	Sl(2);
	S1 = (S1 != S0) ? Truth : Falsity;
	Pop;
}

/*
   ( a b -- a>b )
*/
prim P_gtr(pez_instance *p)
{
	Sl(2);
	S1 = (S1 > S0) ? Truth : Falsity;
	Pop;
}

/*
   ( a b -- a<b )
*/
prim P_lss(pez_instance *p)
{
	Sl(2);
	S1 = (S1 < S0) ? Truth : Falsity;
	Pop;
}

/*
   ( a b -- a>=b )
*/
prim P_geq(pez_instance *p)
{
	Sl(2);
	S1 = (S1 >= S0) ? Truth : Falsity;
	Pop;
}

/*
   ( a b -- a<=b )
*/
prim P_leq(pez_instance *p)
{
	Sl(2);
	S1 = (S1 <= S0) ? Truth : Falsity;
	Pop;
}

/*
   ( a b -- a&b )
   Returns the bitwise AND of the top two elements on the stack.
*/
prim P_and(pez_instance *p)
{
	Sl(2);
	S1 &= S0;
	Pop;
}

/*
   ( a b -- a|b )
   Bitwise OR of the top two elements on the stack.
*/
prim P_or(pez_instance *p)
{
	Sl(2);
	S1 |= S0;
	Pop;
}

/*
   ( a b -- a^b )
   Bitwise XOR of the top two elements on the stack.
*/
prim P_xor(pez_instance *p)
{
	Sl(2);
	S1 ^= S0;
	Pop;
}

/*
   ( a -- ~a )
   Bitwise negation of the top element on the stack.
*/
prim P_not(pez_instance *p)
{
	Sl(1);
	S0 = ~S0;
}

/*
   ( a b -- a<<b )
   Arithmetic shift left of the second item on the stack by number of bits in
   the top item.  Shifts right if the top item is negative.
*/
prim P_shift(pez_instance *p)
{
	Sl(1);
	S1 = (S0 < 0) ? (((unsigned long)S1) >> (-S0)) :
		(((unsigned long)S1) << S0);
	Pop;
}

prim P_1plus(pez_instance *p)
{				/* Add one */
	Sl(1);
	S0++;
}

prim P_2plus(pez_instance *p)
{				/* Add two */
	Sl(1);
	S0 += 2;
}

prim P_1minus(pez_instance *p)
{				/* Subtract one */
	Sl(1);
	S0--;
}

prim P_2minus(pez_instance *p)
{				/* Subtract two */
	Sl(1);
	S0 -= 2;
}

prim P_2times(pez_instance *p)
{				/* Multiply by two */
	Sl(1);
	S0 *= 2;
}

prim P_2div(pez_instance *p)
{				/* Divide by two */
	Sl(1);
	S0 /= 2;
}

prim P_0equal(pez_instance *p)
{				/* Equal to zero ? */
	Sl(1);
	S0 = (S0 == 0) ? Truth : Falsity;
}

prim P_0notequal(pez_instance *p)
{				/* Not equal to zero ? */
	Sl(1);
	S0 = (S0 != 0) ? Truth : Falsity;
}

prim P_0gtr(pez_instance *p)
{				/* Greater than zero ? */
	Sl(1);
	S0 = (S0 > 0) ? Truth : Falsity;
}

prim P_0lss(pez_instance *p)
{				/* Less than zero ? */
	Sl(1);
	S0 = (S0 < 0) ? Truth : Falsity;
}

/*  Storage allocation (mostly heap) primitives  */

/*
   ( n -- addr )
   Allocate n bytes of garbage-collected memory.
*/
prim P_malloc(pez_instance *p)
{
	So(1);
	S0 = (pez_stackitem)GC_MALLOC(S0);
}

/*
   ( -- heap )
   Push current heap address
*/
prim P_here(pez_instance *p)
{
	So(1);
	Push = (pez_stackitem)p->hptr;
}

/*
   ( val addr -- )
   Store value into address
*/
prim P_bang(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	*((pez_stackitem *)S0) = S1;
	Pop2;
}

/*
   ( addr -- *addr )
   Fetch value from address
*/
prim P_at(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = *((pez_stackitem *)S0);
}

/*
   ( n addr -- )
   Add top of stack to value at specified address
*/
prim P_plusbang(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	*((pez_stackitem *)S0) += S1;
	Pop2;
}

/*
   ( addr -- )
   Increments (by 1) the variable at the specified address.
*/
prim P_1plusbang(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	(*((pez_stackitem *)S0))++;
	Pop;
}

/*
   ( n -- )
   Allocate heap bytes
*/
prim P_allot(pez_instance *p)
{
	pez_stackitem n;

	Sl(1);
	n = (S0 + (sizeof(pez_stackitem) - 1)) / sizeof(pez_stackitem);
	Pop;
	Ho(n);
	p->hptr += n;
}

/*
   ( x -- )
   Store top of stack on heap
*/
prim P_comma(pez_instance *p)
{
	Sl(1);
	Ho(1);
	Hstore = S0;
	Pop;
}

/*
   ( byte addr -- )
   Store byte value into address
*/
prim P_cbang(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	*((unsigned char *)S0) = S1;
	Pop2;
}

/*
   ( addr -- *(char *)addr )
   Fetch byte value from address
*/
prim P_cat(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = *((unsigned char *)S0);
}

/*
   ( byte -- )
   Store one byte on heap
*/
prim P_ccomma(pez_instance *p)
{
	unsigned char *chp;

	Sl(1);
	Ho(1);
	chp = ((unsigned char *)p->hptr);
	*chp++ = S0;
	p->hptr = (pez_stackitem *)chp;
	Pop;
}

/*
   ( -- )
   Align heap pointer to stackitem size; useful (if not required for
   portability reasons) after storing a series of bytes.
*/
prim P_cequal(pez_instance *p)
{
	pez_stackitem n = (((pez_stackitem)p->hptr) - ((pez_stackitem)p->heap)) %
		(sizeof(pez_stackitem));

	if(n != 0) {
		char *chp = ((char *)p->hptr);

		chp += sizeof(pez_stackitem) - n;
		p->hptr = ((pez_stackitem *)chp);
	}
}

/*  Variable and constant primitives  */

/*
   ( -- addr )
   Pushes the body address of the current word.
*/
prim P_var(pez_instance *p)
{
	So(1);
	Push = (pez_stackitem)(((pez_stackitem *)p->curword) + Dictwordl);
}

/*
	Create a new word
*/
Exported void P_create(pez_instance *p)
{
	p->defpend = True;		/* Set definition pending */
	Ho(Dictwordl);
	p->createword = (pez_dictword *)p->hptr;// Develop address of word
	p->createword->wname = NULL;		// Clear pointer to name string
	p->createword->wcode = P_var;		// Store default code
	p->hptr += Dictwordl;	// Allocate heap space for word
}

/*
	Forget word
*/
prim P_forget(pez_instance *p)
{
	p->forgetpend = True;	// Mark forget pending
}

/*
	Declare variable
*/
prim P_variable(pez_instance *p)
{
	P_create(p);		// Create dictionary item
	Ho(1);
	Hstore = 0;		// Initial value = 0
}

/*
	Push value in body
*/
prim P_con(pez_instance *p)
{
	So(1);
	Push = *(((pez_stackitem *)p->curword) + Dictwordl);
}

/*
	Declare constant
*/
prim P_constant(pez_instance *p)
{
	Sl(1);
	P_create(p);		// Create dictionary item
	p->createword->wcode = P_con;	// Set code to constant push
	Ho(1);
	Hstore = S0;		// Store constant value in body
	Pop;
}

/*
   A series of very small functions for portably figuring out sizes and offsets
   from within Pez.
*/
#define SIZE_FUNCS(typename, size_fname, plural_fname) \
	prim size_fname(pez_instance *p) { So(1); Push = sizeof(typename); } \
	prim plural_fname(pez_instance *p) { Sl(1); S0 *= sizeof(typename); }
SIZE_FUNCS(pez_stackitem, P_cell_size, P_cells)
SIZE_FUNCS(pez_real, P_float_size, P_floats)
SIZE_FUNCS(void *, P_c_pointer_size, P_c_pointers)
SIZE_FUNCS(short, P_c_short_size, P_c_shorts)
SIZE_FUNCS(long, P_c_long_size, P_c_longs)
SIZE_FUNCS(int, P_c_int_size, P_c_ints)
SIZE_FUNCS(float, P_c_float_size, P_c_floats)
SIZE_FUNCS(double, P_c_double_size, P_c_doubles)
#undef SIZE_FUNCS

/*  Reflection for Pez's compile-time options, for building libs from Pez: */

PUSH_CONSTANT(P_pezconf_bindir, PEZCONF_BINDIR)
PUSH_CONSTANT(P_pezconf_libdir, PEZCONF_LIBDIR)
PUSH_CONSTANT(P_pezconf_cc, PEZCONF_CC)
PUSH_CONSTANT(P_pezconf_ld, PEZCONF_LD)
PUSH_CONSTANT(P_pezconf_cflags, PEZCONF_CFLAGS)
PUSH_CONSTANT(P_pezconf_ldflags, PEZCONF_LDFLAGS)
PUSH_CONSTANT(P_pezconf_ld_lib_cmd,
	PEZCONF_LD " " PEZCONF_LDFLAGS " " PEZCONF_SO_FLAGS)
PUSH_CONSTANT(P_pezconf_build_lib_cmd,
	PEZCONF_CC " " PEZCONF_CFLAGS " " PEZCONF_LDFLAGS " " PEZCONF_SO_FLAGS)

/*  Array primitives  */

#ifdef ARRAY

/*
   ( sub1 sub2 ... subn -- addr )
   Array subscript calculation
*/
prim P_arraysub(pez_instance *p)
{
	int i, offset, esize, nsubs;
	pez_stackitem *array, *isp;

	Sl(1);
	array = (((pez_stackitem *)p->curword) + Dictwordl);
	Hpc(array);
	nsubs = *array++;	// Load number of subscripts
	esize = *array++;	// Load element size
#ifndef BOUNDS_CHECK
	isp = &S0;
	for(i = 0; i < nsubs; i++) {
		pez_stackitem subn = *isp--;

		if(subn < 0 || subn >= array[i])
			trouble("Subscript out of range");
	}
#endif
	isp = &S0;
	offset = *isp;		// Load initial offset
	for(i = 1; i < nsubs; i++)
		offset = (offset * (*(++array))) + *(--isp);
	Npop(nsubs - 1);
	/* Calculate subscripted address.  We start at the current word,
	   advance to the body, skip two more words for the subscript count
	   and the fundamental element size, then skip the subscript bounds
	   words (as many as there are subscripts).  Then, finally, we
	   can add the calculated offset into the array. */
	S0 = (pez_stackitem)(((char *)(((pez_stackitem *)p->curword) +
					 Dictwordl + 2 + nsubs)) +
			  (esize * offset));
}

/*
   ( sub1 sub2 ... subn n esize -- array )
   Declares an array and stores its elements.
*/
prim P_array(pez_instance *p)
{
	int i, nsubs, asize = 1;
	pez_stackitem *isp;

	Sl(2);
	if(S0 <= 0)
		trouble(p, "Bad array element size");
	if(S1 <= 0)
		trouble(p, "Bad array subscript count");

	nsubs = S1;		// Number of subscripts
	Sl(nsubs + 2);		// Verify that dimensions are present

	/* Calculate size of array as the product of the subscripts */

	asize = S0;		// Fundamental element size
	isp = &S2;
	for(i = 0; i < nsubs; i++) {
		if(*isp <= 0)
			trouble(p, "Bad array dimension");
		asize *= *isp--;
	}

	asize = (asize + (sizeof(pez_stackitem) - 1)) / sizeof(pez_stackitem);
	Ho(asize + nsubs + 2);	/* Reserve space for array and header */
	P_create(p);		// Create variable
	p->createword->wcode = P_arraysub; // Set method to subscript calculate
	Hstore = nsubs;		// Header <- Number of subscripts
	Hstore = S0;		// Header <- Fundamental element size
	isp = &S2;
	for(i = 0; i < nsubs; i++) {	// Header <- Store subscripts
		Hstore = *isp--;
	}
	while(asize-- > 0)	// Clear the array to zero
		Hstore = 0;
	Npop(nsubs + 2);
}
#endif				// ARRAY

/*  String primitives  */

prim P_strlit(pez_instance *p)
{				/* Push address of string literal */
	So(1);
	Push = (pez_stackitem)(((char *)p->ip) + 1);

	tracing {
		printf("\"%s\" ", (((char *)p->ip) + 1));
		fflush(stdout);
	}

	Skipstring;		/* Advance IP past it */
}

prim P_string(pez_instance *p)
{				/* Create string buffer */
	Sl(1);
	Ho((S0 + 1 + sizeof(pez_stackitem)) / sizeof(pez_stackitem));
	P_create(p);		// Create variable
	/* Allocate storage for string */
	p->hptr += (S0 + 1 + sizeof(pez_stackitem)) / sizeof(pez_stackitem);
	Pop;
}

/*
   ( dst src -- )
   Copies a string from src to dest.
*/
prim P_strcpy(pez_instance *p)
{				// Copy string to address on stack
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	strcpy((char *)S0, (char *)S1);
	Pop2;
}

prim P_strcat(pez_instance *p)
{				/* Append string to address on stack */
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	strcat((char *)S0, (char *)S1);
	Pop2;
}

prim P_strlen(pez_instance *p)
{				/* Take length of string on stack top */
	Sl(1);
	Hpc(S0);
	S0 = strlen((char *)S0);
}

/*
   ( str1 str2 -- comp )
   Compares two strings.  If they are equal, the result is zero.  If str1 sorts
   before str2, the result is -1.  Otherwise, the result is 1.
*/
prim P_strcmp(pez_instance *p)
{
	int i;
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	i = strcmp((char *)S1, (char *)S0);
	S1 = unit_scale(i);
	Pop;
}

/*
   ( str1 str2 len -- comp )
   Like strcmp, but only matches up to len characters.
*/
prim P_strncmp(pez_instance *p)
{
	int i;
	Sl(3);
	Hpc(S1);
	Hpc(S2);
	i = strncmp((char *)S2, (char *)S1, S0);
	S2 = unit_scale(i);
	Pop2;
}

prim P_strchar(pez_instance *p)
{				// Find character in string
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	S1 = (pez_stackitem)strchr((char *)S1, *((char *)S0));
	Pop;
}

/*
   (source start length/-1 dest -- )
   Extract and store substring
*/
prim P_substr(pez_instance *p)
{
	long sl, sn;
	char *ss, *sp, *se, *ds;

	Sl(4);
	Hpc(S0);
	Hpc(S3);
	sl = strlen(ss = ((char *)S3));
	se = ss + sl;
	sp = ((char *)S3) + S2;
	if((sn = S1) < 0)
		sn = 999999L;
	ds = (char *)S0;
	while(sn-- && (sp < se))
		*ds++ = *sp++;
	*ds++ = 0;
	Npop(4);
}

/*
   ( val fmt buf -- )
   Equivalent to sprintf(buf, fmt, val);
*/
prim P_strform(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	sprintf((char *)S0, (char *)S1, S2);
	Npop(3);
}

/*
   ( f -- str )
   Float->string, using the format "%6.2f"
*/
prim P_fstrform(pez_instance *p)
{
	Sl(2 + Realsize);
	Hpc(S0);
	Hpc(S1);
	sprintf((char *)S0, (char *)S1, ((pez_real *)(p->stk - 2))[-1]);
	Npop(2 + Realsize);
}

/*
   ( str -- str' i )
   Takes a string from the stack, takes an integer from it, and advances the
   string's pointer to the end of that integer.
*/
prim P_strint(pez_instance *p)
{
	pez_stackitem is;
	char *eptr;

	Sl(1);
	So(1);
	Hpc(S0);
	is = strtoul((char *)S0, &eptr, 0);
	S0 = (pez_stackitem)eptr;
	Push = is;
}

prim P_strreal(pez_instance *p)
{				/* String to real *//* str -- endptr value */
	int i;
	union {
		pez_real fs;
		pez_stackitem fss[Realsize];
	} fsu;
	char *eptr;

	Sl(1);
	So(Realsize);
	Hpc(S0);
	fsu.fs = strtod((char *)S0, &eptr);
	S0 = (pez_stackitem)eptr;
	for(i = 0; i < Realsize; i++) {
		Push = fsu.fss[i];
	}
}

/*
   ( string option-string -- regex )
   Compiles a regular expression, leaving its address on the stack.  For invalid
   regexes, NULL is returned instead.  Options are passed as a string, which
   should be NULL or contain one or both of "i" or "m", which mean,
   respectively, case-insensitive matching (REG_ICASE) and the newline tweaking
   rules (REG_NEWLINE).  See the man page for regex(3) for more information.
*/
prim P_regex(pez_instance *p)
{
	regex_t *rx;
	int flags = REG_EXTENDED, problem;

	Sl(2);

	rx = (regex_t *)alloc(sizeof(regex_t));

	if(S0) {
		if(strchr((char *)S0, 'i'))
			flags |= REG_ICASE;
		if(strchr((char *)S0, 'm'))
			flags |= REG_NEWLINE;
	}

	problem = regcomp(rx, (char *)S1, flags);
	S1 = problem ? 0 : (pez_stackitem)(rx);
	Pop;
	return;
}

/*
   ( string regex -- match? )
   Attempts to match the supplied string against the supplied regular
   expression.
*/
prim P_rmatch(pez_instance *p)
{
	int match;
	Sl(2);

	match = !regexec((regex_t *)S0, (char *)S1,
			MAX_REGEX_MATCHES, p->regex_matches, 0);
	S1 = match ? Truth : Falsity;
	Pop;
}

/*
   ( -- len first-offset )
   An approximation of Perl's/Ruby's/other's regex match variables.  The most
   recent regex to be matched is used, and the length and initial offset into
   the string are pushed.  The entire match is $0, the first group is $1, and so
   on.  If there was no match, then the initial offset will be -1 and the length
   will be zero.  (Note, however, that a match can have length zero and still be
   valid; check the offset to be sure if an optional part matched.)
*/
#define PUSH_RX(fname,n) prim fname(pez_instance *p) { So(2); \
		Push = p->regex_matches[n].rm_eo - p->regex_matches[n].rm_so;\
		Push = p->regex_matches[n].rm_so;\
	}
PUSH_RX(P_money0, 0)
PUSH_RX(P_money1, 1)
PUSH_RX(P_money2, 2)
PUSH_RX(P_money3, 3)
PUSH_RX(P_money4, 4)
PUSH_RX(P_money5, 5)
PUSH_RX(P_money6, 6)
PUSH_RX(P_money7, 7)
PUSH_RX(P_money8, 8)
PUSH_RX(P_money9, 9)
PUSH_RX(P_money10, 10)
PUSH_RX(P_money11, 11)
PUSH_RX(P_money12, 12)
PUSH_RX(P_money13, 13)
PUSH_RX(P_money14, 14)
PUSH_RX(P_money15, 15)
PUSH_RX(P_money16, 16)
PUSH_RX(P_money17, 17)
PUSH_RX(P_money18, 18)
PUSH_RX(P_money19, 19)
#undef PUSH_RX

/*  Floating point primitives  */

/*
   Pushes a float literal from the input stream.
*/
prim P_flit(pez_instance *p)
{
	int i;

	So(Realsize);
	tracing {
		pez_real tr;

		memcpy((char *)&tr, (char *)p->ip, sizeof(pez_real));
		printf("%g ", tr);
		fflush(stdout);
	}

	for(i = 0; i < Realsize; i++) {
		Push = (pez_stackitem) *p->ip++;
	}
}

/*
   ( f1 f2 -- f1+f2 )
   Adds the two floats at the top of the stack.
*/
prim P_fplus(pez_instance *p)
{
	Sl(2 * Realsize);
	SREAL1(REAL1 + REAL0);
	Realpop;
}

/*
   ( f1 f2 -- f1-f2 )
   Subtracts the float at the top of the stack from the next float.
*/
prim P_fminus(pez_instance *p)
{
	Sl(2 * Realsize);
	SREAL1(REAL1 - REAL0);
	Realpop;
}

/*
   ( f1 f2 -- f1*f2 )
   Multiplies the two floats at the top of the stack.
*/
prim P_ftimes(pez_instance *p)
{
	Sl(2 * Realsize);
	SREAL1(REAL1 * REAL0);
	Realpop;
}

/*
   ( f1 f2 -- f1/f2 )
   Divides the second float on the stack by the first.
*/
prim P_fdiv(pez_instance *p)
{
	Sl(2 * Realsize);
#ifdef MATH_CHECK
	if(REAL0 == 0.0) {
		divzero(p);
		return;
	}
#endif
	SREAL1(REAL1 / REAL0);
	Realpop;
}

/*
   ( f1 f2 -- min )
   Consumes two floats, leaves the lesser of the two on top of the stack.
*/
prim P_fmin(pez_instance *p)
{
	Sl(2 * Realsize);
	SREAL1(min(REAL1, REAL0));
	Realpop;
}

/*
   ( f1 f2 -- max )
   Consumes two floats, leaves the greater of the two on top of the stack.
*/
prim P_fmax(pez_instance *p)
{
	Sl(2 * Realsize);
	SREAL1(max(REAL1, REAL0));
	Realpop;
}

/*
   ( f -- -f )
*/
prim P_fneg(pez_instance *p)
{
	Sl(Realsize);
	SREAL0(-REAL0);
}

/*
   ( f -- abs(f) )
*/
prim P_fabs(pez_instance *p)
{
	Sl(Realsize);
	SREAL0(abs(REAL0));
}

/*
   ( f1 f2 -- f1=f2 )
*/
prim P_fequal(pez_instance *p)
{
	pez_stackitem t;

	Sl(2 * Realsize);
	t = (REAL1 == REAL0) ? Truth : Falsity;
	Realpop2;
	Push = t;
}

/*
   ( f1 f2 -- f1<>f2 )
*/
prim P_funequal(pez_instance *p)
{
	pez_stackitem t;

	Sl(2 * Realsize);
	t = (REAL1 != REAL0) ? Truth : Falsity;
	Realpop2;
	Push = t;
}

/*
   ( f1 f2 -- f1>f2 )
*/
prim P_fgtr(pez_instance *p)
{
	pez_stackitem t;

	Sl(2 * Realsize);
	t = (REAL1 > REAL0) ? Truth : Falsity;
	Realpop2;
	Push = t;
}

/*
   ( f1 f2 -- f1<f2 )
*/
prim P_flss(pez_instance *p)
{
	pez_stackitem t;

	Sl(2 * Realsize);
	t = (REAL1 < REAL0) ? Truth : Falsity;
	Realpop2;
	Push = t;
}

/*
   ( f1 f2 -- f1>=f2 )
*/
prim P_fgeq(pez_instance *p)
{
	pez_stackitem t;

	Sl(2 * Realsize);
	t = (REAL1 >= REAL0) ? Truth : Falsity;
	Realpop2;
	Push = t;
}

/*
   ( f1 f2 -- f1<=f2 )
*/
prim P_fleq(pez_instance *p)
{
	pez_stackitem t;

	Sl(2 * Realsize);
	t = (REAL1 <= REAL0) ? Truth : Falsity;
	Realpop2;
	Push = t;
}

/*
   ( f -- )
   Print the float at the top of the stack to the current output stream.
*/
prim P_fdot(pez_instance *p)
{
	double f;
	memcpy(&f, p->stk - 1, sizeof(double));
	Sl(Realsize);
	printf("%f ", REAL0);
	fflush(stdout);
	Realpop;
}

/*
   ( i -- f )
   Convert an integer to a floating-point number.
*/
prim P_float(pez_instance *p)
{
	pez_real r;

	Sl(1);
	So(Realsize - 1);
	r = S0;
	p->stk += Realsize - 1;
	SREAL0(r);
}

/*
   ( f -- i )
   Convert a floating-point number to an integer.
*/
prim P_fix(pez_instance *p)
{
	pez_stackitem i;

	Sl(Realsize);
	i = (int)REAL0;
	Realpop;
	Push = i;
}

/*
   ( -- time-as-float )
   Returns the time as number of seconds since the epoch, as a floating point
   value.
*/
prim P_ftime(pez_instance *p)
{
	struct timeval tv;
	double d;

	So(Realsize);
	gettimeofday(&tv, 0);
	d = (double)tv.tv_sec + (double)tv.tv_usec / 1000000.0;
	Realpush(d);
}

#ifdef MATH

#define Mathfunc(x) do { Sl(Realsize); SREAL0(x(REAL0)); } while(0)

prim P_acos(pez_instance *p)
{				/* Arc cosine */
	Mathfunc(acos);
}

prim P_asin(pez_instance *p)
{				/* Arc sine */
	Mathfunc(asin);
}

prim P_atan(pez_instance *p)
{				/* Arc tangent */
	Mathfunc(atan);
}

prim P_atan2(pez_instance *p)
{				/* Arc tangent:  y x -- atan */
	Sl(2 * Realsize);
	SREAL1(atan2(REAL1, REAL0));
	Realpop;
}

prim P_cos(pez_instance *p)
{				/* Cosine */
	Mathfunc(cos);
}

prim P_exp(pez_instance *p)
{				/* E ^ x */
	Mathfunc(exp);
}

prim P_log(pez_instance *p)
{				/* Natural log */
	Mathfunc(log);
}

prim P_ipow(pez_instance *p)
{
	pez_stackitem  i, n;
	Sl(2);

	// A somewhat naive implementation:
	n = S1;
	for(i = 1; i < S0; i++)
		S1 *= n;

	Pop;
}

prim P_pow(pez_instance *p)
{				/* X ^ Y */
	Sl(2 * Realsize);
	SREAL1(pow(REAL1, REAL0));
	Realpop;
}

prim P_sin(pez_instance *p)
{				/* Sine */
	Mathfunc(sin);
}

prim P_sqrt(pez_instance *p)
{				/* Square root */
	Mathfunc(sqrt);
}

prim P_tan(pez_instance *p)
{				/* Tangent */
	Mathfunc(tan);
}

#undef Mathfunc
#endif				/* MATH */

prim P_hton(pez_instance *p) {
	Sl(1);
	pez_stackitem i = S0;
	Pop;
	Push = htonl(i);
}

prim P_ntoh(pez_instance *p) {
	Sl(1);
	pez_stackitem i = S0;
	Pop;
	Push = ntohl(i);
}

/*  Console I/O primitives  */

#ifdef CONIO

prim P_hex(pez_instance *p)
{
	p->base = 16;
}

prim P_decimal(pez_instance *p)
{
	p->base = 10;
}

prim P_argc(pez_instance *p)
{
	char **pa;
	if(!p->argc && p->argv[0]) {
		pa = p->argv;
		while(*pa++)
			p->argc++;
	}

	Push = p->argc;
}

prim P_argv(pez_instance *p)
{
	Push = (pez_stackitem)p->argv;
}

prim P_dot(pez_instance *p)
{
	Sl(1);
	printf(p->base == 16 ? "0x%lx " : "%ld ", S0);
	fflush(stdout);
	Pop;
}

prim P_question(pez_instance *p)
{				// Print value at address
	Sl(1);
	Hpc(S0);
	printf(p->base == 16 ? "0x%lx " : "%ld ", *((pez_stackitem *)S0));
	fflush(stdout);
	Pop;
}

/*
   ( -- )
   Prints a newline to the output stream.
*/
prim P_cr(pez_instance *p)
{
	write(output_stream, "\n", 1);
}

/*
   ( ... n -- ... )
   Prints the top max(n,depth) items on the stack, and ellipses at the beginning
   if there are more than n items.  Like .s, this is mostly useful in
   interactive modes.
*/
prim P_ndots(pez_instance *p)
{
	pez_stackitem *tsp, n;
	long depth = p->stk - p->stack - 1;

	Sl(1);
	n = S0;
	Pop;
	
	if(depth == 0) {
		printf("Stack is empty.\n");
		return;
	} else {
		if(n >= depth) {
			n = depth;
		} else {
			printf("... ");
		}
	}

	for(tsp = p->stk - n; tsp < p->stk; tsp++) {
		printf(p->base == 16 ? "0x%lx " : "%ld ", *tsp);
	}
	printf("\n");
	fflush(stdout);
}

/*
   ( ... -- ... )
   Print the entire stack, as cell-sized integers.
*/
prim P_dots(pez_instance *p)
{
	So(1);
	Push = p->stk - p->stack;
	P_ndots(p);
}

/*
	Print literal string that follows
*/
prim P_dotquote(pez_instance *p)
{
	Compiling;
	p->stringlit = True;		// Set string literal expected
	Compconst(s_dotparen);	// Compile .( word
}

/*
   ( -- )
   Prints the following inline string literal.
*/
prim P_dotparen(pez_instance *p)
{
	if(p->ip) {
		write(output_stream, (char *)p->ip + 1,
				strlen((char *)p->ip + 1));
		Skipstring;	// So we don't execute the string.
	} else {
		// We have to sort of wing it if the string isn't yet available.
		p->stringlit = True;
	}
}

/*
   ( string -- )
   Prints the string at the top of the stack.
*/
prim P_print(pez_instance *p)
{
	int len;

	Sl(1);
	Hpc(S0);

	len = strlen((char *)S0);
	write(output_stream, (char *)S0, len);
	Pop;
}

/*
   Print the string at the top of the stack, followed by \n, unless the string
   already contains it.
   ( string -- )
*/
prim P_puts(pez_instance *p)
{
	int len;

	Sl(1);
	Hpc(S0);

	len = strlen((char *)S0);
	write(output_stream, (char *)S0, len);
	if(*(char *)(S0 + len - 1) != '\n')
		P_cr(p);
	Pop;
}

/*
   ( strbuf maxlen -- len )
*/
prim P_gets(pez_instance *p)
{
	pez_stackitem max;
	char *buf;

	Sl(2);
	Hpc(S1);

	buf = (char *)S1;

	// TODO:  This is horribly inefficient, but will have to stay until we
	// do internal buffering.
	for(max = S0; max; max--) {
		read(input_stream, buf++, 1);
		if(buf[-1] == '\n') {
			if(max - 1)
				*buf = '\0';
			break;
		}
	}
	S1 = buf - (char *)S1;
	Pop;
}

/*
   ( strbuf maxlen -- bytes-read )
   Reads from an input stream up to maxlen bytes, puts them in strbuf, and
   returns the the actual number of bytes read.
*/
prim P_read(pez_instance *p)
{
	int len;
	Sl(2);
	Hpc(S1);
	len = S0;
	S1 = read(input_stream, (char *)S1, len);
	Pop;
}

/*
   ( string len -- bytes-written )
   Writes len bytes from string, returning the actual number of bytes written.
*/
prim P_write(pez_instance *p)
{
	int len;
	Sl(2);
	Hpc(S1);
	len = S0;
	S1 = write(output_stream, (char *)S1, len);
	Pop;
}

/*
   ( -- char )
*/
prim P_getc(pez_instance *p)
{
	char c;

	So(1);
	read(input_stream, &c, 1);
	Push = (pez_stackitem)c;
}

/*
   ( char -- )
*/
prim P_putc(pez_instance *p)
{
	char c;
	Sl(1);
	c = (char)S0;
	write(output_stream, &c, 1);
	Pop;
}

/*
   ( -- )
   Print the currently defined words to stdout.
*/
prim P_words(pez_instance *p)
{
	pez_dictword *dw = p->dict;

	while(dw != NULL) {
		printf("\n%s", dw->wname + 1);
		dw = dw->wnext;
	}
	printf("\n");
	fflush(stdout);
}
#endif				// CONIO

#ifdef FILEIO

/*
   ( fd -- )
   Sets the output stream to the specified file descriptor.
*/
prim P_tooutput(pez_instance *p)
{
	Sl(1);
	p->output_idx = (p->output_idx + 1) % MAX_IO_STREAMS;
	output_stream = S0;
	Pop;
}

/*
   ( fd -- )
   Sets the input stream to the specified file descriptor.
*/
prim P_toinput(pez_instance *p)
{
	Sl(1);
	p->input_idx = (p->input_idx + 1) % MAX_IO_STREAMS;
	input_stream = S0;
	Pop;
}

/*
   ( -- fd )
   Pushes the current output stream onto the stack.
*/
prim P_outputto(pez_instance *p)
{
	So(1);
	Push = output_stream;
	p->output_idx = (p->output_idx + MAX_IO_STREAMS - 1) % MAX_IO_STREAMS;
}

/*
   ( -- fd )
   Pushes the current input stream onto the stack.
*/
prim P_inputto(pez_instance *p)
{
	So(1);
	Push = input_stream;
	p->input_idx = (p->input_idx + MAX_IO_STREAMS - 1) % MAX_IO_STREAMS;
}

/*
   ( fname flags mode -- fd )
*/
prim P_open(pez_instance *p)
{
	char *fname;
	long flags, mode;

	Sl(3);

	mode = S0;
	flags = S1;
	fname = (char *)S2;
	Pop2;
	S0 = open(fname, flags, mode);
}

/* Man, all of these flags are tedious. */
PUSH_CONSTANT(P_o_append, O_APPEND)
PUSH_CONSTANT(P_o_async, O_ASYNC)
PUSH_CONSTANT(P_o_creat, O_CREAT)
PUSH_CONSTANT(P_o_excl, O_EXCL)
PUSH_CONSTANT(P_o_rdonly, O_RDONLY)
PUSH_CONSTANT(P_o_rdwr, O_RDWR)
PUSH_CONSTANT(P_o_sync, O_SYNC)
PUSH_CONSTANT(P_o_trunc, O_TRUNC)
PUSH_CONSTANT(P_o_wronly, O_WRONLY)

/*
   ( fd -- status )
*/
prim P_close(pez_instance *p)
{
	Sl(1);
	S0 = close(S0);
}

/*
   ( fname -- stat )
*/
prim P_unlink(pez_instance *p)
{
	Sl(1);
	S0 = unlink((char *)S0);
}

/*
   ( fd offset whence -- new-offset )
   Seeks to a given position in a file.
*/
prim P_seek(pez_instance *p)
{
	Sl(3);
	S2 = lseek(S2, S1, S0);
	Pop2;
}
PUSH_CONSTANT(P_seek_cur, SEEK_CUR)
PUSH_CONSTANT(P_seek_end, SEEK_END)
PUSH_CONSTANT(P_seek_set, SEEK_SET)

/*
   ( fd -- offset )
   Returns the offset into the file; note that this won't work at all for
   certain types of file descriptors, like sockets, and will only work on some
   platforms for others.  No worries for regular files.
*/
prim P_tell(pez_instance *p)
{
	Sl(1);
	S0 = (pez_stackitem)lseek(S0, 0, SEEK_CUR);
}

/*
   ( fd -- evalstat )
   Reads a file descriptor, loads the code.
*/
prim P_load(pez_instance *p)
{
	FILE *f;

	Sl(1);
	f = fopen((char *)S0, "r");
	if(f) {
		S0 = pez_load(p, f);
	} else {
		perror("P_load");
		S0 = PEZ_BADFILE;
	}
}

PUSH_CONSTANT(P_pathmax, PATH_MAX)

/*
	TODO:  connect, send, recv, accept, socket, umask, dup, dup2, pipe,
	select
	probably others.
*/

#endif				// FILEIO

#ifdef EVALUATE

prim P_evaluate(pez_instance *p)
{				/* string -- status */
	int es = PEZ_SNORM;
	pez_statemark mk;
	pez_int scomm = p->comment;	// Stack comment pending state
	pez_dictword **sip = p->ip;	// Stack instruction pointer
	char *sinstr = p->instream;	// Stack input stream
	char *estring;

	Sl(1);
	Hpc(S0);
	estring = (char *)S0;	// Get string to evaluate
	Pop;			// Pop so it sees arguments below it
	pez_mark(p, &mk);	// Mark in case of error
	p->ip = NULL;		// Fool pez_eval into interp state
	if((es = pez_eval(p, estring)) != PEZ_SNORM) {
		pez_unwind(p, &mk);
	}
	/* If there were no other errors, check for a runaway comment.  If
	   we ended the file in comment-ignore mode, set the runaway comment
	   error status and unwind the file.  */
	if((es == PEZ_SNORM) && (p->comment != 0)) {
		es = PEZ_RUNCOMM;
		pez_unwind(p, &mk);
	}
	p->comment = scomm;	// Unstack comment pending status
	p->ip = sip;		// Unstack instruction pointer
	p->instream = sinstr;	// Unstack input stream
	So(1);
	Push = es;		// Return eval status on top of stack
}

PUSH_CONSTANT(P_permissions_io, PEZ_A_IO)
PUSH_CONSTANT(P_permissions_files, PEZ_A_FILES)
PUSH_CONSTANT(P_permissions_system, PEZ_A_SYSTEM)
PUSH_CONSTANT(P_permissions_sig, PEZ_A_SIG)
PUSH_CONSTANT(P_permissions_process, PEZ_A_PROCESS)
PUSH_CONSTANT(P_permissions_pointers, PEZ_A_POINTERS)
PUSH_CONSTANT(P_permissions_ffi, PEZ_A_FFI)
PUSH_CONSTANT(P_permissions_socket, PEZ_A_SOCKET)
PUSH_CONSTANT(P_permissions_everything, PEZ_A_EVERYTHING)

/*
   ( init-flags -- sub-pez )
   Instantiates a new Pez, with the restrictions specified in the init-flags.
   See pez_init() for details on the flags.  Note that (of course) an instance
   of Pez is restricted from creating instances with higher permissions than it
   has.

   (See comments for P_this_pez for security concerns.)
*/
prim P_new_pez(pez_instance *p)
{
	So(1);
	S0 = (pez_stackitem)pez_init((long)S0 & p->permissions);
}

/*
   ( string sub-pez -- evalstat )
   Feeds the input string to the specified sub-pez, and waits for execution to
   finish, returning the status of the sub-pez.

   (See comments for P_this_pez for security concerns.)
*/
prim P_send_eval(pez_instance *p)
{
	Sl(2);
	S1 = pez_eval((pez_instance *)S0, (char *)S1);
	Pop;
}

/*
   ( pez-instance -- stack-pointer depth )
   Returns the depth and a pointer to the top of the stack for the given
   pez-instance.
*/
prim P_stack_to(pez_instance *p)
{
	pez_instance *sub;

	Sl(1);
	So(1);

	sub = (pez_instance *)S0;
	S0 = (pez_stackitem)sub->stk;
	Push = sub->stk - sub->stack;
}

/*
   ( -- current-pez-instance )
   Returns a reference to the calling instance of Pez.
   TODO:  This totally messes up the security scheme for the time being, so we
   require PEZ_A_EVERYTHING.  I'm not sure of a way to give access to this
   struct without allowing the permissions flags to be rewritten, and it's a bit
   cumbersome (not to mention slow) to save/restore permissions flags of
   currrent instances on calls to '!'.  The same issue applies to new-pez and
   send-eval.
*/
prim P_this_pez(pez_instance *p)
{
	So(1);
	Push = (pez_stackitem)p;
}

#endif				// EVALUATE

/*  Stack mechanics  */

prim P_depth(pez_instance *p)
{				// Push stack depth
	pez_stackitem s = p->stk - p->stack;

	So(1);
	Push = s;
}

prim P_clear(pez_instance *p)
{				// Clear stack
	p->stk = p->stack;
}

prim P_dup(pez_instance *p)
{				// Duplicate top of stack
	pez_stackitem s;

	Sl(1);
	So(1);
	s = S0;
	Push = s;
}

prim P_drop(pez_instance *p)
{				// Drop top item on stack
	Sl(1);
	Pop;
}

prim P_swap(pez_instance *p)
{				// Exchange two top items on stack
	pez_stackitem t;

	Sl(2);
	t = S1;
	S1 = S0;
	S0 = t;
}

prim P_over(pez_instance *p)
{				// Push copy of next to top of stack
	pez_stackitem s;

	Sl(2);
	So(1);
	s = S1;
	Push = s;
}

prim P_pick(pez_instance *p)
{				// Copy indexed item from stack
	Sl(2);
	S0 = p->stk[-(2 + S0)];
}

/*
   ( a b -- b )
*/
prim P_nip(pez_instance *p)
{
	Sl(2);
	S1 = S0;
	Pop;
}

prim P_rot(pez_instance *p)
{				// Rotate 3 top stack items
	pez_stackitem t;

	Sl(3);
	t = S0;
	S0 = S2;
	S2 = S1;
	S1 = t;
}

prim P_minusrot(pez_instance *p)
{				// Reverse rotate 3 top stack items
	pez_stackitem t;

	Sl(3);
	t = S0;
	S0 = S1;
	S1 = S2;
	S2 = t;
}

prim P_roll(pez_instance *p)
{				// Rotate N top stack items
	pez_stackitem i, j, t;

	Sl(1);
	i = S0;
	Pop;
	Sl(i + 1);
	t = p->stk[-(i + 1)];
	for(j = -(i + 1); j < -1; j++)
		p->stk[j] = p->stk[j + 1];
	S0 = t;
}

prim P_tor(pez_instance *p)
{				// Transfer stack top to return stack
	Rso(1);
	Sl(1);
	Rpush = (rstackitem)S0;
	Pop;
}

prim P_rfrom(pez_instance *p)
{				// Transfer return stack top to stack
	Rsl(1);
	So(1);
	Push = (pez_stackitem)R0;
	Rpop;
}

prim P_rfetch(pez_instance *p)
{				// Fetch top item from return stack
	Rsl(1);
	So(1);
	Push = (pez_stackitem)R0;
}

/*
   ( -- time )
   Returns time as number of seconds since the epoch.
*/
prim P_time(pez_instance *p)
{
	So(1);
	Push = time(NULL);
}

#ifdef Macintosh
/* This file creates more than 32K of object code on the Mac, which causes
   MPW to barf.  So, we split it up into two code segments of <32K at this
   point. */
#pragma segment TOOLONG
#endif				// Macintosh

/*  Double stack manipulation items  */

prim P_2dup(pez_instance *p)
{				// Duplicate stack top doubleword
	pez_stackitem s;

	Sl(2);
	So(2);
	s = S1;
	Push = s;
	s = S1;
	Push = s;
}

prim P_2drop(pez_instance *p)
{				/* Drop top two items from stack */
	Sl(2);
	p->stk -= 2;
}

prim P_2swap(pez_instance *p)
{				/* Swap top two double items on stack */
	pez_stackitem t;

	Sl(4);
	t = S2;
	S2 = S0;
	S0 = t;
	t = S3;
	S3 = S1;
	S1 = t;
}

prim P_2over(pez_instance *p)
{				/* Extract second pair from stack */
	pez_stackitem s;

	Sl(4);
	So(2);
	s = S3;
	Push = s;
	s = S3;
	Push = s;
}

prim P_2nip(pez_instance *p)
{
	Sl(4);
	S2 = S0;
	S3 = S1;
	Pop2;
}

prim P_2rot(pez_instance *p)
{				/* Move third pair to top of stack */
	pez_stackitem t1, t2;

	Sl(6);
	t2 = S5;
	t1 = S4;
	S5 = S3;
	S4 = S2;
	S3 = S1;
	S2 = S0;
	S1 = t2;
	S0 = t1;
}

prim P_2variable(pez_instance *p)
{				/* Declare double variable */
	P_create(p);		// Create dictionary item
	Ho(2);
	Hstore = 0;		// Initial value = 0...
	Hstore = 0;		// ...in both words
}

prim P_2con(pez_instance *p)
{				/* Push double value in body */
	So(2);
	Push = *(((pez_stackitem *)p->curword) + Dictwordl);
	Push = *(((pez_stackitem *)p->curword) + Dictwordl + 1);
}

prim P_2constant(pez_instance *p)
{				/* Declare double word constant */
	Sl(1);
	P_create(p);		/* Create dictionary item */
	p->createword->wcode = P_2con;	// Set code to constant push
	Ho(2);
	Hstore = S1;		// Store double word constant value
	Hstore = S0;		// in the two words of body
	Pop2;
}

prim P_2bang(pez_instance *p)
{				// Store double value into address
	pez_stackitem *sp;

	Sl(2);
	Hpc(S0);
	sp = (pez_stackitem *)S0;
	*sp++ = S2;
	*sp = S1;
	Npop(3);
}

prim P_2at(pez_instance *p)
{				// Fetch double value from address
	pez_stackitem *sp;

	Sl(1);
	So(1);
	Hpc(S0);
	sp = (pez_stackitem *)S0;
	S0 = *sp++;
	Push = *sp;
}

prim P_fover(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_over(p);
		break;
	case 2:
		P_2over(p);
		break;
	}
}

prim P_fdrop(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_drop(p);
		break;
	case 2:
		P_2drop(p);
		break;
	}
}

prim P_fdup(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_dup(p);
		break;
	case 2:
		P_2dup(p);
		break;
	}
}

prim P_fswap(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_swap(p);
		break;
	case 2:
		P_2swap(p);
		break;
	}
}

prim P_frot(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_rot(p);
		break;
	case 2:
		P_2rot(p);
		break;
	}
}

prim P_fvariable(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_variable(p);
		break;
	case 2:
		P_2variable(p);
		break;
	}
}

prim P_fconstant(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_constant(p);
		break;
	case 2:
		P_2constant(p);
		break;
	}
}

prim P_fbang(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_bang(p);
		break;
	case 2:
		P_2bang(p);
		break;
	}
}

prim P_fat(pez_instance *p)
{
	switch (sizeof(double) / sizeof(long)) {
	case 1:
		P_at(p);
		break;
	case 2:
		P_2at(p);
		break;
	}
}

/*  Data transfer primitives  */

prim P_dolit(pez_instance *p)
{				/* Push instruction stream literal */
	So(1);
	tracing {
		printf("%ld ", (long)*p->ip);
		fflush(stdout);
	}
	Push = (pez_stackitem) *p->ip++;	/* Push the next datum from the
					   instruction stream. */
}

/*  Control flow primitives  */

/*
	Invoke compiled word
*/
prim P_nest(pez_instance *p)
{
	if(p->tail_call_pending) {
		p->tail_call_pending = False;
	} else {
		Rso(1);
#ifdef WALKBACK
		*p->wbptr++ = p->curword;	// Place word on walkback stack
#endif
		Rpush = p->ip;
	}
	p->ip = (((pez_dictword **)p->curword) + Dictwordl);
}

prim P_exit(pez_instance *p)
{				/* Return to top of return stack */
	Rsl(1);
#ifdef WALKBACK
	p->wbptr = (p->wbptr > p->wback) ? p->wbptr - 1 : p->wback;
#endif
	p->ip = R0;		// Set IP to top of return stack
	Rpop;
}

prim P_branch(pez_instance *p)
{				// Jump to in-line address
	p->ip += (pez_stackitem) *p->ip;	// Jump addresses are IP-relative
}

prim P_qbranch(pez_instance *p)
{				// Conditional branch to in-line addr
	Sl(1);
	if(S0 == 0)		// If flag is false
		p->ip += (pez_stackitem) *p->ip;	// then branch.
	else			// Otherwise
		p->ip++;		// skip the in-line address.
	Pop;
}

prim P_if(pez_instance *p)
{				/* Compile IF word */
	Compiling;
	Compconst(s_qbranch);	// Compile question branch
	So(1);
	Push = (pez_stackitem)p->hptr;	// Save backpatch address on stack
	Compconst(0);		// Compile place-holder address cell
}

prim P_else(pez_instance *p)
{				/* Compile ELSE word */
	pez_stackitem *bp;

	Compiling;
	Sl(1);
	Compconst(s_branch);	// Compile branch around other clause
	Compconst(0);		// Compile place-holder address cell
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get IF backpatch address
	*bp = p->hptr - bp;
	S0 = (pez_stackitem)(p->hptr - 1);	// Update backpatch for THEN
}

prim P_then(pez_instance *p)
{				/* Compile THEN word */
	pez_stackitem *bp;

	Compiling;
	Sl(1);
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get IF/ELSE backpatch address
	*bp = p->hptr - bp;
	Pop;
}

prim P_qdup(pez_instance *p)
{				/* Duplicate if nonzero */
	Sl(1);
	if(S0 != 0) {
		pez_stackitem s = S0;
		So(1);
		Push = s;
	}
}

prim P_begin(pez_instance *p)
{				/* Compile BEGIN */
	Compiling;
	So(1);
	Push = (pez_stackitem)p->hptr;	// Save jump back address on stack
}

prim P_until(pez_instance *p)
{				/* Compile UNTIL */
	pez_stackitem off;
	pez_stackitem *bp;

	Compiling;
	Sl(1);
	Compconst(s_qbranch);	// Compile question branch
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get BEGIN address
	off = -(p->hptr - bp);
	Compconst(off);		// Compile negative jumpback address
	Pop;
}

prim P_again(pez_instance *p)
{				/* Compile AGAIN */
	pez_stackitem off;
	pez_stackitem *bp;

	Compiling;
	Compconst(s_branch);	// Compile unconditional branch
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get BEGIN address
	off = -(p->hptr - bp);
	Compconst(off);		// Compile negative jumpback address
	Pop;
}

prim P_while(pez_instance *p)
{				/* Compile WHILE */
	Compiling;
	So(1);
	Compconst(s_qbranch);	// Compile question branch
	Compconst(0);		// Compile place-holder address cell
	Push = (pez_stackitem)(p->hptr - 1);	// Queue backpatch for REPEAT
}

prim P_repeat(pez_instance *p)
{				/* Compile REPEAT */
	pez_stackitem off, *bp1, *bp;

	Compiling;
	Sl(2);
	Hpc(S0);
	bp1 = (pez_stackitem *)S0;	// Get WHILE backpatch address
	Pop;
	Compconst(s_branch);	// Compile unconditional branch
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get BEGIN address
	off = -(p->hptr - bp);
	Compconst(off);		// Compile negative jumpback address
	*bp1 = p->hptr - bp1;	// Backpatch REPEAT's jump out of loop
	Pop;
}

prim P_do(pez_instance *p)
{				/* Compile DO */
	Compiling;
	Compconst(s_xdo);	// Compile runtime DO word
	So(1);
	Compconst(0);		// Reserve cell for LEAVE-taking
	Push = (pez_stackitem)p->hptr;	// Save jump back address on stack
}

prim P_xdo(pez_instance *p)
{				/* Execute DO */
	Sl(2);
	Rso(3);
	// Push exit address from loop:
	Rpush = p->ip + ((pez_stackitem) *p->ip);
	p->ip++;			// Increment past exit address word
	Rpush = (rstackitem)S1;	// Push loop limit on return stack
	Rpush = (rstackitem)S0;	/* Iteration variable initial value to
					   return stack */
	p->stk -= 2;
}

prim P_qdo(pez_instance *p)
{				/* Compile ?DO */
	Compiling;
	Compconst(s_xqdo);	// Compile runtime ?DO word
	So(1);
	Compconst(0);		// Reserve cell for LEAVE-taking
	Push = (pez_stackitem)p->hptr;	// Save jump back address on stack
}

prim P_xqdo(pez_instance *p)
{				/* Execute ?DO */
	Sl(2);
	if(S0 == S1) {
		p->ip += (pez_stackitem) *p->ip;
	} else {
		Rso(3);
		// Push exit address from loop:
		Rpush = p->ip + ((pez_stackitem) *p->ip);
		p->ip++;		// Increment past exit address word
		Rpush = (rstackitem)S1;	// Push loop limit on return stack
		// Iteration variable initial value to return stack:
		Rpush = (rstackitem)S0;
	}
	p->stk -= 2;
}

prim P_loop(pez_instance *p)
{				/* Compile LOOP */
	pez_stackitem off;
	pez_stackitem *bp;

	Compiling;
	Sl(1);
	Compconst(s_xloop);	// Compile runtime loop
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get DO address
	off = -(p->hptr - bp);
	Compconst(off);		// Compile negative jumpback address
	*(bp - 1) = (p->hptr - bp) + 1;	// Backpatch exit address offset
	Pop;
}

prim P_ploop(pez_instance *p)
{				/* Compile +LOOP */
	pez_stackitem off;
	pez_stackitem *bp;

	Compiling;
	Sl(1);
	Compconst(s_pxloop);	// Compile runtime +loop
	Hpc(S0);
	bp = (pez_stackitem *)S0;	// Get DO address
	off = -(p->hptr - bp);
	Compconst(off);		// Compile negative jumpback address
	*(bp - 1) = (p->hptr - bp) + 1;	// Backpatch exit address offset
	Pop;
}

prim P_xloop(pez_instance *p)
{				/* Execute LOOP */
	Rsl(3);
	R0 = (rstackitem)(((pez_stackitem) R0) + 1);
	if(((pez_stackitem)R0) == ((pez_stackitem)R1)) {
		p->rstk -= 3;	// Pop iteration variable and limit
		p->ip++;		// Skip the jump address
	} else {
		p->ip += (pez_stackitem) * p->ip;
	}
}

prim P_xploop(pez_instance *p)
{				/* Execute +LOOP */
	pez_stackitem niter;

	Sl(1);
	Rsl(3);

	niter = ((pez_stackitem)R0) + S0;
	if(niter == (pez_stackitem)R1
	   || abs(S0) > abs((pez_stackitem)R0 - (pez_stackitem)R1)) {
		p->rstk -= 3;	// Pop iteration variable and limit
		p->ip++;		// Skip the jump address
	} else {
		p->ip += (pez_stackitem) * p->ip;
		R0 = (rstackitem)niter;
	}
	Pop;
}

prim P_leave(pez_instance *p)
{				// Compile LEAVE
	Rsl(3);
	p->ip = R2;
	p->rstk -= 3;
}

prim P_i(pez_instance *p)
{				// Obtain innermost loop index
	Rsl(3);
	So(1);
	Push = (pez_stackitem)R0;	// It's the top item on return stack
}

prim P_j(pez_instance *p)
{				/* Obtain next-innermost loop index */
	Rsl(6);
	So(1);
	// It's the 4th item on return stack:
	Push = (pez_stackitem)p->rstk[-4];
}

/*
   Terminate execution
*/
prim P_quit(pez_instance *p)
{
	p->rstk = p->rstack;		// Clear return stack
#ifdef WALKBACK
	p->wbptr = p->wback;
#endif
	p->ip = NULL;		// Stop execution of current word
}

/*
   Abort, clearing data stack.
*/
prim P_abort(pez_instance *p)
{
	P_clear(p);		// Clear the data stack
	P_quit(p);		// Shut down execution
}

prim P_abortq(pez_instance *p)
{				/* Abort, printing message */
	if(state) {
		p->stringlit = True;	// Set string literal expected
		Compconst(s_abortq);	// Compile ourselves
	} else {
		// Otherwise, print string literal in in-line code:
		printf("%s", (char *)p->ip);
#ifdef WALKBACK
		pwalkback(p);
#endif				// WALKBACK
		P_abort(p);	// Abort
		// Reset all interpretation state:
		p->comment = state = Falsity;
		p->forgetpend = p->defpend = p->stringlit =
			p->tickpend = p->ctickpend =
			False;
	}
}

/*  Compilation primitives  */

prim P_immediate(pez_instance *p)
{				// Mark most recent word immediate
	p->dict->wname[0] |= IMMEDIATE;
}

prim P_lbrack(pez_instance *p)
{				// Set interpret state
	Compiling;
	state = Falsity;
}

prim P_rbrack(pez_instance *p)
{				// Restore compile state
	state = Truth;
}

/*
	Execute indirect call on method
*/
Exported void P_dodoes(pez_instance *p)
{
	Rso(1);
	So(1);
	Rpush = p->ip;		// Push instruction pointer
#ifdef WALKBACK
	*p->wbptr++ = p->curword;	// Place word on walkback stack
#endif
	/* The compiler having craftily squirreled away the DOES> clause
	   address before the word definition on the heap, we back up to
	   the heap cell before the current word and load the pointer from
	   there.  This is an ABSOLUTE heap address, not a relative offset. */
	p->ip = *((pez_dictword ***)(((pez_stackitem *)p->curword) - 1));

	/* Push the address of this word's body as the argument to the
	   DOES> clause. */
	Push = (pez_stackitem)(((pez_stackitem *)p->curword) + Dictwordl);
}

/*
	Specify method for word
*/
prim P_does(pez_instance *p)
{

	/* O.K., we were compiling our way through this definition and we've
	   encountered the Dreaded and Dastardly Does.  Here's what we do
	   about it.  The problem is that when we execute the word, we
	   want to push its address on the stack and call the code for the
	   DOES> clause by diverting the IP to that address.  But...how
	   are we to know where the DOES> clause goes without adding a
	   field to every word in the system just to remember it.  Recall
	   that since this system is portable we can't cop-out through
	   machine code.  Further, we can't compile something into the
	   word because the defining code may have already allocated heap
	   for the word's body.  Yukkkk.  Oh well, how about this?  Let's
	   copy any and all heap allocated for the word down one stackitem
	   and then jam the DOES> code address BEFORE the link field in
	   the word we're defining.

	   Then, when (DOES>) (P_dodoes) is called to execute the word, it
	   will fetch that code address by backing up past the start of
	   the word and seting IP to it.  Note that FORGET must recognise
	   such words (by the presence of the pointer to P_dodoes() in
	   their wcode field, in case you're wondering), and make sure to
	   deallocate the heap word containing the link when a
	   DOES>-defined word is deleted.  */

	if(p->createword != NULL) {
		pez_stackitem *sp = ((pez_stackitem *)p->createword), *hp;

		Rsl(1);
		Ho(1);

		/* Copy the word definition one word down in the heap to
		   permit us to prefix it with the DOES clause address. */

		for(hp = p->hptr - 1; hp >= sp; hp--)
			*(hp + 1) = *hp;
		p->hptr++;		// Expand allocated length of word
		// Store DOES> clause address before word's definition
		// structure:
		*sp++ = (pez_stackitem)p->ip;
		// Move word definition down 1 item:
		p->createword = (pez_dictword *)sp;
		// Set code field to indirect jump:
		p->createword->wcode = P_dodoes;

		/* Now simulate an EXIT to bail out of the definition without
		   executing the DOES> clause at definition time. */

		p->ip = R0;	// Set IP to top of return stack
#ifdef WALKBACK
		p->wbptr = (p->wbptr > p->wback) ? p->wbptr - 1 : p->wback;
#endif
		Rpop;		// Pop the return stack
	}
}

/*
	Begin compiling a word
*/
prim P_colon(pez_instance *p)
{
	state = Truth;	// Set compilation underway
	P_create(p);		// Create conventional word
}

prim P_semicolon(pez_instance *p)
{				/* End compilation */
	Compiling;
	Ho(1);
	Hstore = s_exit;
	state = Falsity;	// No longer compiling
	/* We wait until now to plug the P_nest code so that it will be
	   present only in completed definitions. */
	if(p->createword != NULL)
		p->createword->wcode = P_nest;	// Use P_nest for code
	p->createword = NULL;	// Flag no word being created
}

prim P_tick(pez_instance *p)
{				/* Take address of next word */
	int token;
	char token_buffer[TOK_BUF_SZ];

	/* Try to get next symbol from the input stream.  If
	   we can't, and we're executing a compiled word,
	   report an error.  Since we can't call back to the
	   calling program for more input, we're stuck. */

	token = lex(p, &p->instream, token_buffer);	// Scan for next token
	if(token != TokNull) {
		if(token == TokWord) {
			pez_dictword *di;

			if((di = lookup(p, token_buffer)) != NULL) {
				So(1);
				// Word compile address:
				Push = (pez_stackitem)di;
			} else {
				fprintf(stderr, " '%s' undefined\n",
					token_buffer);
				p->instream = NULL;
				P_abort(p);
			}
		} else {
			fprintf(stderr,
				"\nWord not specified when expected.\n");
			P_abort(p);
		}
	} else {
		/* O.K., there was nothing in the input stream.  Set the
		   tickpend flag to cause the compilation address of the next
		   token to be pushed when it's supplied on a subsequent input
		   line. */
		if(p->ip == NULL) {
			p->tickpend = True;
		} else {
			fprintf(stderr, "\nWord requested by ` not "
					"on same input line.\n");
			P_abort(p);
		}
	}
}

prim P_bracktick(pez_instance *p)
{				/* Compile in-line code address */
	Compiling;
	p->ctickpend = True;	/* Force literal treatment of next
				   word in compile stream */
}

prim P_execute(pez_instance *p)
{				/* Execute word pointed to by stack */
	pez_dictword *wp;

	Sl(1);
	wp = (pez_dictword *)S0;	// Load word address from stack
	Pop;			// Pop data stack before execution
	exword(p, wp);		/* Recursively call exword() to run
				   the word. */
}

prim P_tail_call(pez_instance *p)
{
	p->tail_call_pending = True;
}

prim P_body(pez_instance *p)
{				/* Get body address for word */
	Sl(1);
	S0 += Dictwordl * sizeof(pez_stackitem);
}

prim P_state(pez_instance *p)
{				/* Get state of system */
	So(1);
	Push = (pez_stackitem) & state;
}

/*  Definition field access primitives	*/

#ifdef DEFFIELDS

prim P_find(pez_instance *p)
{				/* Look up word in dictionary */
	pez_dictword *dw;
	char buf[128];

	Sl(1);
	So(1);
	Hpc(S0);
	strcpy(buf, (char *)S0);	// Use built-in token buffer...
	dw = lookup(p, buf);
	// the token on the stack
	if(dw != NULL) {
		S0 = (pez_stackitem)dw;
		// Push immediate flag
		Push = (dw->wname[0] & IMMEDIATE) ? 1 : -1;
	} else {
		Push = 0;
	}
}

#define DfOff(fld)  (((char *)&(p->dict->fld)) - ((char *)p->dict))

prim P_toname(pez_instance *p)
{				/* Find name field from compile addr */
	Sl(1);
	S0 += DfOff(wname);
}

/*
   Find link field from compile addr
 */
prim P_tolink(pez_instance *p)
{
	if(DfOff(wnext) != 0)
		fprintf(stderr, "\n>LINK Foulup--wnext is not at zero!\n");
	// Null operation.  Wnext is first.
	// Sl(1);
	// SO += DfOff(wnext)
}

prim P_frombody(pez_instance *p)
{				/* Get compile address from body */
	Sl(1);
	S0 -= Dictwordl * sizeof(pez_stackitem);
}

prim P_fromname(pez_instance *p)
{				/* Get compile address from name */
	Sl(1);
	S0 -= DfOff(wname);
}

/*
   ( link -- compilation-addr )
   Get the compile address.
*/
prim P_fromlink(pez_instance *p)
{
	if(DfOff(wnext) != 0)
		fprintf(stderr, "\nLINK> Foulup--wnext is not at zero!\n");
	// Essentially a no-op; link is the first item.
	// Sl(1);
	// S0 -= DfOff(wnext);// Null operation.  Wnext is first
}

#undef DfOff

#define DfTran(from,to) (((char *)&(dict->to)) - ((char *)&(dict->from)))

prim P_nametolink(pez_instance *p)
{				/* Get from name field to link */
	char *from, *to;

	Sl(1);
	/*
	   S0 -= DfTran(wnext, wname);
	 */
	from = (char *)&(p->dict->wnext);
	to = (char *)&(p->dict->wname);
	S0 -= (to - from);
}

prim P_linktoname(pez_instance *p)
{				/* Get from link field to name */
	char *from, *to;

	Sl(1);
	/*
	   S0 += DfTran(wnext, wname);
	 */
	from = (char *)&(p->dict->wnext);
	to = (char *)&(p->dict->wname);
	S0 += (to - from);
}

/*
   ( nfa string -- )
   Copy word name to string buffer
*/
prim P_fetchname(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	/* Since the name buffers aren't in the system heap, but
	   rather are separately allocated with alloc(), we can't
	   check the name pointer references.  But, hey, if the user's
	   futzing with word dictionary items on the heap in the first
	   place, there's a billion other ways to bring us down at
	   his command. */
	strcpy((char *)S0, *((char **)S1) + 1);
	Pop2;
}

prim P_storename(pez_instance *p)
{				/* Store string buffer in word name */
	char tflags;
	char *cp;

	Sl(2);			// string nfa --
	Hpc(S0);		// See comments in P_fetchname above
	Hpc(S1);		// checking name pointers
	tflags = **((char **)S0);
	*((char **)S0) = cp = alloc((unsigned int)(strlen((char *)S1) + 2));
	strcpy(cp + 1, (char *)S1);
	*cp = tflags;
	Pop2;
}

#endif				// DEFFIELDS

#ifdef SYSTEM
prim P_system(pez_instance *p)
{				/* string -- status */
	Sl(1);
	Hpc(S0);
	S0 = system((char *)S0);
}
#endif				/* SYSTEM */

#ifdef FFI
#include <dlfcn.h>

/*
   ( libname -- status )
   Loads a .so file that must contain at least one of the following in order
   to be useful:
	1.  A function declared as prim pez_ffi_init() that performs the
	    necessary initializations
	2.  An array named pez_ffi_definitions with type struct primfcn that
	    contains the definitions of new words to be added when the library
	    is loaded.
   If the status is false, there has been an error, which can be checked with
   dlerror.
*/
prim P_ffi_load(pez_instance *p)
{
	void *lib;
	void (*init)();
	struct primfcn *defs;

	Sl(1);
	lib = dlopen((char *)S0, RTLD_NOW);
	if(!lib) {
		S0 = Falsity;
		return;
	}

	init = dlsym(lib, "pez_ffi_init");
	defs = dlsym(lib, "pez_ffi_definitions");
	if(!(init || defs)) {
		S0 = Falsity;
		return;
	}
	S0 = Truth;
	dlerror();		// Which clears the last error.
	if(init)
		init();
	if(defs)
		pez_primdef(p, defs);
}

/*
   ( libname flags -- libhandle )
   Just a thin wrapper around the system's dlopen.
*/
prim P_dlopen(pez_instance *p)
{
	void *lib;
	Sl(2);
	lib = dlopen((char *)S1, S0);
	S1 = (long)lib;
	Pop;
}

/*
   ( -- RTLD_LAZY )
   Pushes the RTLD_LAZY flag onto the stack.
*/
prim P_rtld_lazy(pez_instance *p)
{
	So(1);
	Push = RTLD_LAZY;
}

/*
   ( libhandle symname -- function_address )
   Resolves a symbol.
*/
prim P_dlsym(pez_instance *p)
{
	void *f;
	Sl(2);
	f = dlsym((void *)S1, (char *)S0);
	Pop;
	S0 = (long)f;
}

/*
   ( -- error_string )
   Returns the last error returned by dlopen/dlsym/dlclose.
*/
prim P_dlerror(pez_instance *p)
{
	So(1);
	Push = (long)dlerror();
}

/*
   Define an FFI call.
*/
prim P_ffi_colon(pez_instance *p)
{
	jit_insn *codebuf;
	int i, arglen;
	char *args, *ret, *fname;
	void *lib, *f;

	Sl(4);
	codebuf = GC_malloc(4096); // TODO:  Put a real number in there.

	args = (char *)S3;
	ret = (char *)S2;
	fname = (char *)S1;
	lib = (char *)S0;
	f = dlsym(lib, fname);
	Npop(4);

	if(!f) {
		// TODO:  Error handling.
		fprintf(stderr, "Oops.\n");
	}

	P_create(p);
	p->createword->wcode =
		(void (*)(pez_instance *p))(jit_set_ip(codebuf).vptr);

	// The generated code:
	jit_prolog(1); // We take one arg, although we ignore it.

	// Write the call:
	if(args) {
		arglen = strlen(args);
		jit_prepare(arglen);
		for(i = 0; i < arglen; i++) {
			switch(args[i]) {
				// TODO:  I think these should probably work
				// differently...maybe?
				case 'p':
				case 'l':
				case 'i':
				case 's':
				case 'c':
					jit_ld_S0(JIT_R0);
					jit_pusharg_l(JIT_R0);
					jit_Pop(JIT_R0);
					break;
				case 'f':
					// TODO
					break;
				case 'd':
					// TODO
					break;
				default:
					// TODO:  Error handling?  Bueller?
					fprintf(stderr, "iono?\n");
			}
		}
	}
	jit_finish(f);

	if(ret && ret[0]) {
		switch(ret[0]) {
			// TODO:  I think these should probably work
			// differently...maybe?
			case 'p':
			case 'l':
			case 'i':
			case 's':
			case 'c':
				jit_retval(JIT_R0);
				jit_Pushr(JIT_R0, JIT_R1);
				break;
			case 'f':
				// TODO
				break;
			case 'd':
				// TODO
				break;
			default:
				// TODO:  Error handling?  Bueller?
				fprintf(stderr, "what *will* it return?\n");

		}
	}
	jit_ret();

	jit_flush_code(codebuf, jit_get_ip().ptr);
}

/*
   Calls a void (*)() from the top of the stack.
*/
prim P_call_void_0(pez_instance *p)
{
	void (*f)() = (void (*)()) S0;
	So(1);
	Pop;
	f();
}

/*
   Calls a void (*)(word) from the top of the stack.
*/
prim P_call_void_1w(pez_instance *p)
{
	void (*f)(pez_stackitem) = (void (*)(pez_stackitem))S0;
	So(2);
	f(S1);
	Pop2;
}

/*
   Calls a word (*)() from the top of the stack.
*/
prim P_call_word_0(pez_instance *p)
{
	pez_stackitem(*f)() = (pez_stackitem(*)())S0;
	So(1);
	S0 = f();
}

/*
   Calls a word (*)(word) from the top of the stack.
*/
prim P_call_word_1w(pez_instance *p)
{
	pez_stackitem(*f)(pez_stackitem) = (pez_stackitem(*)(pez_stackitem))S0;
	So(2);
	Pop;
	S0 = f(S0);
}

#endif				// FFI

#ifdef PROCESS
#include <sys/wait.h>
#include <signal.h>

extern char **environ;
/*
   ( -- environment )
   Pushes the environ pointer onto the stack.  You probably actually want to
   interact with getenv/setenv unless you're iterating over all of the
   environment variables.
*/
prim P_environ(pez_instance *p)
{
	So(1);
	Push = (pez_stackitem)environ;
}

/*
   ( varname -- envvar|0 )
   Returns the value for the named variable, or NULL if it isn't set.
*/
prim P_getenv(pez_instance *p)
{
	Sl(1);
	S0 = (pez_stackitem)getenv((char *)S0);
}

/*
   ( varname value -- success=Truth|error=falsity )
   Sets an environment variable.
*/
prim P_setenv(pez_instance *p)
{
	Sl(2);
	S1 = -setenv((char *)S1, (char *)S0, 1) - 1;
	Pop;
}

/*
   ( varname -- success=Truth|error=Falsity )
   Removes a variable from the environment.
*/
prim P_unsetenv(pez_instance *p)
{
	Sl(1);
	S0 = -unsetenv((char *)S0) - 1;
}

/*
   ( message status -- )
   Prints a message to stderr with a \n, and dies with the specified status.
*/
prim P_diebang(pez_instance *p)
{
	fflush(stdout);
	// No underflow-checking here.  die! shouldn't fail, ever, even if it
	// ends up segfaulting instead.
	fprintf(stderr, "%s\n", (char *)S1);
	exit(S0);
}

/*
   ( -- pid|0 )
   Forks a new process.  The child process will see a zero on the stack, and the
   parent will see the child's pid.
*/
prim P_fork(pez_instance *p)
{
	So(1);
	Push = fork();
}

/*
   ( path argv -- )
   exec()s another binary.  Does not return unless there's an error.  Path
   should be the path to the other executable, and argv should be an array of
   strings, with a NULL after the last string.
*/
prim P_execv(pez_instance *p)
{
	Sl(2);
	execv((char *)S1, (char **)S0);
}

/*
   ( -- status pid )
   Waits for the next child process to exit, returning a pid and the process's
   status.
*/
prim P_wait(pez_instance *p)
{
	So(2);
	Push = 0;
	Push = wait((int *)(p->stk - 1));
}

/*
   ( -- pid )
   Returns the pid of the current process.
*/
prim P_pid(pez_instance *p)
{
	So(1);
	Push = getpid();
}

/*
   ( pid signal -- status )
   Sends a signal to a pid, returning the status.
*/
prim P_kill(pez_instance *p)
{
	Sl(2);
	S1 = kill(S1, S0);
	Pop;
}


#endif				// PROCESS

#ifdef TRACE
prim P_trace(pez_instance *p)
{				/* Set or clear tracing of execution */
	Sl(1);
	p->trace = (S0 == 0) ? Falsity : Truth;
	Pop;
}
#endif				// TRACE

#ifdef WALKBACK
prim P_walkback(pez_instance *p)
{				/* Set or clear error walkback */
	Sl(1);
	p->walkback = (S0 == 0) ? Falsity : Truth;
	Pop;
}
#endif				// WALKBACK

#ifdef WORDSUSED

prim P_wordsused(pez_instance *p)
{				/* List words used by program */
	pez_dictword *dw = p->dict;

	while(dw != NULL) {
		if(*(dw->wname) & WORDUSED) {
			printf("\n%s", dw->wname + 1);
		}
#ifdef Keyhit
		if(kbquit()) {
			break;
		}
#endif
		dw = dw->wnext;
	}
	printf("\n");
	fflush(stdout);
}

prim P_wordsunused(pez_instance *p)
{				/* List words not used by program */
	pez_dictword *dw = p->dict;

	while(dw != NULL) {
		if(!(*(dw->wname) & WORDUSED)) {
			printf("\n%s", dw->wname + 1);
		}
#ifdef Keyhit
		if(kbquit()) {
			break;
		}
#endif
		dw = dw->wnext;
	}
	printf("\n");
	fflush(stdout);
}
#endif				/* WORDSUSED */

#ifdef COMPILERW

prim P_brackcompile(pez_instance *p)
{				/* Force compilation of immediate word */
	Compiling;
	p->cbrackpend = True;	// Set [COMPILE] pending
}

prim P_literal(pez_instance *p)
{				/* Compile top of stack as literal */
	Compiling;
	Sl(1);
	Ho(2);
	Hstore = s_lit;		// Compile load literal word
	Hstore = S0;		// Compile top of stack in line
	Pop;
}

/*
	Compile address of next inline word
*/
prim P_compile(pez_instance *p)
{
	Compiling;
	Ho(1);
	// Compile next datum from instruction stream:
	Hstore = (pez_stackitem) * p->ip++;
}

/*
	Mark backward backpatch address
*/
prim P_backmark(pez_instance *p)
{
	Compiling;
	So(1);
	Push = (pez_stackitem)p->hptr;	// Push heap address onto stack
}

/*
	Emit backward jump offset
*/
prim P_backresolve(pez_instance *p)
{
	pez_stackitem offset;

	Compiling;
	Sl(1);
	Ho(1);
	Hpc(S0);
	offset = -(p->hptr - (pez_stackitem *)S0);
	Hstore = offset;
	Pop;
}

prim P_fwdmark(pez_instance *p)
{				/* Mark forward backpatch address */
	Compiling;
	Ho(1);
	Push = (pez_stackitem)p->hptr;	// Push heap address onto stack
	Hstore = 0;
}

/*
   Emit forward jump offset
*/
prim P_fwdresolve(pez_instance *p)
{
	pez_stackitem offset;

	Compiling;
	Sl(1);
	Hpc(S0);
	offset = (p->hptr - (pez_stackitem *)S0);
	*((pez_stackitem *)S0) = offset;
	Pop;
}

#endif				// COMPILERW

/*  Table of primitive words  */
// TODO:  Add a member to primfcn giving permissions required, and don't add
// words to the dictionary when Pez doesn't have permissions.
static struct primfcn primt[] = {
	{"0+", P_plus},
	{"0-", P_minus},
	{"0*", P_times},
	{"0/", P_div},
	{"0MOD", P_mod},
	{"0/MOD", P_divmod},
	{"0MIN", P_min},
	{"0MAX", P_max},
	{"0NEGATE", P_neg},
	{"0ABS", P_abs},
	{"0=", P_equal},
	{"0<>", P_unequal},
	{"0>", P_gtr},
	{"0<", P_lss},
	{"0>=", P_geq},
	{"0<=", P_leq},

	{"0AND", P_and},
	{"0OR", P_or},
	{"0XOR", P_xor},
	{"0NOT", P_not},
	{"0SHIFT", P_shift},

	{"0DEPTH", P_depth},
	{"0CLEAR", P_clear},
	{"0DUP", P_dup},
	{"0DROP", P_drop},
	{"0SWAP", P_swap},
	{"0OVER", P_over},
	{"0PICK", P_pick},
	{"0NIP", P_nip},
	{"0ROT", P_rot},
	{"0-ROT", P_minusrot},
	{"0ROLL", P_roll},
	{"0>R", P_tor},
	{"0R>", P_rfrom},
	{"0R@", P_rfetch},
	{"0TIME", P_time},

	{"01+", P_1plus},
	{"02+", P_2plus},
	{"01-", P_1minus},
	{"02-", P_2minus},
	{"02*", P_2times},
	{"02/", P_2div},

	{"00=", P_0equal},
	{"00<>", P_0notequal},
	{"00>", P_0gtr},
	{"00<", P_0lss},

	{"02DUP", P_2dup},
	{"02DROP", P_2drop},
	{"02SWAP", P_2swap},
	{"02OVER", P_2over},
	{"02NIP", P_2nip},
	{"02ROT", P_2rot},
	{"02VARIABLE", P_2variable},
	{"02CONSTANT", P_2constant},
	{"02!", P_2bang},
	{"02@", P_2at},

	{"0FDUP", P_fdup},
	{"0FDROP", P_fdrop},
	{"0FSWAP", P_fswap},
	{"0FOVER", P_fover},
	{"0FROT", P_frot},
	{"0FVARIABLE", P_fvariable},
	{"0FCONSTANT", P_fconstant},
	{"0F!", P_fbang},
	{"0F@", P_fat},

	{"0VARIABLE", P_variable},
	{"0CONSTANT", P_constant},
	{"0!", P_bang},
	{"0@", P_at},
	{"0+!", P_plusbang},
	{"01+!", P_1plusbang},
	{"0ALLOT", P_allot},
	{"0,", P_comma},
	{"0C!", P_cbang},
	{"0C@", P_cat},
	{"0C,", P_ccomma},
	{"0C=", P_cequal},
	{"0MALLOC", P_malloc},
	{"0HERE", P_here},

	{"0CELL-SIZE", P_cell_size},
	{"0CELLS", P_cells},
	{"0FLOAT-SIZE", P_float_size},
	{"0FLOATS", P_floats},
	{"0c-pointer-size", P_c_pointer_size},
	{"0c-pointers", P_c_pointers},
	{"0c-short-size", P_c_short_size},
	{"0c-shorts", P_c_shorts},
	{"0c-long-size", P_c_long_size},
	{"0c-longs", P_c_longs},
	{"0c-int-size", P_c_int_size},
	{"0c-ints", P_c_ints},
	{"0c-float-size", P_c_float_size},
	{"0c-floats", P_c_floats},
	{"0c-double-size", P_c_double_size},
	{"0c-doubles", P_c_doubles},

	{"0PEZ-BINDIR", P_pezconf_bindir},
	{"0PEZ-LIBDIR", P_pezconf_libdir},
	{"0PEZ-CC", P_pezconf_cc},
	{"0PEZ-LD", P_pezconf_ld},
	{"0PEZ-CFLAGS", P_pezconf_cflags},
	{"0PEZ-LDFLAGS", P_pezconf_ldflags},
	{"0PEZ-LD-LIB-CMD", P_pezconf_ld_lib_cmd},
	{"0PEZ-BUILD-LIB-CMD", P_pezconf_build_lib_cmd},

#ifdef ARRAY
	{"0ARRAY", P_array},
#endif

	{"0(STRLIT)", P_strlit},
	{"0STRING", P_string},
	{"0STRCPY", P_strcpy},
	{"0S!", P_strcpy},
	{"0STRCAT", P_strcat},
	{"0S+", P_strcat},
	{"0STRLEN", P_strlen},
	{"0STRCMP", P_strcmp},
	{"0STRNCMP", P_strncmp},
	{"0STRCHAR", P_strchar},
	{"0SUBSTR", P_substr},
	{"0STRFORM", P_strform},
	{"0FSTRFORM", P_fstrform},
	{"0STRINT", P_strint},
	{"0STRREAL", P_strreal},
	{"0REGEX", P_regex},
	{"0RMATCH", P_rmatch},
	{"0$0", P_money0},
	{"0$1", P_money1},
	{"0$2", P_money2},
	{"0$3", P_money3},
	{"0$4", P_money4},
	{"0$5", P_money5},
	{"0$6", P_money6},
	{"0$7", P_money7},
	{"0$8", P_money8},
	{"0$9", P_money9},
	{"0$10", P_money10},
	{"0$11", P_money11},
	{"0$12", P_money12},
	{"0$13", P_money13},
	{"0$14", P_money14},
	{"0$15", P_money15},
	{"0$16", P_money16},
	{"0$17", P_money17},
	{"0$18", P_money18},
	{"0$19", P_money19},

	{"0(FLIT)", P_flit},
	{"0F+", P_fplus},
	{"0F-", P_fminus},
	{"0F*", P_ftimes},
	{"0F/", P_fdiv},
	{"0FMIN", P_fmin},
	{"0FMAX", P_fmax},
	{"0FNEGATE", P_fneg},
	{"0FABS", P_fabs},
	{"0F=", P_fequal},
	{"0F<>", P_funequal},
	{"0F>", P_fgtr},
	{"0F<", P_flss},
	{"0F>=", P_fgeq},
	{"0F<=", P_fleq},
	{"0F.", P_fdot},
	{"0FLOAT", P_float},
	{"0FIX", P_fix},
	{"0FTIME", P_ftime},

#ifdef MATH
	{"0ACOS", P_acos},
	{"0ASIN", P_asin},
	{"0ATAN", P_atan},
	{"0ATAN2", P_atan2},
	{"0COS", P_cos},
	{"0EXP", P_exp},
	{"0LOG", P_log},
	{"0^", P_ipow},
	{"0F^", P_pow},
	{"0SIN", P_sin},
	{"0SQRT", P_sqrt},
	{"0TAN", P_tan},
#endif				/* MATH */

	{"0(NEST)", P_nest},
	{"0EXIT", P_exit},
	{"0(LIT)", P_dolit},
	{"0BRANCH", P_branch},
	{"0?BRANCH", P_qbranch},
	{"1IF", P_if},
	{"1ELSE", P_else},
	{"1THEN", P_then},
	{"0?DUP", P_qdup},
	{"1BEGIN", P_begin},
	{"1UNTIL", P_until},
	{"1AGAIN", P_again},
	{"1WHILE", P_while},
	{"1REPEAT", P_repeat},
	{"1DO", P_do},
	{"1?DO", P_qdo},
	{"1LOOP", P_loop},
	{"1+LOOP", P_ploop},
	{"0(XDO)", P_xdo},
	{"0(X?DO)", P_xqdo},
	{"0(XLOOP)", P_xloop},
	{"0(+XLOOP)", P_xploop},
	{"0LEAVE", P_leave},
	{"0I", P_i},
	{"0J", P_j},
	{"0QUIT", P_quit},
	{"0ABORT", P_abort},
	{"1ABORT\"", P_abortq},

#ifdef SYSTEM
	{"0SYSTEM", P_system},
#endif
#ifdef FFI
	{"0FFI-LOAD", P_ffi_load},
	{"0DLOPEN", P_dlopen},
	{"0DLSYM", P_dlsym},
	{"0DLERROR", P_dlerror},
	{"0ffi:", P_ffi_colon},

	// dl* flags:
	{"0RTLD_LAZY", P_rtld_lazy},

	// Generic calls:
	{"0CALL-VOID-0", P_call_void_0},
	{"0CALL-VOID-1W", P_call_void_1w},
	{"0CALL-WORD-0", P_call_word_0},
	{"0CALL-WORD-1W", P_call_word_1w},
#endif

#ifdef PROCESS
	{"0ENVIRON", P_environ},
	{"0GETENV", P_getenv},
	{"0SETENV", P_setenv},
	{"0UNSETENV", P_unsetenv},
	{"0DIE!", P_diebang},
	// at-exit is going to have to wait until I figure out a good way to do
	// it.  I am thinking a queue of words to push to
	// {"0AT-EXIT", P_at_exit},
	{"0FORK", P_fork},
	{"0EXECV", P_execv},
	{"0WAIT", P_wait},
	{"0PID", P_pid},
	{"0KILL", P_kill},
#endif

#ifdef TRACE
	{"0TRACE", P_trace},
#endif
#ifdef WALKBACK
	{"0WALKBACK", P_walkback},
#endif

#ifdef WORDSUSED
	{"0WORDSUSED", P_wordsused},
	{"0WORDSUNUSED", P_wordsunused},
#endif

#ifdef MEMSTAT
	{"0MEMSTAT", pez_memstat},
#endif

	{"0:", P_colon},
	{"1;", P_semicolon},
	{"0IMMEDIATE", P_immediate},
	{"1[", P_lbrack},
	{"0]", P_rbrack},
	{"0CREATE", P_create},
	{"0FORGET", P_forget},
	{"0DOES>", P_does},
	{"0'", P_tick},
	{"1[']", P_bracktick},
	{"0EXECUTE", P_execute},
	{"0TAIL-CALL", P_tail_call},
	{"0>BODY", P_body},
	{"0STATE", P_state},

#ifdef DEFFIELDS
	{"0FIND", P_find},
	{"0>NAME", P_toname},
	{"0>LINK", P_tolink},
	{"0BODY>", P_frombody},
	{"0NAME>", P_fromname},
	{"0LINK>", P_fromlink},
	{"0N>LINK", P_nametolink},
	{"0L>NAME", P_linktoname},
	{"0NAME>S!", P_fetchname},
	{"0S>NAME!", P_storename},
#endif				// DEFFIELDS

#ifdef COMPILERW
	{"1[COMPILE]", P_brackcompile},
	{"1LITERAL", P_literal},
	{"0COMPILE", P_compile},
	{"0<MARK", P_backmark},
	{"0<RESOLVE", P_backresolve},
	{"0>MARK", P_fwdmark},
	{"0>RESOLVE", P_fwdresolve},
#endif				// COMPILERW

	{"0HTON", P_hton},
	{"0NTOH", P_ntoh},
	
#ifdef CONIO
	{"0HEX", P_hex},
	{"0DECIMAL", P_decimal},
	{"0ARGC", P_argc},
	{"0ARGV", P_argv},
	{"0.", P_dot},
	{"0?", P_question},
	{"0CR", P_cr},
	{"0.S", P_dots},
	{"0n.s", P_ndots},
	{"1.\"", P_dotquote},
	{"1.(", P_dotparen},
	{"0PRINT", P_print},
	{"0PUTS", P_puts},
	{"0GETS", P_gets},
	{"0READ", P_read},
	{"0WRITE", P_write},
	{"0GETC", P_getc},
	{"0PUTC", P_putc},
	{"0WORDS", P_words},
#endif				// CONIO

#ifdef FILEIO
	{"0>OUTPUT", P_tooutput},
	{"0>INPUT", P_toinput},
	{"0OUTPUT>", P_outputto},
	{"0INPUT>", P_inputto},
	{"0OPEN", P_open},
	{"0O_APPEND", P_o_append},
	{"0O_ASYNC", P_o_async},
	{"0O_CREAT", P_o_creat},
	{"0O_EXCL", P_o_excl},
	{"0O_RDONLY", P_o_rdonly},
	{"0O_RDWR", P_o_rdwr},
	{"0O_SYNC", P_o_sync},
	{"0O_TRUNC", P_o_trunc},
	{"0O_WRONLY", P_o_wronly},
	{"0CLOSE", P_close},
	{"0UNLINK", P_unlink},
	{"0SEEK", P_seek},
	{"0SEEK_CUR", P_seek_cur},
	{"0SEEK_END", P_seek_end},
	{"0SEEK_SET", P_seek_set},
	{"0TELL", P_tell},
	{"0LOAD", P_load},
	{"0PATHMAX", P_pathmax},
#endif				// FILEIO

#ifdef EVALUATE
	{"0EVALUATE", P_evaluate},
	{"0new-pez", P_new_pez},
	{"0send-eval", P_send_eval},
	{"0stack>", P_stack_to},
	{"0this-pez", P_this_pez},
#endif				// EVALUATE

	{NULL, (pez_wordp)0}
};

/*  PEZ_PRIMDEF  --  Initialise the dictionary with the built-in primitive
			 words.  To save the memory overhead of separately
			 allocated word items, we get one buffer for all
			 the items and link them internally within the buffer. */

void pez_primdef(pez_instance *p, struct primfcn *pt)
{
	struct primfcn *pf = pt;
	pez_dictword *nw;
	int i, n = 0;
#ifdef WORDSUSED
#ifdef READONLYSTRINGS
	unsigned int nltotal;
	char *dynames, *cp;
#endif	// READONLYSTRINGS
#endif	// WORDSUSED

	// Count the number of definitions in the table:
	while(pf->pname != NULL) {
		n++;
		pf++;
	}

#ifdef WORDSUSED
#ifdef READONLYSTRINGS
	nltotal = n;
	for(i = 0; i < n; i++) {
		nltotal += strlen(pt[i].pname);
	}
	cp = dynames = alloc(nltotal);
	for(i = 0; i < n; i++) {
		strcpy(cp, pt[i].pname);
		cp += strlen(cp) + 1;
	}
	cp = dynames;
#endif	// READONLYSTRINGS
#endif	// WORDSUSED

	nw = (pez_dictword *)alloc((unsigned int)(n * sizeof(pez_dictword)));

	nw[n - 1].wnext = p->dict;
	p->dict = nw;
	for(i = 0; i < n; i++) {
		nw->wname = pt->pname;
#ifdef WORDSUSED
#ifdef READONLYSTRINGS
		nw->wname = cp;
		cp += strlen(cp) + 1;
#endif	// READONLYSTRINGS
#endif	// WORDSUSED
		nw->wcode = pt->pcode;
		if(i != (n - 1)) {
			nw->wnext = nw + 1;
		}
		nw++;
		pt++;
	}
}

#ifdef WALKBACK

/*  PWALKBACK  --  Print walkback trace.  */

static void pwalkback(pez_instance *p)
{
	if(p->walkback && ((p->curword != NULL) || (p->wbptr > p->wback))) {
		printf("Walkback:\n");
		if(p->curword != NULL) {
			printf("   %s\n", p->curword->wname + 1);
		}
		while(p->wbptr > p->wback) {
			pez_dictword *wb = *(--p->wbptr);
			printf("   %s\n", wb->wname + 1);
			fflush(stdout);
		}
	}
}
#endif				// WALKBACK

/*  TROUBLE  --  Common handler for serious errors.  */

static void trouble(pez_instance *p, char *kind)
{
#ifdef MEMMESSAGE
	fprintf(stderr, "\n%s.\n", kind);
#endif
#ifdef WALKBACK
	pwalkback(p);
#endif				// WALKBACK
	P_abort(p);
	p->comment = state = Falsity;	// Reset all interpretation state
	p->forgetpend = p->defpend = p->stringlit =
		p->tickpend = p->ctickpend =
		False;
}

/*  PEZ_ERROR  --  Handle error detected by user-defined primitive.  */

Exported void pez_error(pez_instance *p, char *kind)
{
	trouble(p, kind);
	p->evalstat = PEZ_APPLICATION;	// Signify application-detected error
}

#ifdef BOUNDS_CHECK

/*  STAKOVER  --  Recover from stack overflow.	*/

Exported void stakover(pez_instance *p)
{
	trouble(p, "Stack overflow");
	p->evalstat = PEZ_STACKOVER;
}

/*  STAKUNDER  --  Recover from stack underflow.  */

Exported void stakunder(pez_instance *p)
{
	trouble(p, "Stack underflow");
	p->evalstat = PEZ_STACKUNDER;
}

/*  RSTAKOVER  --  Recover from return stack overflow.	*/

Exported void rstakover(pez_instance *p)
{
	trouble(p, "Return stack overflow");
	p->evalstat = PEZ_RSTACKOVER;
}

/*  RSTAKUNDER	--  Recover from return stack underflow.  */

Exported void rstakunder(pez_instance *p)
{
	trouble(p, "Return stack underflow");
	p->evalstat = PEZ_RSTACKUNDER;
}

/*  HEAPOVER  --  Recover from heap overflow.  Note that a heap overflow does
 *  NOT wipe the heap; it's up to the user to do this manually with FORGET or
 *  some such.
 */
Exported void heapover(pez_instance *p)
{
	trouble(p, "Heap overflow");
	p->evalstat = PEZ_HEAPOVER;
}

#endif				// BOUNDS_CHECK


#ifdef RESTRICTED_POINTERS

/*  BADPOINTER	--  Abort if pointer reference detected outside the heap.  */
Exported void badpointer()
{
	trouble("Bad pointer");
	evalstat = PEZ_BADPOINTER;
}

#else

Exported void badpointer(pez_instance *p) { }

#endif				// RESTRICTED_POINTERS

/*  NOTCOMP  --  Compiler word used outside definition.  */

#ifdef COMPILATION_SAFETY

static void notcomp(pez_instance *p)
{
	trouble(p, "Compiler word outside definition");
	p->evalstat = PEZ_NOTINDEF;
}

#endif

#ifdef MATH_CHECK

/*  DIVZERO  --  Attempt to divide by zero.  */
static void divzero(pez_instance *p)
{
	trouble(p, "Divide by zero");
	p->evalstat = PEZ_DIVZERO;
}

#endif

/*  EXWORD  --	Execute a word (and any sub-words it may invoke). */

static void exword(pez_instance *p, pez_dictword *wp)
{
	p->curword = wp;
	tracing {
		printf("\nTrace: %s ", p->curword->wname + 1);
		fflush(stdout);
	}
	p->curword->wcode(p);	 // Execute the first word
	while(p->ip != NULL) {
#ifdef BREAK
		Keybreak();	// Poll for asynchronous interrupt
		if(p->broken) {	// Did we receive a break signal
			trouble(p, "Break signal");
			p->evalstat = PEZ_BREAK;
			break;
		}
#endif				/* BREAK */
		p->curword = *p->ip++;
		tracing {
			printf("\nTrace: %s ", p->curword->wname + 1);
			fflush(stdout);
		}
		p->curword->wcode(p);	// Execute the next word
	}
	p->curword = NULL;
}

/*
   This returns a new instance of Pez.  The flags argument is a bitwise OR of
   the PEZ_A_* flags, for preventing the new instance from doing things that you
   may not want it to do.  The flags are as follows:
   	PEZ_A_EVERYTHING	Special flag:  no restrictions, allow everything

	PEZ_A_IO		Allow I/O
	PEZ_A_FILES		Allow files to be opened and closed.
	PEZ_A_SYSTEM		Allow the instance to run commands via system()
	PEZ_A_SIG		Allow signal handlers to be set
	PEZ_A_PROCESS		Allow the instance to create and kill processes
	PEZ_A_POINTERS		Allow unrestricted pointers
	PEZ_A_FFI		Allow C functions to be added to the dictionary
	PEZ_A_SOCKET		Allow the socket library

   These flags are documented a bit more in-depth in pez.h, where they are
   defined.
*/
extern pez_instance *pez_init(long flags)
{
	static int gc_already_inited = 0;
	pez_instance *p;
	int i;

	if(!gc_already_inited) {
		GC_INIT();
		gc_already_inited = 1;
	}

	p = (pez_instance *)alloc(sizeof(pez_instance));
	p->evalstat = PEZ_SNORM;
	p->forgetpend = 0;
	p->defpend = False;
	p->forgetpend = False;
	p->tickpend = False;
	p->ctickpend = False;
	p->cbrackpend = False;
	p->tail_call_pending = False;
	p->stringlit = False;
	p->curword = NULL;
	p->ip = NULL;
	p->trace = Falsity;
	p->walkback = Truth;
	p->comment = Falsity;
	p->redef = Truth;
	p->errline = 0;
	p->ntempstr = 8;
	p->stklen = 1000;		// Evaluation stack length
	p->rstklen = 1000;		// Return stack length
	p->heaplen = 20000;		// Heap length
	p->ltempstr = max(PATH_MAX, 4096);// Temporary string buffer length
	p->base = 10;
	p->broken = Falsity;
	p->instream = NULL;

	for(i = 0; i < MAX_IO_STREAMS; i++) {
		p->output_stk[i] = 1;
		p->input_stk[i] = 0;
	}
	p->output_idx = 0;
	p->input_idx = 0;

	pez_primdef(p, primt);  // Define primitive words
	p->dictprot = p->dict;  // Set protected mark in dictionary, now that we
	                        // have a dictionary.

	/* Look up compiler-referenced words in the new dictionary and
	   save their compile addresses in static variables. */

#define Cconst(cell, name)  do {\
	cell = (pez_stackitem)lookup(p, name);\
	if(!cell) abort();\
	} while(0)

	Cconst(s_exit, "EXIT");
	Cconst(s_lit, "(LIT)");
	Cconst(s_flit, "(FLIT)");
	Cconst(s_strlit, "(STRLIT)");
	Cconst(s_dotparen, ".(");
	Cconst(s_qbranch, "?BRANCH");
	Cconst(s_branch, "BRANCH");
	Cconst(s_xdo, "(XDO)");
	Cconst(s_xqdo, "(X?DO)");
	Cconst(s_xloop, "(XLOOP)");
	Cconst(s_pxloop, "(+XLOOP)");
	Cconst(s_abortq, "ABORT\"");
#undef Cconst

	if(p->stack == NULL) {	// Allocate stack if needed
		p->stack = (pez_stackitem *)
			alloc(((unsigned int)p->stklen) * sizeof(pez_stackitem));
	}
	p->stk = p->stackbot = p->stack;
#ifdef MEMSTAT
	p->stackmax = p->stack;
#endif
	p->stacktop = p->stack + p->stklen;
	if(p->rstack == NULL) {	// Allocate return stack if needed
		p->rstack = (pez_dictword ***)
			alloc(((unsigned int)p->rstklen) *
					sizeof(pez_dictword **));
	}
	p->rstk = p->rstackbot = p->rstack;
#ifdef MEMSTAT
	p->rstackmax = p->rstack;
#endif
	p->rstacktop = p->rstack + p->rstklen;
#ifdef WALKBACK
	if(p->wback == NULL) {
		p->wback = (pez_dictword **)alloc(((unsigned int)p->rstklen) *
				sizeof(pez_dictword *));
	}
	p->wbptr = p->wback;
#endif
	if(p->heap == NULL) {

		/* The temporary string buffers are placed at the start
		   of the heap, which permits us to pointer-check
		   pointers into them as within the heap extents.
		   Hence, the size of the buffer we acquire for the heap
		   is the sum of the heap and temporary string requests.
		   */

		int i;
		char *cp;

		/* Force length of temporary strings to even number of
		   stackitems. */
		p->ltempstr += sizeof(pez_stackitem) -
			(p->ltempstr % sizeof(pez_stackitem));
		cp = alloc((p->heaplen * sizeof(pez_stackitem)) +
				((p->ntempstr * p->ltempstr)));
		p->heapbot = (pez_stackitem *)cp;
		p->strbuf = (char **)alloc(p->ntempstr * sizeof(char *));
		for(i = 0; i < p->ntempstr; i++) {
			p->strbuf[i] = cp;
			cp += p->ltempstr;
		}
		p->cstrbuf = 0;
		// Available heap memory starts after the temp strings:
		p->heap = (pez_stackitem *)cp;
	}
	/* The system state word is kept in the first word of the heap
	   so that pointer checking doesn't bounce references to it.
	   When creating the heap, we preallocate this word and
	   initialise the state to the interpretive state.
	   */
	p->hptr = p->heap + 1;
	state = Falsity;
#ifdef MEMSTAT
	p->heapmax = p->hptr;
#endif
	p->heaptop = p->heap + p->heaplen;

	/* Now that dynamic memory is up and running, allocate constants
	   and variables built into the system.  */

#ifdef FILEIO
	{
		static struct {
			char *sfn;
			pez_stackitem fd;
		} stdfiles[] = {
			{"STDIN", 0},
			{"STDOUT", 1},
			{"STDERR", 2},
		};
		pez_dictword *dw;

		for(i = 0; i < ELEMENTS(stdfiles); i++) {
			if((dw = pez_vardef(p, stdfiles[i].sfn,
			                    sizeof(pez_stackitem))) != NULL) {
				pez_stackitem *si = pez_body(p, dw);
				*si = stdfiles[i].fd;
			}
		}
		output_stream = 1;
		input_stream = 0;

	}
#endif				// FILEIO
	p->dictprot = p->dict;	// Protect all standard words
	return p;
}

/* Look up a word in the dictionary.  Returns its word item if found or NULL if
   the word isn't in the dictionary. */
pez_dictword *pez_lookup(pez_instance *p, char *name)
{
	char buf[TOK_BUF_SZ];
	strcpy(buf, name);
	return lookup(p, buf);	// Now use normal lookup() on it
}

/*  PEZ_BODY  --  Returns the address of the body of a word, given
		  its dictionary entry. */

pez_stackitem *pez_body(pez_instance *p, pez_dictword *dw)
{
	return ((pez_stackitem *)dw) + Dictwordl;
}

/*  PEZ_EXEC  --  Execute a word, given its dictionary address.  The
				  evaluation status for that word's execution is
		  returned.  The in-progress evaluation status is
		  preserved. */

int pez_exec(pez_instance *p, pez_dictword *dw)
{
	int sestat = p->evalstat, restat;

	p->evalstat = PEZ_SNORM;
#ifdef BREAK
	p->broken = False;		// Reset break received
#endif
#undef Memerrs
#define Memerrs p->evalstat
	Rso(1);
	Rpush = p->ip;		// Push instruction pointer
	p->ip = NULL;		// Keep exword from running away
	exword(p, dw);
	if(p->evalstat == PEZ_SNORM) {	// If word ran to completion
		Rsl(1);
		p->ip = R0;	// Pop the return stack
		Rpop;
	}
#undef Memerrs
#define Memerrs
	restat = p->evalstat;
	p->evalstat = sestat;
	return restat;
}

/* Define a variable word.  Called with the word's name and the number of bytes
 * of storage to allocate for its body.  All words defined with pez_vardef()
 * have the standard variable action of pushing their body address on the stack
 * when invoked.  Returns the dictionary item for the new word, or NULL if the
 * heap overflows.
 */
pez_dictword *pez_vardef(pez_instance *p, char *name, int size)
{
	pez_dictword *di;
	char buf[TOK_BUF_SZ];
	int isize = (size + (sizeof(pez_stackitem) - 1)) / sizeof(pez_stackitem);

#undef Memerrs
#define Memerrs NULL
	p->evalstat = PEZ_SNORM;
	Ho(Dictwordl + isize);
#undef Memerrs
#define Memerrs
	if(p->evalstat != PEZ_SNORM)	// Did the heap overflow
		return NULL;	// Yes.  Return NULL
	p->createword = (pez_dictword *)p->hptr;	// Develop address of word
	p->createword->wcode = P_var;	// Store default code
	p->hptr += Dictwordl;	// Allocate heap space for word
	while(isize > 0) {
		Hstore = 0;	// Allocate heap area and clear it
		isize--;
	}
	strcpy(buf, name);	// Use built-in token buffer...
	enter(p, buf);		// Make dictionary entry for it
	di = p->createword;	// Save word address
	p->createword = NULL;	// Mark no word underway
	return di;		// Return new word
}

/*  PEZ_MARK  --  Mark current state of the system.  */

void pez_mark(pez_instance *p, pez_statemark *mp)
{
	mp->mstack = p->stk;	// Save stack position
	mp->mheap = p->hptr;	// Save heap allocation marker
	mp->mrstack = p->rstk;	// Set return stack pointer
	mp->mdict = p->dict;	// Save last item in dictionary
}

/*
   Restore system state to previously saved state, including the dictionary, the
   heap, the stack, and the return stack.
*/
void pez_unwind(pez_instance *p, pez_statemark *mp)
{

	/* If pez_mark() was called before the system was initialised, and
	   we've initialised since, we cannot unwind.  Just ignore the
	   unwind request.  The user must manually pez_init before an
	   pez_mark() request is made. */

	if(mp->mdict == NULL)	// Was mark made before pez_init ?
		return;		// Yes.  Cannot unwind past init

	p->stk = mp->mstack;	// Roll back stack allocation
	p->hptr = mp->mheap;	// Reset heap state
	p->rstk = mp->mrstack;	// Reset the return stack

	/* To unwind the dictionary, we can't just reset the pointer,
	   we must walk back through the chain and release all the name
	   buffers attached to the items allocated after the mark was
	   made. */

	while(p->dict != NULL && p->dict != p->dictprot &&
			p->dict != mp->mdict) {
		p->dict = p->dict->wnext;	// Link to previous item
	}
}

#ifdef BREAK

/*
   Asynchronously interrupt execution.  Note that this function only sets a
   flag, broken, that causes exword() to halt after the current word.  Since
   this can be called at any time, it daren't touch the system state directly,
   as it may be in an unstable condition.
*/
void pez_break(pez_instance *p)
{
	p->broken = True;	// Set break request
}
#endif				// BREAK

/*  PEZ_LOAD  --  Load a file into the system.	*/

int pez_load(pez_instance *p, FILE *fp)
{
	int es = PEZ_SNORM;
	char s[134];
	pez_statemark mk;
	pez_int scomm = p->comment;	// Stack comment pending state
	pez_dictword **sip = p->ip;	// Stack instruction pointer
	char *sinstr = p->instream;	// Stack input stream
	int lineno = 0;		// Current line number

	p->errline = 0;	// Reset line number of error
	pez_mark(p, &mk);
	p->ip = NULL;		// Fool pez_eval into interp state
	while(pez_fgetsp(p, s, 132, fp) != NULL) {
		lineno++;
		if((es = pez_eval(p, s)) != PEZ_SNORM) {
			p->errline = lineno;	// Save line number of error
			pez_unwind(p, &mk);
			break;
		}
	}
	/* If there were no other errors, check for a runaway comment.  If
	   we ended the file in comment-ignore mode, set the runaway comment
	   error status and unwind the file.  */
	if((es == PEZ_SNORM) && (p->comment == Truth)) {
#ifdef MEMMESSAGE
		fprintf(stderr, "\nRunaway `(' comment.\n");
#endif
		es = PEZ_RUNCOMM;
		pez_unwind(p, &mk);
	}
	p->comment = scomm;	// Unstack comment pending status
	p->ip = sip;		// Unstack instruction pointer
	p->instream = sinstr;	// Unstack input stream
	return es;
}

/*  PEZ_PROLOGUE  --  Recognise and process prologue statement.
			  Returns 1 if the statement was part of the
			  prologue and 0 otherwise. */

int pez_prologue(pez_instance *p, char *sp)
{
	struct {
		char *pname;
		pez_int *pparam;
	} proname[] = {
		{"STACK ", &p->stklen},
		{"RSTACK ", &p->rstklen},
		{"HEAP ", &p->heaplen},
		{"TEMPSTRL ", &p->ltempstr},
		{"TEMPSTRN ", &p->ntempstr},
	};

	if(strncmp(sp, "# *", 3) == 0) {
		int i;
		char *ap;

		for(i = 0; i < ELEMENTS(proname); i++) {
			if(strncasecmp(sp + 3, proname[i].pname,
				   strlen(proname[i].pname)) == 0) {
				if((ap = strchr(sp + 3, ' ')) != NULL) {
					sscanf(ap + 1, "%li",
						   proname[i].pparam);
#ifdef PROLOGUEDEBUG
					printf("Prologue set %sto %ld\n",
						   proname[i].pname,
						   *proname[i].pparam);
#endif
					return 1;
				}
			}
		}
	}
	return 0;
}

/*
	The string, you fling upon the heap.
*/

void pez_heap_string(pez_instance *p, char* str)
{
	int l =
	      (strlen(str) + 1 + sizeof(pez_stackitem)) / sizeof(pez_stackitem);
	Ho(l);
	*((char *)p->hptr) = l;	 // Store in-line skip length
	strcpy(((char *)p->hptr) + 1, str);
	p->hptr += l;
}

/*
   Copy a string to one of the temporary buffers and push it on the stack.
*/
void pez_stack_string(pez_instance *p, char *str)
{
	So(1);
	strncpy(p->strbuf[p->cstrbuf], str, p->ltempstr - 1);
	Push = (pez_stackitem)p->strbuf[p->cstrbuf];
	p->cstrbuf = (p->cstrbuf + 1) % ((int)p->ntempstr);
}

void pez_heap_int(pez_instance *p, pez_int val)
{
	Ho(2);
	Hstore = s_lit;		// Push (lit)
	Hstore = val;	// Compile actual literal
}

void pez_stack_int(pez_instance *p, pez_int val)
{
	So(1);
	Push = val;
}

void pez_heap_real(pez_instance *p, pez_real val)
{
	int i;
	union {
		pez_real r;
		pez_stackitem s[Realsize];
	} tru;

	Ho(Realsize + 1);
	Hstore = s_flit;	// Push (flit) at execution

	tru.r = val;
	fflush(stderr);

	for(i = 0; i < Realsize; i++) {
		Hstore = tru.s[i];
	}
}

void pez_stack_real(pez_instance *p, pez_real val)
{
	int i;
	union {
		pez_real r;
		pez_stackitem s[Realsize];
	} tru;

	fflush(stderr);

	So(Realsize);
	tru.r = val;
	for(i = 0; i < Realsize; i++) {
		Push = tru.s[i];
	}
}

void pez_heap_word(pez_instance *p, pez_dictword *di)
{
	Hsingle((pez_stackitem)di);	// Compile word address
}

void pez_stack_word(pez_instance *p, char token_buffer[])
{
	pez_dictword *di;
	p->tickpend = False;
	if((di = lookup(p, token_buffer)) != NULL) {
		So(1);
		Push = (pez_stackitem)di;	// Push word compile address
	} else {
#ifdef MEMMESSAGE
		fprintf(stderr, " '%s' undefined\n", token_buffer);
#endif
		p->evalstat = PEZ_UNDEFINED;
	}

}

// FIXME: yes, this is not a good function name.
void pez_forget_during_eval(pez_instance *p, char token_buffer[])
{
	pez_dictword *di;
	p->forgetpend = False;
	if((di = lookup(p, token_buffer)) != NULL) {
		pez_dictword *dw = p->dict;

		/* Pass 1.  Rip through the dictionary to make sure this word is
		 * not past the marker that guards against forgetting too much.
		 */

		while(dw != NULL) {
			if(dw == p->dictprot) {
#ifdef MEMMESSAGE
				printf("\nForget protected.\n");
#endif
				p->evalstat = PEZ_FORGETPROT;
				di = NULL;
			}
			if(strcasecmp(dw->wname + 1, token_buffer) == 0)
				break;
			dw = dw->wnext;
		}

		/* Pass 2.  Walk back through the dictionary items until we
		 * encounter the target of the FORGET.  Release each item's name
		 * buffer and dechain it from the dictionary list. */
		if(di != NULL) {
			do {
				dw = p->dict;
				p->dict = dw->wnext;
			} while(dw != di);
			/* Finally, back the heap allocation pointer up to the
			  start of the last item forgotten. */
			p->hptr = (pez_stackitem *)di;
			/* Uhhhh, just one more thing. If this word was defined with
			  DOES>, there's a link to the method address hidden before
			  its wnext field.  See if it's a DOES> by testing the wcode
			  field for P_dodoes and, if so, back up the heap one more
			  item. */
			if(di->wcode == (pez_wordp)P_dodoes) {
#ifdef FORGETDEBUG
				printf(" Forgetting DOES> word. ");
#endif
				p->hptr--;
			}
		}
	} else {
#ifdef MEMMESSAGE
		printf(" '%s' undefined\n", token_buffer);
#endif
		p->evalstat = PEZ_UNDEFINED;
	}

}


/*  PEZ_EVAL  --  Evaluate a string containing PEZ words.  */

int pez_eval(pez_instance *p, char *sp)
{
	int token;
	char token_buffer[TOK_BUF_SZ];

#undef Memerrs
#define Memerrs p->evalstat
	p->instream = sp;
	p->evalstat = PEZ_SNORM;	 // Set normal evaluation status
#ifdef BREAK
	p->broken = False;		 // Reset asynchronous break
#endif

	/*
	   If automatic prologue processing is configured and we haven't yet
	   initialised, check if this is a prologue statement. If so, execute
	   it. Otherwise automatically initialise with the memory specifications
	   currently operative.
	*/
#ifdef PROLOGUE
	if(!p->dict && pez_prologue(p, sp))
		return p->evalstat;
#endif				// PROLOGUE

	while((p->evalstat == PEZ_SNORM) &&
		(token = lex(p, &p->instream, token_buffer)) != TokNull) {
		pez_dictword *di;

		switch (token) {
		case TokWord:
			if(p->forgetpend) {
				pez_forget_during_eval(p, token_buffer);
			} else if(p->tickpend) {
				pez_stack_word(p, token_buffer);
			} else if(p->defpend) {
				p->defpend = False;
				// Define word and enter in the dict:
				enter(p, token_buffer);
			} else { // Here's where evaluation actually happens
				di = lookup(p, token_buffer);
				if(di != NULL) {
					/* When interpreting, execute the word
					 * in all cases.  Otherwise compile the
					 * word unless it is a compiler word
					 * flagged for immediate execution by
					 * its dictionary entry.
					 */
					if(state &&
					   (p->cbrackpend || p->ctickpend ||
					    !Immediate(di))) {
						if(p->ctickpend) {
							/* Compile (lit) so this
							 * word's address gets
							 * pushed to be pushed
							 * on the stack at
							 * execution time.
							 */
							Hsingle(s_lit);
						}
						p->cbrackpend = p->ctickpend =
							False;
						pez_heap_word(p, di);
					} else {
						exword(p, di);	// Execute word
					}
				} else {
#ifdef MEMMESSAGE
					fprintf(stderr, " '%s' undefined\n",
						token_buffer);
#endif
					p->evalstat = PEZ_UNDEFINED;
					p->instream = NULL;
					state = Falsity;
					return(p->evalstat);
				}
			}
			break;

		case TokInt:
			if(state)
				pez_heap_int(p, p->tokint);
			else
				pez_stack_int(p, p->tokint);
			break;

		case TokReal:
			if(state)
				pez_heap_real(p, p->tokreal);
			else
				pez_stack_real(p, p->tokreal);
			break;

		case TokString:
			if(state) {
				// When compiling, strings go on the heap
				if(!p->stringlit)
					Hsingle(s_strlit);
				// Preceded by an instruction when literal
				// handling is needed
				p->stringlit = False;
				pez_heap_string(p, token_buffer);
			} else {
				// When interpreting, strings go on the stack:
				if(!p->stringlit)
					pez_stack_string(p, token_buffer);
				// Or get printed out immediately when they're
				// literals:
				else
					printf("%s", token_buffer);
				p->stringlit = False;
			}
			break;

		default:
			fprintf(stderr, "\nUnknown token type %d\n", token);
			break;
		}
	}

	return p->evalstat;
}