/*  Unlambda interpreter / "Compiler".  */

/* Copyright 1999  Jacob L. Mandelson
 *  This software may be distributed and modified without charge
 *   for noncommercial recreational or educational purposes provided
 *   that this copyright and statement is included in all copies.
 */


#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include <time.h>
#include <termios.h>
#include <unistd.h>
#include <string.h>



/* Macros */
#define dupatom(A) (((A)->refcount++, (A)))
#define dupexpr(A) (((A)->refcount++, (A)))
#define freeatom(A) (--(A)->refcount ? 0 : Freeatom((A)))
#define freeexpr(A) (--(A)->refcount ? 0 : Freeexpr((A)))


#define NextContext() ((CurrentContext+1 == 				\
	CurrentContinuation.contextlist+CurrentContinuation.Ncontexts 	\
		   ? grow_context_list(&CurrentContinuation, &CurrentContext) \
			: 0),  CurrentContext+1)

/* Take care using these macros  */
#define PUSHCONTEXT   CurrentContext++; continue;
#define POPCONTEXT    if (CurrentContext == CurrentContinuation.contextlist) \
			{ free(CurrentContext); return rv; } 		     \
		      else { CurrentContext--; continue; }


#define MKA(x) ((struct atom*)(x))
#define MKE(x) ((struct expr*)(x))


#define STRING(x) #x
	   				/*  Make a #define  */
#define MKDF(x) "#define " #x " " STRING(x) "\n"

static char preamble [] =
  "#include <stdio.h>\n"
  "#include <stdlib.h>\n"
  "#include <termios.h>\n"
  "#define IN(x)\n"
  "#define output stdout\n"
  "#define input stdin\n"
  "#define atomI atom0002\n"
  "#define atomV atom0003\n"
  "#define zz ,\n"
  MKDF(dupatom(A))  MKDF(dupexpr(A))    MKDF(freeatom(A))
  MKDF(freeexpr(A)) MKDF(NextContext()) MKDF(PUSHCONTEXT)
  MKDF(POPCONTEXT)  MKDF(MKA(x))        MKDF(MKE(x));


#define IN(x) x		/* Stuff that's only in the interpreter, not in
			 *  the compiler output.     */

#define zz ,		/*  Protect commas from the preprocessor  */

long Nmalloc, Nfree;
int debug;
int compile;
FILE *output, *input;
void error(char []);
struct atom;
void unparseA(struct atom* a);


static void *my_malloc(size_t size)
{  void *rv = malloc(size);
   Nmalloc++;
   if (!rv) error("Out of memory.");
   return rv;
}

static void *my_realloc(void *p, size_t size)
{  void *rv = realloc(p, size);
   if (!rv) error("Out of memory.");
   return rv;
}

#define malloc 	  my_malloc
#define realloc	  my_realloc
#define free(x)   ((Nfree++, free(x)))


#define MKSC(x) #x ; x			/* Make string and code */


char progbody[] = MKSC(
/*  Code common to the parser+interpreter and the 
 *   "compiled" (*cough*) interpreter. 
 */



/* Data structures.   */
/* Continuation is a list of contexts.  */

struct continuation {
IN(int tag;)
   long Ncontexts;
   struct context *contextlist;
};


/* Contexts contain the "stage" of execution, and arguments to execute.
 *  See comment below.  					   */
struct context { 
   enum Stage { Eval1 zz Eval2 zz Eval3 zz Apply1 zz S2a zz S2b zz D1a } stage;
   void *Arg1 zz *Arg2 zz *Int;
};


/*  The unlambda expression.
 *   Expression is either an atom, or `FG where F, G are unlambda expressions.
 */

struct atom {
IN(int tag;)
  long refcount;
  enum atomtype { K zz K1 zz S zz S1 zz S2 zz I zz V zz C zz C1 zz D zz D1 zz 
		Print zz Exit zz Read zz Query zz Reprint } type;
  /* Arguments:  K1, S1:  One atom.  D1: One expression.  S2: Two atoms. */
  /*             Print:  character.  C1:  continuation.   */
  union {
    char character;
    struct atom* oneatom;
    struct { struct atom *a1 zz *a2; } twoatom;
    struct expr* expression;
    struct continuation continuation;
  } d;
};

struct expr {
IN(int tag;)
  long refcount;
  enum  { ATOM zz APPLY } type;
  void *arg1;	/* struct atom* for ATOM, struct expr* for APPLY */
  struct expr *e2;   /* Not used if ATOM */
};


static int Freeexpr(struct expr *E);
void error(char []);
static void FreeContinuation(struct continuation , struct context *);


static int Freeatom(struct atom *A) 
{
   switch (A->type) {
     case S: case K: case I: case V: case C: case D: case Print:
     case Exit: case Read: case Query: case Reprint:
		/* Nothing.  A leaf.  */	break;
     case S1: case K1: 
	freeatom(A->d.oneatom); break;
     case S2:
	freeatom(A->d.twoatom.a1); freeatom(A->d.twoatom.a2); break;
     case D1:
	freeexpr(A->d.expression); break;
     case C1:
	FreeContinuation(A->d.continuation, 
		A->d.continuation.contextlist+A->d.continuation.Ncontexts-2);
	/* Last saved context is contextlist[Ncontexts-2] because current
	 *  context wasn't saved when the continuation was saved.    */
	break;
     default:
	error("Unknown type to free!"); 
   }
   free(A);
   return 0;
}

static int Freeexpr(struct expr *E)
{
   if (E->type == ATOM) freeatom(MKA(E->arg1));
   else { freeexpr(MKE(E->arg1)); freeexpr(E->e2); }
   free(E);
   return 0;
}

void error(char msg[])
{
   fprintf(stderr, "Error: %s\n", msg);
   exit(-1);
}


/* Context element:
     [ Stage, Arg1, Arg2, RV, Int ]
   Arg{1,2} are arguments
   Int is intermediate value
   RV is return value from last step.  
	Not saved with continuatoin!  Just variable for passing value "up"
	  the stack.
   Stage is Eval1: Arg1 is e
	    Eval2: Arg1 is e, RV is eval(e.e1)
	    Eval3: Arg1 is e, Int is eval(e.e1), RV is eval(e.e2)
	    Eval4: Arg1 is e, RV is apply(eval(e.e1), eval(e.e2))
		     Short-circuited to Apply1
	    Apply1: Arg1 is a1, Arg2 is a2
	    S2a: Arg1 is a1, Arg2 is a2, RV is apply(a1.a1, a2)
	    S2b: Arg1 is a1, Arg2 is a2, 
			RV is apply(a1.a2, a2), Int is apply(a1.a1, a2)
	    S2c: RV is apply( apply(a1.a1, a2), apply(a1.a2, a2) )
			Short-circuited to Apply1
	    D1a: Arg2 is a2, RV is eval(a1.e)
	    D1b: RV is apply( eval(a1.e), a2)
			Short-circuited to Apply1
*/


static int grow_context_list(struct continuation *CC, struct context **con)
{
    long cidx = *con - CC->contextlist;
    CC->Ncontexts += CC->Ncontexts/2 + 128;
    CC->contextlist = realloc(CC->contextlist, 
		CC->Ncontexts * sizeof(struct context) );
    *con = CC->contextlist + cidx;
    return 0;
}


IN(static int Ncontinuations;)
static int lastchar = EOF;

static struct continuation 
	SaveContinuation(struct continuation CC, struct context *cxt)
{
    struct continuation rv;

    IN(rv.tag = ++Ncontinuations;)
    rv.Ncontexts = cxt - CC.contextlist + 1;
    rv.contextlist = malloc(rv.Ncontexts * sizeof(*rv.contextlist));
    /* Save contexts up to (but not including) current context.
     *  Don't save current context because it is consumed by making the
     *   C call, and replaced by the argument when the continuation is resumed.
     */
    while (--cxt >= CC.contextlist) {
	rv.contextlist[cxt - CC.contextlist] = *cxt;
	switch (cxt->stage) {
	   case Eval3:
		MKA(cxt->Int)->refcount++;
		/* FALLTHROUGH */
	   case Eval2: 
		MKE(cxt->Arg1)->refcount++; 
		break;
	   case S2b:
		MKA(cxt->Int)->refcount++;
		MKA(cxt->Arg1)->refcount++;
		break;
	   case S2a:
		MKA(cxt->Arg1)->refcount++;
		/* FALLTHROUGH */
	   case D1a:
		MKA(cxt->Arg2)->refcount++;
		break;
	   case Eval1: case Apply1: default:
		error("Unknown stage to SaveContinuation!");
	}
    }

    return rv;
}

/* Free continuation, and contexts in continuation from 
 *   CC.contextlist[0] to ctx			*/
static void FreeContinuation(struct continuation CC, struct context *ctx)
{  
   for ( ; ctx >= CC.contextlist; ctx--) {
      switch (ctx->stage) {
	case Eval3:
	  freeatom(MKA(ctx->Int));
	  /* FALLTHROUGH */
   	case Eval2:
	  freeexpr(MKE(ctx->Arg1));
	  break;
	case S2b:
	  freeatom(MKA(ctx->Int));
	  freeatom(MKA(ctx->Arg1));
	  break;
	case Apply1: case S2a:
	  freeatom(MKA(ctx->Arg1));
	  /* FALLTHROUGH */
	case D1a:
	  freeatom(MKA(ctx->Arg2));
	  break;
	case Eval1: default:
	  error("Bad stage to FreeContinuation!");
      }
   }
   free(CC.contextlist);
}


/* Resuming a continuation must copy to the Current Continuation, not
 *  just make a ref., because changes to the CC in the course of execution
 *  should not affect copys of the continuation resumed.   */
void RestoreContinuation(struct continuation cont, struct continuation *CC,
			 struct context **cxt)
{   long i;
    CC->Ncontexts = cont.Ncontexts;
    CC->contextlist = malloc(cont.Ncontexts * sizeof(*CC->contextlist));
    memcpy(CC->contextlist, cont.contextlist, 
			cont.Ncontexts * sizeof(*CC->contextlist));
    for (i = 0; i < cont.Ncontexts-1; i++) {
/* Ncontexts-1 because Current Context wasn't saved with the continuation. */
	switch (cont.contextlist[i].stage) {
	   case Eval3:
		MKA(cont.contextlist[i].Int)->refcount++;
		/* FALLTHROUGH */
	   case Eval2: 
		MKE(cont.contextlist[i].Arg1)->refcount++; 
		break;
	   case S2b:
		MKA(cont.contextlist[i].Int)->refcount++;
		MKA(cont.contextlist[i].Arg1)->refcount++;
		break;
	   case S2a:
		MKA(cont.contextlist[i].Arg1)->refcount++;
		/* FALLTHROUGH */
	   case D1a:
		MKA(cont.contextlist[i].Arg2)->refcount++;
		break;
	   case Eval1: case Apply1: default:
		error("Unknown stage to RestoreContinuation!");
	}
    }
    *cxt = &CC->contextlist[cont.Ncontexts-1];
}


/* Forward declerations */
extern struct atom atomV;
extern struct atom atomI;


/*  Evaluate an expression.  */
/*  Maintains an explicit call stack, because it needs to save the contexts
 *   of all the function calls when the continuation is saved.
 *  The NextContext()->Arg1 = rv stuff is just setting up the Arguments 
 *   for the next context in the computation, a la passing arguments to 
 *   functions in Assembly.
 *  For example, pasting the "function calls" together for S2 (the
 *   most complicated case), gives:
 *	rv = apply(dupatom(a1->d.twoatom.a1), dupatom(a2));
 *	rv = apply(rv, apply(dupatom(a1->d.twoatom.a2), a2));
 *	freeatom(a1); return rv;
 */

struct atom *eval(struct expr *e)	
{  struct atom *rv;
   struct continuation CurrentContinuation;
   struct context *CurrentContext;
   struct context *nc;	/* Next Context */
   
   IN(CurrentContinuation.tag = 0;)
   CurrentContinuation.Ncontexts = 1024;
   CurrentContext = CurrentContinuation.contextlist = 
	malloc(CurrentContinuation.Ncontexts * sizeof(struct context));

   CurrentContext->Arg1 = e;
   CurrentContext->stage = Eval1;

/* This state machine is the engine:  It interprets the unlambda expression. */
   for (;;) {
     switch (CurrentContext->stage) {
	case Eval1:
	   e = CurrentContext->Arg1;
	   if (e->type == ATOM) {
	     rv = e->arg1;
	     --e->refcount ? rv->refcount++ : free(e);
	     POPCONTEXT
	   } else /* APPLY */ {
	     CurrentContext->stage = Eval2;
	     (nc=NextContext())->stage = Eval1;
	     nc->Arg1 = dupexpr(MKE(e->arg1));
	     PUSHCONTEXT
	   }
	case Eval2:  {
	   struct atom *a1 = rv;
	   e = CurrentContext->Arg1;
     
           if (a1->type == D) /* Delay */ {
	       rv = malloc(sizeof *rv);
	       rv->refcount = 1;
	       rv->type = D1;
	       rv->d.expression = e->e2;
	       if (!--e->refcount) {
		 freeexpr(MKE(e->arg1));
		 free(e);
	       } else {
		 e->e2->refcount++;
	       }
	       if (!--a1->refcount) free(a1);
	       POPCONTEXT
           } else {
	       CurrentContext->stage = Eval3;
	       CurrentContext->Int = a1;
	       (nc=NextContext())->stage = Eval1;
	       nc->Arg1 = dupexpr(e->e2);
	       PUSHCONTEXT
	   }
  	}
	case Eval3:
	   freeexpr(MKE(CurrentContext->Arg1));
	   CurrentContext->stage = Apply1;
	   CurrentContext->Arg2 = rv;
	   CurrentContext->Arg1 = CurrentContext->Int;
	   continue;
	case Apply1: {
	   struct atom *a1 = CurrentContext->Arg1 zz
		       *a2 = CurrentContext->Arg2;

	IN(if (debug) {
	   printf("Applying: [%ld]", a1->refcount);
	   unparseA(a1);
	   printf(" to [%ld]", a2->refcount);
	   unparseA(a2);
	   putchar('\n');
	})

	   switch (a1->type) {
	     case K:	rv = malloc(sizeof *rv);
			rv->refcount = 1;
			rv->type = K1; rv->d.oneatom = a2; break;
	     case K1: 	rv = a1->d.oneatom; freeatom(a2);
			if (a1->refcount != 1) rv->refcount++;
			break;
	     case S: 	rv = malloc(sizeof *rv);
			rv->refcount = 1;
			rv->type = S1; rv->d.oneatom = a2; break;
	     case S1: 	rv = malloc(sizeof *rv);
			rv->refcount = 1;
			rv->type = S2; 
			rv->d.twoatom.a1 = a1->d.oneatom;
			rv->d.twoatom.a2 = a2;
			if (a1->refcount != 1) a1->d.oneatom->refcount++;
			break;
	     case S2:   /* Can't check a1->refcount against 1, because one
			 * of the apply's might save the continuation, making
			 * a copy of a1.    */
			CurrentContext->stage = S2a;
			(nc=NextContext())->stage = Apply1;
			nc->Arg1 = dupatom(a1->d.twoatom.a1);
			nc->Arg2 = dupatom(a2);
			PUSHCONTEXT
	     case D:	/* If 'd' is used as an argument to something that
			 * applies its argument to something (eg, 'c'), 
			 * then 'd' will be applied without "delay".
			 * Fishy if you ask me, but the <``r`cd`.*`cd>
			 * program relies on it.			*/
			/* Treat like I */
	     case I:	rv = a2; break;
	     case V:	freeatom(a2); rv = a1; POPCONTEXT
	     case C: 	
			if (a2->type == V) {  /* <`cv> = v, no continuation. */
			    rv = a2; break;
			}
			rv = malloc(sizeof *rv);
			rv->refcount = 1;
			rv->type = C1;
			rv->d.continuation = 
			  SaveContinuation(CurrentContinuation, CurrentContext);
			freeatom(a1);
			CurrentContext->stage = Apply1;
			CurrentContext->Arg1 = a2;
			CurrentContext->Arg2 = rv;
			continue;
	     case C1:   /* Current Continuation holds references to a1, a2, 
			 *  so need to dup them before we free the CC.	*/
			rv = dupatom(a2);
			a1->refcount++;
			FreeContinuation(CurrentContinuation, CurrentContext);
			RestoreContinuation(a1->d.continuation,
				 &CurrentContinuation, &CurrentContext);
			/* Now we can free a1. */   
			freeatom(a1);
			POPCONTEXT
	     case D1:	CurrentContext->stage = D1a;
			(nc=NextContext())->stage = Eval1;
			nc->Arg1 = a1->d.expression;
			--a1->refcount ?
				 a1->d.expression->refcount++ : free(a1);
			PUSHCONTEXT
	     case Print: putc(a1->d.character, output); rv = a2; break;
	     case Exit: exit(0);	/* Exit program */
	     case Read: lastchar = getc(input);
			freeatom(a1);
			/* CurrentContext->stage = Apply1; */
			CurrentContext->Arg1 = a2;
			if (lastchar == EOF) CurrentContext->Arg2 = &atomV;
			else CurrentContext->Arg2 = &atomI;
			MKA(CurrentContext->Arg2)->refcount++;
			continue;
	     case Query: 
			/* CurrentContext->stage = Apply1; */
			CurrentContext->Arg1 = a2;
			if (lastchar == a1->d.character) 
			    CurrentContext->Arg2 = &atomI;
			else CurrentContext->Arg2 = &atomV;
			freeatom(a1); 
			MKA(CurrentContext->Arg2)->refcount++;
			continue;
	     case Reprint:
			freeatom(a1);
			/* CurrentContext->stage = Apply1; */
			CurrentContext->Arg1 = a2;
			if (lastchar == EOF) {
			    CurrentContext->Arg2 = &atomV;
			    MKA(CurrentContext->Arg2)->refcount++;
			} else {
			    CurrentContext->Arg2 = rv = malloc(sizeof *rv);
			    rv->refcount = 1;
			    rv->type = Print;
			    rv->d.character = lastchar;
			}
			continue;
	     default: 	error("Unexpected type to apply!");
	   }
	   if (!--a1->refcount) free(a1);
	   POPCONTEXT
	}

	case S2a:
	   CurrentContext->Int = rv;
	   CurrentContext->stage = S2b;
	   (nc=NextContext())->stage = Apply1;
	   nc->Arg1 = 
		dupatom(MKA(CurrentContext->Arg1)->d.twoatom.a2);
	   nc->Arg2 = CurrentContext->Arg2;
	   PUSHCONTEXT
	case S2b:
	   freeatom(MKA(CurrentContext->Arg1));
	   CurrentContext->stage = Apply1;
	   CurrentContext->Arg1 = CurrentContext->Int;
	   CurrentContext->Arg2 = rv;
	   continue;
	case D1a:
	   CurrentContext->stage = Apply1;
	   CurrentContext->Arg1 = rv;
	   /* CurrentContext->Arg2 = CurrentContext->Arg2; */
	   continue;
	default:
	   error("Unknown stage in evaluate!");
     }
   }
}


void unbuffer_io()
{  struct termios tio;
   IN(if (!debug || output != stdout)) setbuf(output, NULL);
   tcgetattr(fileno(input), &tio);
   tio.c_lflag &= ~ICANON;
   tio.c_cc[VMIN] = 1;
   tio.c_cc[VTIME] = 0;
   tcsetattr(fileno(input), TCSANOW, &tio);
}
)


struct atom atomK = { 0, 1, K, {0}};
struct atom atomS = { 1, 1, S, {0}};
struct atom atomI = { 2, 1, I, {0}};
struct atom atomV = { 3, 1, V, {0}};
struct atom atomC = { 4, 1, C, {0}};
struct atom atomD = { 5, 1, D, {0}};
struct atom atomR = { 6, 1, Print, {'\n'}};
struct atom atomE = { 7, 1, Exit, {0}};
struct atom atomAT = { 8, 1, Read, {0}};
struct atom atomPIPE = { 9, 1, Reprint, {0}};
struct expr exprK = { 0, 1, ATOM, &atomK };
struct expr exprS = { 1, 1, ATOM, &atomS };
struct expr exprI = { 2, 1, ATOM, &atomI };
struct expr exprV = { 3, 1, ATOM, &atomV };
struct expr exprC = { 4, 1, ATOM, &atomC };
struct expr exprD = { 5, 1, ATOM, &atomD };
struct expr exprR = { 6, 1, ATOM, &atomR };
struct expr exprE = { 7, 1, ATOM, &atomE };
struct expr exprAT = { 8, 1, ATOM, &atomAT };
struct expr exprPIPE = { 9, 1, ATOM, &atomPIPE };

struct atom *predefatomlist[] = { &atomK, &atomS, &atomI, &atomV, &atomC, 
				&atomD, &atomR, &atomE, &atomAT, &atomPIPE};
struct expr *predefexprlist[] = { &exprK, &exprS, &exprI, &exprV, &exprC, 
				&exprD, &exprR, &exprE, &exprAT, &exprPIPE};

struct atom **atomlist;
struct expr **exprlist;
int atomlistsz, exprlistsz;

#define N_PREDEF_ATOMS 10
static int Natoms = N_PREDEF_ATOMS;
static int Nexpr = N_PREDEF_ATOMS;

static void grow_exprlist()
{
   exprlist = realloc(exprlist, 
			(exprlistsz += exprlistsz / 2) * sizeof(*exprlist));
}

static void grow_atomlist()
{
   atomlist = realloc(atomlist, (atomlistsz += 100) * sizeof(*atomlist));
}

struct expr *parse(FILE *file)
{
   int ch;
   struct expr *rv;

   for (;;) {
	ch = getc(file);
        if (ch == EOF) error("Unexpected EOF.");
	if (isspace(ch)) continue;
  	if (ch == '#') {
	   for (;;) {
	     ch = getc(file);
	     if (ch == EOF) error("Unexpected EOF.");
	     if (ch == '\n') break;
	   }
	   continue;
 	}
	break;
   }

   switch (tolower(ch)) {
     case '`': { 
		 struct expr E;
		 int i;
		 E.arg1 = parse(file);
		 E.e2 = parse(file);
		 if (compile)
		  for (i=N_PREDEF_ATOMS; i < Nexpr; i++) {
		    if (exprlist[i]->type == APPLY &&
			exprlist[i]->arg1 == E.arg1 &&
			exprlist[i]->e2 == E.e2)
		    return exprlist[i];
		  }
	      	 rv = malloc(sizeof *rv);
	         rv->refcount = 0;
	         rv->type = APPLY;
	         MKE(rv->arg1 = E.arg1)->refcount++;
	         (rv->e2 = E.e2)->refcount++;
	         if (compile) exprlist[rv->tag=Nexpr] = rv; 
		 Nexpr++;
		 if (compile && Nexpr == exprlistsz) grow_exprlist();
	         return rv;
	       }
     case 'k': return &exprK;
     case 's': return &exprS;
     case 'i': return &exprI;
     case 'v': return &exprV;
     case 'c': return &exprC;
     case 'd': return &exprD;
     case 'r': return &exprR;
     case 'e': return &exprE;
     case '@': return &exprAT;
     case '|': return &exprPIPE;
     case '.': case '?': { 
		 int i; 
		 enum atomtype type = (ch == '?') ? Query : Print;
		 ch = getc(file);
	         if (ch == EOF) error("Unexpected EOF");
		 if (compile)
		  for (i = N_PREDEF_ATOMS; i < Nexpr; i++) {
		    if (exprlist[i]->type == ATOM &&
			MKA(exprlist[i]->arg1)->type == type &&
			MKA(exprlist[i]->arg1)->d.character == ch)
		    return exprlist[i];
		  }
	         rv = malloc(sizeof *rv);
	         if (compile) exprlist[rv->tag=Nexpr] = rv;
		 Nexpr++;
		 if (compile && Nexpr == exprlistsz) grow_exprlist();
	         rv->refcount = 0;
	         rv->type = ATOM;
	         rv->arg1 = malloc(sizeof (struct atom));
	         if (compile) atomlist[MKA(rv->arg1)->tag=Natoms] = rv->arg1;
		 Natoms++;
		 if (compile && Natoms == atomlistsz) grow_atomlist();
	         MKA(rv->arg1)->refcount = 1;
	         MKA(rv->arg1)->type = type;
	         MKA(rv->arg1)->d.character = ch;
	         return rv;
	       }
     default: error("Unexpected character");
	      return 0;
   }
}

void print_parse_tree()
{
   int i;
   char *atype[] = { "K", "K1", "S", "S1", "S2", "I", "V", "C", "C1", 
		     "D", "D1", "Print", "Exit", "Read", "Query", "Reprint"};

   for (i=0; i < Natoms; i++)
     fprintf(output, "struct atom atom%04d = { %ld, %s, '\\x%X' };\n",
		i, atomlist[i]->refcount+1, atype[atomlist[i]->type], 
			atomlist[i]->d.character);
   for (i=0; i < Nexpr; i++)
     if (exprlist[i]->type == ATOM)
	fprintf(output, "struct expr expr%04d = { %ld, ATOM, &atom%04d };\n",
		i, exprlist[i]->refcount+1, 
			MKA(exprlist[i]->arg1)->tag);
     else
      fprintf(output, 
	"struct expr expr%04d = { %ld, APPLY, &expr%04d, &expr%04d };\n",
		i, exprlist[i]->refcount+1, MKE(exprlist[i]->arg1)->tag,
					    exprlist[i]->e2->tag);
}

void print_epilog(struct expr *toplevel)
{
   fprintf(output, "int main() { if (isatty(fileno(input))) unbuffer_io();\n"
				"eval(&expr%04d); return 0; }\n", 
						toplevel->tag);
}

void unparseE(struct expr* e);

void unparseA(struct atom* a)
{
   switch (a->type) {
     case K: putchar('k'); return;
     case K1: putchar('`'); putchar('k'); unparseA(a->d.oneatom); return;
     case S: putchar('s'); return;
     case S1: putchar('`'); putchar('s'); unparseA(a->d.oneatom); return;
     case S2: putchar('`'); putchar('`'); putchar('s');
	      unparseA(a->d.twoatom.a1); unparseA(a->d.twoatom.a2); return;
     case I: putchar('i'); return;
     case V: putchar('v'); return;
     case C: putchar('c'); return;
     case C1: printf("<cont%d>", a->d.continuation.tag); return;
     case D: putchar('d'); return;
     case D1: putchar('`'); putchar('d'); unparseE(a->d.expression); return;
     case Print: a->d.character == '\n' ? putchar('r') : 
			   (putchar('.'), putchar(a->d.character));
		 return;
     case Exit: putchar('e'); return;
     case Read: putchar('@'); return;
     case Query: putchar('?'); putchar(a->d.character); return;
     case Reprint: putchar('|'); return;
     default: error("Unexpected type to unparse!");
  }
}

void unparseE(struct expr* e)
{
   if (e->type == APPLY) {
     putchar('`');
     unparseE(e->arg1);
     unparseE(e->e2);
   } else unparseA(e->arg1);
}




static void bad_usage()
{
   error("Incorrect command-line usage.\n\"unlambda -h\" for help.");
}

static void print_usage_message()
{
   char *usemsg =
	"Usage: unlambda [-c] [-i infile] [-o outfile] [-d] [-h] unlfile\n"
	"  Options:  -c    Compile (save parse tree)\n"
	"            -i    Use <infile> for input (default: std input)\n"
	"            -o    Use <outfile> for output (default: std output)\n"
	"            -d    Print debug information\n"
	"            -h    Print usage message and exit\n\n"
	"  Argument: unlfile   unlambda program (\"-\" specifies std input)\n";

   fputs(usemsg, stdout);
}

int main(int argc, char *argv[])
{  FILE *file;
   struct expr *toplevel;
   struct atom *ret;
   int c;
   char *infile = NULL, *outfile = NULL;
   
   while ((c = getopt(argc, argv, "co:i:dh")) != EOF)
     switch (c) {
	case 'c':
	  compile = 1;
	  break;
	case 'o':
	  outfile = optarg;
	  break;
	case 'i':
	  infile = optarg;
	  break;
	case 'd':
	  debug = 1;
	  break;
	case 'h':
	  print_usage_message();
	  exit(0);
	default:
	  bad_usage();
     }

   if (compile && (debug || infile)) 
	error("-c option cannot be used with -i or -d.");
   if (optind != argc-1) bad_usage();
   if (strcmp(argv[optind], "-"))
       file = fopen(argv[optind], "r");
   else
       file = stdin;
   if (!file) error("Error opening unlambda program.");
   if (outfile) {
       if (!(output = fopen(outfile, "w")))
	  error("Error opening output file.");
   } else output = stdout;
   if (infile) {
       if (!(input = fopen(infile, "r")))
	  error("Error opening input file.");
   } else input = stdin;

   if (compile) {	/* Set up atomlist & exprlist */
      atomlist = malloc((atomlistsz = 100) * sizeof(*atomlist));
      exprlist = malloc((exprlistsz = 1024) * sizeof(*exprlist));
      memcpy(atomlist, predefatomlist, N_PREDEF_ATOMS * sizeof(*atomlist));
      memcpy(exprlist, predefexprlist, N_PREDEF_ATOMS * sizeof(*exprlist));
   }
   toplevel = parse(file);
   toplevel->refcount++;
   fclose(file);
   if (compile) {
      time_t now = time(NULL);
      fprintf(output, 
		"/* Autogenerated by unlambda from file \"%s\" on\n\t%s*/\n",
		argv[optind], asctime(localtime(&now)));
      fputs(preamble, output);
      fputs(progbody, output);
      print_parse_tree();
      print_epilog(toplevel);
   } else {
      if (isatty(fileno(input))) unbuffer_io();
      ret = eval(toplevel);
      freeatom(ret);
      if (debug) { 
	printf("# mallocs: %ld.  # frees: %ld.\n", Nmalloc, Nfree);
        printf("# atoms: %d.   # expr: %d.\n", Natoms, Nexpr);
      }
   }
   return 0;
}