UNSLISP/miniscm/miniscm.c

/*
 *      ---------- Mini-Scheme Interpreter Version 0.85 ----------
 *
 *                coded by Atsushi Moriwaki (11/5/1989)
 *
 *            E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
 *
 *               THIS SOFTWARE IS IN THE PUBLIC DOMAIN
 *               ------------------------------------
 * This software is completely free to copy, modify and/or re-distribute.
 * But I would appreciate it if you left my name on the code as the author.
 *
 */
/*--
 *
 *  This version has been modified by R.C. Secrist.
 *
 *  Mini-Scheme is now maintained by Akira KIDA.
 *
 *  This is a revised and modified version by Akira KIDA.
 *	current version is 0.85k4 (15 May 1994)
 *
 *  Please send suggestions, bug reports and/or requests to:
 *		<SDI00379@niftyserve.or.jp>
 *--
 */ 

/* This version of MiniScheme has been modified to bootstrap UNSLISP.
 *
 * Additions:
 * * Proper support for disabling quasiquote
 * * Chars
 * * Proper support for changing init file by preprocessor define
 * * Ports
 *
 * Ports and chars only support the minimum necessary to run UNSLISP.
 * The eof-object is #f. (Defining an entire type for EOF seems like
 * a kludge. An EOF test function would be a better design.)
 */

/*
 * Here is System declaration.
 * Please define exactly one symbol in the following section.
 */
/* #define LSC		*/	/* LightSpeed C for Macintosh */
/* #define LSC4		*/	/* THINK C version 4.0 for Macintosh */
/* #define MPW2		*/	/* Macintosh Programmer's Workshop v2.0x */
/* #define BSD		*/	/* 4.x BSD */
/* #define MSC		*/	/* Microsoft C Compiler v.4.00 - 7.00 */
/* #define TURBOC	*/	/* Turbo C compiler v.2.0, or TC++ 1.0  */
/* #define SYSV		*/	/* System-V, or POSIX */
/* #define VAXC		*/	/* VAX/VMS VAXC 2.x or later */ /* (automatic) */

#ifdef __BORLANDC__	/* Borland C++ - MS-DOS */
#define TURBOC
#endif

#ifdef __TURBOC__	/* Turbo C V1.5 - MS-DOS */
#define TURBOC
#endif

#ifdef mips		/* DECstation running OSF/1 */
#define BSD
#endif

#ifdef __osf__		/* Alpha AXP running OSF/1 */
#define BSD
#endif

#ifdef __DECC		/* Alpha AXP running VMS */
#define VAXC
#endif

#ifdef _AIX		/* RS/6000 running AIX */
#define BSD
#endif

/*
 * Define or undefine following symbols as you need.
 */
/* #define VERBOSE */	/* define this if you want verbose GC */
#define	AVOID_HACK_LOOP	/* define this if your compiler is poor
			 * enougth to complain "do { } while (0)"
			 * construction.
			 */

#if 0
#define USE_SETJMP	/* undef this if you do not want to use setjmp() */
#define USE_QQUOTE	/* undef this if you do not need quasiquote */
#define USE_MACRO	/* undef this if you do not need macro */
#endif

#define USE_MACRO

#ifdef USE_QQUOTE
/*--
 *  If your machine can't support "forward single quotation character"
 *  i.e., '`',  you may have trouble to use backquote.
 *  So use '^' in place of '`'.
 */
# define BACKQUOTE '`'
#endif

/*
 *  Basic memory allocation units
 */

#ifdef TURBOC             	/* rcs */
#define CELL_SEGSIZE  2048
#define CELL_NSEGMENT  100
#define STR_SEGSIZE   2048
#define STR_NSEGMENT   100
#else
#define CELL_SEGSIZE    5000	/* # of cells in one segment */
#define CELL_NSEGMENT   100	/* # of segments for cells */
#define STR_SEGSIZE     2500	/* bytes of one string segment */
#define STR_NSEGMENT    100	/* # of segments for strings */
#endif



#define banner "UNSLISP MiniScheme 0.85k4-a fork. Must be run from the \n\
UNSLISP repository root directory.\n"


#include <stdio.h>
#include <ctype.h>
#ifdef USE_SETJMP
#include <setjmp.h>
#endif


/* System dependency */
#ifdef LSC
#include <strings.h>
#include <unix.h>
#define malloc(x)	NewPtr((long)(x))
#define prompt "> "
#define FIRST_CELLSEGS 5
#endif

#ifdef LSC4
#include <string.h>
#include <stdlib.h>
#define malloc(x)	NewPtr((long)(x))
#define prompt "> "
#define FIRST_CELLSEGS 5
#endif

#ifdef MPW2
#include <strings.h>
#include <memory.h>
#define malloc(x)	NewPtr((long)(x))
#define prompt "> [enter at next line]\n"
#define FIRST_CELLSEGS 5
#endif

#ifdef BSD
#include <strings.h>
#include <signal.h>
#define prompt "> "
#define FIRST_CELLSEGS 10
#endif

#ifdef MSC
#include <string.h>
#include <stdlib.h>
#include <malloc.h>
#include <process.h>
#define prompt "> "
#define FIRST_CELLSEGS 3
#endif

#ifdef TURBOC
#include <string.h>
#include <stdlib.h>
#define prompt "> "
#define FIRST_CELLSEGS 3
#endif

#ifdef SYSV
#include <string.h>
#include <malloc.h>
#if __STDC__
# include <stdlib.h>
#endif
#define prompt "> "
#define FIRST_CELLSEGS 10
#endif

#ifdef	VAXC
#include <string.h>
#include <stdlib.h>
#define prompt "> "
#define FIRST_CELLSEGS 10
#endif

#ifdef __GNUC__
/*
 * If we use gcc, AVOID_HACK_LOOP is unnecessary
 */
#undef AVOID_HACK_LOOP
#endif

#ifndef	FIRST_CELLSEGS
#error Please define your system type.
/*
 * We refrain this to raise an error anyway even if on pre-ANSI system.
 */
error Please define your system type.
#endif

/* cell structure */
struct cell {
	unsigned short _flag;
	union {
		struct {
			char   *_svalue;
			short   _keynum;
		} _string;
		struct {
			long    _ivalue;
		} _number;
		struct {
			struct cell *_car;
			struct cell *_cdr;
		} _cons;
	} _object;
};

typedef struct cell *pointer;

#define T_STRING         1	/* 0000000000000001 */
#define T_NUMBER         2	/* 0000000000000010 */
#define T_SYMBOL         4	/* 0000000000000100 */
#define T_SYNTAX         8	/* 0000000000001000 */
#define T_PROC          16	/* 0000000000010000 */
#define T_PAIR          32	/* 0000000000100000 */
#define T_CLOSURE       64	/* 0000000001000000 */
#define T_CONTINUATION 128	/* 0000000010000000 */
#ifdef USE_MACRO
# define T_MACRO        256	/* 0000000100000000 */
#endif
#define T_PROMISE      512	/* 0000001000000000 */
#define T_CHAR        1024      /* 0000010000000000 */
#define T_PORT        2048      /* 0000100000000000 */
#define T_ATOM       16384	/* 0100000000000000 */	/* only for gc */
#define CLRATOM      49151	/* 1011111111111111 */	/* only for gc */
#define MARK         32768	/* 1000000000000000 */
#define UNMARK       32767	/* 0111111111111111 */

/* macros for cell operations */
#define type(p)         ((p)->_flag)

#define isstring(p)     (type(p)&T_STRING)
#define strvalue(p)     ((p)->_object._string._svalue)
#define keynum(p)       ((p)->_object._string._keynum)

#define isnumber(p)     (type(p)&T_NUMBER)
#define ivalue(p)       ((p)->_object._number._ivalue)
#define ischar(p)       (type(p)&T_CHAR)

#define ispair(p)       (type(p)&T_PAIR)
#define car(p)          ((p)->_object._cons._car)
#define cdr(p)          ((p)->_object._cons._cdr)

#define issymbol(p)     (type(p)&T_SYMBOL)
#define symname(p)      strvalue(car(p))
#define hasprop(p)      (type(p)&T_SYMBOL)
#define symprop(p)      cdr(p)

#define isport(p)       (type(p)&T_PORT)

#define issyntax(p)     (type(p)&T_SYNTAX)
#define isproc(p)       (type(p)&T_PROC)
#define syntaxname(p)   strvalue(car(p))
#define syntaxnum(p)    keynum(car(p))
#define procnum(p)      ivalue(p)

#define isclosure(p)    (type(p)&T_CLOSURE)
#ifdef USE_MACRO
# define ismacro(p)      (type(p)&T_MACRO)
#endif
#define closure_code(p) car(p)
#define closure_env(p)  cdr(p)

#define iscontinuation(p) (type(p)&T_CONTINUATION)
#define cont_dump(p)    cdr(p)

#define ispromise(p)    (type(p)&T_PROMISE)
#define setpromise(p)   type(p) |= T_PROMISE

#define isatom(p)       (type(p)&T_ATOM)
#define setatom(p)      type(p) |= T_ATOM
#define clratom(p)      type(p) &= CLRATOM

#define ismark(p)       (type(p)&MARK)
#define setmark(p)      type(p) |= MARK
#define clrmark(p)      type(p) &= UNMARK

#define caar(p)         car(car(p))
#define cadr(p)         car(cdr(p))
#define cdar(p)         cdr(car(p))
#define cddr(p)         cdr(cdr(p))
#define cadar(p)        car(cdr(car(p)))
#define caddr(p)        car(cdr(cdr(p)))
#define cadaar(p)       car(cdr(car(car(p))))
#define cadddr(p)       car(cdr(cdr(cdr(p))))
#define cddddr(p)       cdr(cdr(cdr(cdr(p))))

/* arrays for segments */
pointer cell_seg[CELL_NSEGMENT];
int     last_cell_seg = -1;
char   *str_seg[STR_NSEGMENT];
int     str_seglast = -1;

/* We use 4 registers. */
pointer args;			/* register for arguments of function */
pointer envir;			/* stack register for current environment */
pointer code;			/* register for current code */
pointer dump;			/* stack register for next evaluation */

struct cell _NIL;
pointer NIL = &_NIL;		/* special cell representing empty cell */
struct cell _T;
pointer T = &_T;		/* special cell representing #t */
struct cell _F;
pointer F = &_F;		/* special cell representing #f */
pointer oblist = &_NIL;		/* pointer to symbol table */
pointer global_env;		/* pointer to global environment */

/* global pointers to special symbols */
pointer LAMBDA;			/* pointer to syntax lambda */
pointer QUOTE;			/* pointer to syntax quote */

#ifdef USE_QQUOTE
pointer QQUOTE;			/* pointer to symbol quasiquote */
pointer UNQUOTE;		/* pointer to symbol unquote */
pointer UNQUOTESP;		/* pointer to symbol unquote-splicing */

#endif

pointer free_cell = &_NIL;	/* pointer to top of free cells */
long    fcells = 0;		/* # of free cells */

FILE   *infp;			/* input file */
FILE   *outfp;			/* output file */

#ifndef PORTMAX
# define PORTMAX 8
#endif
FILE   *ports[PORTMAX];        /* Ports */

#ifdef USE_SETJMP
jmp_buf error_jmp;

#endif
char    gc_verbose;		/* if gc_verbose is not zero, print gc status */

stricmp(x, y)
char *x;
char *y;
{
	for (; tolower((unsigned char)(*x++))
	       == tolower((unsigned char)(*y++));
	       x++, y++)
		if (!*x)
			break;
	return *x  - *y;
}

/* allocate new cell segment */
alloc_cellseg(n)
int     n;
{
	register pointer p;
	register long i;
	register int k;

	for (k = 0; k < n; k++) {
		if (last_cell_seg >= CELL_NSEGMENT - 1)
			return k;
		p = (pointer) malloc(CELL_SEGSIZE * sizeof(struct cell));
		if (p == (pointer) 0)
			return k;
		cell_seg[++last_cell_seg] = p;
		fcells += CELL_SEGSIZE;
		for (i = 0; i < CELL_SEGSIZE - 1; i++, p++) {
			type(p) = 0;
			car(p) = NIL;
			cdr(p) = p + 1;
		}
		type(p) = 0;
		car(p) = NIL;
		cdr(p) = free_cell;
		free_cell = cell_seg[last_cell_seg];
	}
	return n;
}

/* allocate new string segment */
alloc_strseg(n)
int     n;
{
	register char *p;
	register long i;
	register int k;

	for (k = 0; k < n; k++) {
		if (str_seglast >= STR_NSEGMENT)
			return k;
		p = (char *) malloc(STR_SEGSIZE * sizeof(char));
		if (p == (char *) 0)
			return k;
		str_seg[++str_seglast] = p;
		for (i = 0; i < STR_SEGSIZE; i++)
			*p++ = (char) (-1);
	}
	return n;
}

/* initialization of Mini-Scheme */
init_scheme()
{
	register pointer i;

	if (alloc_cellseg(FIRST_CELLSEGS) != FIRST_CELLSEGS)
		FatalError("Unable to allocate initial cell segments");
	if (!alloc_strseg(1))
		FatalError("Unable to allocate initial string segments");
#ifdef VERBOSE
	gc_verbose = 1;
#else
	gc_verbose = 0;
#endif
	init_globals();
}

/* get new cell.  parameter a, b is marked by gc. */
pointer get_cell(a, b)
register pointer a, b;
{
	register pointer x;

	if (free_cell == NIL) {
		gc(a, b);
		if (free_cell == NIL)
#ifdef USE_SETJMP
			if (!alloc_cellseg(1)) {
				args = envir = code = dump = NIL;
				gc(NIL, NIL);
				if (free_cell != NIL)
					Error("run out of cells --- rerurn to top level");
				else
					FatalError("run out of cells --- unable to recover cells");
			}
#else
			if (!alloc_cellseg(1))
				FatalError("run out of cells  --- unable to recover cells");
#endif
	}
	x = free_cell;
	free_cell = cdr(x);
	--fcells;
	return (x);
}

/* get new cons cell */
pointer cons(a, b)
register pointer a, b;
{
	register pointer x = get_cell(a, b);

	type(x) = T_PAIR;
	car(x) = a;
	cdr(x) = b;
	return (x);
}

/* get number atom */
pointer mk_number(num)
register long num;
{
	register pointer x = get_cell(NIL, NIL);

	type(x) = (T_NUMBER | T_ATOM);
	ivalue(x) = num;
	return (x);
}

/* allocate name to string area */
char   *store_string(name)
char   *name;
{
	register char *q;
	register short i;
	long    len, remain;

	/* first check name has already listed */
	for (i = 0; i <= str_seglast; i++)
		for (q = str_seg[i]; *q != (char) (-1); ) {
			if (!strcmp(q, name))
				goto FOUND;
			while (*q++)
				;	/* get next string */
		}
	len = strlen(name) + 2;
	remain = (long) STR_SEGSIZE - ((long) q - (long) str_seg[str_seglast]);
	if (remain < len) {
		if (!alloc_strseg(1))
			FatalError("run out of string area");
		q = str_seg[str_seglast];
	}
	strcpy(q, name);
FOUND:
	return (q);
}

/* get new string */
pointer mk_string(str)
char   *str;
{
	register pointer x = get_cell(NIL, NIL);

	strvalue(x) = store_string(str);
	type(x) = (T_STRING | T_ATOM);
	keynum(x) = (short) (-1);
	return (x);
}

/* get new symbol */
pointer mk_symbol(name)
char   *name;
{
	register pointer x;

	/* fisrt check oblist */
	for (x = oblist; x != NIL; x = cdr(x))
		if (!strcmp(name, symname(car(x))))
			break;

	if (x != NIL)
		return (car(x));
	else {
		x = cons(mk_string(name), NIL);
		type(x) = T_SYMBOL;
		oblist = cons(x, oblist);
		return (x);
	}
}

/* make symbol or number atom from string */
pointer mk_atom(q)
char   *q;
{
	char    c, *p;

	p = q;
	if (!isdigit(c = *p++)) {
		if ((c != '+' && c != '-') || !isdigit(*p))
			return (mk_symbol(q));
	}
	for ( ; (c = *p) != 0; ++p)
		if (!isdigit(c))
			return (mk_symbol(q));
	return (mk_number(atol(q)));
}

pointer mk_char_c(c)
char c;
{
	register pointer x = get_cell(NIL, NIL);
	type(x) = (T_CHAR | T_ATOM);
	ivalue(x) = c;

	return x;
}

/* make char */
pointer mk_char(name)
char *name;
{
	if (stricmp(name, "space") == 0) {
		name[0] = ' ';
	} else if (stricmp(name, "newline") == 0) {
		name[0] = '\n';
	}

	return mk_char_c(name[0]);
}

/* make constant */
pointer mk_const(name)
char   *name;
{
	long    x;
	char    tmp[256];

	if (!strcmp(name, "t"))
		return (T);
	else if (!strcmp(name, "f"))
		return (F);
	else if (*name == 'o') {/* #o (octal) */
		sprintf(tmp, "0%s", &name[1]);
		sscanf(tmp, "%lo", &x);
		return (mk_number(x));
	} else if (*name == 'd') {	/* #d (decimal) */
		sscanf(&name[1], "%ld", &x);
		return (mk_number(x));
	} else if (*name == 'x') {	/* #x (hex) */
		sprintf(tmp, "0x%s", &name[1]);
		sscanf(tmp, "%lx", &x);
		return (mk_number(x));
	} else if (*name == '\\') { /* Character constant */
		return (mk_char(&name[1]));
	} else {
		return (NIL);
	}
}


/* ========== garbage collector ========== */

/*--
 *  We use algorithm E (Kunuth, The Art of Computer Programming Vol.1,
 *  sec.3.5) for marking.
 */
mark(a)
pointer a;
{
	register pointer t, q, p;

E1:	t = (pointer) 0;
	p = a;
E2:	setmark(p);
E3:	if (isatom(p))
		goto E6;
E4:	q = car(p);
	if (q && !ismark(q)) {
		setatom(p);
		car(p) = t;
		t = p;
		p = q;
		goto E2;
	}
E5:	q = cdr(p);
	if (q && !ismark(q)) {
		cdr(p) = t;
		t = p;
		p = q;
		goto E2;
	}
E6:	if (!t)
		return;
	q = t;
	if (isatom(q)) {
		clratom(q);
		t = car(q);
		car(q) = p;
		p = q;
		goto E5;
	} else {
		t = cdr(q);
		cdr(q) = p;
		p = q;
		goto E6;
	}
}


/* garbage collection. parameter a, b is marked. */
gc(a, b)
register pointer a, b;
{
	register pointer p;
	register short i;
	register long j;

	if (gc_verbose)
		printf("gc...");

	/* mark system globals */
	mark(oblist);
	mark(global_env);

	/* mark current registers */
	mark(args);
	mark(envir);
	mark(code);
	mark(dump);

	/* mark variables a, b */
	mark(a);
	mark(b);

	/* garbage collect */
	clrmark(NIL);
	fcells = 0;
	free_cell = NIL;
	for (i = 0; i <= last_cell_seg; i++) {
		for (j = 0, p = cell_seg[i]; j < CELL_SEGSIZE; j++, p++) {
			if (ismark(p))
				clrmark(p);
			else {
				type(p) = 0;
				cdr(p) = free_cell;
				car(p) = NIL;
				free_cell = p;
				++fcells;
			}
		}
	}

	if (gc_verbose)
		printf(" done %ld cells are recovered.\n", fcells);
}


/* ========== Rootines for Reading ========== */

#define TOK_LPAREN  0
#define TOK_RPAREN  1
#define TOK_DOT     2
#define TOK_ATOM    3
#define TOK_QUOTE   4
#define TOK_COMMENT 5
#define TOK_DQUOTE  6
#ifdef USE_QQUOTE
# define TOK_BQUOTE  7
# define TOK_COMMA   8
# define TOK_ATMARK  9
#endif
#define TOK_SHARP   10

#define LINESIZE 1024
char    linebuff[LINESIZE];
char    strbuff[256];
char   *currentline = linebuff;
char   *endline = linebuff;

/* get new character from input file */
int     inchar()
{
	if (currentline >= endline) {	/* input buffer is empty */
		if (feof(infp)) {
			fclose(infp);
			infp = stdin;
			printf(prompt);
		}
		strcpy(linebuff, "\n");
		if (fgets(currentline = linebuff, LINESIZE, infp) == NULL)
			if (infp == stdin) {
				fprintf(stderr, "Good-bye\n");
				exit(0);
			}
		endline = linebuff + strlen(linebuff);
	}
	return (*currentline++);
}

/* clear input buffer */
clearinput()
{
	currentline = endline = linebuff;
}

/* back to standard input */
flushinput()
{
	if (infp != stdin) {
		fclose(infp);
		infp = stdin;
	}
	clearinput();
}

/* back character to input buffer */
backchar()
{
	currentline--;
}

/* read chacters to delimiter */
char   *readstr(delim)
char   *delim;
{
	char   *p = strbuff;

	while (isdelim(delim, (*p++ = inchar())))
		;
	backchar();
	*--p = '\0';
	return (strbuff);
}

/* read string expression "xxx...xxx" */
char   *readstrexp()
{
	char    c, *p = strbuff;

	for (;;) {
		if ((c = inchar()) != '"')
			*p++ = c;
		else if (p > strbuff && *(p - 1) == '\\')
			*(p - 1) = '"';
		else {
			*p = '\0';
			return (strbuff);
		}
	}
}

/* check c is delimiter */
isdelim(s, c)
char   *s;
char    c;
{
	while (*s)
		if (*s++ == c)
			return (0);
	return (1);
}

/* skip white characters */
skipspace()
{
	while (isspace(inchar()))
		;
	backchar();
}

/* get token */
token()
{
	skipspace();
	switch (inchar()) {
	case '(':
		return (TOK_LPAREN);
	case ')':
		return (TOK_RPAREN);
	case '.':
		return (TOK_DOT);
	case '\'':
		return (TOK_QUOTE);
	case ';':
		return (TOK_COMMENT);
	case '"':
		return (TOK_DQUOTE);
#ifdef USE_QQUOTE
	case BACKQUOTE:
		return (TOK_BQUOTE);
	case ',':
		if (inchar() == '@')
			return (TOK_ATMARK);
		else {
			backchar();
			return (TOK_COMMA);
		}
#endif
	case '#':
		return (TOK_SHARP);
	default:
		backchar();
		return (TOK_ATOM);
	}
}

/* ========== Rootines for Printing ========== */
#define	ok_abbrev(x)	(ispair(x) && cdr(x) == NIL)

strunquote(p, s)
char *p;
char *s;
{
	*p++ = '"';
	for ( ; *s; ++s) {
		if (*s == '"') {
			*p++ = '\\';
			*p++ = '"';
		} else if (*s == '\n') {
			*p++ = '\\';
			*p++ = 'n';
		} else
			*p++ = *s;
	}
	*p++ = '"';
	*p = '\0';
}


/* print atoms */
int printatom(l, f)
pointer l;
int     f;
{
	char	*p;
	
	if (l == NIL)
		p = "()";
	else if (l == T)
		p = "#t";
	else if (l == F)
		p = "#f";
	else if (isnumber(l)) {
		p = strbuff;
		sprintf(p, "%ld", ivalue(l));
	} else if (isstring(l)) {
		if (!f)
			p = strvalue(l);
		else {
			p = strbuff;
			strunquote(p, strvalue(l));
		}
	} else if (issymbol(l))
		p = symname(l);
	else if (isproc(l)) {
		p = strbuff;
		sprintf(p, "#<PROCEDURE %ld>", procnum(l));
#ifdef USE_MACRO
	} else if (ismacro(l)) {
		p = "#<MACRO>";
#endif
	} else if (isclosure(l))
		p = "#<CLOSURE>";
	else if (iscontinuation(l))
		p = "#<CONTINUATION>";
	else if (ischar(l)) {
		if (ivalue(l) == '\n')
			p = "#\\newline";
		else if (ivalue(l) == ' ')
			p = "#\\space";
		else {
			p = strbuff;
			sprintf(p, "#\\%c", ivalue(l));
		}
	} else if (isport(l)) {
		p = strbuff;
		sprintf(p, "#<PORT %ld>", ivalue(l));
	}
	if (f < 0)
		return strlen(p);
	fputs(p, outfp);
	return 0;
}


/* ========== Rootines for Evaluation Cycle ========== */

/* make closure. c is code. e is environment */
pointer mk_closure(c, e)
register pointer c, e;
{
	register pointer x = get_cell(c, e);

	type(x) = T_CLOSURE;
	car(x) = c;
	cdr(x) = e;
	return (x);
}

/* make continuation. */
pointer mk_continuation(d)
register pointer d;
{
	register pointer x = get_cell(NIL, d);

	type(x) = T_CONTINUATION;
	cont_dump(x) = d;
	return (x);
}

/* reverse list -- make new cells */
pointer reverse(a)
register pointer a;		/* a must be checked by gc */
{
	register pointer p = NIL;

	for ( ; ispair(a); a = cdr(a))
		p = cons(car(a), p);
	return (p);
}

/* reverse list --- no make new cells */
pointer non_alloc_rev(term, list)
pointer term, list;
{
	register pointer p = list, result = term, q;

	while (p != NIL) {
		q = cdr(p);
		cdr(p) = result;
		result = p;
		p = q;
	}
	return (result);
}

/* append list -- make new cells */
pointer append(a, b)
register pointer a, b;
{
	register pointer p = b, q;

	if (a != NIL) {
		a = reverse(a);
		while (a != NIL) {
			q = cdr(a);
			cdr(a) = p;
			p = a;
			a = q;
		}
	}
	return (p);
}

/* equivalence of atoms */
eqv(a, b)
register pointer a, b;
{
	if (isstring(a)) {
		if (isstring(b))
			return (strvalue(a) == strvalue(b));
		else
			return (0);
	} else if (isnumber(a)) {
		if (isnumber(b))
			return (ivalue(a) == ivalue(b));
		else
			return (0);
	} else if (ischar(a)) {
		if (ischar(b))
			return (ivalue(a) == ivalue(b));
		else
			return (0);
	} else if (isport(a)) {
		if (isport(b))
			return (ivalue(a) == ivalue(b));
		else
			return (0);
	} else
		return (a == b);
}

/* true or false value macro */
#define istrue(p)       ((p) != NIL && (p) != F)
#define isfalse(p)      ((p) == NIL || (p) == F)

/* Error macro */
#ifdef	AVOID_HACK_LOOP
# define	BEGIN	{
# define	END	}
#else
/*
 * I believe this is better, but some compiler complains....
 */
# define	BEGIN	do {
# define	END	} while (0)
#endif

#define Error_0(s) BEGIN                       \
    args = cons(mk_string((s)), NIL);          \
    operator = (short)OP_ERR0;                 \
    return T; END

#define Error_1(s, a) BEGIN                    \
    args = cons((a), NIL);                     \
    args = cons(mk_string((s)), args);         \
    operator = (short)OP_ERR0;                 \
    return T; END

/* control macros for Eval_Cycle */
#define s_goto(a) BEGIN                        \
    operator = (short)(a);                     \
    return T; END

#define s_save(a, b, c)  (                     \
    dump = cons(envir, cons((c), dump)),       \
    dump = cons((b), dump),                    \
    dump = cons(mk_number((long)(a)), dump))   \


#define s_return(a) BEGIN                      \
    value = (a);                               \
    operator = ivalue(car(dump));              \
    args = cadr(dump);                         \
    envir = caddr(dump);                       \
    code = cadddr(dump);                       \
    dump = cddddr(dump);                       \
    return T; END

#define s_retbool(tf)	s_return((tf) ? T : F)



/* ========== Evaluation Cycle ========== */

/* operator code */
#define	OP_LOAD			0
#define	OP_T0LVL		1
#define	OP_T1LVL		2
#define	OP_READ			3
#define	OP_VALUEPRINT		4
#define	OP_EVAL			5
#define	OP_E0ARGS		6
#define	OP_E1ARGS		7
#define	OP_APPLY		8
#define	OP_DOMACRO		9

#define	OP_LAMBDA		10
#define	OP_QUOTE		11
#define	OP_DEF0			12
#define	OP_DEF1			13
#define	OP_BEGIN		14
#define	OP_IF0			15
#define	OP_IF1			16
#define	OP_SET0			17
#define	OP_SET1			18
#define	OP_LET0			19
#define	OP_LET1			20
#define	OP_LET2			21
#define	OP_LET0AST		22
#define	OP_LET1AST		23
#define	OP_LET2AST		24
#define	OP_LET0REC		25
#define	OP_LET1REC		26
#define	OP_LET2REC		27
#define	OP_COND0		28
#define	OP_COND1		29
#define	OP_DELAY		30
#define	OP_AND0			31
#define	OP_AND1			32
#define	OP_OR0			33
#define	OP_OR1			34
#define	OP_C0STREAM		35
#define	OP_C1STREAM		36
#define	OP_0MACRO		37
#define	OP_1MACRO		38
#define	OP_CASE0		39
#define	OP_CASE1		40
#define	OP_CASE2		41

#define	OP_PEVAL		42
#define	OP_PAPPLY		43
#define	OP_CONTINUATION		44
#define	OP_ADD			45
#define	OP_SUB			46
#define	OP_MUL			47
#define	OP_DIV			48
#define	OP_REM			49
#define	OP_CAR			50
#define	OP_CDR			51
#define	OP_CONS			52
#define	OP_SETCAR		53
#define	OP_SETCDR		54
#define	OP_NOT			55
#define	OP_BOOL			56
#define	OP_NULL			57
#define	OP_ZEROP		58
#define	OP_POSP			59
#define	OP_NEGP			60
#define	OP_NEQ			61
#define	OP_LESS			62
#define	OP_GRE			63
#define	OP_LEQ			64
#define	OP_GEQ			65
#define	OP_SYMBOL		66
#define	OP_NUMBER		67
#define	OP_STRING		68
#define	OP_PROC			69
#define	OP_PAIR			70
#define	OP_EQ			71
#define	OP_EQV			72
#define	OP_FORCE		73
#define	OP_WRITE		74
#define	OP_DISPLAY		75
#define	OP_NEWLINE		76
#define	OP_ERR0			77
#define	OP_ERR1			78
#define	OP_REVERSE		79
#define	OP_APPEND		80
#define	OP_PUT			81
#define	OP_GET			82
#define	OP_QUIT			83
#define	OP_GC			84
#define	OP_GCVERB		85
#define	OP_NEWSEGMENT		86

#define	OP_RDSEXPR		87
#define	OP_RDLIST		88
#define	OP_RDDOT		89
#define	OP_RDQUOTE		90
#define	OP_RDQQUOTE		91
#define	OP_RDUNQUOTE		92
#define	OP_RDUQTSP		93

#define	OP_P0LIST		94
#define	OP_P1LIST		95

#define	OP_LIST_LENGTH		96
#define	OP_ASSQ			97
#define	OP_PRINT_WIDTH		98
#define	OP_P0_WIDTH		99
#define	OP_P1_WIDTH		100
#define	OP_GET_CLOSURE		101
#define	OP_CLOSUREP		102
#define	OP_MACROP		103
#define OP_CHAR                 104

#define OP_OPENIN               105
#define OP_CLOSEIN              106
#define OP_READIN               107

#define OP_OPENOUT              108
#define OP_CLOSEOUT             109
#define OP_WRITEOUT             110

#define OP_CHAR2INT             111
#define OP_STRINGREF            112

static FILE *tmpfp;
static int tok;
static int print_flag;
static pointer value;
static short operator;

pointer opexe_0(op)
register short op;
{
	register pointer x, y;

	switch (op) {
	case OP_LOAD:		/* load */
		if (!isstring(car(args))) {
			Error_0("load -- argument is not string");
		}
		if ((infp = fopen(strvalue(car(args)), "r")) == NULL) {
			infp = stdin;
			Error_1("Unable to open", car(args));
		}
		fprintf(outfp, "loading %s", strvalue(car(args)));
		s_goto(OP_T0LVL);

	case OP_T0LVL:	/* top level */
		fprintf(outfp, "\n");
		dump = NIL;
		envir = global_env;
		s_save(OP_VALUEPRINT, NIL, NIL);
		s_save(OP_T1LVL, NIL, NIL);
		if (infp == stdin)
			printf(prompt);
		s_goto(OP_READ);

	case OP_T1LVL:	/* top level */
		code = value;
		s_goto(OP_EVAL);
		
	case OP_READ:		/* read */
		tok = token();
		s_goto(OP_RDSEXPR);

	case OP_VALUEPRINT:	/* print evalution result */
		print_flag = 1;
		args = value;
		s_save(OP_T0LVL, NIL, NIL);
		s_goto(OP_P0LIST);

	case OP_EVAL:		/* main part of evalution */
		if (issymbol(code)) {	/* symbol */
			for (x = envir; x != NIL; x = cdr(x)) {
				for (y = car(x); y != NIL; y = cdr(y))
					if (caar(y) == code)
						break;
				if (y != NIL)
					break;
			}
			if (x != NIL) {
				s_return(cdar(y));
			} else {
				Error_1("Unbounded variable", code);
			}
		} else if (ispair(code)) {
			if (issyntax(x = car(code))) {	/* SYNTAX */
				code = cdr(code);
				s_goto(syntaxnum(x));
			} else {/* first, eval top element and eval arguments */
#ifdef USE_MACRO
				s_save(OP_E0ARGS, NIL, code);
#else
				s_save(OP_E1ARGS, NIL, cdr(code));
#endif
				code = car(code);
				s_goto(OP_EVAL);
			}
		} else {
			s_return(code);
		}

#ifdef USE_MACRO
	case OP_E0ARGS:	/* eval arguments */
		if (ismacro(value)) {	/* macro expansion */
			s_save(OP_DOMACRO, NIL, NIL);
			args = cons(code, NIL);
			code = value;
			s_goto(OP_APPLY);
		} else {
			code = cdr(code);
			s_goto(OP_E1ARGS);
		}
#endif

	case OP_E1ARGS:	/* eval arguments */
		args = cons(value, args);
		if (ispair(code)) {	/* continue */
			s_save(OP_E1ARGS, args, cdr(code));
			code = car(code);
			args = NIL;
			s_goto(OP_EVAL);
		} else {	/* end */
			args = reverse(args);
			code = car(args);
			args = cdr(args);
			s_goto(OP_APPLY);
		}

	case OP_APPLY:		/* apply 'code' to 'args' */
		if (isproc(code)) {
			s_goto(procnum(code));	/* PROCEDURE */
		} else if (isclosure(code)) {	/* CLOSURE */
			/* make environment */
			envir = cons(NIL, closure_env(code));
			for (x = car(closure_code(code)), y = args;
			     ispair(x); x = cdr(x), y = cdr(y)) {
				if (y == NIL) {
					Error_0("Few arguments");
				} else {
					car(envir) = cons(cons(car(x), car(y)), car(envir));
				}
			}
			if (x == NIL) {
				/*--
				 * if (y != NIL) {
				 * 	Error_0("Many arguments");
				 * }
				 */
			} else if (issymbol(x))
				car(envir) = cons(cons(x, y), car(envir));
			else {
				Error_0("Syntax error in closure");
			}
			code = cdr(closure_code(code));
			args = NIL;
			s_goto(OP_BEGIN);
		} else if (iscontinuation(code)) {	/* CONTINUATION */
			dump = cont_dump(code);
			s_return(args != NIL ? car(args) : NIL);
		} else {
			Error_0("Illegal function");
		}

#ifdef USE_MACRO
	case OP_DOMACRO:	/* do macro */
		code = value;
		s_goto(OP_EVAL);
#endif

	case OP_LAMBDA:	/* lambda */
		s_return(mk_closure(code, envir));

	case OP_QUOTE:		/* quote */
		s_return(car(code));

	case OP_DEF0:	/* define */
		if (ispair(car(code))) {
			x = caar(code);
			code = cons(LAMBDA, cons(cdar(code), cdr(code)));
		} else {
			x = car(code);
			code = cadr(code);
		}
		if (!issymbol(x)) {
			Error_0("Variable is not symbol");
		}
		s_save(OP_DEF1, NIL, x);
		s_goto(OP_EVAL);

	case OP_DEF1:	/* define */
		for (x = car(envir); x != NIL; x = cdr(x))
			if (caar(x) == code)
				break;
		if (x != NIL)
			cdar(x) = value;
		else
			car(envir) = cons(cons(code, value), car(envir));
		s_return(code);

	case OP_SET0:		/* set! */
		s_save(OP_SET1, NIL, car(code));
		code = cadr(code);
		s_goto(OP_EVAL);

	case OP_SET1:		/* set! */
		for (x = envir; x != NIL; x = cdr(x)) {
			for (y = car(x); y != NIL; y = cdr(y))
				if (caar(y) == code)
					break;
			if (y != NIL)
				break;
		}
		if (x != NIL) {
			cdar(y) = value;
			s_return(value);
		} else {
			Error_1("Unbounded variable", code);
		}

	case OP_BEGIN:		/* begin */
		if (!ispair(code)) {
			s_return(code);
		}
		if (cdr(code) != NIL) {
			s_save(OP_BEGIN, NIL, cdr(code));
		}
		code = car(code);
		s_goto(OP_EVAL);

	case OP_IF0:		/* if */
		s_save(OP_IF1, NIL, cdr(code));
		code = car(code);
		s_goto(OP_EVAL);

	case OP_IF1:		/* if */
		if (istrue(value))
			code = car(code);
		else
			code = cadr(code);	/* (if #f 1) ==> () because
						 * car(NIL) = NIL */
		s_goto(OP_EVAL);

	case OP_LET0:		/* let */
		args = NIL;
		value = code;
		code = issymbol(car(code)) ? cadr(code) : car(code);
		s_goto(OP_LET1);

	case OP_LET1:		/* let (caluculate parameters) */
		args = cons(value, args);
		if (ispair(code)) {	/* continue */
			s_save(OP_LET1, args, cdr(code));
			code = cadar(code);
			args = NIL;
			s_goto(OP_EVAL);
		} else {	/* end */
			args = reverse(args);
			code = car(args);
			args = cdr(args);
			s_goto(OP_LET2);
		}

	case OP_LET2:		/* let */
		envir = cons(NIL, envir);
		for (x = issymbol(car(code)) ? cadr(code) : car(code), y = args;
		     y != NIL; x = cdr(x), y = cdr(y))
			car(envir) = cons(cons(caar(x), car(y)), car(envir));
		if (issymbol(car(code))) {	/* named let */
			for (x = cadr(code), args = NIL; x != NIL; x = cdr(x))
				args = cons(caar(x), args);
			x = mk_closure(cons(reverse(args), cddr(code)), envir);
			car(envir) = cons(cons(car(code), x), car(envir));
			code = cddr(code);
			args = NIL;
		} else {
			code = cdr(code);
			args = NIL;
		}
		s_goto(OP_BEGIN);

	case OP_LET0AST:	/* let* */
		if (car(code) == NIL) {
			envir = cons(NIL, envir);
			code = cdr(code);
			s_goto(OP_BEGIN);
		}
		s_save(OP_LET1AST, cdr(code), car(code));
		code = cadaar(code);
		s_goto(OP_EVAL);

	case OP_LET1AST:	/* let* (make new frame) */
		envir = cons(NIL, envir);
		s_goto(OP_LET2AST);

	case OP_LET2AST:	/* let* (caluculate parameters) */
		car(envir) = cons(cons(caar(code), value), car(envir));
		code = cdr(code);
		if (ispair(code)) {	/* continue */
			s_save(OP_LET2AST, args, code);
			code = cadar(code);
			args = NIL;
			s_goto(OP_EVAL);
		} else {	/* end */
			code = args;
			args = NIL;
			s_goto(OP_BEGIN);
		}
	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);
	}
	return T;
}


pointer opexe_1(op)
register short op;
{
	register pointer x, y;

	switch (op) {
	case OP_LET0REC:	/* letrec */
		envir = cons(NIL, envir);
		args = NIL;
		value = code;
		code = car(code);
		s_goto(OP_LET1REC);

	case OP_LET1REC:	/* letrec (caluculate parameters) */
		args = cons(value, args);
		if (ispair(code)) {	/* continue */
			s_save(OP_LET1REC, args, cdr(code));
			code = cadar(code);
			args = NIL;
			s_goto(OP_EVAL);
		} else {	/* end */
			args = reverse(args);
			code = car(args);
			args = cdr(args);
			s_goto(OP_LET2REC);
		}

	case OP_LET2REC:	/* letrec */
		for (x = car(code), y = args; y != NIL; x = cdr(x), y = cdr(y))
			car(envir) = cons(cons(caar(x), car(y)), car(envir));
		code = cdr(code);
		args = NIL;
		s_goto(OP_BEGIN);

	case OP_COND0:		/* cond */
		if (!ispair(code)) {
			Error_0("Syntax error in cond");
		}
		s_save(OP_COND1, NIL, code);
		code = caar(code);
		s_goto(OP_EVAL);

	case OP_COND1:		/* cond */
		if (istrue(value)) {
			if ((code = cdar(code)) == NIL) {
				s_return(value);
			}
			s_goto(OP_BEGIN);
		} else {
			if ((code = cdr(code)) == NIL) {
				s_return(NIL);
			} else {
				s_save(OP_COND1, NIL, code);
				code = caar(code);
				s_goto(OP_EVAL);
			}
		}

	case OP_DELAY:		/* delay */
		x = mk_closure(cons(NIL, code), envir);
		setpromise(x);
		s_return(x);

	case OP_AND0:		/* and */
		if (code == NIL) {
			s_return(T);
		}
		s_save(OP_AND1, NIL, cdr(code));
		code = car(code);
		s_goto(OP_EVAL);

	case OP_AND1:		/* and */
		if (isfalse(value)) {
			s_return(value);
		} else if (code == NIL) {
			s_return(value);
		} else {
			s_save(OP_AND1, NIL, cdr(code));
			code = car(code);
			s_goto(OP_EVAL);
		}

	case OP_OR0:		/* or */
		if (code == NIL) {
			s_return(F);
		}
		s_save(OP_OR1, NIL, cdr(code));
		code = car(code);
		s_goto(OP_EVAL);

	case OP_OR1:		/* or */
		if (istrue(value)) {
			s_return(value);
		} else if (code == NIL) {
			s_return(value);
		} else {
			s_save(OP_OR1, NIL, cdr(code));
			code = car(code);
			s_goto(OP_EVAL);
		}

	case OP_C0STREAM:	/* cons-stream */
		s_save(OP_C1STREAM, NIL, cdr(code));
		code = car(code);
		s_goto(OP_EVAL);

	case OP_C1STREAM:	/* cons-stream */
		args = value;	/* save value to register args for gc */
		x = mk_closure(cons(NIL, code), envir);
		setpromise(x);
		s_return(cons(args, x));

#ifdef USE_MACRO
	case OP_0MACRO:	/* macro */
		x = car(code);
		code = cadr(code);
		if (!issymbol(x)) {
			Error_0("Variable is not symbol");
		}
		s_save(OP_1MACRO, NIL, x);
		s_goto(OP_EVAL);

	case OP_1MACRO:	/* macro */
		type(value) |= T_MACRO;
		for (x = car(envir); x != NIL; x = cdr(x))
			if (caar(x) == code)
				break;
		if (x != NIL)
			cdar(x) = value;
		else
			car(envir) = cons(cons(code, value), car(envir));
		s_return(code);
#endif

	case OP_CASE0:		/* case */
		s_save(OP_CASE1, NIL, cdr(code));
		code = car(code);
		s_goto(OP_EVAL);

	case OP_CASE1:		/* case */
		for (x = code; x != NIL; x = cdr(x)) {
			if (!ispair(y = caar(x)))
				break;
			for ( ; y != NIL; y = cdr(y))
				if (eqv(car(y), value))
					break;
			if (y != NIL)
				break;
		}
		if (x != NIL) {
			if (ispair(caar(x))) {
				code = cdar(x);
				s_goto(OP_BEGIN);
			} else {/* else */
				s_save(OP_CASE2, NIL, cdar(x));
				code = caar(x);
				s_goto(OP_EVAL);
			}
		} else {
			s_return(NIL);
		}

	case OP_CASE2:		/* case */
		if (istrue(value)) {
			s_goto(OP_BEGIN);
		} else {
			s_return(NIL);
		}
	case OP_PAPPLY:	/* apply */
		code = car(args);
		args = cadr(args);
		s_goto(OP_APPLY);

	case OP_PEVAL:	/* eval */
		code = car(args);
		args = NIL;
		s_goto(OP_EVAL);

	case OP_CONTINUATION:	/* call-with-current-continuation */
		code = car(args);
		args = cons(mk_continuation(dump), NIL);
		s_goto(OP_APPLY);

	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);
	}
	return T;
}


pointer opexe_2(op)
register short op;
{
	register pointer x, y;
	register long v;

	switch (op) {
	case OP_ADD:		/* + */
		for (x = args, v = 0; x != NIL; x = cdr(x))
			v += ivalue(car(x));
		s_return(mk_number(v));

	case OP_SUB:		/* - */
		for (x = cdr(args), v = ivalue(car(args)); x != NIL; x = cdr(x))
			v -= ivalue(car(x));
		s_return(mk_number(v));

	case OP_MUL:		/* * */
		for (x = args, v = 1; x != NIL; x = cdr(x))
			v *= ivalue(car(x));
		s_return(mk_number(v));

	case OP_DIV:		/* / */
		for (x = cdr(args), v = ivalue(car(args)); x != NIL; x = cdr(x)) {
			if (ivalue(car(x)) != 0)
				v /= ivalue(car(x));
			else {
				Error_0("Divided by zero");
			}
		}
		s_return(mk_number(v));

	case OP_REM:		/* remainder */
		for (x = cdr(args), v = ivalue(car(args)); x != NIL; x = cdr(x)) {
			if (ivalue(car(x)) != 0)
				v %= ivalue(car(x));
			else {
				Error_0("Divided by zero");
			}
		}
		s_return(mk_number(v));

	case OP_CAR:		/* car */
		if (ispair(car(args))) {
			s_return(caar(args));
		} else {
			Error_0("Unable to car for non-cons cell");
		}

	case OP_CDR:		/* cdr */
		if (ispair(car(args))) {
			s_return(cdar(args));
		} else {
			Error_0("Unable to cdr for non-cons cell");
		}

	case OP_CONS:		/* cons */
		cdr(args) = cadr(args);
		s_return(args);

	case OP_SETCAR:	/* set-car! */
		if (ispair(car(args))) {
			caar(args) = cadr(args);
			s_return(car(args));
		} else {
			Error_0("Unable to set-car! for non-cons cell");
		}

	case OP_SETCDR:	/* set-cdr! */
		if (ispair(car(args))) {
			cdar(args) = cadr(args);
			s_return(car(args));
		} else {
			Error_0("Unable to set-cdr! for non-cons cell");
		}
	case OP_CHAR2INT: /* char->integer */
		if (ischar(car(args))) {
			s_return(mk_number(ivalue(car(args))));
		} else {
			Error_0("char->integer: argument must be char");
		}

	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);
	}
	return T;
}


pointer opexe_3(op)
register short op;
{
	register pointer x, y;

	switch (op) {
	case OP_NOT:		/* not */
		s_retbool(isfalse(car(args)));
	case OP_BOOL:		/* boolean? */
		s_retbool(car(args) == F || car(args) == T);
	case OP_NULL:		/* null? */
		s_retbool(car(args) == NIL);
	case OP_ZEROP:		/* zero? */
		s_retbool(ivalue(car(args)) == 0);
	case OP_POSP:		/* positive? */
		s_retbool(ivalue(car(args)) > 0);
	case OP_NEGP:		/* negative? */
		s_retbool(ivalue(car(args)) < 0);
	case OP_NEQ:		/* = */
		s_retbool(ivalue(car(args)) == ivalue(cadr(args)));
	case OP_LESS:		/* < */
		s_retbool(ivalue(car(args)) < ivalue(cadr(args)));
	case OP_GRE:		/* > */
		s_retbool(ivalue(car(args)) > ivalue(cadr(args)));
	case OP_LEQ:		/* <= */
		s_retbool(ivalue(car(args)) <= ivalue(cadr(args)));
	case OP_GEQ:		/* >= */
		s_retbool(ivalue(car(args)) >= ivalue(cadr(args)));
	case OP_SYMBOL:	/* symbol? */
		s_retbool(issymbol(car(args)));
	case OP_NUMBER:	/* number? */
		s_retbool(isnumber(car(args)));
	case OP_CHAR: /* char? */
		s_retbool(ischar(car(args)));
	case OP_STRING:	/* string? */
		s_retbool(isstring(car(args)));
	case OP_PROC:		/* procedure? */
		/*--
	         * continuation should be procedure by the example
	         * (call-with-current-continuation procedure?) ==> #t
                 * in R^3 report sec. 6.9
	         */
		s_retbool(isproc(car(args)) || isclosure(car(args))
			  || iscontinuation(car(args)));
	case OP_PAIR:		/* pair? */
		s_retbool(ispair(car(args)));
	case OP_EQ:		/* eq? */
		s_retbool(car(args) == cadr(args));
	case OP_EQV:		/* eqv? */
		s_retbool(eqv(car(args), cadr(args)));
	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);
	}
	return T;
}


pointer opexe_4(op)
register short op;
{
	register pointer x, y;

	switch (op) {
	case OP_FORCE:		/* force */
		code = car(args);
		if (ispromise(code)) {
			args = NIL;
			s_goto(OP_APPLY);
		} else {
			s_return(code);
		}

	case OP_WRITE:		/* write */
		print_flag = 1;
		args = car(args);
		s_goto(OP_P0LIST);

	case OP_DISPLAY:	/* display */
		print_flag = 0;
		args = car(args);
		s_goto(OP_P0LIST);

	case OP_NEWLINE:	/* newline */
		fprintf(outfp, "\n");
		s_return(T);

	case OP_ERR0:	/* error */
		if (!isstring(car(args))) {
			Error_0("error -- first argument must be string");
		}
		tmpfp = outfp;
		outfp = stderr;
		fprintf(outfp, "Error: ");
		fprintf(outfp, "%s", strvalue(car(args)));
		args = cdr(args);
		s_goto(OP_ERR1);

	case OP_ERR1:	/* error */
		fprintf(outfp, " ");
		if (args != NIL) {
			s_save(OP_ERR1, cdr(args), NIL);
			args = car(args);
			print_flag = 1;
			s_goto(OP_P0LIST);
		} else {
			fprintf(outfp, "\n");
			flushinput();
			outfp = tmpfp;
			s_goto(OP_T0LVL);
		}

	case OP_REVERSE:	/* reverse */
		s_return(reverse(car(args)));

	case OP_APPEND:	/* append */
		s_return(append(car(args), cadr(args)));

	case OP_PUT:		/* put */
		if (!hasprop(car(args)) || !hasprop(cadr(args))) {
			Error_0("Illegal use of put");
		}
		for (x = symprop(car(args)), y = cadr(args); x != NIL; x = cdr(x))
			if (caar(x) == y)
				break;
		if (x != NIL)
			cdar(x) = caddr(args);
		else
			symprop(car(args)) = cons(cons(y, caddr(args)),
						  symprop(car(args)));
		s_return(T);

	case OP_GET:		/* get */
		if (!hasprop(car(args)) || !hasprop(cadr(args))) {
			Error_0("Illegal use of get");
		}
		for (x = symprop(car(args)), y = cadr(args); x != NIL; x = cdr(x))
			if (caar(x) == y)
				break;
		if (x != NIL) {
			s_return(cdar(x));
		} else {
			s_return(NIL);
		}

	case OP_QUIT:		/* quit */
		return (NIL);

	case OP_GC:		/* gc */
		gc(NIL, NIL);
		s_return(T);

	case OP_GCVERB:		/* gc-verbose */
	{	int	was = gc_verbose;
		
		gc_verbose = (car(args) != F);
		s_retbool(was);
	}

	case OP_NEWSEGMENT:	/* new-segment */
		if (!isnumber(car(args))) {
			Error_0("new-segment -- argument must be number");
		}
		fprintf(outfp, "allocate %d new segments\n",
			alloc_cellseg((int) ivalue(car(args))));
		s_return(T);

	case OP_STRINGREF:
		if (!isstring(car(args))) {
			Error_0("string-ref -- argument must be string");
		}
		x = car(args);

		if (!isnumber(cadr(args))) {
			Error_0("string-ref -- second argument must be int");
		}
		y = cadr(args);

		if (strlen(strvalue(x)) <= ivalue(y)) {
			Error_0("string-ref -- index out of range");
		}

		if (ivalue(y) < 0) {
			Error_0("string-ref -- index cannot be negative");
		}

		s_return(mk_char_c(strvalue(x)[ivalue(y)]));
	}
}


pointer opexe_5(op)
register short op;
{
	register pointer x, y;

	switch (op) {
	/* ========== reading part ========== */
	case OP_RDSEXPR:
		switch (tok) {
		case TOK_COMMENT:
			while (inchar() != '\n')
				;
			tok = token();
			s_goto(OP_RDSEXPR);
		case TOK_LPAREN:
			tok = token();
			if (tok == TOK_RPAREN) {
				s_return(NIL);
			} else if (tok == TOK_DOT) {
				Error_0("syntax error -- illegal dot expression");
			} else {
				s_save(OP_RDLIST, NIL, NIL);
				s_goto(OP_RDSEXPR);
			}
		case TOK_QUOTE:
			s_save(OP_RDQUOTE, NIL, NIL);
			tok = token();
			s_goto(OP_RDSEXPR);
#ifdef USE_QQUOTE
		case TOK_BQUOTE:
			s_save(OP_RDQQUOTE, NIL, NIL);
			tok = token();
			s_goto(OP_RDSEXPR);
		case TOK_COMMA:
			s_save(OP_RDUNQUOTE, NIL, NIL);
			tok = token();
			s_goto(OP_RDSEXPR);
		case TOK_ATMARK:
			s_save(OP_RDUQTSP, NIL, NIL);
			tok = token();
			s_goto(OP_RDSEXPR);
#endif
		case TOK_ATOM:
			s_return(mk_atom(readstr("();\t\n ")));
		case TOK_DQUOTE:
			s_return(mk_string(readstrexp()));
		case TOK_SHARP:
			if ((x = mk_const(readstr("();\t\n "))) == NIL) {
				Error_0("Undefined sharp expression");
			} else {
				s_return(x);
			}
		default:
			Error_0("syntax error -- illegal token");
		}
		break;

	case OP_RDLIST:
		args = cons(value, args);
		tok = token();
		if (tok == TOK_COMMENT) {
			while (inchar() != '\n')
				;
			tok = token();
		}
		if (tok == TOK_RPAREN) {
			s_return(non_alloc_rev(NIL, args));
		} else if (tok == TOK_DOT) {
			s_save(OP_RDDOT, args, NIL);
			tok = token();
			s_goto(OP_RDSEXPR);
		} else {
			s_save(OP_RDLIST, args, NIL);;
			s_goto(OP_RDSEXPR);
		}

	case OP_RDDOT:
		if (token() != TOK_RPAREN) {
			Error_0("syntax error -- illegal dot expression");
		} else {
			s_return(non_alloc_rev(value, args));
		}

	case OP_RDQUOTE:
		s_return(cons(QUOTE, cons(value, NIL)));

#ifdef USE_QQUOTE
	case OP_RDQQUOTE:
		s_return(cons(QQUOTE, cons(value, NIL)));

	case OP_RDUNQUOTE:
		s_return(cons(UNQUOTE, cons(value, NIL)));

	case OP_RDUQTSP:
		s_return(cons(UNQUOTESP, cons(value, NIL)));
#endif

	/* ========== printing part ========== */
	case OP_P0LIST:
		if (!ispair(args)) {
			printatom(args, print_flag);
			s_return(T);
		} else if (car(args) == QUOTE && ok_abbrev(cdr(args))) {
			fprintf(outfp, "'");
			args = cadr(args);
			s_goto(OP_P0LIST);
#ifdef USE_QQUOTE
		} else if (car(args) == QQUOTE && ok_abbrev(cdr(args))) {
			fprintf(outfp, "`");
			args = cadr(args);
			s_goto(OP_P0LIST);
		} else if (car(args) == UNQUOTE && ok_abbrev(cdr(args))) {
			fprintf(outfp, ",");
			args = cadr(args);
			s_goto(OP_P0LIST);
		} else if (car(args) == UNQUOTESP && ok_abbrev(cdr(args))) {
			fprintf(outfp, ",@");
			args = cadr(args);
			s_goto(OP_P0LIST);
#endif
		} else {
			fprintf(outfp, "(");
			s_save(OP_P1LIST, cdr(args), NIL);
			args = car(args);
			s_goto(OP_P0LIST);
		}

	case OP_P1LIST:
		if (ispair(args)) {
			s_save(OP_P1LIST, cdr(args), NIL);
			fprintf(outfp, " ");
			args = car(args);
			s_goto(OP_P0LIST);
		} else {
			if (args != NIL) {
				fprintf(outfp, " . ");
				printatom(args, print_flag);
			}
			fprintf(outfp, ")");
			s_return(T);
		}

	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);

	}
	return T;
}


pointer opexe_6(op)
register short op;
{
	register pointer x, y;
	register long v;
	static long	w;
	char	buffer[32];

	switch (op) {
	case OP_LIST_LENGTH:	/* list-length */	/* a.k */
		for (x = car(args), v = 0; ispair(x); x = cdr(x))
			++v;
		s_return(mk_number(v));
		
	case OP_ASSQ:		/* assq */	/* a.k */
		x = car(args);
		for (y = cadr(args); ispair(y); y = cdr(y)) {
			if (!ispair(car(y))) {
				Error_0("Unable to handle non pair element");
			}
			if (x == caar(y))
				break;
		}
		if (ispair(y)) {
			s_return(car(y));
		} else {
			s_return(F);
		}
		
	case OP_PRINT_WIDTH:	/* print-width */	/* a.k */
		w = 0;
		args = car(args);
		print_flag = -1;
		s_goto(OP_P0_WIDTH);
		
	case OP_P0_WIDTH:
		if (!ispair(args)) {
			w += printatom(args, print_flag);
			s_return(mk_number(w));
		} else if (car(args) == QUOTE
			   && ok_abbrev(cdr(args))) {
			++w;
			args = cadr(args);
			s_goto(OP_P0_WIDTH);
#ifdef USE_QQUOTE
		} else if (car(args) == QQUOTE
			   && ok_abbrev(cdr(args))) {
			++w;
			args = cadr(args);
			s_goto(OP_P0_WIDTH);
		} else if (car(args) == UNQUOTE
			   && ok_abbrev(cdr(args))) {
			++w;
			args = cadr(args);
			s_goto(OP_P0_WIDTH);
		} else if (car(args) == UNQUOTESP
			   && ok_abbrev(cdr(args))) {
			w += 2;
			args = cadr(args);
			s_goto(OP_P0_WIDTH);
#endif
		} else {
			++w;
			s_save(OP_P1_WIDTH, cdr(args), NIL);
			args = car(args);
			s_goto(OP_P0_WIDTH);
		}
		
	case OP_P1_WIDTH:
		if (ispair(args)) {
			s_save(OP_P1_WIDTH, cdr(args), NIL);
			++w;
			args = car(args);
			s_goto(OP_P0_WIDTH);
		} else {
			if (args != NIL)
				w += 3 + printatom(args, print_flag);
			++w;
			s_return(mk_number(w));
		}
		
	case OP_GET_CLOSURE:	/* get-closure-code */	/* a.k */
		args = car(args);
		if (args == NIL) {
			s_return(F);
		} else if (isclosure(args)) {
			s_return(cons(LAMBDA, closure_code(value)));
#ifdef USE_MACRO
		} else if (ismacro(args)) {
			s_return(cons(LAMBDA, closure_code(value)));
#endif
		} else {
			s_return(F);
		}
	case OP_CLOSUREP:		/* closure? */
		/*
		 * Note, macro object is also a closure.
		 * Therefore, (closure? <#MACRO>) ==> #t
		 */
		if (car(args) == NIL) {
		    s_return(F);
		}
		s_retbool(isclosure(car(args)));
#ifdef USE_MACRO
	case OP_MACROP:		/* macro? */
		if (car(args) == NIL) {
		    s_return(F);
		}
		s_retbool(ismacro(car(args)));
#endif
	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);
	}
	return T;	/* NOTREACHED */
}

#define CANNOT_OPEN_FILE -1
#define TOO_MANY_PORTS -2
int try_to_open(name, mode)
const char *name;
const char *mode;
{
	register int x;

	for (x = 0; x < PORTMAX; x++) {
		if (ports[x] == NULL) {
			ports[x] = fopen(name, mode);
			if (!ports[x])
				return CANNOT_OPEN_FILE;
			return x;
		}
	}

	return TOO_MANY_PORTS;
}

pointer mk_port(port)
int port;
{
	register pointer x = get_cell(NIL, NIL);
	type(x) = (T_PORT | T_ATOM);
	ivalue(x) = port;
	return x;
}

pointer opexe_7(op)
register short op;
{
	pointer x;
	int port;

	switch (op) {
	case OP_OPENIN: case OP_OPENOUT:
		if (!isstring(car(args))) {
			Error_0("open-input/output-file -- argument is not string");
		}
		port = try_to_open(strvalue(car(args)), op == OP_OPENIN ? "rb" : "wb");
		switch (port) {
		case CANNOT_OPEN_FILE:
			Error_1("open-input/output-file -- cannot open file", car(args));
		case TOO_MANY_PORTS:
			Error_0("open-input/output-file -- too many ports open");
		default:
			x = mk_port(port);
			s_return(x);
		}
	case OP_CLOSEIN: case OP_CLOSEOUT:
		if (!isport(car(args))) {
			Error_0("close-input/output-file -- argument is not port");
		}

		port = ivalue(car(args));
		if (port < 0 || port >= PORTMAX) {
			Error_0("close-input/output-file -- corrupted port value");
		}

		fclose(ports[port]);
		ports[port] = NULL;
		s_return(T);
	case OP_READIN:
		if (!isport(car(args))) {
			Error_0("read-char -- argument is not port");
		}

		port = ivalue(car(args));
		if (port < 0 || port >= PORTMAX) {
			Error_0("read-char -- corrupted port value");
		}

		port = getc(ports[port]);
		if (port == EOF) {
			x = F;
		} else {
			x = mk_char_c((char)port);
		}

		s_return(x);
	case OP_WRITEOUT:
		if (!isport(car(args))) {
			Error_0("write-char -- 1st argument is not port");
		}

		if (!ischar(cadr(args))) {
			Error_0("write-char -- 2nd argument is not char");
		}

		port = ivalue(car(args));
		if (port < 0 || port >= PORTMAX) {
			Error_0("read-char -- corrupted port value");
		}

		putc((char)ivalue(cadr(args)), ports[port]);
		s_return(T);
	default:
		sprintf(strbuff, "%d is illegal operator", operator);
		Error_0(strbuff);
	}

	return T;
}


pointer	(*dispatch_table[])() = {
	opexe_0,	/* OP_LOAD = 0, */
	opexe_0,	/* OP_T0LVL, */
	opexe_0,	/* OP_T1LVL, */
	opexe_0,	/* OP_READ, */
	opexe_0,	/* OP_VALUEPRINT, */
	opexe_0,	/* OP_EVAL, */
	opexe_0,	/* OP_E0ARGS, */
	opexe_0,	/* OP_E1ARGS, */
	opexe_0,	/* OP_APPLY, */
	opexe_0,	/* OP_DOMACRO, */
	
	opexe_0,	/* OP_LAMBDA, */
	opexe_0,	/* OP_QUOTE, */
	opexe_0,	/* OP_DEF0, */
	opexe_0,	/* OP_DEF1, */
	opexe_0,	/* OP_BEGIN, */
	opexe_0,	/* OP_IF0, */
	opexe_0,	/* OP_IF1, */
	opexe_0,	/* OP_SET0, */
	opexe_0,	/* OP_SET1, */
	opexe_0,	/* OP_LET0, */
	opexe_0,	/* OP_LET1, */
	opexe_0,	/* OP_LET2, */
	opexe_0,	/* OP_LET0AST, */
	opexe_0,	/* OP_LET1AST, */
	opexe_0,	/* OP_LET2AST, */
	
	opexe_1,	/* OP_LET0REC, */
	opexe_1,	/* OP_LET1REC, */
	opexe_1,	/* OP_LETREC2, */
	opexe_1,	/* OP_COND0, */
	opexe_1,	/* OP_COND1, */
	opexe_1,	/* OP_DELAY, */
	opexe_1,	/* OP_AND0, */
	opexe_1,	/* OP_AND1, */
	opexe_1,	/* OP_OR0, */
	opexe_1,	/* OP_OR1, */
	opexe_1,	/* OP_C0STREAM, */
	opexe_1,	/* OP_C1STREAM, */
	opexe_1,	/* OP_0MACRO, */
	opexe_1,	/* OP_1MACRO, */
	opexe_1,	/* OP_CASE0, */
	opexe_1,	/* OP_CASE1, */
	opexe_1,	/* OP_CASE2, */
	
	opexe_1,	/* OP_PEVAL, */
	opexe_1,	/* OP_PAPPLY, */
	opexe_1,	/* OP_CONTINUATION, */
	
	opexe_2,	/* OP_ADD, */
	opexe_2,	/* OP_SUB, */
	opexe_2,	/* OP_MUL, */
	opexe_2,	/* OP_DIV, */
	opexe_2,	/* OP_REM, */
	opexe_2,	/* OP_CAR, */
	opexe_2,	/* OP_CDR, */
	opexe_2,	/* OP_CONS, */
	opexe_2,	/* OP_SETCAR, */
	opexe_2,	/* OP_SETCDR, */
	
	opexe_3,	/* OP_NOT, */
	opexe_3,	/* OP_BOOL, */
	opexe_3,	/* OP_NULL, */
	opexe_3,	/* OP_ZEROP, */
	opexe_3,	/* OP_POSP, */
	opexe_3,	/* OP_NEGP, */
	opexe_3,	/* OP_NEQ, */
	opexe_3,	/* OP_LESS, */
	opexe_3,	/* OP_GRE, */
	opexe_3,	/* OP_LEQ, */
	opexe_3,	/* OP_GEQ, */
	opexe_3,	/* OP_SYMBOL, */
	opexe_3,	/* OP_NUMBER, */
	opexe_3,	/* OP_STRING, */
	opexe_3,	/* OP_PROC, */
	opexe_3,	/* OP_PAIR, */
	opexe_3,	/* OP_EQ, */
	opexe_3,	/* OP_EQV, */
	
	opexe_4,	/* OP_FORCE, */
	opexe_4,	/* OP_WRITE, */
	opexe_4,	/* OP_DISPLAY, */
	opexe_4,	/* OP_NEWLINE, */
	opexe_4,	/* OP_ERR0, */
	opexe_4,	/* OP_ERR1, */
	opexe_4,	/* OP_REVERSE, */
	opexe_4,	/* OP_APPEND, */
	opexe_4,	/* OP_PUT, */
	opexe_4,	/* OP_GET, */
	opexe_4,	/* OP_QUIT, */
	opexe_4,	/* OP_GC, */
	opexe_4,	/* OP_GCVERB, */
	opexe_4,	/* OP_NEWSEGMENT, */
	
	opexe_5,	/* OP_RDSEXPR, */
	opexe_5,	/* OP_RDLIST, */
	opexe_5,	/* OP_RDDOT, */
	opexe_5,	/* OP_RDQUOTE, */
	opexe_5,	/* OP_RDQQUOTE, */
	opexe_5,	/* OP_RDUNQUOTE, */
	opexe_5,	/* OP_RDUQTSP, */
	opexe_5,	/* OP_P0LIST, */
	opexe_5,	/* OP_P1LIST, */
	
	opexe_6,	/* OP_LIST_LENGTH, */
	opexe_6,	/* OP_ASSQ, */
	opexe_6,	/* OP_PRINT_WIDTH, */
	opexe_6,	/* OP_P0_WIDTH, */
	opexe_6,	/* OP_P1_WIDTH, */
	opexe_6,	/* OP_GET_CLOSURE, */
	opexe_6,	/* OP_CLOSUREP, */
	/* OP_MACROP is kept in to fill in a slot. Will return illegal
	 * operator when macros are disabled. */
	opexe_6,	/* OP_MACROP, */

	opexe_3,        /* OP_CHAR */

	opexe_7,        /* OP_OPENIN */
	opexe_7,        /* OP_CLOSEIN */
	opexe_7,        /* OP_READIN */
	opexe_7,        /* OP_OPENOUT */
	opexe_7,        /* OP_CLOSEOUT */
	opexe_7,        /* OP_WRITEOUT */

	opexe_2,        /* OP_CHAR2INT */
	opexe_4         /* OP_STRINGREF */
};


/* kernel of this intepreter */
pointer Eval_Cycle(op)
register short op;
{

	operator = op;
	for (;;)
		if ((*dispatch_table[operator])(operator) == NIL)
			return NIL;
}

/* ========== Initialization of internal keywords ========== */

mk_syntax(op, name)
unsigned short op;
char   *name;
{
	pointer x;

	x = cons(mk_string(name), NIL);
	type(x) = (T_SYNTAX | T_SYMBOL);
	syntaxnum(x) = op;
	oblist = cons(x, oblist);
}

mk_proc(op, name)
unsigned short op;
char   *name;
{
	pointer x, y;

	x = mk_symbol(name);
	y = get_cell(NIL, NIL);
	type(y) = (T_PROC | T_ATOM);
	ivalue(y) = (long) op;
	car(global_env) = cons(cons(x, y), car(global_env));
}


init_vars_global()
{
	pointer x;

	/* init input/output file */
	infp = stdin;
	outfp = stdout;
	/* init NIL */
	type(NIL) = (T_ATOM | MARK);
	car(NIL) = cdr(NIL) = NIL;
	/* init T */
	type(T) = (T_ATOM | MARK);
	car(T) = cdr(T) = T;
	/* init F */
	type(F) = (T_ATOM | MARK);
	car(F) = cdr(F) = F;
	/* init global_env */
	global_env = cons(NIL, NIL);
	/* init else */
	x = mk_symbol("else");
	car(global_env) = cons(cons(x, T), car(global_env));
}


init_syntax()
{
	/* init syntax */
	mk_syntax(OP_LAMBDA, "lambda");
	mk_syntax(OP_QUOTE, "quote");
	mk_syntax(OP_DEF0, "define");
	mk_syntax(OP_IF0, "if");
	mk_syntax(OP_BEGIN, "begin");
	mk_syntax(OP_SET0, "set!");
	mk_syntax(OP_LET0, "let");
	mk_syntax(OP_LET0AST, "let*");
	mk_syntax(OP_LET0REC, "letrec");
	mk_syntax(OP_COND0, "cond");
	mk_syntax(OP_DELAY, "delay");
	mk_syntax(OP_AND0, "and");
	mk_syntax(OP_OR0, "or");
	mk_syntax(OP_C0STREAM, "cons-stream");
#ifdef USE_MACRO
	mk_syntax(OP_0MACRO, "macro");
#endif
	mk_syntax(OP_CASE0, "case");
}


init_procs()
{
	/* init procedure */
	mk_proc(OP_PEVAL, "eval");
	mk_proc(OP_PAPPLY, "apply");
	mk_proc(OP_CONTINUATION, "call-with-current-continuation");
	mk_proc(OP_FORCE, "force");
	mk_proc(OP_CAR, "car");
	mk_proc(OP_CDR, "cdr");
	mk_proc(OP_CONS, "cons");
	mk_proc(OP_SETCAR, "set-car!");
	mk_proc(OP_SETCDR, "set-cdr!");
	mk_proc(OP_ADD, "+");
	mk_proc(OP_SUB, "-");
	mk_proc(OP_MUL, "*");
	mk_proc(OP_DIV, "/");
	mk_proc(OP_REM, "remainder");
	mk_proc(OP_NOT, "not");
	mk_proc(OP_BOOL, "boolean?");
	mk_proc(OP_SYMBOL, "symbol?");
	mk_proc(OP_NUMBER, "number?");
	mk_proc(OP_STRING, "string?");
	mk_proc(OP_PROC, "procedure?");
	mk_proc(OP_PAIR, "pair?");
	mk_proc(OP_EQV, "eqv?");
	mk_proc(OP_EQ, "eq?");
	mk_proc(OP_NULL, "null?");
	mk_proc(OP_ZEROP, "zero?");
	mk_proc(OP_POSP, "positive?");
	mk_proc(OP_NEGP, "negative?");
	mk_proc(OP_NEQ, "=");
	mk_proc(OP_LESS, "<");
	mk_proc(OP_GRE, ">");
	mk_proc(OP_LEQ, "<=");
	mk_proc(OP_GEQ, ">=");
	mk_proc(OP_READ, "read");
	mk_proc(OP_WRITE, "write");
	mk_proc(OP_DISPLAY, "display");
	mk_proc(OP_NEWLINE, "newline");
	mk_proc(OP_LOAD, "load");
	mk_proc(OP_ERR0, "error");
	mk_proc(OP_REVERSE, "reverse");
	mk_proc(OP_APPEND, "append");
	mk_proc(OP_PUT, "put");
	mk_proc(OP_GET, "get");
	mk_proc(OP_GC, "gc");
	mk_proc(OP_GCVERB, "gc-verbose");
	mk_proc(OP_NEWSEGMENT, "new-segment");
	mk_proc(OP_LIST_LENGTH, "list-length");	/* a.k */
	mk_proc(OP_ASSQ, "assq");	/* a.k */
	mk_proc(OP_PRINT_WIDTH, "print-width");	/* a.k */	
	mk_proc(OP_GET_CLOSURE, "get-closure-code");	/* a.k */
	mk_proc(OP_CLOSUREP, "closure?");	/* a.k */
#ifdef USE_MACRO
	mk_proc(OP_MACROP, "macro?");	/* a.k */
#endif
	mk_proc(OP_QUIT, "quit");
	mk_proc(OP_CHAR, "char?");

	mk_proc(OP_OPENIN, "open-input-file");
	mk_proc(OP_CLOSEIN, "close-input-port");
	mk_proc(OP_READIN, "read-char");

	mk_proc(OP_OPENOUT, "open-output-file");
	mk_proc(OP_CLOSEOUT, "close-output-port");
	mk_proc(OP_WRITEOUT, "write-char");

	mk_proc(OP_CHAR2INT, "char->integer");

	mk_proc(OP_STRINGREF, "string-ref");
}


/* initialize several globals */
init_globals()
{
	init_vars_global();
	init_syntax();
	init_procs();
	/* intialization of global pointers to special symbols */
	LAMBDA = mk_symbol("lambda");
	QUOTE = mk_symbol("quote");
#ifdef USE_QQUOTE
	QQUOTE = mk_symbol("quasiquote");
	UNQUOTE = mk_symbol("unquote");
	UNQUOTESP = mk_symbol("unquote-splicing");
#endif

}

/* ========== Error ==========  */

FatalError(fmt, a, b, c)
char   *fmt, *a, *b, *c;
{
	fprintf(stderr, "Fatal error: ");
	fprintf(stderr, fmt, a, b, c);
	fprintf(stderr, "\n");
	exit(1);
}

#ifdef USE_SETJMP
Error(fmt, a, b, c)
char   *fmt, *a, *b, *c;
{
	fprintf(stderr, "Error: ");
	fprintf(stderr, fmt, a, b, c);
	fprintf(stderr, "\n");
	flushinput();
	longjmp(error_jmp, OP_T0LVL);
}

#endif

/* ========== Main ========== */

main()
{
	short   op = (short) OP_LOAD;

	printf(banner);
	init_scheme();
	args = cons(mk_string(InitFile), NIL);
#ifdef USE_SETJMP
	op = setjmp(error_jmp);
#endif
	Eval_Cycle(op);
}