/* * 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 #include #include #include #include #include #include #include #include #include //#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 = 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("Str(i) + ">")); } else if (verb == twerp->EVAL) { stream << " == " << twerp->Str(obj) << "\n"; twerp->Push(stk, twerp->Atom(string("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("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 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, QUOTE, BIND, UNBIND, APPLY, EVAL, PRIM, IF, ADDR, DEF, _FRAME_; sn ASSERT, CAR, CDR, CONS, NULL_, NOT, EQ, ATOMP, LIST, DEFUN, LET; sn CMP, OP_LT, OP_EQ, OP_GT, IMPLODE, EXPLODE, CALL_CC, JUMP, NL; 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 (32push_back(c); } else { z->push_back('\\'); z->push_back(c); } } string Escaped(string s) { string z; for (int i=0; i"; } // 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; Debug << "LOOKUP NOT FOUND: " << AtomName(x) << "\n"; assert(0); } sn PrimAssert(sn env, sn args) { Debug << "PrimAssert: " << Str(args) << "\n"; CheckCons(args); sn a1 = car(args); assert(a1 != NIL); return a1; } 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 PrimEval(sn env, sn args) { Debug << "PrimEval: " << Str(args) << "\n"; CheckCons(args); CheckCons(cdr(args)); assert(cddr(args) == NIL); sn a1 = car(args); sn a2 = cadr(args); assert(a2 == NIL); // env not supported yet // TODO: This doesnt work -- modifying state is overwritten. 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. } void InitAtoms() { NIL = Atom("nil"); T = Atom("t"); LAMBDA = Atom("lambda"); QUOTE = Atom("quote"); BIND = Atom("bind"); UNBIND = Atom("unbind"); 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; 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; 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)); } 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"; 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. sn fn = Pop(stk); CheckCons(fn); Pop(a); // pop & ignore, for the counter if (PRIM == car(fn)) { // Primative (builtin) functions sn r_args = NIL; while (!null(a)) { sn x = Pop(stk); //Debug << "Apply: pushing Pop(stk) to r_args: " << Str(x) << "\n"; Push(r_args, x); Pop(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); 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 = params; while (pp != NIL) { Push(work, Pop(pp)); Push(work, UNBIND); } Push(work, expr); Push(work, EVAL); pp = rev_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 { Debug << "Apply Error: Not a function: " << Str(fn) << "\n"; assert(0); } } 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 == 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); } 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); while (args != NIL) { sn arg = Pop(args); Push(work, arg); Push(work, EVAL); } } } } 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(); } 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' ' && *p!='(' && *p!=')' && pname); 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(list2(PRIM, CAR), three))); assert("( ENV: nil WORK: nil STK: ( one ) )" == Str(t3)); Debug << "t4:\n"; State t4 = Step(State(NIL, list2(APPLY, list3(NIL, NIL, NIL)), list3(list2(PRIM, CONS), def, three))); 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)); Debug << "t8:\n"; State t8 = Step(State(NIL, list2(EVAL, list2(CAR, list2(QUOTE, three))), NIL)); Debug << Str(t8) << "\n"; t8 = Step(t8); // eval quote... Debug << Str(t8) << "\n"; t8 = Step(t8); // eval lambda... 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), list2(EVAL, list2(CAR, list2(CAR, list3(CONS, def, 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)); 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); 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 " << Str(z) << "\n"; free(cp); } Twerp() : verbose(0) { InitAtoms(); Tests(); } }; int main(int argc, const char* argv[]) { Twerp twerp; for (int i=1; i