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