commit 88910e0

First commit, includes a crappy C interpreter plus a much more pretty lua one

  1@@ -0,0 +1,358 @@
  2+#include <stdio.h>
  3+#include <stdlib.h>
  4+#include <string.h>
  5+
  6+#define DBGS(s) printf("DBG LINE %d: %s\n", __LINE__, s)
  7+#define DBGF(n) printf("DBG LINE %d: %f\n", __LINE__, n)
  8+#define DBGN(n) printf("DBG LINE %d: %d\n", __LINE__, n)
  9+
 10+struct Cons;
 11+
 12+typedef struct Expr {
 13+  enum {T_NMBR, T_PRIM, T_CONS, T_SYMB, T_NIL} tag;
 14+  union {
 15+	double number;
 16+	char* symbol;
 17+	struct Cons* cons;
 18+	//rest of fn( prog, stack, binds )
 19+	struct Expr (*fn)(struct Expr, struct Expr, struct Expr*);
 20+  } value;
 21+} Expr;
 22+
 23+typedef struct Cons {
 24+  Expr car;
 25+  Expr cdr;
 26+} Cons;
 27+
 28+Cons* cons(Expr car, Expr cdr) {
 29+  Cons* c = malloc(sizeof(Cons));
 30+  c->car = car;
 31+  c->cdr = cdr;
 32+  return c;
 33+}
 34+
 35+#define DELIMS " \n\t"
 36+
 37+char* getnext() {
 38+  char* next = strtok(NULL, DELIMS);
 39+  if (next == NULL) {
 40+	printf("Unexpected EOF");
 41+  }
 42+  return next;
 43+}
 44+
 45+int isnum(char* tok) {
 46+  return (strspn(tok, "0123456789") == strlen(tok));
 47+}
 48+
 49+void makesymb(Expr* e, char* tok) {
 50+  e->tag = T_SYMB;
 51+  int toklen = strlen(tok);
 52+  e->value.symbol = malloc((toklen + 1) * sizeof(char));
 53+  strcpy(e->value.symbol, tok);
 54+}
 55+
 56+void makenum(Expr* e, double f) {
 57+  e->tag = T_NMBR;
 58+  e->value.number = f;
 59+}
 60+
 61+void makecons(Expr* e, Expr car, Expr cdr) {
 62+  e->value.cons = cons(car, cdr);
 63+  e->tag = T_CONS;
 64+}
 65+
 66+void parseatom(Expr* e, char* tok) {
 67+  if (isnum(tok)) {
 68+	return makenum(e, atof(tok));
 69+  }
 70+  return makesymb(e, tok);
 71+}
 72+
 73+void parselist(Expr*);
 74+
 75+void parsetok(Expr* e, char* tok) {
 76+  if (strcmp(tok, ")") == 0) {
 77+	exit(1);
 78+  }
 79+  if (strcmp(tok, "(") == 0) {
 80+	return parselist(e);
 81+  }
 82+  return parseatom(e, tok);
 83+}
 84+
 85+void parselist(Expr* e) {
 86+  char* tok;
 87+  tok = getnext();
 88+  if (strcmp(tok, ")") == 0) {
 89+	e->tag = T_NIL;
 90+	return;
 91+  }
 92+  if (strcmp(tok, ".") == 0) {
 93+	tok = getnext();
 94+	parsetok(e, tok);
 95+	tok = getnext();
 96+	if (strcmp(tok, ")") != 0) {
 97+	  exit(1);
 98+	}
 99+	return;
100+  }
101+  Expr head;
102+  parsetok(&head, tok);
103+  Expr tail;
104+  parselist(&tail);
105+  makecons(e, head, tail);
106+}
107+
108+struct Expr parse(char* progstr) {
109+  int proglen = strlen(progstr);
110+  char* prog = malloc(sizeof(char) * (proglen + 1));
111+  strcpy(prog, progstr);
112+  char* tok;
113+  tok = strtok(prog, DELIMS);
114+  Expr r;
115+  parsetok(&r, tok);
116+  free(prog);
117+  return r;
118+}
119+
120+void printexp(Expr);
121+
122+void printlist(Expr e) {
123+  Expr car = e.value.cons->car;
124+  Expr cdr = e.value.cons->cdr;
125+  printexp(car);
126+  printf(" ");
127+  if (cdr.tag == T_CONS) {
128+	printlist(cdr);
129+	return;
130+  }
131+  if (cdr.tag == T_NIL) {
132+	printf(")");
133+	return;
134+  }
135+  printf(". ");
136+  printexp(cdr);
137+  printf(")");
138+}
139+
140+void printexp(Expr e) {
141+  switch (e.tag) {
142+  case T_NMBR:
143+	printf("%f", e.value.number);
144+	break;
145+  case T_SYMB:
146+	printf("%s", e.value.symbol);
147+	break;
148+  case T_NIL:
149+	printf("()");
150+	break;
151+  case T_CONS:
152+	printf("( ");
153+	printlist(e);
154+	break;
155+  case T_PRIM:
156+	printf("PRIMITIVE");
157+	break;
158+  }
159+}
160+
161+void freeexpr(Expr* tofree) {
162+  if (tofree->tag == T_CONS) {
163+	freeexpr(&(tofree->value.cons->car));
164+	Expr cdr = tofree->value.cons->cdr;
165+	free(tofree->value.cons);
166+	return freeexpr(&cdr);
167+  }
168+  if (tofree->tag == T_SYMB) {
169+	free(tofree->value.symbol);
170+  }
171+}
172+
173+void dup(Expr* into, Expr* e) {
174+  switch (e->tag) {
175+  case T_SYMB:
176+	return makesymb(into, e->value.symbol);
177+	break;
178+  case T_CONS:
179+	Expr car;
180+	Expr cdr;
181+	makecons(into, car, cdr);
182+	dup(&(into->value.cons->car), &(e->value.cons->car));
183+	// We make the recursive call on the cdr for lists
184+	return dup(&(into->value.cons->cdr), &(e->value.cons->cdr));
185+	break;
186+  case T_NIL:
187+	into->tag = T_NIL;
188+	return;
189+	break;
190+  }
191+  into->tag = e->tag;
192+  into->value = e->value;
193+}
194+
195+// Checks if two expressions are equal, Non recursive
196+int expsequal(Expr* e1, Expr* e2) {
197+  if (e1->tag != e2->tag) {return 0;}
198+  switch (e1->tag) {
199+  case T_SYMB:
200+	return strcmp(e1->value.symbol, e2->value.symbol) == 0;
201+  case T_NMBR:
202+	return e1->value.number == e2->value.number;
203+  case T_CONS:
204+	return e1->value.cons == e2->value.cons;
205+  }
206+  return 0;
207+}
208+
209+// Adds a bind onto the list, returns pointer to the new list
210+void makebind(Expr* newbinds, char* sym, Expr value, Expr binds) {
211+  Expr symb;
212+  Expr bind;
213+  makesymb(&symb, sym);
214+  makecons(&bind, symb, value);
215+  makecons(newbinds, bind, binds);
216+}
217+
218+Expr* findbind(char* sym, Expr* binds) {
219+  if (binds == NULL) {
220+	return NULL;
221+  }
222+  if (strcmp(binds->value.cons->car.value.cons->car.value.symbol, sym) == 0) {
223+	return &(binds->value.cons->car.value.cons->cdr);
224+  }
225+  return findbind(sym, &(binds->value.cons->cdr));
226+}
227+
228+void evalatom(Expr* val, Expr* binds) {
229+  if (val->tag == T_SYMB) {
230+	dup(val, findbind(val->value.symbol, binds));
231+	return;
232+  }
233+}
234+
235+void uncons(Expr* car, Expr* cdr, Expr pair) {
236+  *car = pair.value.cons->car;
237+  *cdr = pair.value.cons->cdr;
238+  free(pair.value.cons);
239+}
240+
241+Expr evallist(Expr val, Expr stack, Expr* binds) {
242+  if (val.tag == T_NIL) {return stack;}
243+  Expr head;
244+  Expr tail;
245+  uncons(&head, &tail, val);
246+  DBGS("CURRENT EVAL:");
247+  printexp(head);
248+  printf("\n");
249+  evalatom(&head, binds);
250+  if (head.tag == T_PRIM) {
251+	return head.value.fn(tail, stack, binds);
252+  }
253+  Expr newstack;
254+  makecons(&newstack, head, stack);
255+  return evallist(tail, newstack, binds);
256+}
257+
258+void popstack(Expr* top, Expr* stack) {
259+  *top = stack->value.cons->car;
260+  Expr cdr = stack->value.cons->cdr;
261+  free(stack->value.cons);
262+  *stack = cdr;
263+}
264+
265+void pushstack(Expr val, Expr* stack) {
266+  Expr newstack;
267+  makecons(&newstack, val, *stack);
268+  *stack = newstack;
269+}
270+
271+// Builtins
272+
273+Expr add2(Expr prog, Expr stack, Expr* binds) {
274+  Expr arg1;
275+  Expr arg2;
276+  popstack(&arg1, &stack);
277+  popstack(&arg2, &stack);
278+  Expr res;
279+  makenum(&res, arg1.value.number + arg2.value.number);
280+  pushstack(res, &stack);
281+  return evallist(prog, stack, binds);
282+}
283+
284+Expr execmacro(Expr prog, Expr stack, Expr* binds) {
285+  Expr macro;
286+  popstack(&macro, &stack);
287+  pushstack(prog, &stack);
288+  return evallist(macro, stack, binds);
289+}
290+
291+Expr unconsbuiltin(Expr prog, Expr stack, Expr* binds) {
292+  Expr arg1;
293+  popstack(&arg1, &stack);
294+  Expr car;
295+  Expr cdr;
296+  uncons(&car, &cdr, arg1);
297+  pushstack(cdr, &stack);
298+  pushstack(car, &stack);
299+  return evallist(prog, stack, binds);
300+}
301+
302+Expr bindbuiltin(Expr prog, Expr stack, Expr* binds) {
303+  Expr tobind;
304+  Expr sym;
305+  Expr restprog;
306+  popstack(&tobind, &stack);
307+  uncons(&sym, &restprog, prog);
308+  makebind(binds, sym.value.symbol, tobind, *binds);
309+  return evallist(restprog, stack, binds);
310+}
311+
312+Expr evalbuiltin(Expr prog, Expr stack, Expr* binds) {
313+  Expr top;
314+  popstack(&top, &stack);
315+  Expr newbinds;
316+  dup(&newbinds, binds);
317+  Expr nstack = evallist(top, stack, &newbinds);
318+  freeexpr(&newbinds);
319+  return evallist(prog, nstack, binds);
320+}
321+
322+// End Builtins
323+
324+Expr createpriminst(Expr (*prim)(Expr, Expr, Expr*)) {
325+  Expr p;
326+  p.tag = T_PRIM;
327+  p.value.fn = prim;
328+  return p;
329+}
330+
331+void makebase(Expr* binds) {
332+  makebind(binds, "+", createpriminst(add2), *binds);
333+  makebind(binds, ",", createpriminst(evalbuiltin), *binds);
334+  makebind(binds, "$", createpriminst(bindbuiltin), *binds);
335+  makebind(binds, "uncons", createpriminst(unconsbuiltin), *binds);
336+  makebind(binds, "execmacro", createpriminst(execmacro), *binds);
337+}
338+
339+Expr evalprog(char* progstr) {
340+  Expr p = parse(progstr);
341+  DBGS("Finished Parsing");
342+  Expr binds;
343+  binds.tag = T_NIL;
344+  makebase(&binds);
345+  DBGS("Finished Making Binds");
346+  printexp(binds);
347+  printf("\n");
348+  DBGS("Now Evaluating Prog");
349+  Expr s;
350+  s.tag = T_NIL;
351+  Expr e = evallist(p, s, &binds);
352+  return e;
353+}
354+
355+int main() {
356+  Expr s = evalprog("( ( $ x $ y y x ) $ swap ( uncons , ) execmacro x )");
357+  printf("Result: ");
358+  printexp(s);
359+}

  1@@ -0,0 +1,199 @@
  2+local EXPTYPES = {}
  3+EXPTYPES.SYMB = 1
  4+EXPTYPES.CONS = 2
  5+EXPTYPES.PRIM = 3
  6+EXPTYPES.NMBR = 4
  7+EXPTYPES.RUNE = 5
  8+EXPTYPES.NIL  = 6
  9+
 10+local NILOBJ = {type=EXPTYPES.NIL}
 11+
 12+function cons(x, y)
 13+	return {car=x,cdr=y}
 14+end
 15+
 16+function makesymbol(s)
 17+	return {value=s, type=EXPTYPES.SYMB}
 18+end
 19+
 20+function makenumber(n)
 21+	return {value=n, type=EXPTYPES.NMBR}
 22+end
 23+
 24+function makecons(car, cdr)
 25+	return {value=cons(car,cdr), type=EXPTYPES.CONS}
 26+end
 27+
 28+function makeprim(fn)
 29+	return {value=fn, type=EXPTYPES.PRIM}
 30+end
 31+
 32+function getnexttok(p)
 33+	if p ~= nil then
 34+		GETNEXTBUFF = string.gmatch(p, "%S+")
 35+	end
 36+	return GETNEXTBUFF()
 37+end
 38+
 39+function parsetok(tok)
 40+	if tok == "(" then
 41+		return parselist()
 42+	end
 43+	if tonumber(tok) ~= nil then
 44+		return makenumber(tonumber(tok))
 45+	end
 46+	return makesymbol(tok)
 47+end
 48+
 49+function parselist()
 50+	local tok = getnexttok()
 51+	if tok == nil then 
 52+		error("Unmatched Parens") 
 53+	end
 54+	if tok == ")" then
 55+		return NILOBJ
 56+	end
 57+	car = parsetok(tok)
 58+	return makecons(car, parselist())
 59+end
 60+
 61+function parse(prog)
 62+	local tok = getnexttok(prog)
 63+	return parsetok(tok)
 64+end
 65+
 66+function fmtlist(e)
 67+	if e.type == EXPTYPES.NIL then
 68+		return ")"
 69+	end
 70+	if e.type ~= EXPTYPES.CONS then
 71+		return ". " .. fmtexp(e) .. " )"
 72+	end
 73+	return fmtexp(e.value.car) .. " " .. fmtlist(e.value.cdr)
 74+end
 75+
 76+function fmtexp(e)
 77+	local t = e.type
 78+	if t == EXPTYPES.CONS then
 79+		return "( " .. fmtlist(e)
 80+	end
 81+	return tostring(e.value)
 82+end
 83+
 84+local function printtable(t)
 85+	if type(t) == "table" then
 86+		print("{")
 87+		for k, v in pairs(t) do
 88+			print(tostring(k) .. ":")
 89+			printtable(v)
 90+		end
 91+		print("}")
 92+	elseif type(t) == "nil" then print(nil)
 93+	else
 94+		print(t)
 95+	end
 96+end
 97+
 98+-- Binds are in the form ((name, value) (name value) (name value) ...)
 99+
100+local function addbind(sym, value, oldbinds)
101+	return makecons(makecons(sym, value), oldbinds)
102+end
103+
104+local function findbind(sym, binds)
105+	if binds.type == EXPTYPES.NIL then error("bind doesn't exist for " .. sym.value) end
106+	local curbind = binds.value.car
107+	if curbind.value.car.value == sym.value then
108+		return curbind.value.cdr
109+	end
110+	return findbind(sym, binds.value.cdr)
111+end
112+
113+local function evallist(prog, stack, binds)
114+	if prog.type == EXPTYPES.NIL then return stack end
115+	local top = prog.value.car
116+	local prog = prog.value.cdr
117+	if top.type == EXPTYPES.SYMB then
118+		top = findbind(top, binds)
119+	end
120+	if top.type == EXPTYPES.PRIM then
121+		return top.value(prog, stack, binds)
122+	end
123+	return evallist(prog, makecons(top, stack), binds)
124+end
125+
126+
127+local function uncons(c)
128+	return c.value.car, c.value.cdr
129+end
130+
131+-- Start Builtins
132+
133+local function add2(prog, stack, binds)
134+	local arg1, stack = uncons(stack)
135+	local arg2, stack = uncons(stack)
136+	local res = makenumber(arg1.value + arg2.value)
137+	return evallist(prog, makecons(res, stack), binds)
138+end
139+
140+local function evalbuiltin(prog, stack, binds)
141+	local toeval, stack = uncons(stack)
142+	stack = evallist(toeval, stack, binds)
143+	return evallist(prog, stack, binds)
144+end
145+
146+local function bindbuiltin(prog, stack, binds)
147+	local sym, prog = uncons(prog)
148+	local val, stack = uncons(stack)
149+	return evallist(prog, stack, addbind(sym, val, binds))
150+end
151+
152+local function execmacro(prog, stack, binds)
153+	local mac, stack = uncons(stack)
154+	stack = makecons(prog, stack)
155+	return evallist(mac, stack, binds)
156+end
157+
158+local function unconsbuiltin(prog, stack, binds)
159+	local top, stack = uncons(stack)
160+	stack = makecons(top.value.cdr, stack)
161+	stack = makecons(top.value.car, stack)
162+	return evallist(prog, stack, binds)
163+end
164+
165+local function consbuiltin(prog, stack, binds)
166+	local car, stack = uncons(stack)
167+	local cdr, stack = uncons(stack)
168+	return evallist(prog, makecons(makecons(car, cdr), stack), binds)
169+end
170+
171+-- End Builtins
172+-- Register Builtins
173+
174+local function getbase()
175+	local base = NILOBJ
176+	local function addprim(s, f)
177+		base = addbind(makesymbol(s), makeprim(f), base)
178+	end
179+	addprim("+", add2)
180+	addprim(",", evalbuiltin)
181+	addprim("$", bindbuiltin)
182+	addprim("uncons", unconsbuiltin)
183+	addprim("cons", consbuiltin)
184+	addprim("!", execmacro)
185+	return base
186+end
187+
188+-- End Register Builtins
189+
190+local function readfile(file) -- from stackoverflow
191+	local f = assert(io.open(file, "rb"))
192+	local content = f:read("*all")
193+	f:close()
194+	return content
195+end
196+
197+local testterm = readfile(arg[1])
198+local parsed = parse(testterm)
199+local evalled = evallist(parsed, NILOBJ, getbase())
200+print(fmtexp(evalled))

1@@ -0,0 +1,7 @@
2+(
3+
4+( $ x $ y x y ) $ swap
5+
6+( uncons swap , , ) ! quoted_symbol 1 2 3
7+
8+)