#include <stdio.h>
#include <unix.h>
#include <ctype.h>

/* =========================== TYPE DECLARATIONS =========================== */              
typedef enum {false,true} boolean;
typedef enum {alphanumeric, numeric, delimiter, endfile} type_of_token;
typedef enum {is_symbol, is_number, is_cons} celltype;
typedef enum {left, right} backtype;
typedef enum {parsing, execing} gc_flag;

/* ======================== END TYPE DECLARATIONS ========================== */

/* ======================== CONSTANT DECLARATIONS ========================== */

#define MAX_LINE_LENGTH 	90		/* Linelength for reading */
#define MAX_OUT_LINE_LENGTH 80		/* smaller lines to put out */
#define MAX_STORE 			400		/* Proto Hash Table for Identifiers */
#define MAX_CONS 			100000	/* Cons Cells Available */
#define MAX_TOKEN_LENGTH	20 		/* maximum identifier length */
#define NIL					0L
#define BLANK 				' '
#define END_OF_INPUT 		'&'


/* The opcodes for the SECD machine */
#define 	LD		1		
#define		LDC 	2
#define		LDF		3
#define		AP		4
#define		RTN		5
#define		DUM		6
#define		RAP		7
#define		SEL		8
#define		JOIN	9
#define		CAR		10
#define		CDR		11
#define		ATOM	12	
#define		CONS	13
#define		EQ		14
#define		ADD		15		/* Arithmetic ops */
#define		SUB		16
#define		MUL		17
#define		DIV		18
#define		REM		19
#define		LEQ		20
#define		STOP	21		/* End of computation */
#define		SOR		31		/* Non-deterministic OR */
#define 	NON		32		/* branch termination no good */
#define		LDE		33		/* Lazy evaluation ops */
#define		UPD		34
#define		AP0		35
/* End of Opcodes */


/* ====================== END CONSTANT DECLARATIONS ======================== */

/* ===================== GLOBAL VARIABLE DECLARATIONS ====================== */
		
long	index = 0;		/* used as an index whenever needed */

int		out_buffer = 0,
		in_buffer = 0,
		in_buff_pointer = 0,
		linelength = 0,
		storefree = 0;  
		
type_of_token	tokentype;

FILE	*outfile,
		*infile;
		
boolean in_disk = false,
		out_disk = false,
		in_echo = false,		
		out_echo = true,
		fun_echo = false,
		arg_echo = false,
		save_function = false,
		go_on = false,
		keep_going = true,
		dumpsomething = false,
		dumpstack = false,
		dumpenvironment = false,
		dumpcontrol = false,
		dumpdump = false,
		trace_ops = false,
		put_back_char = false;

/* Trace Information */		
boolean 	TraceLD 	= false,		
		 	TraceLDC 	= false,
		 	TraceLDF 	= false,
			TraceAP		= false,
 			TraceRTN 	= false,
 			TraceDUM 	= false,
 			TraceRAP 	= false,
 			TraceSEL 	= false,
 			TraceJOIN	= false,
 			TraceCAR	= false,
			TraceCDR	= false,
			TraceATOM	= false,	
			TraceCONS	= false,
			TraceEQ		= false,
			TraceADD	= false,
			TraceSUB	= false,
			TraceMUL	= false,
			TraceDIV	= false,
			TraceREM	= false,
			TraceLEQ	= false,
			TraceSTOP	= false,
			TraceSOR	= false,
			TraceNON	= false,
			TraceLDE	= false,
			TraceUPD	= false,
			TraceAP0	= false;
			
			
/* memory stuff */
boolean		*marked; 	/* has cons cell been marked?? */
celltype 	*is;     	/* what type is this cell?? */
backtype	*back;   	/* for bounded space garbage collection */
long		*car,		/* CAR & CDR, boys and girls... */
			*cdr;

/* pointers into CONS space */			
long 		consfree 	= MAX_CONS - 1,
			s 			= NIL, 	/* STACK */
			e 			= NIL, 	/* ENVIRONMENT */
			c 			= NIL, 	/* CONTROL */
			d 			= NIL,	/* DUMP */
			r 			= NIL, 	/* RESUMPTION */
			t 			= NIL, 	/* TRUE */
			f			= NIL, 	/* FALSE */
			omega		= NIL,	/* UNDEFINED */
			w 			= NIL,  /* WORKING */
			fn 			= NIL,	/* Pointer to the initial code */
			args 		= NIL,	/* Pointer to the initial data */
			result 		= NIL,	/* hopefully, anyway.. */
			tempnum 	= NIL,	/* global temps - for speed */
			temp1 		= NIL,
			temp2		= NIL;	
			
char		stringstore[MAX_STORE][MAX_TOKEN_LENGTH],
			token[MAX_TOKEN_LENGTH],
			in_line[MAX_LINE_LENGTH];
			
gc_flag		which_mode = execing;	/* are we parsing or executing? */

/* =================== END GLOBAL VARIABLE DECLARATIONS ==================== */				

/* ======================  USER INTERFACE GENERICS  ======================== */
/* YES_NO */
boolean yes_no()
{	int 	ch;
	do {ch = getche();}
		while (ch != 'Y' && ch != 'y' && ch != 'N' &&  ch != 'n');
	cputs("\n");
	if (ch == 'Y' || ch == 'y') return(true);
	else return(false);
}
/* END YES_NO */
/* =====================  END USER INTERFACE GENERICS  ===================== */
	
/* ======================  GARBAGE COLLECTION MODULE  ====================== */

/* COLLECT_GARBAGE : This function starts the GC process. It first 
   initializes the MARKED array to FALSE, and then starts marking from the
   four available entry points into memory. 
   These are the four registers: T, F, FN and ARGS */
collect_garbage()	
{ 	long savecar;
	savecar = car[NIL];
	car[NIL] = NIL;
	printf("GC: ");
	for ( index = NIL; index < MAX_CONS; index++)
		marked[index] = false;
	marked[NIL] = true;
	markit(t);
	markit(f);
	markit(omega);
	if (which_mode == parsing)
	{	markit(fn);			/* the other stacks are not being used */
		markit(args);
	}
	else 
	{	if (save_function == true)	
			markit(fn); 	/* we intend to run it again */
		markit(w);			/* the execution time registers */
		markit(s);
		markit(e);
		markit(c);
		markit(d);
		markit(r);
	}
	collect();
	if ( consfree == NIL)	/* no space to be found */
		cleanup(4);
	car[NIL] = savecar;
	cdr[NIL] = NIL;
}
/* END COLLECT_GARBAGE */

/* ROTATE : this function rotates the pointers - see A. H. U. for algorithm */
rotate(p1, p2, p3)
long	*p1,
		*p2,
		*p3;
{	temp1 = *p1;
	*p1 = *p2;
	*p2 = *p3;
	*p3 = temp1;
}
/* END ROTATE */

/* MARKIT : this is the marking routine. It works in bounded space, since
	one usually garbage collects when one is out of space and using a lot
	of stack for recursion is not a swift idea  */
markit(p)
long 	p;	
{	long	current,
			previous;
	int 	label;
	/* ----- */
	current = p;
	previous = NIL;
	back[NIL] = right;
	cdr[NIL] = NIL;
	marked[NIL] = true;
	label = 10;	
	/* the marking algorithm proper (Deutsch - Schorr - Waite) */
	while (label != 30)
	{	if (label == 10)
		{	if (marked[current] == true || 
				is[current] != is_cons ||
				(car[current] == NIL && cdr[current] == NIL))
			{	marked[current] = true;
				label = 20;
			}
			else
			{	marked[current] = true;
				if (car[current] == NIL)
				{	back[current] = right;
					rotate(&previous, &current, &cdr[current]);
				}
				else
				{	back[current] = left;
					rotate(&previous, &current, &car[current]);
				}
				label = 10;
			}
		}
		else if (label == 20)
		{	if (previous == current)
				label = 30;
			else if (back[previous] == left && cdr[previous] != NIL)
			{	back[previous] = right;
				rotate(&car[previous], &current, &cdr[previous]);
				label = 10;
			}
			else if (back[previous] == right)
				rotate(&previous, &cdr[previous], &current);
			else rotate(&previous, &car[previous], &current);
		}
	}
}					
/* END MARKIT */

/* COLLECT : this function collects	the garbage and puts it back on the free
	list */
collect()
{	long 	nodesfree;
	/* ----- */
	nodesfree = 0;
	for (index = NIL; index < MAX_CONS; index++)
		if (marked[index] != true)
		{	car[index] = consfree;
			consfree = index;
			++nodesfree;
		}
	printf("Collected: %ld\n", nodesfree);
}
/* ===================== END GARBAGE COLLECTION MODULE ===================== */	

/* =========================== MEMORY ALLOCATION =========================== */
/* NEWNODE : allocates a new cons cell */
long 	newnode(kind)
celltype	kind;
{	/* if (which_mode == execing) 	printf("In newnode\n"); */
	if (consfree == NIL)
		collect_garbage();
	temp1 = consfree;
	consfree = car[consfree];
	car[temp1] = NIL;
	cdr[temp1] = NIL;
	is[temp1] = kind;
	return(temp1);
}		
/* END NEWNODE */					

/* CONS : this makes a CONS cell with given CAR and CDR */
long 	cons (e1, e2)
long	e1,
		e2;
{	temp2 = newnode(is_cons);
	car[temp2] = e1;
	cdr[temp2] = e2;
	return(temp2);
}
/* END CONS */

/*COPY_LIST : recall that NIL is a symbol in this system */
long copy_list(exp)
long exp;
{	if (is[exp] == is_symbol || is[exp] == is_number)
		return(exp);
	else
		return(cons(copy_list(car[exp]),copy_list(cdr[exp])));
}
/* END COPY_LIST */
			
/* INSTALL :  this function installs an alphanumeric atom into the STRINGSTORE.
	This will probably have to augmented to a hash table later. */
install(cp, word)
long	cp;
char	word[MAX_TOKEN_LENGTH];
{	int wordindex = 0;
	while (strcmp(stringstore[wordindex],word) != 0 && wordindex < storefree)
		wordindex++;
	if (wordindex < storefree)
		car[cp] = wordindex;
	else if (storefree < MAX_STORE)
	{	car[cp] = storefree;
		strcpy(stringstore[storefree], word);
		storefree++;
	}
	else cleanup(3);
}
/* END INSTALL */
/* ========================= END MEMORY ALLOCATION ========================= */

/* ===========================  DEBUGGING AIDS  ============================ */
/* DUMPREGISTERS - This is a debugging procedure - it allows the printing out
	of selected registers as execution progresses */
dumpregisters()
{	int	ch;
	if (dumpstack == true)  		putoutput(s);
	if (dumpenvironment == true)	putoutput(e);
	if (dumpcontrol == true)		putoutput(c);
	if (dumpdump == true)			putoutput(d);
	if (out_disk == true) 			putc("\n", outfile);
	if (kbhit() == 1)
	{	ch = getche();
		if (ch == 27) cleanup(6);
	}
	if (out_echo == true)
	{	while ((ch = getch()) != '\n')
		{	if (ch == '$') cleanup(6);
		}
	}
}
/* END DUMPREGISTERS */

/* HEADER_DUMP_AND_OPCODE */
header_dump_and_opcode(opcode)
int opcode;
{	printf("===================\n");
	dumpregisters();
	printf("Opcode: %d\n", opcode);
}
/* END HEADRE_DUMP_AND_OPCODE */

/* CHECK_FOR_REGISTER_DUMPS */
check_for_register_dumps()
{	dumpsomething = false;
	cputs("REGISTERS to be displayed: \n");
	cputs("STACK: ");
	dumpstack = yes_no();
	cputs("ENVIRONMENT: ");
	dumpenvironment = yes_no();
	cputs("CONTROL: ");
	dumpcontrol = yes_no();
	cputs("DUMP: ");
	dumpdump = yes_no();
	if (dumpstack == true || dumpenvironment == true || 
	    dumpcontrol == true || dumpdump == true)
		dumpsomething = true;
}
/* END CHECK_FOR_REGISTER_DUMPS */

/* COLLECT_OPCODES_TO_TRACE */
collect_opcodes_to_trace()
{	int	ch;
	trace_ops = false; /* not all of them */
	printf("Trace LD  : (y/n) - ");
	TraceLD = yes_no();
	printf("Trace LDC : (y/n) - ");		
	TraceLDC 	= yes_no();
	printf("Trace LDF : (y/n) - ");
	TraceLDF 	= yes_no();
	printf("Trace AP  : (y/n) - ");
	TraceAP		= yes_no();
	printf("Trace RTN : (y/n) - ");
 	TraceRTN 	= yes_no();
 	printf("Trace DUM : (y/n) - ");
 	TraceDUM 	= yes_no();
 	printf("Trace RAP : (y/n) - ");
 	TraceRAP 	= yes_no();
 	printf("Trace SEL : (y/n) - ");
 	TraceSEL 	= yes_no();
 	printf("Trace JOIN: (y/n) - ");
 	TraceJOIN	= yes_no();
 	printf("Trace CAR : (y/n) - ");
 	TraceCAR	= yes_no();
 	printf("Trace CDR : (y/n) - ");
	TraceCDR	= yes_no();
	printf("Trace ATOM: (y/n) - ");
	TraceATOM	= yes_no();
	printf("Trace CONS: (y/n) - ");	
	TraceCONS	= yes_no();
	printf("Trace EQ  : (y/n) - ");
	TraceEQ		= yes_no();
	printf("Trace ADD : (y/n) - ");
	TraceADD	= yes_no();
	printf("Trace SUB : (y/n) - ");
	TraceSUB	= yes_no();
	printf("Trace MUL : (y/n) - ");
	TraceMUL	= yes_no();
	printf("Trace DIV : (y/n) - ");
	TraceDIV	= yes_no();
	printf("Trace REM : (y/n) - ");
	TraceREM	= yes_no();
	printf("Trace LEQ : (y/n) - ");
	TraceLEQ	= yes_no();
	printf("Trace STOP: (y/n) - ");
	TraceSTOP	= yes_no();
	printf("Trace SOR : (y/n) - ");
	TraceSOR	= yes_no();
	printf("Trace NON : (y/n) - ");
	TraceNON	= yes_no();
	printf("Trace LDE : (y/n) - ");
	TraceLDE	= yes_no();
	printf("Trace UPD : (y/n) - ");
	TraceUPD	= yes_no();
	printf("Trace AP0 : (y/n) - ");
	TraceAP0	= yes_no();
}
/* END COLLECT_OPCODES_TO_TRACE */

/* KILL_OPCODE_TRACE : sets all opcode trace flags to false */
kill_opcode_trace()
{	TraceLD 	= false;		
	TraceLDC 	= false;
	TraceLDF 	= false;
	TraceAP		= false;
 	TraceRTN 	= false;
 	TraceDUM 	= false;
 	TraceRAP 	= false;
 	TraceSEL 	= false;
 	TraceJOIN	= false;
 	TraceCAR	= false;
	TraceCDR	= false;
	TraceATOM	= false;	
	TraceCONS	= false;
	TraceEQ		= false;
	TraceADD	= false;
	TraceSUB	= false;
	TraceMUL	= false;
	TraceDIV	= false;
	TraceREM	= false;
	TraceLEQ	= false;
	TraceSTOP	= false;
	TraceSOR	= false;
	TraceNON	= false;
	TraceLDE	= false;
	TraceUPD	= false;
	TraceAP0	= false;
}
/* END KILL_OPCODE_TRACE */

/* =========================  END DEBUGGING AIDS  ========================== */

/* ======================= SECD MACHINE INTERPRETER ======================== */

/* ==> THE OPCODES : we give the stack operations for each opcode - this 
	is what defines the SECD machine */

/* M_LD - OPCODE : LD = 1 
 	S			E	(LD (i.j) . C)		D	
-->	(w . S)	 	E	C					D  
 	where w has been extracted from the ENVIRONMENT stack 	*/
m_ld()
{	w = e;
	for (index = 1; index <= car[car[car[cdr[c]]]]; index++) 
		w = cdr[w];
	w = car[w];
	for (index = 1; index <= car[cdr[car[cdr[c]]]]; index++)
		w = cdr[w];
	w = car[w];
	s = cons(w,s);
	c = cdr[cdr[c]];	/* skip operator and operand */
}
/* END M_LD */

/* M_LDC - OPCODE : LDC = 2 
	S 			E 	(LDC x . C)		D	
-->	(x . S)		E	C				D 	*/
m_ldc()
{	if (is[car[cdr[c]]] == is_cons)	
		s = cons(copy_list(car[cdr[c]]),s); /* copy constant lists */
	else 
		s = cons(car[cdr[c]], s);
	c = cdr[cdr[c]];
}
/* END M_LDC */

/* M_LDF - OPCODE : LDF = 3 
	This loads a closure - code + environment - on the stack, and continues.
	The next opcode, AP, sets things up for function execution.
	S				E	(LDF C' . C)	D	
-->	((C' . E) . S)	E	C				D	*/
m_ldf()
{	s = cons(cons(car[cdr[c]],e),s);
	c = cdr[cdr[c]];
}
/* END M_LDF */

/* M_AP - OPCODE : AP = 4
	This is the FUNCTION APPLICATION opcode. Notice how the system already
	expects that the function CODE and LOCAL ENVIRONMENT be already at the top
	of the stack. It moves the function code to the CONTROL register, ZEROS 
	the STACK REGISTER, sets up the ENVIRONMENT REGISTER, and saves all further
	computation instructions on the DUMP REGISTER. 
	((C' . E') v . S)	E			(AP . C)	D	
-->	NIL					(v . E')	C'			(S E C . D)		*/
m_ap()
{	d = cons(cdr[cdr[s]],cons(e,cons(cdr[c],d)));
	e = cons(car[cdr[s]],cdr[car[s]]);
	c = car[car[s]];
	s = NIL;
}
/* END M_AP */

/* M_RTN - OPCODE : RTN = 5
	This function assumes the top of the STACK contains the result of some
	computation - a function call -, and that we are now returning from it.
	Notice the restoration of all the saved registers.
	(x)			E'	(RTN)	(S E C . D)		
-->	(x . S)		E	C		D	*/
m_rtn()
{	s = cons(car[s],car[d]);
	e = car[cdr[d]];
	c = car[cdr[cdr[d]]];
	d = cdr[cdr[cdr[d]]];
}
/* END M_RTN */

/* M_DUM - OPCODE : DUM = 6	
	This instruction creates a dummy environment with OMEGA as its first sublist.
	Any attempts to access values in this sublists will be undefined, until 
	OMEGA has been replaced.
	S	E				(DUM . C)	D	
-->	S	(omega . E)		C			D	*/
m_dum()
{	e = cons(omega, e);
	c = cdr[c];
}
/* END M_DUM */

/* M_RAP - OPCODE : RAP = 7
	This insruction is similar to AP, using RPLACA on a DUMMY environment
	rather than consing.
	((C'. E') v . S) 	(omega . E) 	(RAP . C)	D	
-->	NIL					rplaca(E', v)	C'			(S E C . D) */
m_rap()
{	d = cons(cdr[cdr[s]],cons(cdr[e],cons(cdr[c],d)));
	e = cdr[car[s]];
	car[e] = car[cdr[s]]; 	/* here is RPLACA */
	c = car[car[s]];
	s = NIL;
}
/* END M_RAP */

/* M_SEL - OPCODE : SEL = 8
	This is the branch instruction - it depends on the truth status of the
	top of the stack.
	(x . S)		E	(SEL Ctrue Cfalse . C) 	D
-->	S 			E 	Cx 						(C . D)		
	where x is either true or false	*/ 
m_sel()
{	d = cons(cdr[cdr[cdr[c]]], d);
	if (car[car[s]] == car[t])
		c = car[cdr[c]];
	else
		c = car[cdr[cdr[c]]];
	s = cdr[s];
}
/* END M_SEL */

/* M_JOIN - OPCODE : JOIN = 9
	This is the RETURN FROM BRANCH instruction.
	S	E	(JOIN)	(C . D)
-->	S	E	C		D	*/
m_join()
{	c = car[d];
	d = cdr[d];
}
/* END M_JOIN */

/* M_CAR - OPCODE : CAR = 10
	This is the usual CAR instruction : takes the first element of the top
	list of the stack and puts it back on top of the stack.
	((a . b) . S)	E	(CAR . C)	D
-->	(a . S) 		E 	C			D	*/
m_car()
{	s = cons (car[car[s]], cdr[s]);
	c = cdr[c];
}	
/* END M_CAR */

/* M_CDR - OPCODE : CDR = 11
	This is the usual CDR instruction : takes all but the first element of 
	the top list of the stack and puts it back on top of the stack.
	((a . b) . S)	E	(CDR . C)	D
-->	(b . S) 		E 	C			D	*/
m_cdr()
{	s = cons(cdr[car[s]], cdr[s]);
	c = cdr[c];
}
/* END M_CDR */

/* M_ATOM - OPCODE : ATOM = 12
	Checks is the top of the stack is an atom - leaves t or f on top of stack.
	(a . S) 	E 	(ATOM . C) 	D
-->	(ax . S)	E	C			D	*/
m_atom()
{	if (is[car[s]] == is_number || is[car[s]] == is_symbol)
		s = cons(t, cdr[s]);
	else
		s = cons(f, cdr[s]);
	c = cdr[c];
}

/* M_CONS - OPCODE : CONS = 13
	Creates a cons cell of the two topmost elements of the stack and puts it
	on the stack.
	(a b . S)		E	(CONS . C) 		D
-->	((a . b) .S) 	E	C				D	*/
m_cons()
{	if (TraceCONS == true)
	{	printf("Print CAR & CADR?");
		if (yes_no() == true)
		{	printf("CAR: ");
			putoutput(car[s]);
			printf("CADR: ");
			putoutput(car[cdr[s]]);
		}
	}
	s = cons(cons(car[s], car[cdr[s]]), cdr[cdr[s]]);
	c = cdr[c];
}	
/* END M_CONS */

/* M_EQ - OPCODE : EQ = 14
	a and b could be symbols, numbers or conses - two pointers to the same 
	list will return T.
	(a b . S) 	E	(EQ . C)	D
-->	(? . S)		E	C			D		where ? is T or F	*/
m_eq()
{	if ((is[car[s]] == is_symbol &&
		 is[car[cdr[s]]] == is_symbol &&
		 car[car[s]] == car[car[cdr[s]]]) || 	/* pointing to same string? */
		(is[car[s]] == is_number &&
		 is[car[cdr[s]]] == is_number &&
		 car[car[s]] == car[car[cdr[s]]]))		/* same number? */
		s = cons(t, cdr[cdr[s]]);
	else
		s = cons(f, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_EQ */ 

/* M_ADD - OPCODE : ADD = 15
	(a b . S) 		E	(ADD . C) 	D
-->	((b+a) . S)		E	C			D	*/
m_add()
{	tempnum = newnode(is_number);
	car[tempnum] = car[car[cdr[s]]] + car[car[s]];
	s = cons(tempnum, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_ADD */

/* M_SUB - OPCODE : SUB = 16
	(a b . S) 		E	(SUB . C) 	D
-->	((b-a) . S)		E	C			D	*/
m_sub()
{	tempnum = newnode(is_number);
	car[tempnum] = car[car[cdr[s]]] - car[car[s]];
	s = cons(tempnum, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_SUB */

/* M_MUL - OPCODE : MUL = 17
	(a b . S) 		E	(MUL . C) 	D
-->	((b*a) . S)		E	C			D	*/
m_mul()
{	tempnum = newnode(is_number);
	car[tempnum] = car[car[cdr[s]]] * car[car[s]];
	s = cons(tempnum, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_MUL */

/* M_DIV - OPCODE : DIV = 18
	(a b . S) 		E	(DIV . C) 	D
-->	((b/a) . S)		E	C			D	*/
m_div()
{	tempnum = newnode(is_number);
	car[tempnum] = car[car[cdr[s]]] / car[car[s]];
	s = cons(tempnum, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_DIV */

/* M_REM - OPCODE : REM = 19
	(a b . S) 		E	(REM . C) 	D
-->	((bMODa) . S)	E	C			D	*/
m_rem()
{	long 	num1, 
			num2;
	tempnum = newnode(is_number);
	num1 = car[car[cdr[s]]];
	num2 = car[car[s]];
	car[tempnum] = num1 - num2 * (num1 / num2);
	s = cons(tempnum, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_REM */	

/* M_LEQ - OPCODE : LEQ = 20
	(a b . S)	E	(LEQ . C)	D
-->	(x . S) 	E	C			D	
	where x = t if b <= a and f otherwise */
m_leq()
{	if (car[car[cdr[s]]] <= car[car[s]])
		s = cons(t, cdr[cdr[s]]);
	else
		s = cons(f, cdr[cdr[s]]);
	c = cdr[c];
}
/* END M_LEQ */

/* M_STOP - OPCODE : STOP = 21
	This has as side-effect the stopping of execution. It leaves the SECD
	machine intact.
	S 	E 	(STOP) 	D
--> S	E	(STOP)	D	*/
m_stop()
{	go_on = false;
}
/* END M_STOP */

/* Extended stuff -  OR plus FORCE and DELAY */	

/* M_SOR - OPCODE : SOR = 31 
	This implementation is actually deterministic : try first THEN second
	S 	E	(SOR c1 c2 . C)		D			R
-->	S	E	c1					(C . D)		(S E c2 (C . D) . R) */
m_sor()
{	c = car[cdr[c]];
	d = cons(cdr[cdr[cdr[c]]],d);
	r = cons(s,cons(e,cons(car[cdr[cdr[c]]],cons(d,r))));
}
/* END M_SOR */

/* M_NON - OPCODE : NON = 32
	This opcode checks that the RESUMPTION register holds something - if it 
	does, the computation backtracks to the saved state, otherwise it stops.
	S	E	(NON)	D	(S' E' C' D' . R)
--> S'	E'	C'		D'	R
	--- OR ---
	S 	E 	(NON)	D	NIL
-->	NIL	E	(NON)	D	NIL 	with go_on = false. */
m_non()
{	if (r == NIL)
	{	s = NIL;
		go_on = false;
	}
	else
	{	s = car[r];
		e = car[cdr[r]];
		c = car[cdr[cdr[r]]];
		d = car[cdr[cdr[cdr[r]]]];
		r = cdr[cdr[cdr[cdr[r]]]];
	}
}
/* END M_NON */

/* M_LDE - OPCODE : LDE = 33 
	S					E	(LDE C . C')		D
-->	([F(C . E)] . S)	E	C'					D	
	where [F(C . E)] is a "recipe" for computation 	*/
m_lde()
{	s = cons(cons(f, cons(car[cdr[c]], e)), s);
	c = cdr[cdr[c]];
}
/* END M_LDE */

/* M_UPD - OPCODE : UPD = 34 
	(x)			E	(UPD)	(([F(C . E)] . S) E' C' . D)
-->	(x . S)		E'	C'		D	
	A better implementation will also have [F(C . E)] --> [T x]. We accept
	the inefficiency. */
m_upd()
{	s = cons(car[s], cdr[car[d]]);
	e = car[cdr[d]];
	c = car[cdr[cdr[d]]];
	d = cdr[cdr[cdr[d]]];
}
/* END M_UPD */		

/* M_AP0 - OPCODE : AP0 = 35 
	([F(C . E)] . S)	E'	(AP0 . C')	D
-->	NIL					E	C			(([F(C . E)] . S) E' C' . D) 
	A different transition would be used for an EVALUATED recipe - [T x]  */
m_ap0()
{	d = cons(s, cons(e, cons(cdr[c],d)));
	e = cdr[cdr[car[s]]];
	c = car[cdr[car[s]]];
	s = NIL;
}
/* END M_AP0 */


/* ==> THE MACHINE INTREPRETER */
/* EXEC : this function takes an expression, FN, and an expression list, ARGS,
	and sets up and runs the SECD machine until termination. The result of
	the computation is left at the top of the stack */
long 	exec(fn, args)
long 	fn,
		args;
{	int	opcode;
	/* SECD initialization section */
	go_on = true;
	which_mode = execing;
	s = newnode(is_cons);
	car[s] = args;
	e = NIL;
	c = fn;
	d = NIL;
	/* end of SECD initialization section */
	if (trace_ops == true && dumpsomething == true) dumpregisters();
	while (go_on == true)
	{	opcode = car[car[c]]; 	/* we MUST first coerce to INTEGER */
		if (trace_ops == true) 	/* Tracing ALL opcodes */
		{	printf("opcode: %d \n", opcode);
			if (out_disk == true) 
				fprintf(outfile,"Opcode: %d\n", opcode);
		}
		switch	(opcode)
		{	case	LD  :	if (TraceLD == true)
							{	header_dump_and_opcode(LD);
								m_ld();
								dumpregisters();
							}
							else m_ld(); 	break;
			case	LDC :	if (TraceLDC == true)
							{	header_dump_and_opcode(LDC);
								m_ldc();
								dumpregisters();
							}
							else m_ldc(); 	break;
			case	LDF :	if (TraceLDF == true)
							{	header_dump_and_opcode(LDF);
								m_ldf();
								dumpregisters();
							}
							else m_ldf();	break;
			case	AP  :	if (TraceAP == true)
							{	header_dump_and_opcode(AP);
								m_ap();
								dumpregisters();
							}
							else m_ap();		break;
			case	RTN :	if (TraceRTN == true)
							{	header_dump_and_opcode(RTN);
								m_rtn();
								dumpregisters();
							}
							else m_rtn();	break;
			case	DUM :	if (TraceDUM == true)
							{	header_dump_and_opcode(DUM);
								m_dum();
								dumpregisters();
							}
							else m_dum();	break;
			case	RAP :	if (TraceRAP == true)
							{	header_dump_and_opcode(RAP);
								m_rap();
								dumpregisters();
							}
							else m_rap();	break;
			case 	SEL :	if (TraceSEL == true)
							{	header_dump_and_opcode(SEL);
								m_sel();
								dumpregisters();
							}
							else m_sel();	break;
			case	JOIN:	if (TraceJOIN == true)
							{	header_dump_and_opcode(JOIN);
								m_join();
								dumpregisters();
							}
							else m_join();	break;
			case	CAR :	if (TraceCAR == true)
							{	header_dump_and_opcode(CAR);
								m_car();
								dumpregisters();
							}
							else m_car();	break;
			case	CDR :	if (TraceCDR == true)
							{	header_dump_and_opcode(CDR);
								m_cdr();
								dumpregisters();
							}
							else m_cdr();	break;
			case 	ATOM:	if (TraceATOM == true)
							{	header_dump_and_opcode(ATOM);
								m_atom();
								dumpregisters();
							}
							else m_atom();	break;
			case	CONS:	if (TraceCONS == true)
							{	header_dump_and_opcode(CONS);
								m_cons();
								dumpregisters();
							}
							else m_cons();	break;
			case	EQ  :	if (TraceEQ == true)
							{	header_dump_and_opcode(EQ);
								m_eq();
								dumpregisters();
							}
							else m_eq();		break;
			case	ADD :	if (TraceADD == true)
							{	header_dump_and_opcode(ADD);
								m_add();
								dumpregisters();
							}
							else m_add();	break;
			case	SUB :	if (TraceSUB == true)
							{	header_dump_and_opcode(SUB);
								m_sub();
								dumpregisters();
							}
							else m_sub();	break;
			case	MUL :	if (TraceMUL == true)
							{	header_dump_and_opcode(MUL);
								m_mul();
								dumpregisters();
							}
							else m_mul();	break;
			case	DIV :	if (TraceDIV == true)
							{	header_dump_and_opcode(DIV);
								m_div();
								dumpregisters();
							}
							else m_div();	break;
			case	REM :	if (TraceREM == true)
							{	header_dump_and_opcode(REM);
								m_rem();
								dumpregisters();
							}
							else m_rem();	break;
			case	LEQ :	if (TraceLEQ == true)
							{	header_dump_and_opcode(LEQ);
								m_leq();
								dumpregisters();
							}
							else m_leq();	break;
			case	STOP:	if (TraceSTOP == true)
							{	header_dump_and_opcode(STOP);
								m_stop();
								dumpregisters();
							}
							else m_stop();	break;
			case	SOR	:	if (TraceSOR == true)
							{	header_dump_and_opcode(SOR);
								m_sor();
								dumpregisters();
							}
							else m_sor();	break;
			case	NON	:	if (TraceNON == true)
							{	header_dump_and_opcode(NON);
								m_non();
								dumpregisters();
							}
							else m_non();	break;
			case	LDE :	if (TraceLDE == true)
							{	header_dump_and_opcode(LDE);
								m_lde();
								dumpregisters();
							}
							else m_lde();	break;
			case	UPD :	if (TraceUPD == true)
							{	header_dump_and_opcode(UPD);
								m_upd();
								dumpregisters();
							}
							else m_upd();	break;
			case	AP0 :	if (TraceAP0 == true)
							{	header_dump_and_opcode(AP0);
								m_ap0();
								dumpregisters();
							}
							else m_ap0();	break;
			default		:	cleanup(10);break;
		}
		if (trace_ops == true && dumpsomething == true) dumpregisters();/* Info for debugging? */
	}
	if (s == NIL) return(omega);		/* return undefined */
	else return(car[s]);				/* return top of stack */
}
/* ======================  END SECD MACHINE INTERPRETER  =================== */

/* ==========================  OUTPUT ROUTINES  ============================ */

/* PUTTOKEN : this function prints a string either to a file or to the
	console or both. It does not break identifiers at line boundaries: they are
	put on the next line. */
puttoken(token)
char token[MAX_TOKEN_LENGTH];
{	int		toklen;
	toklen = strlen(token);
	if ((out_buffer + toklen) > (MAX_OUT_LINE_LENGTH))
	{	if (out_disk == true) 	fputc('\n', outfile);
		if (out_echo == true) 	printf("\n");	
		out_buffer = 0;
	}
	if (out_disk == true) 
		fprintf(outfile, "%s ", token);
	if (out_echo == true)
		printf("%s ",token);
	out_buffer = out_buffer + toklen + 1;
}
/* END PUTTOKEN */

/* PUTEXP : this function outputs a whole lisp expression */
putexp(exp)
long 	exp;
{	long	p;
	char	temp[MAX_TOKEN_LENGTH];
	if (marked[exp] == false)  	/* this avoids circularities */
	{	if (is[exp] == is_symbol)
			puttoken(stringstore[car[exp]]);
		else if (is[exp] == is_number)
		{	stci_ld(temp, car[exp], 10);	/*convert to string for output */
			puttoken(temp);
		}
		else
		{	puttoken("(");
			p = exp;
			while (is[p] == is_cons && marked[p] == false)
			{	putexp(car[p]);
				marked[p] = true;
				p = cdr[p];
			}
			if (is[p] == is_symbol)
			{	if (strcmp(stringstore[car[p]], "NIL") != 0)
				{ 	puttoken(".");
					putexp(p);
				}
			}
			else
			{	puttoken(".");
				putexp(p);
			}
			puttoken(")");
		}
	}
}
/* END PUTEXP */

/* PUTOUTPUT : This function sends output to the screen, to a file or both 
	index is a global index... We need */
putoutput(result)
long	result;
{	out_buffer = 0;
	for ( index = NIL; index < MAX_CONS; index++)
		marked[index] = false;
	putexp(result);
	if (out_disk == true) 	
	{	fputc('&',outfile);	/* end_of_input character */
		fputc('\n', outfile);
		fflush(outfile);
	}
	if (out_echo == true) 	printf("\n");
}			
/* END PUTOUTPUT */	
/* ========================  END OUTPUT ROUTINES  ========================== */

/* ========================  CONVERSION ROUTINES  ========================== */
/* These routines exist to support a conversion from a LONG to an ASCII string.
A program that uses only INT rather than LONG will use a call to stci_d, rather
than a call to stci_ld, and these routines can be dropped */

static stc_ld(out, in, outlen, signflag)
register char *out;
register unsigned long in;
register int outlen;
int signflag;
{
char revnum [8];
register int i=0;
register char *out0 = out;

	if (outlen<=0) return (0);
	
	if (in == 0) revnum[i++]=0;
	else
		while (in)
		{
			revnum[i++] = in - (in/10)*10;
			in /= 10;
		}
	
	if (signflag)
	{
		*out++ = '-';
		outlen--;
	}
	
	for (; i && outlen; i--, outlen--)
		*out++ = revnum[i-1] + '0';
	
	*out = '\0';
	
	return (out-out0);
	
}

/* THIS WOULD BE REPLACED BY stci_d in a version with no LONGs */
stci_ld(out, in, outlen)
char *out;
long in;
int outlen;
{
	return (stc_ld(out, (in>=0?in:-in), outlen, in<0));
}
/* =======================  END CONVERSION ROUTINES  ======================= */

/* ============================  INPUT ROUTINES  =========================== */
/* GET_CHAR_FROM_INBUFFER : this gets a charcter from the input buffer and
	does appropriate input buffer housecleaning. */
int	get_char_from_inbuffer()
{	int 	ch;
	if (in_disk == true)	/* you are reading this from disk */
	{	ch = fgetc(infile);
		if ((ch != EOF) && (in_echo == true))
		{ 	if (put_back_char == false) 
				putch(ch); /* you do not want chars appearing twice */
			else put_back_char = false;
		}
		if (ch == EOF) cleanup(2);
		else if (ch == '\n' || ch == '\t' || (ch == '\r')) return(BLANK);
		else return(ch);
	}
	else if (in_buff_pointer >= linelength)
	{	in_buff_pointer = 0;
		putch('>');
		while ((linelength = strlen(cgets(in_line))) < 1)
			 putch('>');
		if (in_line[0] == '$') cleanup(2);
		return(BLANK);
	}
	else	
	{	ch = in_line[in_buff_pointer];
		in_buff_pointer++;
		if (ch == '\t')
			return(BLANK);
		else	return(ch);
	}	 
}
/* END GET_CHAR_FROM_INBUFFER */

/* GETTOKEN : this function gets the next token from the input buffer and
	returns the type of the token */
gettoken()
{	int ch;
	char short_string[2]; 
	short_string[0] = '\0';
	short_string[1] = '\0';
	token[0] = '\0';
	do { ch = get_char_from_inbuffer();} while (isspace(ch));	
	if (ch == END_OF_INPUT) 
	{	tokentype = endfile;
		token[0] = ')';
		token[1] = '\0';
	}
	else if (isdigit(ch) || ch == '-') 	/* a number !! */
	{	tokentype = numeric;
		do 
		{	short_string[0] = ch;
			if (strlen(token) < MAX_TOKEN_LENGTH)
				strcat(token, short_string);
			ch = get_char_from_inbuffer();
		}	while (isdigit(ch));
		if (ch != BLANK) 
		{	if (in_disk == true) 
			{	ungetc(ch,infile); /* put last char back */
				put_back_char = true;
			}
			else in_buff_pointer--;
		}
	}
	else if (isalpha(ch))
	{	tokentype = alphanumeric;
	 	do
		{	short_string[0] = ch;
			if (strlen(token) < MAX_TOKEN_LENGTH)
				strcat(token, short_string);
			ch = get_char_from_inbuffer();
		}	while (isalnum(ch));
		if (isspace(ch) == 0)	/*a potentially significant character */
		{	if (in_disk == true) 
			{	ungetc(ch,infile); /* put last char back */
				put_back_char = true;
			}
			else in_buff_pointer--;
		}
	}
	else
	{	tokentype = delimiter;
		short_string[0] = ch;
		strcat(token, short_string);
	}
}
/* END GETTOKEN */	
	 
/* FORWARD GETEXPLIST : declaration of function - C will type ANY undeclared 
	function that appears in a piece of code as int, and then give a 
	REDECLARATION error if you define it anywhere else as anything but int. */
long 	getexplist(); 
/* END FORWARD GETEXPLIST */

/* GETEXP : this function returns an expression */
long 	getexp()
{	long 	exp;
	if (token[0] == '(')
	{	gettoken();
		exp = getexplist();
		gettoken();
	}
	else if (tokentype == numeric)
	{	exp = newnode(is_number);
		car[exp] = atol(token);
		gettoken();
	}
	else if (tokentype == alphanumeric)
	{	exp = newnode(is_symbol);
		install(exp, token);
		gettoken();
	}
	return(exp);
}
/* END GETEXP */

/* GETEXPLIST : this function returns (a pointer to) an expression list */
long 	getexplist()
{	long 	exp;
	exp = newnode(is_cons);			/* this is a list, so make a cons cell */
	car[exp] = getexp();		 	/* get the head of the list */
	if (token[0] == '.')
	{	gettoken();
		cdr[exp] = getexp();       	/* get the tail - dotted pair */
	}
	else if (token[0] != ')' && token[0] != END_OF_INPUT)
		cdr[exp] = getexplist();	/* get the tail - NOT dotted pair */
	return(exp);					/* return pointer to tree or list */
}
	
/* GETINPUT : This function reads input from some file. When COMPIN is TRUE
	it reads an expression - i.e. a function - when FALSE it reads an 
	expression list - i.e. an argument list for a function. Acts both as a
	parser and a lexical scanner. */
long 	getinput(compin)
boolean	compin;
{	which_mode = parsing;
	put_back_char = false;
	gettoken(); 	/* get the first token */
	if (compin == true)  	
		return(getexp());
	else					
		return(getexplist());
}		
/* END GETINPUT */
/* =========================  END INPUT ROUTINES  ========================== */

/* ======================  USER INTERFACE ROUTINES  ======================== */

/* GETPROGFILE : this function opens the file that contains the program to be 
	executed. If another file is open, it will close it first. Only one 
	file can be open for reading and one for writing at the same time. */
getprogfile()
{	char	ch,
			filename[MAX_LINE_LENGTH]; /* why not? */
	save_function = false; 
	keep_going = true;
	in_disk = true;
	cputs("Execute: ");
	cgets(filename);
	if (strcmp(filename, "quit") == 0 || strcmp(filename, "QUIT") == 0 )
		keep_going = false;
	else if ((strcmp(filename, "console") == 0) ||
			 (strcmp(filename, "CONSOLE") == 0)) 
		in_disk = false;
	else if (strcmp(filename, "") > 0)
	{	fclose(infile);	/* try to close possibly open file */
		in_disk = true;
		cputs("Echo to console: ");
		fun_echo = yes_no();
		infile = fopen(filename, "r");
		if (infile == NULL) 	cleanup(5);
	}
	if (keep_going == true)
	{	cputs("Multiple Execution: ");
		save_function = yes_no();
	}
	in_echo = fun_echo;
}
/* END GETPROGFILE */

/* SETOUTFILE : this function sets up the disk file, if any, to which the 
result of the computation will be written. */
setoutfile()
{	char	ch,
			filename[MAX_LINE_LENGTH];
	cputs("Output File: ");
	cgets(filename);
	if ((strcmp(filename, "console") == 0) ||
	    (strcmp(filename, "CONSOLE") == 0))
	{	out_disk = false;
		out_echo = true;
	}
	else if (strcmp(filename, "") > 0)
	{	out_disk = true;
		outfile = fopen(filename, "w");
		cputs("Echo to console: ");
		out_echo = yes_no();
	}
}
/* END SETOUTFILE */

/* GETARGFILE: get the parameters of the function */
getargfile()
{	char	ch,
			filename[MAX_LINE_LENGTH];
	cputs("Argument File: ");
	cgets(filename);
	if (strcmp(filename, "quit") == 0)
		keep_going = false;
	if ((strcmp(filename, "console") == 0) ||
	    (strcmp(filename, "CONSOLE") == 0))
	{	in_disk = false;
		arg_echo == false;
	}
	else if (strcmp(filename, "") > 0) 	
	{	fclose(infile);
		in_disk = true;
		arg_echo = true;
		if ((infile = fopen(filename, "r")) == NULL) cleanup(5);
		cputs("Echo to console: ");
		if ((in_echo = yes_no()) == false)
			arg_echo = false;
	}
	in_echo = arg_echo;
}
/* END GETARGFILE */
/* ====================  END USER INTERFACE ROUTINES  ====================== */	

/* =================  INITIALIZATION AND EXIT MODULE  ====================== */		

/* ALLOCATE_ARRAYS : large structures allocation and program exit */		
allocate_arrays()
{	marked 	= (boolean *)NewPtr(sizeof(boolean) *MAX_CONS);
	is 		= (celltype *)NewPtr(sizeof(celltype) *MAX_CONS);
	back 	= (backtype *)NewPtr(sizeof(backtype) *MAX_CONS);
	car		= (long *)NewPtr(sizeof(long) *MAX_CONS);
	cdr		= (long *)NewPtr(sizeof(long) *MAX_CONS);
}
/* END ALLOCATE_ARRAYS */

/* CLEANUP : this sends an error message and exits as neatly as possible */	
cleanup(ercode)
int 	ercode;
{	printf("Error %d\n", ercode);
	exit(1); 		/* this closes all open files--- */
}
/* END CLEANUP */

/* INITIALIZE : this function does all up-front initializations of globals 
	and SECD machine registers and reserved symbols. */
initialize()
{	int 	ch = BLANK;
	int		i, j;
	in_line[0] = '\0';
	printf("Initializing the stringstore \n");
	for (j = 0; j < MAX_STORE; j++)
		for (i = 0; i < MAX_TOKEN_LENGTH; i++)
			stringstore[j][i] = '\0'; 
		/*initialize the "hash table" */
	consfree = MAX_CONS - 1;
	printf("Initializing cons space: %ld\n", consfree);
	for (index = consfree; index > 0; index--)
		car[index] = index - 1;	
	printf("Installing NIL, T, F & OMEGA\n");	
	cdr[NIL] = NIL;
	is[NIL] = is_symbol;
	install(NIL, "NIL");		/* so we can print it out */	
	t = newnode(is_symbol);
	install(t, "T");
	f = newnode(is_symbol);
	install(f, "F");
	omega = newnode(is_symbol);
	install(omega,"OMEGA");
	fn = NIL;
	args = NIL;
	check_for_register_dumps();
}
/* END INITIALIZE */
/* =================  END INITIALIZATION AND EXIT MODULE  ================== */

/* =============================   MAIN   ================================== */
/* MAIN : this is the main loop. It must first allocate all the large arrays,
	which cannot be allocated at compile time */
main()
{ 	int ch;
	allocate_arrays();
	initialize();
	while (keep_going == true)
	{	getprogfile();
		if (keep_going == true)
		{	fn = getinput(true);
			setoutfile();
			while (keep_going == true)
			{	getargfile();
				if (keep_going == true)
				{	args = getinput(false);
				 	cputs("\nTrace opcodes?");
					trace_ops = yes_no();
					if (trace_ops == true)
					{	cputs("Trace ALL opcodes?");
						if (yes_no() == false)
							collect_opcodes_to_trace();
					}
					else
						kill_opcode_trace();
					result = exec(fn,args);
					printf("Exited computation\n"); 
					args = NIL;
					putoutput(result);
					cputs("\nDo you want to change register dumps? ");
					if (yes_no() == true)
						check_for_register_dumps();
					cputs("New Function? ");
					if (yes_no() == true)
					{	getprogfile();		/* from where? */
				 		fn = getinput(true);
				 		setoutfile();		/* where do we send output? */
				 	}
				}
			}
			keep_going = true; 
		}
	}
	cleanup(1);
}
/* ============================  END MAIN  ================================= */
/* = END = END = END = END = END = END = END = END = END = END = END = END = */