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>
#else
#include <pez_sysconfig.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 <sys/stat.h>
#include <regex.h>
#include <limits.h>
#include <gc/gc.h>

#include <libtcc.h>

#include <memory.h>

/*
   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 functions
#define FFI			// Foreign function interface
#define PROCESS			// Process-level facilities

// #define NO_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"
#include "st.h"

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

#ifdef FFI
#include <dlfcn.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))
// Because this one may be a little non-obvious, this expression is -1 if the
// argument is less than zero, 0 if it is zero, and 1 if it is greater than
// zero.  This version tests a little faster than a clearer one would, mostly
// because it does not branch.
#define unit_scale(a)	(((a) > 0) - (((a) < 0)))

/*  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.

   For the forseeable future, these functions don't need to vary between
   instances of Pez, so it's harmless to keep them static for now.
*/
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 pez_forget_during_eval(pez_instance *p, char token_buffer[]);
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.  */
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);
		fflush(stderr);
		abort();
	}
	return cp;
}

void *pez_realloc(void *ptr, long size)
{
	void *p = GC_REALLOC(ptr, size);

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

char *pez_strdup(char *s)
{
	char *dup = GC_STRDUP(s);
	if(dup == NULL) {
		fprintf(stderr, "\n\nOut of memory!  Couldn't strdup 0x%lx!\n",
			(long)s);
		fflush(stderr);
		abort();
	}
	return dup;
}

/*
   Returns the concatenation of a and b.
*/
static char *pez_strcat(char *a, char *b)
{
	long lena, lenb;
	char *s;

	lena = strlen((char *)a);
	lenb = strlen((char *)b);

	s = alloc(lena + lenb + 1);

	if(lena)
		memcpy(s, (void *)a, lena);

	if(lenb)
		memcpy(s + lena, (void *)b, lenb);

	return s;
}

/*
   Escapes honored by Pez:
   \0 -> null
   \a -> bell
   \b -> backspace
   \e -> escape
   \f -> form feed
   \n -> LF
   \r -> CR
   \t -> tab
   \v -> vertical tab

   Every other character maps to a literal version of itself when prefixed with
   a backslash.  Octal bytes (\0NNN) aren't going to be supported.  Sorry, kids.
   Hex bytes (\xNN) probably will.
   TODO:  The thing on the above line.
*/
static char string_escape_table[256] = {
	   0,    1,    2,    3,    4,    5,    6,    7,    8,    9,
	  10,   11,   12,   13,   14,   15,   16,   17,   18,   19,
	  20,   21,   22,   23,   24,   25,   26,   27,   28,   29,
	  30,   31,   32,   33,   34,   35,   36,   37,   38,   39,
	  40,   41,   42,   43,   44,   45,   46,   47,    0,   49,
	  50,   51,   52,   53,   54,   55,   56,   57,   58,   59,
	  60,   61,   62,   63,   64,   65,   66,   67,   68,   69,
	  70,   71,   72,   73,   74,   75,   76,   77,   78,   79,
	  80,   81,   82,   83,   84,   85,   86,   87,   88,   89,
	  90,   91,   92,   93,   94,   95,   96, '\a', '\b',   99,
	 100,   27, '\f',  103,  104,  105,  106,  107,  108,  109,
	'\n',  111,  112,  113, '\r',  115, '\t',  117, '\v',  119,
	 120,  121,  122,  123,  124,  125,  126,  127,  128,  129,
	 130,  131,  132,  133,  134,  135,  136,  137,  138,  139,
	 140,  141,  142,  143,  144,  145,  146,  147,  148,  149,
	 150,  151,  152,  153,  154,  155,  156,  157,  158,  159,
	 160,  161,  162,  163,  164,  165,  166,  167,  168,  169,
	 170,  171,  172,  173,  174,  175,  176,  177,  178,  179,
	 180,  181,  182,  183,  184,  185,  186,  187,  188,  189,
	 190,  191,  192,  193,  194,  195,  196,  197,  198,  199,
	 200,  201,  202,  203,  204,  205,  206,  207,  208,  209,
	 210,  211,  212,  213,  214,  215,  216,  217,  218,  219,
	 220,  221,  222,  223,  224,  225,  226,  227,  228,  229,
	 230,  231,  232,  233,  234,  235,  236,  237,  238,  239,
	 240,  241,  242,  243,  244,  245,  246,  247,  248,  249,
	 250,  251,  252,  253,  254,  255,
};

/*
	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) {
		unsigned 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;
			}
			c = string_escape_table[c];
		}
		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;
}

static int is_word(pez_instance *p, pez_dictword *d)
{
	pez_dictword *c = p->dict;
	while(c) {
		if(c == d)
			return 1;
		c = c->wnext;
	}
	return 0;
}

/* 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, "Float stack",
		   ((long)(p->fstk - p->fstack)),
		   ((long)(p->fstackmax - p->fstack)),
		   p->fstklen, (100L * (p->fstk - p->fstack)) / p->fstklen);
	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);
	fflush(stdout);
}
#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

/*
   Runs a regex on a string, returning 1 for a match, 0 otherwise, and filling
   in all the $n variables, as well as the pre- and post-matches.  For use by
   rmatch, rsub, rgsub, etc.  'flags' is passed directly as 'eflags' to
   regexec(3).
*/
static int regex_match(pez_instance *p, regex_t *rx, char *str, int flags)
{
	int match;
	int len = strlen(str);

	match = !regexec(rx, str, MAX_REGEX_MATCHES, p->regex_matches, flags);
	if(match) {
		p->regex_prematch[0] = 0;
		p->regex_prematch[1] = p->regex_matches[0].rm_so;
		p->regex_postmatch[0] = p->regex_matches[0].rm_eo;
		p->regex_postmatch[1] = len - p->regex_matches[0].rm_eo;
		return 1;
	} else {
		p->regex_prematch[0] = p->regex_postmatch[0] = -1;
		p->regex_prematch[1] = p->regex_postmatch[1] = 0;
		return 0;
	}
}

/*  Primitive word definitions.  */

#ifndef 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_mul(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);
	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);
	Pop;
}

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

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

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

/*
   ( a b -- a<=b )
*/
prim P_leq(pez_instance *p)
{
	Sl(2);
	S1 = -(S1 <= S0);
	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;
}

/*
   ( -- random! )
   Pushes a random number onto the stack.
*/
prim P_rand(pez_instance *p)
{
	Push = rand();
	if(sizeof(int) < sizeof(pez_stackitem))
		S0 |= (pez_stackitem)rand() << (sizeof(int) * 8);
}

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_2mul(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);
}

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

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

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

/*  Storage allocation (mostly heap) primitives  */

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

/*
   ( n addr -- addr' )
   Reallocates storage.
*/
prim P_realloc(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	S1 = (pez_stackitem)pez_realloc((void *)S0, S1);
	Pop;
}

/*
   ( dest src len -- )
   Just memcpy.
*/
prim P_memcpy(pez_instance *p)
{
	Sl(3);
	Hpc(S2);
	Hpc(S1);
	memcpy((void *)S2, (void *)S1, S0);
	Npop(3);
}

/*
   ( -- 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.

   TODO:  There are some cell size mismatch bugs lurking.
*/
#define SIZE_FUNCS(typename, size_fn, plural_fn, read_fn, write_fn) \
	prim size_fn(pez_instance *p) { So(1); Push = sizeof(typename); } \
	prim plural_fn(pez_instance *p) { Sl(1); S0 *= sizeof(typename); } \
	prim read_fn(pez_instance *p) {\
		pez_stackitem *sp; \
		Sl((sizeof(typename) + sizeof(pez_stackitem) - 1) / \
			sizeof(pez_stackitem)); \
		sp = (pez_stackitem *)S0; Pop; \
		Hpc(sp); \
		switch((sizeof(typename) + sizeof(pez_stackitem) - 1) / \
			sizeof(pez_stackitem)) { \
		case 4: Push = *sp++;\
		case 3: Push = *sp++;\
		case 2: Push = *sp++;\
		case 1: Push = *sp++;\
		} \
		S0 = (pez_stackitem)(*(typename *)S0); \
	} \
	prim write_fn(pez_instance *p) {\
		Sl(2); \
		Hpc(S0); \
		*(typename *)S0 = (typename)S1; \
		Npop(1 + (sizeof(typename) + sizeof(pez_stackitem) - 1) / \
					sizeof(pez_stackitem)); \
	}

SIZE_FUNCS(pez_stackitem, P_cell_size, P_cells, P_cell_at, P_cell_bang)
SIZE_FUNCS(pez_real, P_float_size, P_floats, P_float_at, P_float_bang)
SIZE_FUNCS(void *, P_c_pointer_size, P_c_pointers, P_c_pointer_at,
		P_c_pointer_bang)

#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_pez_libdir, PEZCONF_PEZ_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 NO_BOUNDS_CHECK
	isp = &S0;
	for(i = 0; i < nsubs; i++) {
		pez_stackitem subn = *isp--;

		if(subn < 0 || subn >= array[i])
			trouble(p, "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)
{
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	strcpy((char *)S0, (char *)S1);
	Pop2;
}

/*
   ( str -- copy )
   Produces a copy of a string.
*/
prim P_sdup(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = (pez_stackitem)pez_strdup((char *)S0);
}

/*
   ( s1 s2 -- s3 )
   Given two null-terminated strings, s+ returns their concatenation in a fresh
   buffer.
*/
prim P_splus(pez_instance *p)
{
	char *s;

	Sl(2);
	Hpc(S0);
	Hpc(S1);

	s = pez_strcat((char *)S1, (char *)S0);
	Pop;
	S0 = (pez_stackitem)s;

}

/*
   ( s -- )
   Removes a trailing newline (with optional carriage return) from a string, in
   place.
*/
prim P_chomp_bang(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	char *s = (char *)S0, *nl;

	Pop;

	nl = strrchr(s, '\n');
	if(!nl)
		return;

	*nl = 0;
	if(nl[-1] == '\r')
		nl[-1] = 0;
}

/*
   ( s -- s' )
   Removes a trailing newline, non-destructively.
*/
prim P_chomp(pez_instance *p)
{
	Sl(1);
	Hpc(S0);

	char *s = pez_strdup((char *)S0);
	S0 = (pez_stackitem)s;
	P_chomp_bang(p);
	Push = (pez_stackitem)s;
}

/*
   ( s1 s2 -- )
   Just like C's strcat, it copies s1 to the end of s2.
*/
prim P_strcat(pez_instance *p)
{
	Sl(2);
	Hpc(S0);
	Hpc(S1);
	strcat((char *)S0, (char *)S1);
	Pop2;
}

/*
   ( str -- len )
   Returns the length of the null-terminated string at the top of the stack.
*/
prim P_strlen(pez_instance *p)
{
	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;
}

/*
   ( len offset s -- s' )
   Returns a substring from s, starting at offset and going to len.  Passing a
   length of zero or less gets you an empty string, passing a negative offset
   gets you a null pointer.  For example:
   ( 2 1 "abcd" -- "bc" )
*/
prim P_substr(pez_instance *p)
{
	char *sub;
	long len;

	Sl(3);
	Hpc(S0);

	if(!S0 || S1 < 0) {
		Pop2;
		S0 = 0;
		return;
	}

	len = S2 <= 0 ? 0 : S2;
	sub = alloc(len + 1);

	if(len > 0)
		strncpy(sub, (char *)S0 + S1, len);

	Pop2;
	S0 = (pez_stackitem)sub;
}

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

/*
   ( val format -- str )
   Like sprintf(malloc(enough), format, val), where val is an integer.
   
   Also like sprintf, you should choose your format strings with caution; Pez
   team takes no responsibility if you decide to do bad things in the format
   string, like tell it "%ld%ld%ld%ld" (thus getting gibberish from effectively
   random argument registers and/or smashing the C stack).

   (I may fix this with a trivial scan for exactly one '%' not followed by
   another '%'.)
*/
prim P_format(pez_instance *p)
{
	char *formatted;

	Sl(2);
	Hpc(S0);
	// There are about ceil(log(2)/log(10)) digits per bit, but the upper
	// limit is actually the number of digits in octal plus the length of
	// the format, minus the metacharacters in the format, plus a \0 and
	// possibly a sign and/or a prefix if you use something like "%#lx".
	// It's better to err on the side of allocating too much in this case,
	// so we do.  I say all of this only so that whoever comes up with
	// something more clever for this line does so without accidentally
	// breaking it.
	formatted = alloc(sizeof(long) * 4 + 2 + strlen((char *)S0));
	sprintf(formatted, (char *)S0, S1);
	Pop;
	S0 = (pez_stackitem)formatted;
}

/*
   ( f -- str )
   Float->string, using the format "%6.2f"
*/
prim P_fstrform(pez_instance *p)
{
	Sl(2);
	FSl(1);
	Hpc(S0);
	Hpc(S1);
	sprintf((char *)S0, (char *)S1, REAL0);
	Realpop;
	Pop2;
}

/*
   ( 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;
}

/*
   ( str -- i )
   Like strint, but doesn't advance the pointer.
*/
prim P_atoi(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = atol((char *)S0);
}

/*
   ( string -- string' f: float )
   Parses a floating point number out of a string, and increments the string's
   pointer to the end of that float.
*/
prim P_strreal(pez_instance *p)
{
	pez_real d;
	char *eptr;

	Sl(1);
	FSo(1);
	Hpc(S0);
	d = strtod((char *)S0, &eptr);
	S0 = (pez_stackitem)eptr;
	Realpush(d);
}

/*
   ( 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)
{
	char *str;
	regex_t *rx;

	Hpc(S0);
	Hpc(S1);
	Sl(2);

	str = (char *)S1;
	rx = (regex_t *)S0;
	Pop;
	S0 = -regex_match(p, rx, str, 0);
}

/*
   ( -- len first-offset )
   An approximation of Perl's/Ruby's/others' 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

/*
   ( -- len offset )
   Returns the prematch.  Offset is always zero if there was a match, -1
   otherwise.
*/
prim P_moneypre(pez_instance *p)
{
	So(2);
	Push = p->regex_prematch[1];
	Push = p->regex_prematch[0];
}

/*
   ( -- len offset )
   Returns the postmatch.  
*/
prim P_moneypost(pez_instance *p)
{
	So(2);
	Push = p->regex_postmatch[1];
	Push = p->regex_postmatch[0];
}

/*
   ( str rx word -- new-str )
   Performs a substitution on a string.  Needs a string, a regex, and a word to
   execute if a match is found.  The word to execute will get the matching part
   of the string on the stack, followed by whatever was there before rsub was
   called; the match variables ($0 et al) are available and valid for the word.
   The word is expected to have the stack effect ( match -- replacement|0 ).  If
   it leaves 0 on the stack, the subtitution is left off.
   A newly allocated string is left on the stack after the call.  See also
   rgsub.
*/
prim P_rsub(pez_instance *p)
{
	pez_dictword *subber;
	regex_t *rx;
	char *str, *rep, *sub;
	long len, sublen = 0;

	Sl(3);

	// Stack's gotta be cleared before we call the word.
	subber = (pez_dictword *)S0;
	rx = (regex_t *)S1;
	str = (char *)S2;
	Npop(3);

	if(regex_match(p, rx, str, 0)) {
		len = p->regex_prematch[1] + p->regex_postmatch[1];

		P_money0(p);
		Push = (pez_stackitem)str;
		P_substr(p);
		pez_exec(p, subber);
		Sl(1);

		if(S0) {
			Hpc(S0);
			sub = (char *)S0;
			sublen = strlen(sub);
			len += sublen;
		} else {
			sub = "";
		}

		rep = alloc(len +  1);
		memcpy(rep, str, p->regex_prematch[1]);
		memcpy(rep + p->regex_prematch[1], sub, sublen);
		memcpy(rep + p->regex_prematch[1] + sublen,
				str + p->regex_postmatch[0],
				p->regex_postmatch[1]);
		S0 = (pez_stackitem)rep;
	} else {
		Push = (pez_stackitem)pez_strdup(str);
	}
}

/* Hashtable stuff */

/*
   ( -- new-hash-table )
   Returns a new cell-keyed hash table.
*/
prim P_htable(pez_instance *p)
{
	So(1);
	Push = (pez_stackitem)st_init_numtable();
}

/*
   ( -- new-str-hash-table )
   Returns a new string-keyed hash table.
*/
prim P_str_htable(pez_instance *p)
{
	So(1);
	Push = (pez_stackitem)st_init_strtable();
}

/*
   ( val key table -- )
   Stores val as key in table.
*/
prim P_htbang(pez_instance *p)
{
	Sl(3);
	Hpc(S0);
	st_insert((st_table *)S0, (st_data_t)S1, (st_data_t)S2);
	Npop(3);
}

/*
   ( key table -- val )
   Looks up a value by key in table.  val is 0 if it is not found; you may be
   interested in ht? if you want to check presence or absence.
*/
prim P_htat(pez_instance *p)
{
	st_data_t key;
	st_table *table;

	Sl(2);
	table = (st_table *)S0;
	key = (st_data_t)S1;

	Pop;
	if(!st_lookup(table, key, (st_data_t *)&S0))
		S0 = 0;
}

/*
   ( key table -- bool )
   Returns true if key exists in table, false otherwise.
*/
prim P_htp(pez_instance *p)
{
	st_data_t key;
	st_table *table;

	Sl(2);
	table = (st_table *)S0;
	key = (st_data_t)S1;

	Pop;
	S0 = (pez_stackitem)st_lookup(table, key, (st_data_t *)0) ?
		Truth : Falsity;
}

/*
   ( table -- copy )
   Produces a copy of a hash table.
*/
prim P_ht_dup(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = (pez_stackitem)st_copy((st_table *)S0);
}

/*
   ( table -- )
   Clears all keys from the provided hash table.
*/
prim P_ht_clear(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	st_clear((st_table *)S0);
	Pop;
}

/*
   ( table -- size )
   Returns the number of values in the hash table.
*/
prim P_ht_size(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = ((st_table *)S0)->num_entries;
}

static int ht_keys(pez_stackitem key, pez_stackitem val, pez_stackitem **ary)
{
	**ary = key;
	(*ary)++;
	return ST_CONTINUE;
}

/*
   ( table -- keys size )
   Leaves on the stack an array of keys, and the size of the array.  Note that
   order is not guaranteed.  (It is a hash table, after all.)
*/
prim P_ht_keys(pez_instance *p)
{
	Sl(1);
	So(1);
	Hpc(S0);

	st_table *t = (st_table *)S0;
	pez_stackitem size, *a, *tmp;

	size = t->num_entries;
	a = tmp = (pez_stackitem *)alloc((size + 1) * sizeof(pez_stackitem));
	st_foreach(t, ht_keys, (st_data_t)&tmp);
	S0 = (pez_stackitem)a;
	Push = size;
}
   
static int ht_values(pez_stackitem key, pez_stackitem val, pez_stackitem **ary)
{
	**ary = val;
	(*ary)++;
	return ST_CONTINUE;
}

/*
   ( table -- values size )
   Leaves on the stack an array of values, and the size of the array.  Note that
   order is not guaranteed.  (It is a hash table, after all.)
*/
prim P_ht_values(pez_instance *p)
{
	Sl(1);
	So(1);
	Hpc(S0);

	st_table *t = (st_table *)S0;
	pez_stackitem size, *a, *tmp;

	size = t->num_entries;
	a = tmp = (pez_stackitem *)alloc((size + 1) * sizeof(pez_stackitem));
	st_foreach(t, ht_values, (st_data_t)&tmp);
	S0 = (pez_stackitem)a;
	Push = size;
}

/*  Floating point primitives  */

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

	FSo(1);
	if(sizeof(pez_real) == sizeof(pez_stackitem))
		f = *(pez_real *)p->ip;
	else
		memcpy((void *)&f, (void *)p->ip, sizeof(pez_real));
	p->ip += Realsize;
	Realpush(f);

	tracing {
		printf("%g ", f);
		fflush(stdout);
	}
}

/*
   ( f1 f2 -- f1+f2 )
   Adds the two floats at the top of the stack.
*/
prim P_fplus(pez_instance *p)
{
	FSl(2);
	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)
{
	FSl(2);
	SREAL1(REAL1 - REAL0);
	Realpop;
}

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

/*
   ( f1 f2 -- f1/f2 )
   Divides the second float on the stack by the first.
*/
prim P_fdots(pez_instance *);
prim P_fdiv(pez_instance *p)
{
	FSl(2);
#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)
{
	FSl(2);
	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)
{
	FSl(2);
	SREAL1(max(REAL1, REAL0));
	Realpop;
}

/*
   ( f -- -f )
*/
prim P_fneg(pez_instance *p)
{
	FSl(1);
	SREAL0(-REAL0);
}

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

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

	FSl(2);
	So(1);
	t = -(REAL1 == REAL0);
	Realpop2;
	Push = t;
}

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

	FSl(2);
	So(1);
	t = -(REAL1 != REAL0);
	Realpop2;
	Push = t;
}

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

	FSl(2);
	So(1);
	t = -(REAL1 > REAL0);
	Realpop2;
	Push = t;
}

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

	FSl(2);
	So(1);
	t = -(REAL1 < REAL0);
	Realpop2;
	Push = t;
}

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

	FSl(2);
	So(1);
	t = -(REAL1 >= REAL0);
	Realpop2;
	Push = t;
}

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

	FSl(2);
	So(1);
	t = -(REAL1 <= REAL0);
	Realpop2;
	Push = t;
}

/*
   ( f -- )
   Print the float at the top of the stack to the current output stream.
*/
prim P_fdot(pez_instance *p)
{
	FSl(1);
	printf("%f ", REAL0);
	fflush(stdout);
	Realpop;
}

/*
   ( i -- f )
   Convert an integer to a floating-point number.
*/
prim P_float(pez_instance *p)
{
	Sl(1);
	FSo(1);
	Realpush((pez_real)S0);
	Pop;
}

/*
   ( f -- i )
   Convert a floating-point number to an integer, truncating towards zero.
*/
prim P_fix(pez_instance *p)
{
	FSl(1);
	So(1);
	Push = REAL0;
	Realpop;
}

/*
   ( f -- floor(f) )
   The greatest integer that is less than or equal to f.
*/
prim P_floor(pez_instance *p)
{
	FSl(1);
	So(1);
	Push = floor(REAL0);
	Realpop;
}

/*
   ( f -- ceil(f) )
   The smallest integer that is greater than or equal to f.
*/
prim P_ceil(pez_instance *p)
{
	FSl(1);
	So(1);
	Push = ceil(REAL0);
	Realpop;
}

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

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

#ifdef MATH

#define Mathfunc(x) do { FSl(1); 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);
}


/* Arc tangent:  y x -- atan */
prim P_atan2(pez_instance *p)
{
	FSl(2);
	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_log10(pez_instance *p)
{
	Mathfunc(log10);
}

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 */
	FSl(2);
	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);
	fflush(stdout);
	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;
	}

	printf("Stack:  ");
	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)
{
	pez_stackitem i;
	So(1);
	i = p->stk - p->stack;
	Push = i;
	P_ndots(p);
}

/*
   ( n -- )
   Print the top n floats from the float stack.
*/
prim P_nfdots(pez_instance *p)
{
	pez_stackitem n, depth = p->fstk - p->fstack;
	pez_real *tsp;

	Sl(1);
	n = S0;
	Pop;

	if(depth == 0) {
		printf("Float stack is empty.\n");
		return;
	}
	printf("Float stack:  ");
	if(n >= depth)
		n = depth;
	else
		printf("... ");
	for(tsp = p->fstk - n; tsp < p->fstk; tsp++)
		printf("%f ", *tsp);
	printf("\n");
	fflush(stdout);
}

prim P_fdots(pez_instance *p)
{
	So(1);
	Push = p->fstk - p->fstack;
	P_nfdots(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;
}

/*
   ( -- str|0 )
   Grabs a string from the current input stream up to and including the first
   newline.  Returns 0 on EOF.
*/
prim P_gets(pez_instance *p)
{
	pez_stackitem max = 1024; // TODO:  Real numbers
	int i, more_input;
	char *buf, *c, *tmp;

	So(1);

	buf = alloc(max);
	c = buf;
	i = max;

	// TODO:  This is horribly inefficient, but will have to stay until we
	// do internal buffering.
	while((more_input = read(input_stream, c++, 1)) > 0) {
		i--;
		if(!i) {
			i = max;
			max *= 2;
			tmp = GC_REALLOC(buf, max);
			if(!tmp) {
				fprintf(stderr, "Couldn't realloc.  Bad.\n");
				abort();
			}
			buf = tmp;
			c = buf + (max / 2);
		}

		if(c[-1] == '\n') {
			if(i - 1)
				*c = '\0';
			break;
		}
	}

	if(!more_input)
		Push = 0;
	else
		Push = (pez_stackitem)buf;
}

/*
   ( 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)
{
	long len, r, acc = 0;
	char *s;

	Sl(2);
	Hpc(S1);

	len = S0;
	s = (char *)S1;
	Pop;

	while(len > 0) {
		r = write(output_stream, s, len);
		if(r < 1)
			break;

		s += r;
		acc += r;
		len -= r;
	}

	S0 = acc;
}

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

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

/*
   ( -- read-fd|-1 write-fd|-1 )
   Opens a pipe, provides read and write FDs, which are both -1 on failure.  See
   pipe(2).
*/
prim P_pipe(pez_instance *p)
{
	int fds[2];

	So(2);

	if(pipe(fds) < 0) {
		Push = -1;
		Push = -1;
		return;
	}

	Push = fds[0];
	Push = fds[1];
}

/*
   ( old-fd -- new-fd|-1 )
   Duplicates a file descriptor.  See dup(2).
*/
prim P_fddup(pez_instance *p)
{
	Sl(1);

	int fd = Pop;
	fd = dup(fd);

	if(fd < -2)
		fd = -1;

	Push = fd;
}

/*
   ( old-fd new-fd -- 0|-1 )
   Makes new-fd a copy of old-fd, closing new-fd first if necessary.  See
   dup2(2).
*/
prim P_fddup2(pez_instance *p)
{
	Sl(2);
	int s = 0;

	if(dup2(S1, S0) < 0)
		s = -1;

	Pop;
	S0 = s;
}

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

	It may be more desirable for most of this stuff to get defined in a
	library (that thinly wraps libc via the FFI).
	
*/

/*
   ( -- load-paths count )
   Push onto the stack an array of the current load paths and the number of load
   paths.
*/
prim P_load_paths(pez_instance *p)
{
	pez_load_path *cur = p->load_path;
	int count = 0, i;
	char **lps;
	So(2);

	fflush(stderr);

	while(cur) {
		count++;
		cur = cur->next;
	}
	lps = (char **)alloc(count);

	cur = p->load_path;
	for(i = 0; cur; i++) {
		lps[i] = pez_strdup(cur->path);
		cur = cur->next;
	}

	Push = (pez_stackitem)lps;
	Push = (pez_stackitem)count;
}

/*
   ( path -- )
   Adds a load path.
*/
prim P_add_load_path(pez_instance *p)
{
	pez_load_path *head = (pez_load_path *)alloc(sizeof(pez_load_path));
	Sl(1);
	head->next = p->load_path;
	head->path = pez_strdup((char *)S0);
	p->load_path = head;
	Pop;
}

/*
   ( libname -- lib-path )
   Given the name of a library, return the actual path that would be loaded, or
   NULL if the library can't be found.
*/
prim P_which_lib(pez_instance *p)
{
	Sl(1);
	S0 = (pez_stackitem)pez_which_lib(p, (char *)S0);
}

/*
   ( libname -- )
   Loads a library with the given name.  Differs from 'load' in that it will
   search the load path for the library, and will only load the library once,
   regardless of the number of calls.  If the library can't be found, we die.
*/
prim P_load_lib(pez_instance *p)
{
	FILE *loadme;
	int estat;
	char *which, *path, *tmp;
	pez_load_path *cur = p->already_loaded;
	Sl(1);

	path = (char *)S0;
	Pop;

	// Just in case:
	tmp = alloc(PATH_MAX + sizeof("Could not load ") + 1);
	sprintf(tmp, "Could not load %s", path);

	// Try to find it:
	which = pez_which_lib(p, path);
	if(!which) {
		pez_error(p, tmp);
		return;
	}

	// .so files are assumed to be Pez FFI libraries.
	if(!strcmp(".so", which + strlen(which) - 3)) {
		switch(pez_ffi_load(p, which)) {
			case -1:
				pez_error(p, "Not a valid Pez FFI lib");
				return;
			case -2:
				pez_error(p, pez_strdup(dlerror()));
				return;
		}
		return;
	}

	// See if we've loaded it:
	while(cur) {
		if(!strcmp(which, cur->path))
			return;
		cur = cur->next;
	}

	// Add it to the list of already loaded files, and load it.
	cur = (pez_load_path *)alloc(sizeof(pez_load_path));
	cur->path = which;
	cur->next = p->already_loaded;
	p->already_loaded = cur;

	estat = ~PEZ_SNORM;
	loadme = fopen(which, "r");

	if(loadme) {
		estat = pez_load(p, loadme);
		fclose(loadme);
	}

	if(estat != PEZ_SNORM) {
		p->already_loaded = p->already_loaded->next;
		trouble(p, tmp);
		return;
	}
}

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

	Sl(1);
	fn = (char *)S0;
	Pop;
	f = fopen(fn, "r");
	if(f) {
		Push = pez_load(p, f);
		fclose(f);
	} else {
		perror("load");
		Push = PEZ_BADFILE;
	}
}

PUSH_CONSTANT(P_pathmax, PATH_MAX)

#endif				// FILEIO

#ifdef EVALUATE

/*
   ( string -- status )
*/
prim P_evaluate(pez_instance *p)
{
	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)
{
	pez_instance *inst;
	pez_stackitem result;
	char *str;
	Sl(2);

	// We have to copy/pop everything we're using before calling pez_eval,
	// otherwise it'll mess up if p == S0.
	inst = (pez_instance *)S0;
	str = (char *)S1;
	Npop(2);

	result = pez_eval(inst, str);
	Push = result;
}

/*
   ( 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 - 1);
	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  */

/*
   ( a1 ... an -- a1 ... an n )
   Leaves on the stack a count of the number of elements on the stack.
*/
prim P_depth(pez_instance *p)
{				// Push stack depth
	pez_stackitem s = p->stk - p->stack;

	So(1);
	Push = s;
}

/*
   ( ... -- )
   Wipes the stack and the float stack.  Usually shouldn't be used outside
   interactive mode.
*/
prim P_clear(pez_instance *p)
{
	p->stk = p->stack;
	p->fstk = p->fstack;
}

/*
   ( a -- a a )
   Duplicates the top item on the stack.
*/
prim P_dup(pez_instance *p)
{				// Duplicate top of stack
	pez_stackitem s;

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

/*
   ( a -- )
   Drops the top item on the stack.
*/
prim P_drop(pez_instance *p)
{				// Drop top item on stack
	Sl(1);
	Pop;
}

/*
   ( a b -- b a )
   Swaps the first two items on the stack.
*/
prim P_swap(pez_instance *p)
{
	pez_stackitem t;

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

/*
   ( a b -- a b a )
   Duplicates the second item on the stack.
*/
prim P_over(pez_instance *p)
{
	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;
}

/*
   ( a b c -- b c a )
*/
prim P_rot(pez_instance *p)
{
	pez_stackitem t;

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

/*
   ( a b c -- c a b )
*/
prim P_minusrot(pez_instance *p)
{
	pez_stackitem t;

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

/*
   ( a b -- b a b )
*/
prim P_tuck(pez_instance *p)
{
	So(1); // swap does the Sl(2)
	// I love the inline keyword.
	P_swap(p);
	P_over(p);
}

/*
   ( cN ... c0 N -- c(N-1) ... c0 cN )
   With the top of the stack as zero, roll moves the Nth item to the top, and
   all other items down one.
*/
prim P_roll(pez_instance *p)
{
	pez_stackitem i, j, tmp;
	Sl(1);

	i = S0;
	Pop;

	Sl(i + 1);

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

/*
   ( x -- )
   Puts the top cell onto the return stack.
*/
prim P_tor(pez_instance *p)
{
	Rso(1);
	Sl(1);
	Rpush = (rstackitem)S0;
	Pop;
}

/*
   ( -- x )
   Takes the top item from the return stack, and pushes it onto the regular
   stack.
*/
prim P_rfrom(pez_instance *p)
{
	Rsl(1);
	So(1);
	Push = (pez_stackitem)R0;
	Rpop;
}

/*
   ( -- x )
   Copies the top item on the return stack to the regular stack.
*/
prim P_rfetch(pez_instance *p)
{
	Rsl(1);
	So(1);
	Push = (pez_stackitem)R0;
}

/*
   ( -- )
   Drops the top item off the return stack.
*/
prim P_rdrop(pez_instance *p)
{
	Rsl(1);
	Rpop;
}

/*
   ( -- 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  */

/*
   ( a b -- a b a b )
   Dups the top two cells.
*/
prim P_2dup(pez_instance *p)
{
	pez_stackitem s;

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

/*
   ( a b -- )
   Drops the top two items from the stack.
*/
prim P_2drop(pez_instance *p)
{
	Sl(2);
	p->stk -= 2;
}

/*
   ( a b c d -- c d a b )
   Swaps the top two pairs of cells.
*/
prim P_2swap(pez_instance *p)
{
	pez_stackitem t;

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

/*
   ( a b c d -- a b c d a b )
   Pushes the second pair of cells onto the top of the stack.
*/
prim P_2over(pez_instance *p)
{
	pez_stackitem s;

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

/*
   ( a b c d -- c d )
   Nips the second pair of cells.
*/
prim P_2nip(pez_instance *p)
{
	Sl(4);
	S2 = S0;
	S3 = S1;
	Pop2;
}

/*
   ( a b c d e f -- c d e f a b )
   Move third pair to top of stack.
*/
prim P_2rot(pez_instance *p)
{
	pez_stackitem t1, t2;

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

	/*
	pez_stackitem t;

	Sl(6);
	t = S5;
	S5 = S3;
	S3 = S1;
	S1 = t;

	t = S4;
	S4 = S2;
	S2 = S0;
	S0 = t;
	*/
}

/*
   ( a b c d -- c d a b c d )
*/
prim P_2tuck(pez_instance *p)
{
	// See P_tuck
	So(2);
	P_2swap(p);
	P_2over(p);
}

/*
   Declare a double-cell variable.
*/
prim P_2variable(pez_instance *p)
{
	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)
{
	pez_real r;
	FSl(2);
	r = REAL1;
	Realpush(r);
}

prim P_fdrop(pez_instance *p)
{
	FSl(1);
	Realpop;
}

prim P_fdup(pez_instance *p)
{
	pez_real r;
	FSl(1);
	FSo(1);
	r = REAL0;
	Realpush(r);
}

prim P_fswap(pez_instance *p)
{
	FSl(2);
	pez_real d;

	d = REAL1;
	SREAL1(REAL0);
	SREAL0(d);
}

prim P_frot(pez_instance *p)
{
	FSl(3);
	pez_real d = REAL2;
	SREAL2(REAL1);
	SREAL1(REAL0);
	SREAL0(d);
}

prim P_ftuck(pez_instance *p)
{
	pez_real r;
	FSl(2);
	FSo(1);
	P_fswap(p);
	r = REAL1;
	Realpush(r);
}

prim P_fnip(pez_instance *p)
{
	FSl(2);
	SREAL1(REAL0);
	Realpop;
}

prim P_fvar(pez_instance *p)
{
	FSo(1);
	pez_real d;
	if(sizeof(pez_real) == sizeof(pez_stackitem))
		d = *(pez_real *)(p->curword + Dictwordl);
	else
		memcpy(&d, (((pez_stackitem *)p->curword) + Dictwordl),
				sizeof(pez_real));
	Realpush(d);
}

prim P_fcreate(pez_instance *p)
{
	p->defpend = True;
	Ho(Dictwordl);
	p->createword = (pez_dictword *)p->hptr;
	p->createword->wname = NULL;
	p->createword->wcode = P_var;
	p->hptr += Dictwordl;
}

prim P_fvariable(pez_instance *p)
{
	FSo(1);
	P_fcreate(p);
	Ho(Realsize);
	
	switch (Realsize) {
		case 2: Hstore = 0;
		case 1: Hstore = 0;
	}
}

prim P_fcon(pez_instance * p)
{
	FSo(1);
	pez_real d;
	if(sizeof(pez_real) == sizeof(pez_stackitem))
		d = *(pez_real *)((pez_stackitem *)p->curword + Dictwordl);
	else
		memcpy(&d, ((pez_stackitem *)p->curword + Dictwordl),
				sizeof(pez_real));
	Realpush(d);
}

prim P_fconstant(pez_instance *p)
{
	FSl(1);
	P_create(p);
	p->createword->wcode = P_fcon;
	Ho(Realsize);
	if(sizeof(pez_real) == sizeof(pez_stackitem))
		*(pez_real *)p->hptr = REAL0;
	else
		memcpy((void *)p->hptr, (void *)&REAL0, sizeof(pez_real));
	p->hptr += Realsize;
	Realpop;
}

prim P_fbang(pez_instance *p)
{
	Sl(1);
	FSl(1);
	Hpc(S0);
	if(sizeof(pez_real) == sizeof(pez_stackitem))
		*(pez_real *)S0 = REAL0;
	else
		memcpy((void *)S0, &(REAL0), sizeof(pez_real));
	Realpop;
	Pop;
}

prim P_fat(pez_instance *p)
{
	Sl(1);
	FSo(1);
	Hpc(S0);
	pez_real d;

	if(sizeof(pez_real) == sizeof(pez_stackitem))
		d = *(pez_real *)S0;
	else
		memcpy((void *)&d, (void *)S0, sizeof(pez_real));
	Pop;
	Realpush(d);
}

/*  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.  Usually used implicitly by the compiler rather
	than by the user.
*/
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;
	}
	// curword points to the header, after which is the actual code.  See
	// also exword().
	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;
}

/*
   A jump to an IP-relative inline address.
*/
prim P_branch(pez_instance *p)
{
	p->ip += (pez_stackitem) *p->ip;
}

/*
   As above, but jump conditionally, if the top item on the stack is zero.
*/
prim P_qbranch(pez_instance *p)
{
	Sl(1);
	if(S0 == 0) {
		p->ip += (pez_stackitem) *p->ip - 1;
	}
	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
	Compconst(0);		// Reserve cell for LEAVE-taking
	So(1);
	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
}

/*
   Ends compile mode.
*/
prim P_semicolon(pez_instance *p)
{
	Compiling;
	Ho(1);
	Hstore = s_exit;
	state = Falsity;
	pez_stackitem *bit;
	char *diag;

	if(p->createword != NULL) {
		// We wait until now to plug the P_nest code so that it will be
		// present only in completed definitions:
		p->createword->wcode = P_nest;
		// Next, we loop over the body of the word, looking for
		// un-backpatched branches:
		// TODO:  This is a good place for a few compile-time checks,
		// and perhaps an optimization pass.
		for(bit = (pez_stackitem *)p->createword + Dictwordl;
				bit < p->hptr - 1;
				bit++) {
			if((*bit == s_qbranch || *bit == s_branch) && !bit[1]) {
				diag = alloc(1024);
				pez_forget_during_eval(p,
						p->createword->wname + 1);
				snprintf(diag, 1024, 
					"Zero branch in definition of %s!\n"
					"Non-terminated if/do/begin are "
					"likely culprits",
					p->createword->wname + 1);
				trouble(p, diag);
				return;
			}
		}
	}

	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 */
}

/*
   ( word -- )
   Executes the word on the top of the stack.  For example,
   	' cr execute
   is equivalent to
   	cr
*/
prim P_execute(pez_instance *p)
{
	// You've got to be a bit more careful inside here than one might
	// expect.
	pez_dictword **ip = p->ip;
	pez_dictword *wp;

	Sl(1);
	wp = (pez_dictword *)S0;
	Pop;	// Pop the word off the stack *before* calling it.
	// We have to save and restore the instruction pointer; otherwise,
	// exword will punish the stack.
	p->ip = NULL;
	exword(p, wp);
	p->ip = ip;
}

/*
   ( word n -- ... )
   Executes the supplied word n times.
   	' cr 5 times
   is equivalent to
   	cr cr cr cr cr
   You will probably want to make sure that the word is careful with the stack.
*/
prim P_times(pez_instance *p)
{
	// You've got to be a bit more careful inside here than one might
	// expect.
	pez_dictword **ip = p->ip;
	pez_dictword *wp;
	pez_stackitem n, i;

	Sl(2);
	Rso(1);
	n = S0;
	wp = (pez_dictword *)S1;
	Pop2;
	// We have to save and restore the instruction pointer; otherwise,
	// exword will punish the stack.
	p->ip = NULL;
	for(i = 0; i < n; i++)
		exword(p, wp);
	p->ip = ip;
}

/*
   ( pointer -- bool )
   True if the pointer is a valid word in the dictionary.
*/
prim P_wordp(pez_instance *p)
{
	Sl(1);
	S0 = -is_word(p, (pez_dictword *)S0);
}

/*
   FIXME: This is done, like, really poorly.
*/
prim P_tail_call(pez_instance *p)
{
	p->tail_call_pending = True;
}

/*
   ( word -- body-addr )
   Given a word, leaves the address of the word's body on the stack.  Don't do
   this to built-ins, you'll get nothing useful.
*/
prim P_body(pez_instance *p)
{
	Sl(1);
	S0 += Dictwordl * sizeof(pez_stackitem);
}

/*
   ( -- t|f )
   Pushes the address of the interpreter's state (the 'compiling' flag).
*/
prim P_state(pez_instance *p)
{
	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))

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

/*
   ( addr -- link )
   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)
}

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

/*
   ( name -- addr )
   Get compile address from name
*/
prim P_fromname(pez_instance *p)
{
	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 buf -- )
   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
/*
   ( string -- status )
   Makes a system call, returning the exit status of the process.
*/
prim P_system(pez_instance *p)
{
	Sl(1);
	Hpc(S0);
	S0 = system((char *)S0);
}

/*
   ( string -- fd pid )
   Makes a system call, and leaves on the stack its pid and a file descriptor to
   read its stdout from.
*/
prim P_money(pez_instance *p)
{
	Sl(1);
	So(1);
	Hpc(S0);

	int pid;
	int pipefd[2];
	char *cmd = (char *)S0;
	char *exec_argv[4] = { "sh", "-c", 0, 0 };

	Pop;

	if(pipe(pipefd) < 0) {
		Push = -1;
		Push = -1;
		return;
	}
	
	pid = fork();
	if(pid < 0) {
		Push = -1;
		Push = -1;
		return;
	}
	
	if(pid) {
		close(pipefd[1]);
		Push = pipefd[0];
		Push = pid;
	} else {
		close(pipefd[0]);
		dup2(pipefd[1], 1);
		exec_argv[2] = (char *)cmd;
		execv("/bin/sh", exec_argv);
	}
}
#endif	// SYSTEM

/*
   Starts a struct definition.
*/
prim P_struct_colon(pez_instance *p)
{
	int token;
	char *buf;

	p->createstruct = (pez_struct *)alloc(sizeof(pez_struct));

	buf = alloc(TOK_BUF_SZ);
	token = lex(p, &p->instream, buf);
	if(token != TokWord) {
		trouble(p, "Expected a word to follow 'struct:'");
		return;
	}

	p->createstruct->name = buf;
}

/*
   Ends a struct definition.
*/
prim P_semicolon_struct(pez_instance *p)
{
	pez_dictword *w;
	int namelen;
	char *buf;

	if(!p->createstruct) {
		trouble(p, "No struct to finish");
		return;
	}

	// First, we create a word named after the struct, which just pushes a
	// pointer to newly allocated memory in the size of that struct:
	Ho(Dictwordl);
	w = (pez_dictword *)p->hptr;
	p->hptr += Dictwordl;
	namelen = strlen(p->createstruct->name);
	buf = alloc(namelen + 2);
	memcpy(buf + 1, p->createstruct->name, namelen);
	w->wname = buf;
	w->wcode = P_nest;
	Hsingle(s_lit);
	Hsingle(p->createstruct->size);
	Hsingle((pez_stackitem)lookup(p, "malloc"));
	Hsingle(s_exit);
	w->wnext = p->dict;
	p->dict = w;

	// Next, we create a word that just pushes the size of the struct.
	Ho(Dictwordl);
	w = (pez_dictword *)p->hptr;
	p->hptr += Dictwordl;
	buf = alloc(namelen + 7);
	snprintf(buf + 1, namelen + 6, "%s-size", p->createstruct->name);
	w->wname = buf;
	w->wcode = P_nest;
	Hsingle(s_lit);
	Hsingle(p->createstruct->size);
	Hsingle(s_exit);
	w->wnext = p->dict;
	p->dict = w;

	// And now we're done.
	p->createstruct = NULL;
}

/*
   Defines a cell member of a struct.

   It creates three words, one that adds the offset, one that reads from that
   offset, and one that writes to the offset.
*/
prim P_cell_colon(pez_instance *p)
{
	pez_dictword *offsetw = (pez_dictword *)p->hptr, *w;
	pez_stackitem plus;
	int namelen, token;
	char *name, *buf;

	if(!p->createstruct) {
		trouble(p, "Tried to define struct member outside struct "\
				"definition");
		return;
	}

	plus = (pez_stackitem)lookup(p, "+");

	name = alloc(TOK_BUF_SZ);
	token = lex(p, &p->instream, name);
	if(token != TokWord) {
		trouble(p, "Expected a word to follow 'cell:'");
		return;
	}
	namelen = strlen(name);

	// ( struct-addr -- member-addr ) The offset-adder:
	Ho(Dictwordl);
	p->hptr += Dictwordl;
	buf = alloc(namelen + 2);
	memcpy(buf + 1, name, namelen);
	offsetw->wname = buf;
	offsetw->wcode = P_nest;
	offsetw->wnext = p->dict;
	p->dict = offsetw;
	if(p->createstruct->size) { // No point in adding zero.
		Hsingle(s_lit);
		Hsingle(p->createstruct->size);
		Hsingle(plus);
	}
	Hsingle(s_exit);

	// ( struct-addr -- member ) The reader:
	Ho(Dictwordl);

	buf = alloc(namelen + 3);
	sprintf(buf + 1, "%s@", name);
	w = (pez_dictword *)p->hptr;
	p->hptr += Dictwordl;
	w->wname = buf;
	w->wcode = P_nest;
	w->wnext = p->dict;
	p->dict = w;
	if(p->createstruct->size) {
		Hsingle(s_lit);
		Hsingle(p->createstruct->size);
		Hsingle(plus);
	}
	Hsingle((pez_stackitem)lookup(p, "@"));
	Hsingle(s_exit);

	// ( val struct-addr -- ) The writer:
	Ho(Dictwordl);
	w = (pez_dictword *)p->hptr;
	p->hptr += Dictwordl;
	buf = alloc(namelen + 3);
	sprintf(buf + 1, "%s!", name);
	w->wname = buf;
	w->wcode = P_nest;
	w->wnext = p->dict;
	p->dict = w;
	if(p->createstruct->size) {
		Hsingle(s_lit);
		Hsingle(p->createstruct->size);
		Hsingle(plus);
	}
	Hsingle((pez_stackitem)lookup(p, "!"));
	Hsingle(s_exit);

	// And, finally, we add the size of a cell to the size of the struct.
	p->createstruct->size += sizeof(pez_stackitem);
}

prim P_cells_colon(pez_instance *p)
{
	pez_dictword *w = (pez_dictword *)p->hptr;
	pez_stackitem plus;
	int namelen, token;
	char *name, *buf;

	if(!p->createstruct) {
		trouble(p, "Tried to define struct member outside struct "
				"definition");
		return;
	}
	Sl(1);

	plus = (pez_stackitem)lookup(p, "+");

	name = alloc(TOK_BUF_SZ);
	token = lex(p, &p->instream, name);
	if(token != TokWord) {
		trouble(p, "Expected a word to follow 'cells:'");
		return;
	}
	namelen = strlen(name);

	Ho(Dictwordl);
	p->hptr += Dictwordl;
	buf = alloc(namelen + 2);
	memcpy(buf + 1, name, namelen);
	w->wname = buf;
	w->wcode = P_nest;
	w->wnext = p->dict;
	p->dict = w;
	if(p->createstruct->size) { // No point in adding zero.
		Hsingle(s_lit);
		Hsingle(p->createstruct->size);
		Hsingle(plus);
	}
	Hsingle(s_exit);

	p->createstruct->size += S0 * sizeof(pez_stackitem);
	Pop;
}

/*
   ( n -- )
   Aligns a struct to the given boundary size (in bytes).
*/
prim P_align_struct(pez_instance *p)
{
	if(!p->createstruct) {
		trouble(p, "Tried to align struct outside struct definition");
		return;
	}
	Sl(1);

	p->createstruct->size = S0 * ((p->createstruct->size + (S0 - 1)) / S0);
	Pop;
}

// I know what you're about to think when you read the next line, and I can
// sympathize, but doing it otherwise presents the same issues that splitting
// up this file presents.  A sensible plan for fixing these issues is pending.
#include "type_primitives.c"

#ifdef FFI

static char *ffi_types_table[256] = {
	"void", 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	"unsigned char", 0, 0, 0, 0, 0, "unsigned int", 0, 0, 0, 0, 0, 0, 0,
	0, 0, "unsigned short", 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	"char", "double", 0, "float", 0, 0, "int", 0, 0, "long", 0, 0, 0,
	"void *", 0, 0, "short", 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
};

/*
   ( 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)
{
	Sl(1);
	char *libname = (char *)S0;
	if(pez_ffi_load(p, libname) < 0) {
		Push = 0;
	} else {
		Push = -1;
	}
}

/*
   ( 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();
}

/*
   ( libname -- )
   Defines an FFI library.  The .so filename is expected to be on the stack, and
   it reads the next word to use as the name of the library.
*/
prim P_ffi_lib_colon(pez_instance *p)
{
	pez_ffi_lib *lib = GC_MALLOC(sizeof(pez_ffi_lib));
	char *tmp;

	Sl(1);
	if(S0) // NULL is fine.  See dlopen(3).
		Hpc(S0);

	lib->sofile = dlopen((char *)S0, RTLD_LAZY);
	lib->name = S0 ? pez_strdup((char *)S0) : "[current process]";

	if(!lib->sofile) {
		trouble(p, "Error opening shared library!");
		tmp = dlerror();
		if(tmp)
			trouble(p, tmp);
		return;
	}

	S0 = (pez_stackitem)lib;
	P_constant(p);
}

/*
   Adds a file to be #include'd for ffi functions.
*/
prim P_ffi_include(pez_instance *p)
{
	pez_ffi_lib *l;
	pez_ffi_include *i;

	Sl(2);
	Hpc(S0);
	Hpc(S1);

	l = (pez_ffi_lib *)S0;
	i = (pez_ffi_include *)alloc(sizeof(pez_ffi_include));
	i->fname = (char *)S1;
	i->next = l->includes;
	l->includes = i;

	Npop(2);
}

// Just a few macros for the somewhat complicated FFI stuff:
#define emit(s) (ccode = pez_strcat(ccode, (s)))
#define RETFLOAT 1
#define RETINT 2

/*
   Adds the includes from lib to the C code, returns the result as a GC'd
   string.
*/
static char *add_ffi_includes(pez_ffi_lib *lib, char *ccode)
{
	pez_ffi_include *inc;

	inc = lib->includes;
	while(inc) {
		emit("#include <");
		emit(inc->fname);
		emit(">\n");
		inc = inc->next;
	}

	return ccode;
}

#define tbsz 1024
/*
   Define an FFI call.
*/
prim P_ffi_colon(pez_instance *p)
{
	// Only ~17 local vars and only ~200 lines!  Brevity, clean design, this
	// function has it al--oh, who am I kidding, FIXME all over this chunk.
	TCCState *s;
	long fsz;
	int i, arglen, nstackitems = 0, rs, nfstackitems = 0, fs, retstack = 0;
	unsigned char *args, *ret;
	char *fname, *ccode, tmpbuf[tbsz];
	pez_ffi_lib *lib;
	void *f;

	Sl(4);
	ret = (unsigned char *)S3;
	Hpc(S3);
	fname = (char *)S2;
	Hpc(S2);
	args = (unsigned char *)S1;
	Hpc(S1);
	lib = (pez_ffi_lib *)S0;
	Hpc(S0);
	Npop(4);

	if(ret && !*ret) ret = 0;
	if(args && !*args) args = 0;

	f = dlsym(lib->sofile, fname);

	if(!f) {
		pez_error(p, pez_strcat("Function \"",
			pez_strcat(fname,
				"\" not found when compiling ffi: call!")));
			
		return;
	}

	P_create(p);

	ccode = add_ffi_includes(lib,
			"#include <pez.h>\n"
			"#include <pezdef.h>\n");

	emit("\n"
	     "void ffi_call(pez_instance *p)\n"
	     "{\n");

	// Figure out the stack that the return value goes onto:
	if(ret) {
		switch(*ret) {
		// Return values pushed onto the regular stack:
		case 'p': case 'i': case 'c': case 'l': case 's':
			retstack = RETINT;
			emit("pez_stackitem ret;\n\n");
			break;
		// Return values pushed onto the float stack:
		case 'f': case 'd':
			retstack = RETFLOAT;
			emit("pez_real ret;\n\n");
			break;
		default:
			snprintf(tmpbuf, tbsz,
				"Unrecognized return type \"%c\" in ffi: call "
				"for \"%s\"!", *ret, fname);
			pez_error(p, tmpbuf);
			return;
		}
	}

	// Check to see how many arguments we have, and which stack they come
	// from:
	if(args) {
		arglen = strlen((char *)args);
		for(i = 0; i < arglen; i++) {
			switch(args[i]) {
			// Args that come off the regular stack:
			case 'p': case 'i': case 'c': case 'l': case 's':
				nstackitems++;
				break;
			// Args that come off the float stack:
			case 'f': case 'd':
				nfstackitems++;
				break;
			default:
				snprintf(tmpbuf, tbsz,
					"Unrecognized arg type \"%c\" in ffi: "
					"call for \"%s\"!", args[i], fname);
				pez_error(p, tmpbuf);
				return;
			}
		}

		if(nstackitems > 0) {
			snprintf(tmpbuf, tbsz, "Sl(%d);\nNpop(%d);\n",
					nstackitems, nstackitems);
			emit(tmpbuf);
		}
		if(nfstackitems > 0) {
			snprintf(tmpbuf, tbsz, "FSl(%d);\nNRealpop(%d);\n",
					nfstackitems, nfstackitems);
			emit(tmpbuf);
		}
	}

	// If nothing was popped, we need to check overflow before pushing:
	if(retstack == RETINT) {
		if(!nstackitems)
			emit("So(1);\n");
		emit("ret = (pez_stackitem)");
	} else if(retstack == RETFLOAT) {
		if(!nfstackitems)
			emit("FSo(1);\n");
	}

	if(ret) {
		emit("ret = ");
	}

	emit(fname);
	emit("(");
	if(args && *args) {
		rs = fs = 0;
		for(i = 0; i < arglen; i++) {
			switch(args[i]) {
			// Args that come off the regular stack:
			case 'p': case 'i': case 'c': case 'l': case 's':
				snprintf(tmpbuf, tbsz, "%s(%s)(p->stk[%d])",
					i ? ", " : "",
					ffi_types_table[args[i]], rs++);
				emit(tmpbuf);
				break;
			// Args that come off the float stack:
			case 'f': case 'd':
				snprintf(tmpbuf, tbsz, "%s(%s)p->fstk[%d]",
					i ? ", " : "",
					ffi_types_table[args[i]], fs++);
				emit(tmpbuf);
				break;
			// We've already checked above that the types are sane.
			}
		}
	}
	emit(");\n");

	if(retstack == RETINT) {
		emit("Push = ret;\n");
	} else if(retstack == RETFLOAT && !nfstackitems) {
		emit("Realpush(ret);\n");
	}

	emit("\nreturn;\n}\n");

	// Compile it, finally, damn!
	s = tcc_new();
	if(!s) {
		pez_error(p, "Could not create a new TCC state when "
			"compiling FFI call!");
		return;
	}

	if(tcc_set_output_type(s, TCC_OUTPUT_MEMORY) == -1) {
		pez_error(p, "Couldn't set TCC output type to \"memory\".");
		return;
	}

	if(tcc_compile_string(s, ccode) == -1) {
		pez_error(p, pez_strcat("Couldn't compile FFI call to ",
					fname));
		return;
	}

	tcc_add_symbol(s, fname, f);
	tcc_add_symbol(s, "trouble", trouble);

	fsz = tcc_relocate(s, 0);
	if(fsz < 0) {
		pez_error(p, "Couldn't relocate ffi function!");
		return;
	}

	f = (void *)alloc(fsz);
	tcc_relocate(s, f);
	p->createword->wcode = tcc_get_symbol(s, "ffi_call");
	if(!p->createword->wcode) {
		p->createword->wcode = P_var;
		pez_error(p, "Error getting symbol from compiled FFI function!");
		return;
	}

	tcc_delete(s);
}
#undef tbsz

/*
   ( type name lib -- )
   Define a value to push.  Useful for, e.g., using macros that resolve to
   literals by name.  For example:
   	"i" "O_RDONLY" libc ffi-const: o_rdonly
   	"i" "O_WRONLY" libc ffi-const: o_wronly
*/
prim P_ffi_const(pez_instance *p)
{
	TCCState *s;
	pez_ffi_lib *lib;
	long fsz;
	char *cname, *ccode, *c;
	int ctype;
	void *f;
	
	Sl(3);
	Hpc(S0);
	Hpc(S1);
	Hpc(S2);

	lib = (pez_ffi_lib *)S0;
	cname = (char *)S1;
	ctype = *((unsigned char *)S2);

	Npop(3);

	if(!ffi_types_table[ctype]) {
		pez_error(p,
			pez_strcat("Could not determine return type of ",
				pez_strcat(cname, "!")));
		return;
	}

	for(c = cname; *c; c++) {
		if(!((*c >= 'a' && *c <= 'z') ||
		     (*c >= 'A' && *c <= 'Z') ||
		     (*c >= '0' && *c <= '9') ||
		     *c == '_')) {
			pez_error(p,
				pez_strcat("Invalid identifier name \"",
				pez_strcat(cname,
					"\" when defining FFI constant.")));
			return;
		}
	}

	P_create(p);
	ccode = add_ffi_includes(lib,
			"#include <pez.h>\n"
			"#include <pezdef.h>\n");

	emit("\n"
	     "void ffi_call(pez_instance *p)\n"
	     "{\n");

	switch(ctype) {
	// Return values pushed onto the regular stack:
	case 'p': case 'i': case 'c': case 'l': case 's':
		emit("So(1);\n"
		     "Push = ");
		emit(cname);
		emit(";\n");
		break;
	case 'f': case 'd':
		emit("FSo(1);\n"
		     "Realpush(");
		emit(cname);
		emit(";\n");
		break;
	default:
		pez_error(p, "Programmer error in P_ffi_const!");
		return;
	}

	emit("}\n");

	// Compile it, finally, damn!
	s = tcc_new();
	if(!s) {
		pez_error(p, "Could not create a new TCC state when "
			"compiling FFI call!");
		return;
	}

	if(tcc_set_output_type(s, TCC_OUTPUT_MEMORY) == -1) {
		pez_error(p, "Couldn't set TCC output type to \"memory\".");
		return;
	}

	if(tcc_compile_string(s, ccode) == -1) {
		pez_error(p, "Couldn't compile FFI call!");
		return;
	}

	tcc_add_symbol(s, "trouble", trouble);

	fsz = tcc_relocate(s, 0);
	if(fsz < 0) {
		pez_error(p, "Couldn't relocate ffi function!");
		return;
	}

	f = (void *)alloc(fsz);
	tcc_relocate(s, f);
	p->createword->wcode = tcc_get_symbol(s, "ffi_call");
	if(!p->createword->wcode) {
		p->createword->wcode = P_var;
		pez_error(p,
			"Error getting symbol from compiled FFI function!");
		return;
	}

	tcc_delete(s);
}

#undef emit
#undef RETFLOAT
#undef RETINT

/*
   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>

/*
   ( seconds -- )
   Sleeps the specified number of seconds.
*/
prim P_sleep(pez_instance *p)
{
	Sl(1);
	sleep(S0);
	Pop;
}

/*
   ( seconds -- )
   Sleeps the specified number of seconds, which are passed as a float.
*/
prim P_fsleep(pez_instance *p)
{
	FSl(1);
	double t = REAL0;
	Realpop;
	usleep((long)(t * 1000000.0));
}

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

/*
   ( status -- )
   Just exits; no message.
*/
prim P_die(pez_instance *p)
{
	// No underflow-checking here.  die shouldn't fail, ever, even if it
	// ends up segfaulting instead.
	exit(S0);
}

/*
   ( 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 *)&S0);
}

PUSH_CONSTANT(P_wait_untraced, WUNTRACED)
PUSH_CONSTANT(P_wait_nohang, WNOHANG)

/*
   ( pid flags -- status )
   Waits for the pid to exit, and returns its status.
*/
prim P_waitpid(pez_instance *p)
{
	Sl(2);
	int pid, status, options;

	pid = (int)S1;
	options = (int)S0;
	Pop;

	waitpid(pid, &status, options);
	S0 = (pez_stackitem)status;
}

/*
   ( -- 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.
// TODO:  At some point, probably the same time the above happens, change these
// all to lower-case and drop the case-insensitivity from dictionary lookups.
static struct primfcn primt[] = {
	// We open with a severely long list of size and load/store words for
	// all of the types one might run into when inter-operating with C.
	{"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-pointer@", P_c_pointer_at},
	{"0c-pointer!", P_c_pointer_bang},
	{"0c-short-size", P_c_short_size},
	{"0c-shorts", P_c_shorts},
	{"0c-short@", P_c_short_at},
	{"0c-short!", P_c_short_bang},
	{"0c-long-size", P_c_long_size},
	{"0c-longs", P_c_longs},
	{"0c-long@", P_c_long_at},
	{"0c-long!", P_c_long_bang},
	{"0c-int-size", P_c_int_size},
	{"0c-ints", P_c_ints},
	{"0c-int@", P_c_int_at},
	{"0c-int!", P_c_int_bang},
	{"0c-float-size", P_c_float_size},
	{"0c-floats", P_c_floats},
	{"0c-float@", P_c_float_at},
	{"0c-float!", P_c_float_bang},
	{"0c-double-size", P_c_double_size},
	{"0c-doubles", P_c_doubles},
	{"0c-double@", P_c_double_at},
	{"0c-double!", P_c_double_bang},
	{"0int8-size", P_int8_size},
	{"0int8s", P_int8s},
	{"0int8@", P_int8_at},
	{"0int8!", P_int8_bang},
	{"0uint8-size", P_uint8_size},
	{"0uint8s", P_uint8s},
	{"0uint8@", P_uint8_at},
	{"0uint8!", P_uint8_bang},
	{"0int16-size", P_int16_size},
	{"0int16s", P_int16s},
	{"0int16@", P_int16_at},
	{"0int16!", P_int16_bang},
	{"0uint16-size", P_uint16_size},
	{"0uint16s", P_uint16s},
	{"0uint16@", P_uint16_at},
	{"0uint16!", P_uint16_bang},
	{"0int32-size", P_int32_size},
	{"0int32s", P_int32s},
	{"0int32@", P_int32_at},
	{"0int32!", P_int32_bang},
	{"0uint32-size", P_uint32_size},
	{"0uint32s", P_uint32s},
	{"0uint32@", P_uint32_at},
	{"0uint32!", P_uint32_bang},
	{"0int64-size", P_int64_size},
	{"0int64s", P_int64s},
	{"0int64@", P_int64_at},
	{"0int64!", P_int64_bang},
	{"0uint64-size", P_uint64_size},
	{"0uint64s", P_uint64s},
	{"0uint64@", P_uint64_at},
	{"0uint64!", P_uint64_bang},

	{"0+", P_plus},
	{"0-", P_minus},
	{"0*", P_mul},
	{"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},
	{"0tuck", P_tuck},
	{"0ROLL", P_roll},
	{"0>R", P_tor},
	{"0R>", P_rfrom},
	{"0R@", P_rfetch},
	{"0RDROP", P_rdrop},
	{"0TIME", P_time},
	{"0rand", P_rand},

	{"01+", P_1plus},
	{"02+", P_2plus},
	{"01-", P_1minus},
	{"02-", P_2minus},
	{"02*", P_2mul},
	{"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},
	{"02tuck", P_2tuck},
	{"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},
	{"0Fnip", P_fnip},
	{"0Ftuck", P_ftuck},
	{"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},
	{"0realloc", P_realloc},
	{"0memcpy", P_memcpy},
	{"0HERE", P_here},

	{"0PEZ-BINDIR", P_pezconf_bindir},
	{"0PEZ-LIBDIR", P_pezconf_libdir},
	{"0PEZ-PEZ-LIBDIR", P_pezconf_pez_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},
	{"0sdup", P_sdup},
	{"0S+", P_splus},
	{"0chomp!", P_chomp_bang},
	{"0chomp", P_chomp},
	{"0STRLEN", P_strlen},
	{"0STRCMP", P_strcmp},
	{"0STRNCMP", P_strncmp},
	{"0STRCHAR", P_strchar},
	{"0SUBSTR", P_substr},
	{"0STRFORM", P_strform},
	{"0format", P_format},
	{"0FSTRFORM", P_fstrform},
	{"0STRINT", P_strint},
	{"0atoi", P_atoi},
	{"0STRREAL", P_strreal},
	{"0REGEX", P_regex},
	{"0RMATCH", P_rmatch},
	{"0$pre", P_moneypre},
	{"0$post", P_moneypost},
	{"0rsub", P_rsub},
	{"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},

	{"0htable", P_htable},
	{"0str-htable", P_str_htable},
	{"0ht!", P_htbang},
	{"0ht@", P_htat},
	{"0ht?", P_htp},
	{"0ht-dup", P_ht_dup},
	{"0ht-clear", P_ht_clear},
	{"0ht-size", P_ht_size},
	{"0ht-keys", P_ht_keys},
	{"0ht-values", P_ht_values},

	{"0(FLIT)", P_flit},
	{"0F+", P_fplus},
	{"0F-", P_fminus},
	{"0F*", P_fmul},
	{"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},
	{"0floor", P_floor},
	{"0ceil", P_ceil},
	{"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},
	{"0log10", P_log10},
	{"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},
	{"0$", P_money},
#endif

	{"0struct:", P_struct_colon},
	{"0;struct", P_semicolon_struct},
	{"0cell:", P_cell_colon},
	{"0cells:", P_cells_colon},
	{"0align-struct", P_align_struct},

#ifdef FFI
	{"0FFI-LOAD", P_ffi_load},
	{"0DLOPEN", P_dlopen},
	{"0DLSYM", P_dlsym},
	{"0DLERROR", P_dlerror},
	{"0ffi-lib:", P_ffi_lib_colon},
	{"0ffi-include", P_ffi_include},
	{"0ffi:", P_ffi_colon},
	{"0ffi-const:", P_ffi_const},

	// 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
	{"0sleep", P_sleep},
	{"0fsleep", P_fsleep},
	{"0ENVIRON", P_environ},
	{"0GETENV", P_getenv},
	{"0SETENV", P_setenv},
	{"0UNSETENV", P_unsetenv},
	{"0DIE", P_die},
	{"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},
	{"0waitpid", P_waitpid},
	{"0wait_untraced", P_wait_untraced},
	{"0wait_nohang", P_wait_nohang},
	{"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},
	{"0times", P_times},
	{"0word?", P_wordp},
	{"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},
	{"0f.s", P_fdots},
	{"0nf.s", P_nfdots},
	{"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},
	{"0pipe", P_pipe},
	{"0fddup", P_fddup},
	{"0fddup2", P_fddup2},
	{"0load-paths", P_load_paths},
	{"0add-load-path", P_add_load_path},
	{"0which-lib", P_which_lib},
	{"0load-lib", P_load_lib},
	{"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}
};

/*
   Loads a library on the fly.  The library is expected to export at least one
   of two symbols:
   	void pez_ffi_init(pez_instance *p)
	struct primfcn pez_ffi_definitions[]
   The initializer will be called first, and then the defs will be added to the
   instance of Pez.

   On success, 0 is returned.  If the library couldn't be opened, it returns -2
   and dlerror() will return something appropriate.  If neither symbol could be
   resolved, then the it returns -1.
*/
int pez_ffi_load(pez_instance *p, char *libname)
{
	void *lib;
	void (*init)(pez_instance *p);
	struct primfcn *defs;

	// TODO:  Remembering libraries that have been loaded.
	lib = dlopen(libname, RTLD_NOW);
	if(!lib) {
		return -2;
	}

	init = dlsym(lib, "pez_ffi_init");
	defs = dlsym(lib, "pez_ffi_definitions");
	if(!(init || defs)) {
		return -1;
	}

	dlerror();		// Which clears the last error.
	if(init)
		init(p);
	if(defs)
		pez_primdef(p, defs);
	return 0;
}


/*
   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 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

/*
   Execute a word (and any sub-words it may invoke).  Note that it will continue
   to execute until p->ip is NULL, so take care to save and restore it if you
   don't want exword() to take over until you hit the toplevel again.
*/
static inline void exword(pez_instance *p, pez_dictword *wp)
{
	pez_dictword *nw = wp;
	pez_wordp nwc;

	while(1) {
		nwc = nw->wcode;
		p->curword = nw;

		Keybreak();	// Check if we received an interrupt.
		if(p->broken) {
			trouble(p, "Break signal");
			p->evalstat = PEZ_BREAK;
			break;
		}

		tracing {
			printf("\nTrace: %s ", nw->wname + 1);
			fflush(stdout);
		}

		nwc(p);

		if(!p->ip) {
			p->curword = NULL;
			return;
		}

		nw = *p->ip++;
	}
}

/*
   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.

   TODO:  
*/
extern pez_instance *pez_init(long flags)
{
	static int gc_already_inited = 0;
	pez_instance *p;
	int i;
	char *pathtmp;

	// To (hopefully) increase cache hits, we allocate the interpreter and the
	// fixed buffers as a chunk of contiguous memory, and set pointers.
	long stklen = 5000, fstklen = 3500, rstklen = 5000, heaplen = 25000;
	long allocsz =
		sizeof(pez_instance) +
		(stklen * sizeof(pez_stackitem)) + (sizeof(pez_stackitem) - 1) +
		(fstklen * sizeof(pez_real)) + (sizeof(pez_real) - 1) +
		(rstklen * sizeof(pez_dictword **)) + (sizeof(pez_dictword **) - 1) +
		(heaplen * sizeof(pez_stackitem)) + (sizeof(pez_stackitem) - 1);
#ifdef WALKBACK
	allocsz += rstklen * sizeof(pez_dictword *) + (sizeof(pez_dictword *) - 1);
#endif

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

	char *cmem = (char *)alloc(allocsz);
#define ALIGN_CMEM(x, n) do { \
		cmem += ((n) - 1); \
		cmem = (char *)(((long)cmem) & (~((n) - 1))); \
	} while(0)

	p = (pez_instance *)cmem;
	cmem += sizeof(pez_instance);

	p->stklen = stklen;    // Evaluation stack length
	p->fstklen = fstklen;  // Float stack length
	p->rstklen = rstklen;  // Return stack length
	p->heaplen = heaplen;  // Heap length

	ALIGN_CMEM("STACK", sizeof(pez_stackitem));
	p->stk = p->stack = (pez_stackitem *)cmem;
	cmem += sizeof(pez_stackitem) * stklen;
#ifdef MEMSTAT
	p->stackmax = p->stack;
#endif
	p->stacktop = p->stack + p->stklen;

	ALIGN_CMEM("RSTACK", sizeof(pez_dictword **));
	p->rstk = p->rstack = (pez_dictword ***)cmem;
	cmem += sizeof(pez_dictword **) * rstklen;
	// The return stack:
	if(p->rstack == NULL) {	// Allocate return stack if needed
		p->rstack = (pez_dictword ***)alloc(((unsigned int)p->rstklen) *
					sizeof(pez_dictword **));
	}
#ifdef MEMSTAT
	p->rstackmax = p->rstack;
#endif
	p->rstacktop = p->rstack + p->rstklen;

#ifdef WALKBACK
	ALIGN_CMEM("WALKBACK", sizeof(pez_dictword *));
	p->wbptr = p->wback = (pez_dictword **)cmem;
	cmem += sizeof(pez_dictword **) * rstklen;
#endif

	ALIGN_CMEM("REAL", sizeof(pez_real));
	p->fstk = p->fstack = (pez_real *)cmem;
	cmem += sizeof(pez_real) * fstklen;
#ifdef MEMSTAT
	p->fstackmax = p->fstack;
#endif
	p->fstacktop = p->fstack + p->fstklen;

	ALIGN_CMEM("HEAP", sizeof(pez_stackitem));
	p->heap = (pez_stackitem *)cmem;
	cmem += sizeof(pez_stackitem) * heaplen;
	/*
	   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;

#undef ALIGN_CMEM
	
	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->base = 10;
	p->broken = Falsity;
	p->instream = NULL;

	pathtmp = alloc(sizeof(PEZCONF_PEZ_LIBDIR));
	strcpy(pathtmp, PEZCONF_PEZ_LIBDIR);

	p->load_path = (pez_load_path *)alloc(sizeof(pez_load_path));
	p->load_path->path = pathtmp;
	p->load_path->next = NULL;

	p->already_loaded = (pez_load_path *)alloc(sizeof(pez_load_path));
	p->already_loaded->path = alloc(1);
	p->already_loaded->path[0] = '\0';
	p->already_loaded->next = 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;

	// Define primitive words, first the memory/struct stuff, then the
	// regular set of words.
	pez_primdef(p, memory_primitives);
	pez_primdef(p, primt);
	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 {\
		if(!(cell)) { (cell) = (pez_stackitem)lookup(p, name); }\
		if(!(cell)) {\
			fprintf(stderr, \
				"Compiler error!  Couldn't lookup %s!  " \
				"Aborting!\n", name); \
			    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

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

/*  
    Execute a word, given an instance of Pez and 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->mfstack = p->fstk;	// Save float 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->fstk = mp->mfstack;	// Roll back the float stack.
	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

static char *pez_cjoin(char c, char *first, char *second)
{
	int flen = strlen(first), slen = strlen(second);
	char *joined;

	// Both strings, the character, and a NULL:
	joined = alloc(flen + slen + 2);

	memcpy(joined, first, flen);
	joined[flen] = c;
	memcpy(joined + flen + 1, second, slen);
	return joined;
}

static int pez_file_exists(char *path)
{
	struct stat *ignored = (struct stat *)alloc(sizeof(struct stat));
	return !stat(path, ignored);
}

/*
   Given a library name, returns the library to load.  It first tries to load
   the file, then the file with a .pez extension, and then with a .so extension.
*/
char *pez_which_lib(pez_instance *p, char *libname)
{
	pez_load_path *cur = p->load_path;
	char *try, *suffixed;
	while(cur) {
		try = pez_cjoin('/', cur->path, libname);
		if(pez_file_exists(try))
			return try;
		suffixed = pez_cjoin('.', try, "pez");
		if(pez_file_exists(suffixed))
			return suffixed;
		suffixed = pez_cjoin('.', try, "so");
		if(pez_file_exists(suffixed))
			return suffixed;
		cur = cur->next;
	}
	return NULL;
}

/*  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},
	};

	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 a new GC'd buffer, and push it onto the stack.
*/
void pez_stack_string(pez_instance *p, char *str)
{
	So(1);
	Push = (pez_stackitem)pez_strdup(str);
}

void pez_heap_int(pez_instance *p, pez_int val)
{
	// Compile a (LIT), and store the literal inline.
	Ho(2);
	Hstore = s_lit;
	Hstore = val;
}

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

void pez_heap_float(pez_instance *p, pez_real val)
{
	Ho(Realsize + 1);
	Hstore = s_flit;	// Push (flit) at execution
	if(sizeof(pez_real) == sizeof(pez_stackitem))
		*(pez_real *)p->hptr = val;
	else
		memcpy((void *)p->hptr, (void *)&val, sizeof(pez_real));
	p->hptr += Realsize;
}

void pez_stack_float(pez_instance *p, pez_real val)
{
	FSo(1);
	Realpush(val);
}

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

}

/*
   Returns true if Pez is anticipating a token, as in the case of : or create.
*/
int pez_anticipating_token(pez_instance * p)
{
	return(p->tickpend || p->ctickpend || p->cbrackpend || p->defpend ||
		p->forgetpend);
}

/*
   Tokenize and execute the supplied input in the supplied Pez instance.
*/
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_float(p, p->tokreal);
			else
				pez_stack_float(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;
}

long pez_pop_int(pez_instance *p)
{
	long ret;

	Sl(1);
	ret = S0;
	Pop;
	return ret;
}

double pez_pop_float(pez_instance *p)
{
	double ret;

	FSl(1);
	ret = REAL0;
	Realpop;
	return ret;
}