/*
 * 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>

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

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

class Twerp;

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

typedef sn (*PrimFunc)(Twerp*, 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;


sn PrimAssert(Twerp* t, sn env, sn args);
sn PrimSay(Twerp* t, sn env, sn args);
sn PrimCar(Twerp* t, sn env, sn args);
sn PrimCdr(Twerp* t, sn env, sn args);
sn PrimCons(Twerp* t, sn env, sn args);
sn PrimNull(Twerp* t, sn env, sn args);
sn PrimNot(Twerp* t, sn env, sn args);
sn PrimAtomp(Twerp* t, sn env, sn args);
sn PrimEq(Twerp* t, sn env, sn args);
sn PrimList(Twerp* t, sn env, sn args);
sn PrimCmp(Twerp* t, sn env, sn args);
sn PrimExplode(Twerp* t, sn env, sn args);
sn PrimImplode(Twerp* t, sn env, sn args);
sn PrimAddr(Twerp* t, sn env, sn args);
sn PrimDef(Twerp* t, sn env, sn args);
sn PrimDefp(Twerp* t, sn env, sn args);
sn PrimEval(Twerp* t, sn env, sn args);
sn PrimSucc(Twerp* t, sn env, sn args);
sn PrimPred(Twerp* t, sn env, sn args);

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

#define TDebug if(t->verbose) Logger(t, 0).stream
#define TFatal Logger(t, 1).stream

struct Logger {
  Twerp* twerp;
  int fatal;
  ostream &stream;
  Logger(Twerp* t, bool fatality);
  ~Logger();
  void PrintState();
};
  
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) {}
};

struct Twerp {
int verbose;
State state;


SymTable Syms;

sym Intern(const string& s);

sn NIL, T, LAMBDA, NLAMBDA, QUOTE, BIND, UNBIND, APPLY, PREPLY, EVAL, PRIM, IF, ADDR, DEF, DEFP, _FRAME_;
sn VERBOSE, 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) << "} "

#define TCheckAtom(X) Tassert(t->atomp(X)) << "{Not an Atom: " << t->Str(X) << "} "
#define TCheckCons(X) Tassert(t->consp(X)) << "{Not a Cons: " << t->Str(X) << "} "
#define TCheckList(X) Tassert(t->listp(X)) << "{Not a List: " << t->Str(X) << "} "
#define TCheckNil(X) Tassert(t->not_(X)) << "{Not Nil: " << t->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);

string Escaped(string s) {
  string z;
  for (size_t 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";
  return NULL; /*NOTREACHED*/
}


void InitAtoms();

string Str(State t);

sn Reverse(sn a);

void Step();
State Step(State t);
  
  
sn Eval(sn x);

// All control characters are considered White, like spaces.
bool WhiteChar(char c);

sn ParseLisp(const char* &p, const char* end);

sn ParseLisp(const string& s);

sn ParseLisp(const char* s);
void Tests();

void Slurp(const char* filename);

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