/*
 * Copyright (c) 2009  Henry Strickland.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. The name of Henry Strickland
 *    may not be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY HENRY STRICKLAND ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL HENRY STRICKLAND BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>

#include <iostream>
#include <map>
#include <string>

//#ifdef DEBUG
//#define Debug   if (1) cerr << "## "
//#else
//#define Debug   if (0) cerr
//#endif

#define assert(X) if (!(X)) Fatal << "FATAL: LINE{" << __LINE__ << "} ASSERT{" #X "}  "
using namespace std;

struct Twerp {
int verbose;

#define Debug if(verbose) Logger(this, 0).stream
#define Fatal Logger(this, 1).stream

struct Logger {
  Twerp* twerp;
  int fatal;
  ostream &stream;
  Logger(Twerp* t, bool fatality)
      : twerp(t), fatal(fatality), stream(cerr) {
    PrintState();
  }
  ~Logger() {
    stream << "\n";
    if (fatal) {
      stream << "FATAL: Exiting with bad status.\n";
      exit(13);
    }
  }
  void PrintState() {
    if (fatal || twerp->verbose>1) {
      sn env = twerp->state.env;
      sn work = twerp->state.work;
      sn stk = twerp->state.stk;
      int i = 0;  // frame counter
      sn w = work;
      while (w != twerp->NIL) {
        twerp->Pop(w);
        twerp->Pop(w);
	++i; // count how many frames
      }
      while (work != twerp->NIL) {
        sn verb = twerp->Pop(work);
        sn obj = twerp->Pop(work);
	stream << "      [" << i << "] " << twerp->Str(verb) << ":\n";
	if (verb == twerp->APPLY) {
	  sn a = twerp->Reverse(obj);
	  while (a != twerp->NIL) {
	    sn p = twerp->Pop(a);
	    sn v = (stk != twerp->NIL) ? twerp->Pop(stk) : sn(0);
	    stream << "        ++ " << twerp->Str(p)
	           << "  ==>  " << twerp->Str(v) << "  <==\n";
	  }
	  // simulated result of APPLY
	  twerp->Push(stk, twerp->Atom(string("<APPLY#") + twerp->Str(i) + ">"));
	} else if (verb == twerp->EVAL) {
	  stream << "        == " << twerp->Str(obj) << "\n";
	  twerp->Push(stk, twerp->Atom(string("<EVAL#") + twerp->Str(i) + ">"));
	} else if (verb == twerp->PREPLY) {
	  stream << "        == " << twerp->Str(obj) << "\n";
	  //twerp->Push(stk, twerp->Atom(string("<EVAL#") + twerp->Str(i) + ">"));
	} else if (verb == twerp->IF) {
	  sn value = stk != twerp->NIL ? twerp->Pop(stk) : sn(0);
	  stream << "        -- If    ==>  " << twerp->Str(value) << "  <==\n";
	  stream << "        -- Then  ==>  " << twerp->Str(twerp->car(obj)) << "  <==\n";
	  stream << "        -- Else  ==>  " << twerp->Str(twerp->cadr(obj)) << "  <==\n";
	  twerp->Push(stk, twerp->Atom(string("<IF#") + twerp->Str(i) + ">"));
	} else if (verb == twerp->BIND) {
	  sn value = stk != twerp->NIL ? twerp->Pop(stk) : sn(0);
	  twerp->Push(env, value);
	  twerp->Push(env, obj);
	  stream << "        -- " << twerp->Str(obj)
	         << "  ==>  " << twerp->Str(value) << "  <==\n";
	} else if (verb == twerp->UNBIND) {
	  sn label = env != twerp->NIL ? twerp->Pop(env) : sn(0);
	  sn value = env != twerp->NIL ? twerp->Pop(env) : sn(0);
	  stream << "        -- " << twerp->Str(label)
	         << "  ==>  " << twerp->Str(value) << "  <==\n";
	} else {
	  stream << "        ?? " << twerp->Str(verb) << "\n";
	}
	--i;
      }
      if (env != twerp->NIL) stream << "OOPS -- env not empty.\n", exit(13);
      if (!twerp->consp(stk)) stream << "OOPS -- stk not list.\n", exit(13);
      if (twerp->cdr(stk) != twerp->NIL) stream << "OOPS -- stk not only 1 item.\n", exit(13);
      stream << "      [0] Result: " << twerp->Str(twerp->car(stk)) << "\n";
    }
  }
};
  

typedef unsigned long word;  // big enough to hold a pointer
static const word LOBIT = 1;

typedef struct SNode {
  struct SNode *left, *right;
  SNode(SNode* l, SNode* r) : left(l), right(r) {}
} *sn;

typedef sn (Twerp::*PrimFunc)(sn env, sn args);

typedef struct Symbol {
  const string name;
  sn global;
  PrimFunc prim;
  Symbol(const string& n) : name(n), global(NULL), prim(NULL) {}
} *sym;

typedef map<string, sym> SymTable;
SymTable Syms;

sym Intern(const string& s) {
  SymTable::iterator it = Syms.find(s);
  if (it == Syms.end()) {
    sym p = new Symbol(s);
    Syms[s] = p;
    return p;
  } else {
    return it->second;
  }
}

sn NIL, T, LAMBDA, NLAMBDA, QUOTE, BIND, UNBIND, APPLY, PREPLY, EVAL, PRIM, IF, ADDR, DEF, DEFP, _FRAME_;
sn ASSERT, SAY, CAR, CDR, CONS, NULL_, NOT, EQ, ATOMP, LIST, DEFUN, LET;
sn CMP, OP_LT, OP_EQ, OP_GT, IMPLODE, EXPLODE, CALL_CC, JUMP, NL, SUCC, PRED;

bool atomp(sn x) { return (LOBIT == (LOBIT&word(x))); }
bool consp(sn x) { return (0 == (LOBIT&word(x))); }
bool listp(sn x) { return (x == NIL || consp(x)); }

#define CheckAtom(X) assert(atomp(X)) << "{Not an Atom: " << Str(X) << "} "
#define CheckCons(X) assert(consp(X)) << "{Not a Cons: " << Str(X) << "} "
#define CheckList(X) assert(listp(X)) << "{Not a List: " << Str(X) << "} "
#define CheckNil(X) assert(not_(X)) << "{Not Nil: " << Str(X) << "} "

sn Atom(const string& s) { return sn(LOBIT|word(Intern(s))); }
sym AtomSym(sn x) { CheckAtom(x); return sym(~LOBIT&word(x)); }
string AtomName(sn x) { return AtomSym(x)->name; }

sn car(sn x) { CheckCons(x); return x->left; }
sn cdr(sn x) { CheckCons(x); return x->right; }
sn cons(sn l, sn r) { CheckList(r); return new SNode(l, r); }
bool null(sn x) { CheckList(x); return x == NIL; }
bool not_(sn x) { return x == NIL; }

sn cadr(sn x) { return car(cdr(x)); }
sn cddr(sn x) { return cdr(cdr(x)); }
sn caddr(sn x) { return car(cdr(cdr(x))); }
sn cadddr(sn x) { return car(cdr(cdr(cdr(x)))); }
sn list1(sn x) { return cons(x, NIL); }
sn list2(sn x, sn y) { return cons(x, cons(y, NIL)); }
sn list3(sn x, sn y, sn z) { return cons(x, cons(y, cons(z, NIL))); }
sn list4(sn x, sn y, sn z, sn a) { return cons(x, cons(y, cons(z, cons(a, NIL)))); }
sn list5(sn x, sn y, sn z, sn a, sn b) { return cons(x, cons(y, cons(z, cons(a, cons(b, NIL))))); }
sn list6(sn x, sn y, sn z, sn a, sn b, sn c) { return cons(x, cons(y, cons(z, cons(a, cons(b, cons(c, NIL)))))); }

sn Pop(sn &X) { sn z = car(X); X = cdr(X); return z; }
void Push(sn &X, sn a) { X = cons(a, X); }

void AppendEscapedChar(char c, string *z) {
  if (32<c && c<127 && c!='(' && c!=')' && c!='\\' && c!='\'' && c!='\"') {
    z->push_back(c);
  } else {
    z->push_back('\\');
    z->push_back(c);
  }
}

string Escaped(string s) {
  string z;
  for (int i=0; i<s.size(); i++) {
    AppendEscapedChar(s[i], &z);
  }
  return z;
}

string Str(word x) {
  char buf[99];
  sprintf(buf, "%ld", x);
  return buf;
}
string Str(sn x) {
  // Special C-NULL case
  if (!x) {
    return "<NULL>";
  }

  // Case of Atom
  if (atomp(x)) {
    return Escaped(AtomName(x));
  }

  // Case of (QUOTE quoted)
  if (car(x) == QUOTE && cdr(x) != NIL && cddr(x) == NIL) {
    return string("\'") + Str(cadr(x));
  }

  // Case of List
  string z = "( ";
  while (x != NIL) {
    z += Str(car(x)) + " ";
    x = cdr(x);
  }
  return z + ")";
}

sn Lookup(sn env, sn x) {
  CheckList(env);
  CheckAtom(x);
  while (env != NIL) {
    if (car(env) == x) return cadr(env);
    env = cddr(env);
  }
  sym s = AtomSym(x);
  if (s->global) return s->global;

  Fatal << "LOOKUP NOT FOUND: " << AtomName(x) << "\n";
}

sn PrimAssert(sn env, sn args) {
  Debug << "PrimAssert: " << Str(args) << "\n";
  CheckCons(args);
  sn a1 = car(args);
  assert(a1 != NIL);
  return a1;
}
sn PrimSay(sn env, sn args) {
  Debug << "PrimSay: " << Str(args) << "\n";
  CheckCons(args) << "SAY needs an arg.";
  CheckNil(cdr(args)) << "Too many args to SAY.";
  string s = Str(car(args));
  fprintf(stderr, "## %s\n", s.c_str());
  return car(args);
}
sn PrimCar(sn env, sn args) {
  Debug << "PrimCar: " << Str(args) << "\n";
  CheckCons(args) << "car needs an arg.";
  CheckNil(cdr(args)) << "Too many args to car.";
  sn a1 = car(args);
  return car(a1);
}
sn PrimCdr(sn env, sn args) {
  Debug << "PrimCdr: " << Str(args) << "\n";
  CheckCons(args) << "cdr needs an arg.";
  CheckNil(cdr(args)) << "Too many args to cdr.";
  sn a1 = car(args);
  return cdr(a1);
}
sn PrimCons(sn env, sn args) {
  Debug << "PrimCons: " << Str(args) << "\n";
  CheckCons(args);
  assert(cddr(args) == NIL);
  sn a1 = car(args);
  sn a2 = cadr(args);
  return cons(a1, a2);
}
sn PrimNull(sn env, sn args) {
  Debug << "PrimNull: " << Str(args) << "\n";
  CheckCons(args);
  assert(cdr(args) == NIL);
  sn a1 = car(args);
  return null(a1) ? T : NIL;
}
sn PrimNot(sn env, sn args) {
  Debug << "PrimNot: " << Str(args) << "\n";
  CheckCons(args);
  assert(cdr(args) == NIL);
  sn a1 = car(args);
  return not_(a1) ? T : NIL;
}
sn PrimAtomp(sn env, sn args) {
  Debug << "PrimAtomp: " << Str(args) << "\n";
  CheckCons(args);
  assert(cdr(args) == NIL);
  sn a1 = car(args);
  return atomp(a1) ? T : NIL;
}
sn PrimEq(sn env, sn args) {
  Debug << "PrimEq: " << Str(args) << "\n";
  CheckCons(args);
  assert(cddr(args) == NIL);
  sn a1 = car(args);
  sn a2 = cadr(args);
  return a1 == a2 ? T : NIL;
}
sn PrimList(sn env, sn args) {
  Debug << "PrimList: " << Str(args) << "\n";
  CheckList(args);
  return args;
}
sn PrimCmp(sn env, sn args) {
  Debug << "PrimCmp: " << Str(args) << "\n";
  CheckList(args);
  CheckCons(args);
  assert(cddr(args) == NIL);
  sn a1 = car(args);
  sn a2 = cadr(args);
  CheckAtom(a1);
  CheckAtom(a2);
  int z = strcmp(AtomName(a1).c_str(), AtomName(a2).c_str());
  return z<0 ? OP_LT : z==0 ? OP_EQ : OP_GT;
}
sn PrimExplode(sn env, sn args) {
  Debug << "PrimExplode: " << Str(args) << "\n";
  CheckCons(args);
  assert(cdr(args) == NIL);
  sn a1 = car(args);
  CheckAtom(a1);
  string s1 = AtomName(a1).c_str();
  int n = s1.size();
  sn z = NIL;
  for (int i=n-1; i>=0; i--) {
    Push(z, Atom(s1.substr(i, 1)));
  }
  return z;
}
sn PrimImplode(sn env, sn args) {
  Debug << "PrimImplode: " << Str(args) << "\n";
  CheckCons(args);
  assert(cdr(args) == NIL);
  sn a1 = car(args);
  CheckCons(a1);
  string s;
  while (a1 != NIL) {
    CheckAtom(car(a1));
    s += AtomName(car(a1));
    a1 = cdr(a1);
  }
  return Atom(s);
}
sn PrimAddr(sn env, sn args) {
  Debug << "PrimAddr: " << Str(args) << "\n";
  CheckCons(args);
  assert(cdr(args) == NIL);
  sn a1 = car(args);
  char buf[99];
  sprintf(buf, "<%lu>", word(a1));
  return Atom(buf);
}
sn PrimDef(sn env, sn args) {
  Debug << "PrimDef: " << Str(args) << "\n";
  CheckCons(args);
  CheckCons(cdr(args));
  assert(cddr(args) == NIL);
  sn a1 = car(args);
  sn a2 = cadr(args);
  sym s1 = AtomSym(a1);
  assert(s1->global == NULL);
  s1->global = a2;
  return a2;
}
sn PrimDefp(sn env, sn args) {
  Debug << "PrimDefp: " << Str(args) << "\n";
  CheckCons(args);
  CheckNil(cdr(args));
  sn a1 = car(args);
  sym s1 = AtomSym(a1);
  return (s1->global == NULL) ? NIL : T;
}
sn PrimEval(sn env, sn args) {
  Debug << "PrimEval: " << Str(args) << "\n";
  CheckCons(args) << "eval requires an arg";
  CheckNil(cdr(args)) << "eval requires only one arg";
  sn a1 = car(args);

  // This is tricky -- modifying state is overwritten, unless we return NULL.
  Pop(state.stk);  // get rid of the pending (prim eval) and arg
  Pop(state.stk);
  Pop(state.work);  // get rid of the pending APPLY
  Pop(state.work);
  Push(state.work, a1);
  Push(state.work, EVAL); // 3. now EVAL for result

  return NULL;  // special return value, means use tweaked state.
}
#ifndef THIN
sn PrimSucc(sn env, sn args) {
  Debug << "PrimSucc: " << Str(args) << "\n";
  CheckCons(args) << "car needs an arg.";
  CheckNil(cdr(args)) << "Too many args to car.";
  sn a1 = car(args);
  CheckAtom(a1) << "succ requires an atom";
  sym s = AtomSym(a1);
  assert(s->name.size() == 1) << "succ requires a single char symbol";
  const char* cp = s->name.c_str();
  char buf[1];
  buf[0] = cp[0] + 1;
  return cp[0] == char(255) ? NIL : Atom(string(buf, 1));
}
sn PrimPred(sn env, sn args) {
  Debug << "PrimPred: " << Str(args) << "\n";
  CheckCons(args) << "car needs an arg.";
  CheckNil(cdr(args)) << "Too many args to car.";
  sn a1 = car(args);
  CheckAtom(a1) << "pred requires an atom";
  sym s = AtomSym(a1);
  assert(s->name.size() == 1) << "pred requires a single char symbol";
  const char* cp = s->name.c_str();
  char buf[1];
  buf[0] =  cp[0] - 1;
  return cp[0] == 0 ? NIL : Atom(string(buf, 1));
}
#endif


void InitAtoms() {
  NIL = Atom("nil");
  T = Atom("t");
  LAMBDA = Atom("lambda");
  NLAMBDA = Atom("nlambda");
  QUOTE = Atom("quote");
  BIND = Atom("bind");
  UNBIND = Atom("unbind");
  PREPLY = Atom("preply");
  APPLY = Atom("apply");
  PRIM = Atom("prim");
  IF = Atom("if");
  DEFUN = Atom("defun");
  LET = Atom("let");
  CALL_CC = Atom("call-cc");
  JUMP = Atom("jump");
  _FRAME_ = Atom("___FRAME___");

  OP_LT = Atom("<");
  OP_EQ = Atom("=");
  OP_GT = Atom(">");

  AtomSym(T)->global = T; // global t has value t

  ASSERT = Atom("assert");
  AtomSym(ASSERT)->global = list2(PRIM, ASSERT);
  AtomSym(ASSERT)->prim = &Twerp::PrimAssert;

  SAY = Atom("say");
  AtomSym(SAY)->global = list2(PRIM, SAY);
  AtomSym(SAY)->prim = &Twerp::PrimSay;

  CAR = Atom("car");
  AtomSym(CAR)->global = list2(PRIM, CAR);
  AtomSym(CAR)->prim = &Twerp::PrimCar;

  CDR = Atom("cdr");
  AtomSym(CDR)->global = list2(PRIM, CDR);
  AtomSym(CDR)->prim = &Twerp::PrimCdr;

  CONS = Atom("cons");
  AtomSym(CONS)->global = list2(PRIM, CONS);
  AtomSym(CONS)->prim = &Twerp::PrimCons;

  NULL_ = Atom("null");
  AtomSym(NULL_)->global = list2(PRIM, NULL_);
  AtomSym(NULL_)->prim = &Twerp::PrimNull;

  NOT = Atom("not");
  AtomSym(NOT)->global = list2(PRIM, NOT);
  AtomSym(NOT)->prim = &Twerp::PrimNot;

  ATOMP = Atom("atomp");
  AtomSym(ATOMP)->global = list2(PRIM, ATOMP);
  AtomSym(ATOMP)->prim = &Twerp::PrimAtomp;

  EQ = Atom("eq");
  AtomSym(EQ)->global = list2(PRIM, EQ);
  AtomSym(EQ)->prim = &Twerp::PrimEq;

  LIST = Atom("list");
  AtomSym(LIST)->global = list2(PRIM, LIST);
  AtomSym(LIST)->prim = &Twerp::PrimList;

  CMP = Atom("cmp");
  AtomSym(CMP)->global = list2(PRIM, CMP);
  AtomSym(CMP)->prim = &Twerp::PrimCmp;

  EVAL = Atom("eval");
  AtomSym(EVAL)->global = list2(PRIM, EVAL);
  AtomSym(EVAL)->prim = &Twerp::PrimEval;

  IMPLODE = Atom("implode");
  AtomSym(IMPLODE)->global = list2(PRIM, IMPLODE);
  AtomSym(IMPLODE)->prim = &Twerp::PrimImplode;

  EXPLODE = Atom("explode");
  AtomSym(EXPLODE)->global = list2(PRIM, EXPLODE);
  AtomSym(EXPLODE)->prim = &Twerp::PrimExplode;

  ADDR = Atom("addr");
  AtomSym(ADDR)->global = list2(PRIM, ADDR);
  AtomSym(ADDR)->prim = &Twerp::PrimAddr;

  DEF = Atom("def");
  AtomSym(DEF)->global = list2(PRIM, DEF);
  AtomSym(DEF)->prim = &Twerp::PrimDef;

  DEFP = Atom("defp");
  AtomSym(DEFP)->global = list2(PRIM, DEFP);
  AtomSym(DEFP)->prim = &Twerp::PrimDefp;

#ifndef THIN
  SUCC = Atom("succ");
  AtomSym(SUCC)->global = list2(PRIM, SUCC);
  AtomSym(SUCC)->prim = &Twerp::PrimSucc;

  PRED = Atom("pred");
  AtomSym(PRED)->global = list2(PRIM, PRED);
  AtomSym(PRED)->prim = &Twerp::PrimPred;
#endif
  sn newline = Atom("\n");
  NL = Atom("nl");
  AtomSym(NL)->global = newline;
}

struct State {
  sn env, work, stk;
  State(sn e, sn w, sn s) : env(e), work(w), stk(s) {}
  State() : env(NULL), work(NULL), stk(NULL) {}
} state;

string Str(State t) { return Str(list6(Atom("ENV:"), t.env, Atom("WORK:"), t.work, Atom("STK:"), t.stk)); }

sn Reverse(sn a) {
  sn z = NIL;
  while (a != NIL) {
    Push(z, Pop(a));
  }
  return z;
}

void Step() {
  sn env = state.env;
  sn work = state.work;
  sn stk = state.stk;
  CheckList(env);
  CheckCons(work);  // not NIL
  CheckList(stk);
  sn w = Pop(work);
  sn a = Pop(work);
  Debug << "\n### Step:  " << Str(w) << "  " << Str(a) << "\n";
  Debug << "\n###        " << Str(state) << "\n";

  if (w == BIND) {
    sn value = Pop(stk);
    Push(env, value);
    Push(env, a);
    //Debug << "Bind: " << Str(a) << " <- " << Str(value) << "\n";
  } else if (w == UNBIND) {
    sn var = Pop(env);
    assert (var == a);
    sn value = Pop(env);
    //Debug << "UnBind: " << Str(a) << " // " << Str(value) << "\n";
  } else if (w == APPLY) {
    //Debug << "Apply:: [" << Str(a) << "]   stk: " << Str(stk) << "\n";
    // a has length of num of args.

    // PRE REVERSING HACK
    sn v_stk = NIL;
    sn v_a = NIL;
    sn counter = a;
    while (!null(counter)) {
      Push(v_stk, Pop(stk));
      Push(v_a, Pop(counter));
    }

    sn fn = Pop(v_stk);
    CheckCons(fn);
    Pop(v_a); // pop & ignore, for the counter
    
    if (PRIM == car(fn)) { // Primative (builtin) functions

      sn r_args = NIL;
      while (!null(v_a)) {
        sn x = Pop(v_stk);
        //Debug << "Apply: pushing Pop(v_stk) to r_args: " << Str(x) << "\n";
        Push(r_args, x);
        (void) Pop(v_a); // pop & ignore, for the counter
      }
      sn args = NIL;
      while (!null(r_args)) {
        Push(args, Pop(r_args));
      }
      CheckAtom(cadr(fn));
      sym sy = AtomSym(cadr(fn));
      assert(sy);
      //Debug << "Apply: Prim: " << sy->name << "  args: " << Str(args) << "\n";
      assert(sy->prim);
      sn z = (this->*sy->prim)(env, args);
      if (z) {
        // Normal Case  
        //Debug << "Apply: Prim Returns: " << Str(z) << "\n";
        Push(stk, z);
      } else {
        // Special case, just for EVAL, so far
	// EVAL changed state, so get stuff from there.
	env = state.env;
	work = state.work;
	stk = state.stk;
      }
    } else if (LAMBDA == car(fn)) {

        // Apply the lambda function
        CheckCons(cdr(fn));  // must have 2nd part: params
        CheckCons(cddr(fn)); // must have 3rd part: expr
        sn params = cadr(fn);
        sn expr = caddr(fn);

	// Put stuff back on stack, so it can be bound.
	while (!null(v_stk)) {
	  Push(stk, Pop(v_stk));
	}

        sn rev_params = NIL;
        sn pp = params;
        while (pp != NIL) {
          sn p = Pop(pp);
          CheckAtom(p);
          Push(rev_params, p);
	}
#ifndef NDEBUG
        // Debugging Marker
        Push(work, _FRAME_);
        Push(work, UNBIND);
	sn lambda_frame = fn;
#endif

	pp = rev_params;
        while (pp != NIL) {
          Push(work, Pop(pp));
          Push(work, UNBIND);
        }
	Push(work, expr);
	Push(work, EVAL);

        pp = params;
        while (pp != NIL) {
          sn param = Pop(pp);
          Push(work, param);
          Push(work, BIND);
//Debug << "Apply bind:  " << Str(param) << "\n";
	}
#ifndef NDEBUG
        // Debugging Marker
        Push(stk, lambda_frame);
        Push(work, _FRAME_);
        Push(work, BIND);
#endif


    } else if (JUMP == car(fn)) {
      Pop(fn);  // pop the JUMP
      Pop(a);  // pop the counter
//Debug << "Apply JUMP record:  " << Str(fn) << "\n";
      sn retval = Pop(stk); // retval from stack
//Debug << "Apply JUMP retval:  " << Str(retval) << "\n";
      sn new_env = Pop(fn); 
      sn new_work = Pop(fn); 
      sn new_stk = Pop(fn); 
      env = new_env;
      work = new_work;
      stk = new_stk;
      Push(stk, retval);

    } else {
      Fatal << "Apply Error:  Not a function: " << Str(fn) << "\n";
    }
  } else if (w == IF) {
    sn pred = Pop(stk);
    if (not_(pred)) {
      // Use the else clause.
      Push(work, cadr(a));
    } else {
      // Use the then clause.
      Push(work, car(a));
    }
    Push(work, EVAL);  // eval 1 of them.
  } else if (w == EVAL) {
    //Debug << "Eval: " << Str(a) << " env: " << Str(env) << "\n";
    if (atomp(a)) {
      sn z = Lookup(env, a);
      assert(z);
      //Debug << "Eval Lookup Result: " << Str(z) << "\n";
      Push(stk, z);
    } else {
      CheckCons(a); // cant be empty
      sn cmd = car(a);
      // Check for Special Forms...
      if (cmd == QUOTE) {
        Push(stk, cadr(a));
      } else if (cmd == LAMBDA) {
        Push(stk, a);  // LAMBDA is self-evaluating
      } else if (cmd == NLAMBDA) {
        Push(stk, a);  // NLAMBDA is self-evaluating
      } else if (cmd == IF) {
#ifndef NDEBUG
        // Debugging Marker
        Push(work, _FRAME_);
        Push(work, UNBIND);
	sn if_frame = a;
#endif

        Push(work, list2(caddr(a), cadddr(a)));  // then & else clauses
	Push(work, IF);
        Push(work, cadr(a));  // Predicate to evaluate
	Push(work, EVAL);

#ifndef NDEBUG
        // Debugging Marker
        Push(stk, if_frame);
        Push(work, _FRAME_);
        Push(work, BIND);
#endif

      } else if (cmd == CALL_CC) {
        Pop(a); // pop the CALL_CC
        sn fn = Pop(a); // pop the function arg

        sn jump = NIL;     // a JUMP record for current state
	Push(jump, stk);
	Push(jump, work);
	Push(jump, env);
	Push(jump, JUMP);

        sn expr = NIL;     // expression to pass JUMP to fn
	Push(expr, jump);
	Push(expr, fn);

	Push(stk, jump);
	Push(stk, fn);

	Push(work, expr);
	Push(work, APPLY);

      } else if (cmd == LET) {
//Debug << "LET pre-work <- " << Str(work) << "\n";
//Debug << "LET a <- " << Str(a) << "\n";
//
#ifndef NDEBUG
        // Debugging Marker
        Push(work, _FRAME_);
        Push(work, UNBIND);
	sn let_frame = a;
#endif

        Pop(a); // pop the LET
        sn todo = NIL;  // for reversing the work
	CheckCons(a);   // must have at least 1 arg
	while (a != NIL && cdr(a) != NIL) {
	  // symbol and value
	  sn sym = Pop(a);
	  sn expr = Pop(a);
//Debug << "PUSHING EVAL <- " << Str(car(a)) << "\n";
	  Push(todo, EVAL);
	  Push(todo, expr);
//Debug << "PUSHING BIND <- " << Str(car(a)) << "\n";
	  Push(todo, BIND);
	  Push(todo, sym);

	  Push(work, sym);
	  Push(work, UNBIND);
	}
	CheckCons(a);
//Debug << "LET2a <- " << Str(a) << "\n";
	Push(work, Pop(a));
	Push(work, EVAL);
//Debug << "LET3a <- " << Str(a) << "\n";
	assert(a == NIL);
	// from todo to work, reversing.
	while (todo != NIL) {
	  Push(work, Pop(todo));
	}

#ifndef NDEBUG
        // Debugging Marker
        Push(stk, let_frame);
        Push(work, _FRAME_);
        Push(work, BIND);
#endif

//Debug << "LET work <- " << Str(work) << "\n";
      } else if (cmd == DEFUN) {
        sn funname = cadr(a);
	sn funargs = caddr(a);
	CheckAtom(funname);
	CheckList(funargs);
	sym s = AtomSym(funname);
	assert(s->global == NULL);  // cannot already be set
	s->global = cons(LAMBDA, cddr(a)); // lambda & args & expr
	Push(stk, s->global);
#if 0
@      } else if (consp(cmd) && car(cmd)==NLAMBDA) {
@        // Special non-arg-evaluating NLAMBDA
@        sn param = car(cadr(cmd)); // first(only) word in second of cmd
@        sn body = caddr(cmd); // third of cmd
@
@#ifndef NDEBUG
@  Push(work, _FRAME_);
@  Push(work, UNBIND);
@  sn eval_frame = cmd;
@#endif
@
@        Push(work, param);
@        Push(work, UNBIND);
@
@        Push(work, body);
@        Push(work, EVAL);
@
@        sn args = cdr(a); // Leave off the head, which is the nlambda list.
@        Push(stk, args);
@        Push(work, param);
@        Push(work, BIND);
@      
@#ifndef NDEBUG
@  // Debugging Marker
@  Push(stk, eval_frame);
@  Push(work, _FRAME_);
@  Push(work, BIND);
@#endif
#endif
      } else {
        // Else it's not special; eval all the args, including the first.
        sn args = a;
	Push(work, args);   // used for its length == arg count
	Push(work, APPLY);
	args = Reverse(args);
	while (args != NIL) {
	  sn arg = Pop(args);
	  if (null(args)) {
	    Push(work, a);
	    Push(work, PREPLY);
	  }
	  Push(work, arg);
	  Push(work, EVAL);
        }
      }
    }
  } else if (w == PREPLY) {
    // inspect the first thing on stack, for a NLAMBDA list
    sn peek = car(stk);
    if (consp(peek) && NLAMBDA == car(peek)) {
      (void) Pop(stk); // already got it in peek

      sn var = car(cadr(peek));  // first and only var name
      sn body = caddr(peek);

      sn count = a;
      (void) Pop(count);   // decrement once for the NLAMBDA
      while (!null(count)) {
        (void) Pop(count); 
        sn should_be_eval = Pop(work);
	assert(EVAL == should_be_eval);
        (void) Pop(work); // arg of eval
      }
      sn should_be_apply = Pop(work);
      assert(APPLY == should_be_apply);
      (void) Pop(work); //arg of apply

      Push(work, var);
      Push(work, UNBIND);

      Push(work, body);
      Push(work, EVAL);

      Push(stk, cdr(a));
      Push(work, var);
      Push(work, BIND);

    } else { // not an NLAMBDA
      // nothing.
    }
  } else {
    Fatal << "BAD WORK: " << Str(w) << ", " << Str(a) << ", " << Str(work) << "\n";
  }
  state.env = env;
  state.work = work;
  state.stk = stk;
}
State Step(State t) { // for old tests
  state = t;
  Step();
  return state;
}
  
  
sn Eval(sn x) {
  state.env = NIL;
  state.work = NIL;
  state.stk = NIL;

#ifndef NDEBUG
  // Debugging Marker
  Push(state.work, _FRAME_);
  Push(state.work, UNBIND);
  sn eval_frame = x;
#endif

  Push(state.work, x);
  Push(state.work, EVAL);

#ifndef NDEBUG
  // Debugging Marker
  Push(state.stk, eval_frame);
  Push(state.work, _FRAME_);
  Push(state.work, BIND);
#endif


  while (state.work != NIL) {
    Step();
    // cerr << "STATE: " << Str(state) << "\n";
  }

  CheckCons(state.stk) << "Final stack should be list.";
  CheckNil(cdr(state.stk)) << "Final stack should only have one item.";

  sn result = car(state.stk);
  Debug << "...RETURNING " << Str(result) << "\n";
  return result;
}

// All control characters are considered White, like spaces.
bool WhiteChar(char c) { return c <= ' '; }

sn ParseLisp(const char* &p, const char* end) {
  // TODO -- always check for end
  //
  while (WhiteChar(*p) && p<end) ++p;  // skip white

  if (*p == ';') {  // comment thru end of line
    ++p; // skip the semicolon
    while (*p != '\n' && p<end) ++p;
    ++p; // skip the newline
    return ParseLisp(p, end);

  } else if (*p == '(') {
    ++p;
    sn rev = NIL;
    while (true) {
      sn x = ParseLisp(p, end);
      if (!x) break;
      Push(rev, x);
    }
    sn list = NIL;
    while (rev != NIL) {
      Push(list, Pop(rev));
    }
    return list;

  } else if (*p == ')') {
    ++p;
    return NULL;           // special return value: End Of List

  } else if (*p == '\'') {   // QUOTE abbr.
    ++p;
    sn quoted = ParseLisp(p, end);
    assert(quoted);
    return list2(QUOTE, quoted);

  } else if (*p == '\"') {   // "double quoted atom"
    ++p;
    string z;
    while (*p != '\"' && p<end) {
      if (*p == '\\') {
        ++p;
	if (p<end) z.push_back(*p);
	++p;
      } else {
        if (p<end) z.push_back(*p);
	++p;
      }
    }
    assert(*p == '\"' && p<end);
    ++p;
      
    return Atom(z);

  } else if (p == end) {
    return NULL;           // special return value: End Of List

  } else {
    // get atom
    string z;
    while (*p>' ' && *p!='(' && *p!=')' && p<end) {
      if (*p == '\\') {
        ++p;  // Skip over backslash push any char after it.
      }
      if (p<end) z.push_back(*p);
      ++p;
    }
    return Atom(z);
  }
}

sn ParseLisp(const string& s) {
  const char* start = s.c_str();
  const char* end = s.c_str() + s.size();
  return ParseLisp(start, end);
}

sn ParseLisp(const char* s) {
  const char* end = s + strlen(s);
  return ParseLisp(s, end);
}
void Tests() {
  sym abc = Intern("abc");

  assert(abc == Intern("abc"));
  assert("abc" == Intern("abc")->name);
  assert(abc != Intern("def"));
  assert("abc" != Intern("def")->name);

  sn def = Atom("def");
  sn xyz = Atom("xyz");
  assert("def" == AtomName(def));
  assert("xyz" == AtomName(xyz));
  assert("nil" == AtomName(NIL));
  assert("t" == AtomName(T));

  assert(atomp(Atom("def")));
  assert(!consp(Atom("def")));
  assert(!listp(Atom("def")));
  assert(listp(Atom("nil")));

  assert(def == car(cons(Atom("def"), list1(Atom("xyz")))));
  assert(xyz == cadr(cons(Atom("def"), list1(Atom("xyz")))));

  sn three = list3(Atom("one"), Atom("two"), Atom("three"));
  assert(Atom("one") == car(three));
  assert(Atom("two") == cadr(three));
  assert(Atom("three") == car(cddr(three)));
  assert(Atom("three") == cadr(cdr(three)));
  assert(NIL == cddr(cdr(three)));

  assert(def == car(list2(def, xyz)));
  assert(xyz == cadr(list2(def, xyz)));
  assert(NIL == cddr(list2(def, xyz)));

  assert(three == car(list1(three)));
  assert(NIL == cdr(list1(three)));

  assert(T == Lookup(NIL, T));
  assert(T == Lookup(list2(def, xyz), T));
  assert(xyz == Lookup(list2(def, xyz), def));

  assert("def" == Str(def));
  assert("( def )" == Str(list1(def)));
  assert("( def ( one two three ) )" == Str(list2(def, three)));

  State t1 = Step(State(NIL, list2(BIND, def), list1(xyz)));
  assert("( def xyz )" == Str(t1.env));
  assert("( ENV: ( def xyz ) WORK: nil STK: nil )" == Str(t1));

  State t2 = Step(State(t1.env, list2(UNBIND, def), NIL));
  assert("( ENV: nil WORK: nil STK: nil )" == Str(t2));

  Debug << "t3:\n";
  State t3 = Step(State(NIL,
                        list2(APPLY, list2(NIL, NIL)),
                        list2(three, list2(PRIM, CAR))));
  assert("( ENV: nil WORK: nil STK: ( one ) )" == Str(t3));

  Debug << "t4:\n";
  State t4 = Step(State(NIL,
                        list2(APPLY, list3(NIL, NIL, NIL)),
                        list3(three, def, list2(PRIM, CONS))));
  assert("( ENV: nil WORK: nil STK: ( ( def one two three ) ) )" == Str(t4));

  Debug << "t5:\n";
  State t5 = Step(State(NIL,
                        list2(EVAL, CAR),
                        NIL));
  assert("( ENV: nil WORK: nil STK: ( ( prim car ) ) )" == Str(t5));

  Debug << "t6:\n";
  State t6 = Step(State(NIL,
                        list2(EVAL, list2(QUOTE, three)),
                        NIL));
  assert("( ENV: nil WORK: nil STK: ( ( one two three ) ) )" == Str(t6));

  Debug << "t7:\n";
  State t7 = Step(State(NIL,
                        list2(EVAL, list3(LAMBDA, list2(def, xyz), NIL)),
                        NIL));
  assert("( ENV: nil WORK: nil STK: ( ( lambda ( def xyz ) nil ) ) )" == Str(t7));

//++verbose;
//++verbose;
  Debug << "t8:\n";
  State t8 = Step(State(NIL,
                        list2(EVAL, list2(CAR, list2(QUOTE, three))),
                        NIL));
  Debug << Str(t8) << "\n";
  t8 = Step(t8);  // eval lambda...
  Debug << Str(t8) << "\n";
  t8 = Step(t8);  // eval preply...
  Debug << Str(t8) << "\n";
  t8 = Step(t8);  // eval quote...
  Debug << Str(t8) << "\n";
  t8 = Step(t8);  // Apply 
  assert("( ENV: nil WORK: nil STK: ( one ) )" == Str(t8));

  Debug << "t9:\n";
  State t9 = Step(State(list2(def, three),
                        list4(EVAL, list2(CAR, list2(CAR, list3(CONS, def, def))),
			      UNBIND, def),
                        NIL));
  while (consp(t9.work)) {
    Debug << Str(t9) << "\n";
    t9 = Step(t9);  // eval quote...
  }
  Debug << "t9 => " << Str(t9) << "\n";
  assert("( one )" == Str(t9.stk));

//++verbose;
  Debug << "t10:\n";
  sn x = Atom("x");
  sn y = Atom("y");
  sn lambda10 = list3(LAMBDA, list2(x, y), list3(CONS, x, y));
  State t10 = Step(State(list2(def, three),
                        list2(EVAL, list3(lambda10, def, list2(CDR, def))),
                        NIL));
  while (consp(t10.work)) {
    Debug << "  .. env: " << Str(t10.env) << "\n";
    Debug << "  .... work: " << Str(t10.work) << "\n";
    Debug << "  ...... stk: " << Str(t10.stk) << "\n";
    t10 = Step(t10);  // eval quote...
  }
  Debug << "t10 => " << Str(t10) << "\n";
  assert("( ( ( one two three ) two three ) )" == Str(t10.stk));

  Debug << "t11:\n";
  sn append = Atom("append");
  AtomSym(append)->global = list3(
      LAMBDA,
      list2(x, y),
      list4(IF,
            list2(NULL_, x),
	    y,
	    list3(CONS,
	          list2(CAR, x),
		  list3(append, list2(CDR, x), y))));
  sn z11 = Eval(list3(append, list2(QUOTE, three), list2(QUOTE, three)));
  Debug << "t11 => " << Str(z11) << "\n";
  assert("( one two three one two three )" == Str(z11));

  Debug << "t12:\n";
  sn reverse = Atom("reverse");
  AtomSym(reverse)->global = list3(
      LAMBDA,
      list1(x),
      list4(IF,
            list2(NULL_, x),
	    list2(QUOTE, NIL),
	    list3(append,
	          list2(reverse, list2(CDR, x)),
		  list2(LIST, list2(CAR, x)))));
  sn z12 = Eval(list2(reverse, list2(QUOTE, three)));
  Debug << "t12 => " << Str(z12) << "\n";
  assert("( three two one )" == Str(z12));

  string t13("  foo  ");
  const char* p13 = t13.c_str();
  const char* e13 = t13.c_str() + t13.size();
  sn z13 = ParseLisp(p13, e13);
  assert(AtomName(z13) == "foo");

  string t14("  ( mumble ( foo ) bar )  ");
  const char* p14 = t14.c_str();
  const char* e14 = t14.c_str() + t14.size();
  sn z14 = ParseLisp(p14, e14);
  CheckList(z14);
  assert(AtomName(car(z14)) == "mumble");
  assert(AtomName(car(cadr(z14))) == "foo");
  assert(AtomName(caddr(z14)) == "bar");

  assert(AtomName(Eval(ParseLisp("( cmp ( quote alpha ) ( quote beta ) )"))) == "<");
  assert(AtomName(Eval(ParseLisp("( cmp ( quote beta ) ( quote beta ) )"))) == "=");
  assert(AtomName(Eval(ParseLisp("( cmp ( quote beta ) ( quote alpha ) )"))) == ">");

  // OKAY
  Debug << "TESTS OKAY." << "\n";
}

void Slurp(const char* filename) {
  struct stat st;
  int e = stat(filename, &st);
  assert(e==0) << "Cannot open file: " << filename;
  char* cp = (char*) malloc(st.st_size+1);
  FILE* fd = fopen(filename, "r");
  assert(fd);
  int cc = fread(cp, 1, st.st_size, fd);
  assert(cc == st.st_size);
  fclose(fd);
  cp[st.st_size] = '\0';

  const char* p = (const char*) cp;
  const char* end = cp + st.st_size;

  sn z = NIL;
  while (p<end) {
    sn x = ParseLisp(p, end);
    if (x) {
      if (verbose) cerr << "\nSLURP expr: " << Str(x) << "\n";
      z = Eval(x);
      if (verbose) cerr << "\nSLURP result: " << Str(z) << "\n\n";
    }
  }
  if (verbose) cerr << "[[" << filename << "]] => " << Str(z) << "\n";
  free(cp);
}

  Twerp() : verbose(0) { InitAtoms(); Tests(); }
};

int main(int argc, const char* argv[]) {
  Twerp twerp;

  for (int i=1; i<argc; ++i) {
    if (string(argv[i]) == "-v") {
      ++ twerp.verbose;
    } else if (argv[i][0] == '(') {
      Twerp::sn x = twerp.ParseLisp(argv[i]);
      if (!x) {
        cerr << "Cannot parse expression: " << argv[i] << "\n";
	return 2;
      }
      Twerp::sn z = twerp.Eval(x);
      if (twerp.atomp(z)) {
        // If just an atom, print it raw: no escaping, no newline.
	cout << twerp.AtomName(z);
      } else {
        // Otherwise, a formatted list, with escaping and newline.
        cout << twerp.Str(z) << "\n";
      }
    } else {
      twerp.Slurp(argv[i]);
    }
  }
  return 0;
}