/*  Unlambda interpreter  */

/* 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"
  "#include \"strtail.h\"\n"
  "#define IN(x)\n"
  "#define output stdout\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;
FILE *output;
struct char_lock * 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;

	   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 = uncons( 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!");
     }
   }
}


)


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);
	      	 rv = malloc(sizeof *rv);
	         rv->refcount = 0;
	         rv->type = APPLY;
	         MKE(rv->arg1 = E.arg1)->refcount++;
	         (rv->e2 = E.e2)->refcount++;
		 Nexpr++;
	         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");
	         rv = malloc(sizeof *rv);
		 Nexpr++;
	         rv->refcount = 0;
	         rv->type = ATOM;
	         rv->arg1 = malloc(sizeof (struct atom));
		 Natoms++;
	         MKA(rv->arg1)->refcount = 1;
	         MKA(rv->arg1)->type = type;
	         MKA(rv->arg1)->d.character = ch;
	         return rv;
	       }
     default: error("Unexpected character");
	      return 0;
   }
}

int main(int argc, char *argv[])
{  FILE *file; 
   struct expr *toplevel;
   struct atom *ret;

   input = get_input( argc , argv );
   
   file = stdin;
   output = stdout;

   toplevel = parse(file);
   toplevel->refcount++;
   ret = eval(toplevel);
   freeatom(ret);
   free( input );
   return 0;
}