#include <stdio.h>
#include <stdlib.h>
#include <stdint.h>
#include <string.h>

#define CAT   -1  /* inner should be treated normally, except continue with
		    this el's next once it's evaluated */
#define INNER -2  /* inner is a quotation */
#define STACK -3  /* inner is a stack element */

typedef uint_fast8_t fint;

typedef struct tag_el {
  int_least32_t val;    /* character, or a special value if negative */
  size_t refcount;      /* reference count from inner, next, or globals */
  /* this counts the number of locations referencing, even if they're
     referenced multiple times themselves they only count as 1 */
  struct tag_el* next;  /* the element after this one */
  struct tag_el* inner; /* the element inside this one, if val is negative */
} el;

enum {unknown, underload, underlambda} lang = unknown;

int debuglevel = 0;

void serialize(el* e, FILE* f, fint stackdir);

void error(const char* errstr) {
  fprintf(stderr,"Error: %s\n",errstr);
  exit(EXIT_FAILURE); }

el* malloc_el(void) {
  el* x = malloc(sizeof (el));
  if(!x) error("Out of memory");
  return x; }
void checkfree(el* e) {
  if(!e) return;
  if(!(e->refcount)) {
    e->refcount=1;
    if(debuglevel >= 6) fprintf(stderr,"[free] ");
    if(debuglevel >= 6) serialize(e,stderr,1);
    if(debuglevel >= 6) fputc('\n',stderr);
    if(e->next) e->next->refcount--;
    checkfree(e->next);
    if(e->inner) e->inner->refcount--;
    checkfree(e->inner);
    free(e); }}

void uniputc(int_least32_t c, FILE* f) {
  if     (c <          0)
    error("Attempt to output a negative-coded character");
  if     (c <       0x80)
    putc(c,f);
  else if(c <      0x800) {
    putc(0xc0| (c>> 6),f);
    putc(0x80|( c     &0x3f),f); }
  else if(c <    0x10000) {
    putc(0xd0| (c>>12),f);
    putc(0x80|((c>> 6)&0x3f),f);
    putc(0x80| (c     &0x3f),f); }
  else if(c <   0x200000) {
    putc(0xf0| (c>>18),f);
    putc(0x80|((c>>12)&0x3f),f);
    putc(0x80|((c>> 6)&0x3f),f);
    putc(0x80|( c     &0x3f),f); }
  else if(c <  0x4000000) {
    putc(0xf8| (c>>24),f);
    putc(0x80|((c>>18)&0x3f),f);
    putc(0x80|((c>>12)&0x3f),f);
    putc(0x80|((c>> 6)&0x3f),f);
    putc(0x80|( c     &0x3f),f); }
  else {
    putc(0xfc| (c>>30),f);
    putc(0x80|((c>>24)&0x3f),f);
    putc(0x80|((c>>18)&0x3f),f);
    putc(0x80|((c>>12)&0x3f),f);
    putc(0x80|((c>> 6)&0x3f),f);
    putc(0x80|( c     &0x3f),f); }}
int_least32_t unigetc(FILE* f) {
  int_least32_t rv=0;
  int_least32_t min=0x40;
  fint count=0;
  int c=getc(f);
  unsigned char mask = 0xc0;
  if(c < 0x80) return c;
  while(c & mask) {count++; c &= ~mask; mask>>=1;}
  if(count < 1) error("UTF-8 input contains invalid first byte in character");
  if(count > 1) min <<= 1;
  rv = c;
  while(count--) {
    rv *= 1<<6; 
    min <<= 5;
    c = getc(f);
    if((c&0xc0) != 0x80)
      error("UTF-8 input contains invalid subsequent byte in character");
    rv += (c & 0x3f); }
  if(rv < min) error("UTF-8 character has a non-shortest representation");
  return rv; }

el* popstack(el** stack, const char* errmsg) {
  el* rv;
  el* temp;
  if(!*stack) error(errmsg);
  if((**stack).val != STACK) error("Internal error: Stack is not a stack");
  if((**stack).refcount != 1) error("Internal error: Overreferenced stack");
  rv = (**stack).inner;
  temp = (**stack).next;
  free(*stack);
  /* temp.refcount stays the same */
  *stack = temp;
  if(rv) rv->refcount--;
  return rv; }
void pushstack(el** stack, el* e) {
  el* temp = malloc_el();
  if(e) e->refcount++;
  temp->val = STACK;
  temp->refcount = 1;
  temp->inner = e;
  temp->next = *stack;
  /* *stack.refcount stays the same */
  *stack = temp; }

void serialize_underload(el* e, FILE* f, fint stackdir) {
serialise_tco: /* tail-call optimisation of this function by hand */;
  if(!e) return;
  if(debuglevel >= 6) fprintf(f,"[%lu]",(unsigned long)e->refcount);
  switch(e->val) {
  case STACK:
    if(!stackdir) {
      if(debuglevel >+ 6) fprintf(f,"[z]");
      if(e->inner) serialize_underload(e->inner,f,stackdir);
      break; }
    if(e->next) serialize_underload(e->next,f,stackdir);
    putc('{',f);
    if(e->inner) serialize_underload(e->inner,f,stackdir);
    fputs("} ",f);
    return;
  case INNER:
    putc('(',f);
    if(e->inner) serialize_underload(e->inner,f,stackdir);
    putc(')',f);
    break;
  case CAT:
    serialize_underload(e->inner,f,stackdir); break;
  default:
    uniputc(e->val,f); break; }
  if(debuglevel >= 5 && !e->refcount)
    error("Sanity check failed: This should be free by now");
  e=e->next; goto serialise_tco; }
void serialize(el* e, FILE* f, fint stackdir) {
  /* //tk: Efficient serialization for Underlambda */
  serialize_underload(e, f, stackdir); }

el  *stack;     /* the stack */
el  *ip;        /* current point in the program we're executing */
el  *zerostack; /* stack of places to go if we hit null next pointers */
int main(int argc, char **argv) {
  FILE* in;
  int usingstdin;
  el **working;
  el  *temp, *temp2, *temp3;
  int_least32_t c;
  if(!argc||!argv[0]) error("Could not determine executable name");
  char* a0 = argv[0];
  if(strrchr(argv[0],'/')) a0=strrchr(argv[0],'/')+1;
  if(!strcmp(a0,"derlo")) lang=underload;
  if(!strcmp(a0,"derla")) lang=underlambda;
  while(argc>=2) {
    if(!strcmp(argv[1],"-o")) {lang=underload; argv++; argc--;}
    else if(!strcmp(argv[1],"-a")) {lang=underlambda; argv++; argc--;}
    else if(!strncmp(argv[1],"-d",2)) {
      debuglevel=argv[1][2]-'0';
      if(debuglevel < 0 || debuglevel > 7) debuglevel = 0;
      argv++; argc--; }
    else break; }
  if(lang==unknown || argc > 2) {
    puts("Usage: derl (-o|-a) [inputfile]");
    puts("Options:");
    puts("    -o   Interpret input as Underload");
    puts("    -a   Interpret input as Underlambda");
    puts("    -d0  No debugging");
    puts("    -d1: enable warnings");
    puts("    -d2: free all used resources at program exit");
    puts("    -d3: show program and stack every step");
    puts("    -d5: enable internal sanity checks");
    puts("    -d6: debug memory allocation");
    puts("    -d7: debug internal interpreter program flow");
    puts("Instead of using the -o or -a option, you can invoke this program");
    puts("with the name 'derlo' or 'derla'. All -d options include all");
    puts("previous -d options except -d0. -d0 is the default.");
    return argc==1 ? 0 : EXIT_FAILURE; }
  if(argc==2) {
    in = fopen(argv[1],"rb");
    if(!in) {perror(argv[1]); return EXIT_FAILURE;}
  } else {in = stdin; usingstdin = 1;}
  stack = 0;
  ip = 0;
  zerostack = 0;
  working = &ip;
  while(((c=unigetc(in)))!=EOF) {
    if(c==')') {
      temp = popstack(&zerostack,"Unmatched )");
      working = &(temp->next);
      continue; }
    if(c=='(') {
      *working = malloc_el();
      (**working).refcount = 1;
      (**working).val = INNER;
      (**working).inner = 0;
      (**working).next = 0;
      pushstack(&zerostack,*working);
      working = &((**working).inner);
      continue; }
    /* //tk: string parsing for Underlambda */
    /* //tk: EOF parsing for Underlambda */
    *working = malloc_el();
    (**working).refcount = 1;
    (**working).val = c;
    (**working).inner = 0;
    (**working).next = 0;
    working = &((**working).next); }
  if(zerostack) error("Expected ) at end of input");

  while(ip || zerostack) {
    if(!ip) {
      if(debuglevel >= 7) fprintf(stderr,"Moving back in zerostack.\n");
      ip = popstack(&zerostack,"Internal error: Zerostack disappeared");
      if(ip) ip->refcount++;
      continue; }
    if(debuglevel >= 3) {
      putc('\t',stderr);
      serialize(stack,stderr,1);
      serialize(ip,stderr,0);
      serialize(zerostack,stderr,0);
      putc('\n',stderr); }
    switch(ip->val) {
    case STACK:
      error("Internal error: Stack element found in program");
    case CAT:
      /* not a command, but an optimisation to avoid duplicating things;
	 put ip->next on the zerostack so we can go back to it later, and
	 continue with ip->inner */
      if(debuglevel >= 7) fprintf(stderr,"Evaluating a lazy cat.\n");
      if(!ip->inner) break; /* continue with ip->next */
      if(debuglevel >= 7) fprintf(stderr,"The cat was nontrivial.\n");
      pushstack(&zerostack,ip->next);
      temp = ip->inner;
      ip->refcount--;
      temp->refcount++;
      checkfree(ip);
      ip = temp;
      continue;
    case INNER:
      if(debuglevel >= 7) fprintf(stderr,"Pushing to the stack.\n");
      if(ip->inner)
	pushstack(&stack,ip->inner);
      else
	pushstack(&stack,0);
      break;
    case '!':
      if(debuglevel >= 7) fprintf(stderr,"Popping the stack.\n");
      temp = popstack(&stack,"Stack underflow in !");
      checkfree(temp);
      break;
    case 'S':
      if(debuglevel >= 7) fprintf(stderr,"Serialising TOS.\n");
      temp = popstack(&stack,"Stack underflow in S");
      if(temp) temp->refcount++;
      serialize(temp,stdout,0);
      fflush(stdout);
      if(temp) temp->refcount--;
      if(debuglevel >= 3) putc('\n',stdout);
      checkfree(temp);
      break;
    case '~':
      if(debuglevel >= 7) fprintf(stderr,"Swapping stack elements.\n");
      temp  = popstack(&stack,"Stack underflow in ~");
      temp2 = popstack(&stack,"Stack underflow in ~");
      pushstack(&stack,temp);
      pushstack(&stack,temp2);
      break;
    case 'a':
      if(debuglevel >= 7) fprintf(stderr,"Wrapping the top stack element.\n");
      temp = malloc_el();
      temp->refcount = 0;
      temp->inner = popstack(&stack,"Stack underflow in a");
      if(temp->inner) temp->inner->refcount++;
      temp->val = INNER;
      temp->next = 0;
      pushstack(&stack,temp);
      break;
    case ':':
      if(debuglevel >= 7) fprintf(stderr,"Duplicating the top stack element.\n");
      temp = popstack(&stack,"Stack underflow in :");
      pushstack(&stack,temp);
      pushstack(&stack,temp);
      break;
    case '*':
      if(debuglevel >= 7) fprintf(stderr,"Catting two stack elements.\n");
      temp  = popstack(&stack,"Stack underflow in *");
      temp2 = popstack(&stack,"Stack underflow in *");
      /* The degenerate cases of catting a null string need to be handled */
      if(!temp ) {pushstack(&stack,temp2); break;}
      if(!temp2) {pushstack(&stack,temp ); break;}
      temp->refcount++; /* if temp and temp2 are aliased, this correctly
			   prevents the optimisation happening */
      if(temp2->refcount == 0) {
	/* Tailcat optimisation: if nothing else is using the stack
	   element we're catting to, just change its next pointer to do
	   the catting directly. */
	if(debuglevel >= 7) fprintf(stderr,"Trying tailcat optimisation.\n");
	temp3 = temp2;
	while(temp3->next) {
	  if(temp3->refcount > 1) goto cantoptimise_star;
	  temp3 = temp3->next; }
	if(temp3->refcount > 1) goto cantoptimise_star;
	if(debuglevel >= 7) fprintf(stderr,"Tailcat optimisation succeeded.\n");
	temp3->next = temp;
	temp3 = temp2; }
      else {
      cantoptimise_star: ;
	temp3 = malloc_el();
	temp3->refcount = 0;
	temp3->next = temp;
	temp3->inner = temp2;
	temp2->refcount++;
	temp3->val = CAT; }
      pushstack(&stack,temp3);
      break;
    case '^':
      if(debuglevel >= 7) fprintf(stderr,"Evalling the stack.\n");
      temp = popstack(&stack,"Stack underflow in ^");
      if(!temp) break; /* continue with ip->next */
      while(ip->refcount == 1 && !(ip->next) && zerostack) {
	/* Tailcall optimisation. */
	if(debuglevel >= 7) fprintf(stderr,"Tailcall optimisation.\n");
	ip->next = popstack(&zerostack,
			    "Internal error: Zerostack disappeared"); }
      if(ip->next) ip->next->refcount++;
      if(temp->refcount == 0) {
	/* Tailcat optimisation on the call stack; replace the return at
	   the end of the called code with a goto, as long as it isn't
	   used anywhere else */
	if(debuglevel >= 7) fprintf(stderr,"Trying tailcat optimisation.\n");
	temp3 = temp;
	while(temp3->next) {
	  if(temp3->refcount > 1) goto cantoptimise_caret;
	  temp3 = temp3->next; }
	if(temp3->refcount > 1) goto cantoptimise_caret;
	temp3->next = ip->next;
	if(debuglevel >= 7) fprintf(stderr,"Tailcat optimisation succeeded.\n");
	temp2 = temp; }
      else {
      cantoptimise_caret: ;
	temp2 = malloc_el();
	temp2->refcount = 0;
	temp2->next = ip->next;
	temp2->inner = temp;
	temp->refcount++;
	temp2->val = CAT; }
      ip->refcount--;
      if(temp2) temp2->refcount++;
      checkfree(ip);
      ip = temp2;
      continue;
    default:
      fprintf(stderr, "Attempt to execute unknown command %d\n",ip->val);
      return EXIT_FAILURE; }
    temp = ip->next;
    ip->refcount--;
    if(temp) temp->refcount++;
    checkfree(ip);
    ip = temp; }
  if(!usingstdin) fclose(in);
  if(debuglevel >= 1 && stack)
    fprintf(stderr, "Warning: Stack was not empty at program exit\n");
  if(debuglevel >= 3) {
    serialize(stack,stderr,1);
    putc('\n',stderr); }
  if(debuglevel >= 2)
    while(stack)
      checkfree(popstack(&stack,"Internal error: Stack has inconsistent size"));
  return 0; }