aesthetic.computer
Monorepo for Aesthetic.Computer
aesthetic.computer
1/* tinylisp-commented.c with NaN boxing by Robert A. van Engelen 2022 */
2/* tinylisp.c but adorned with comments in an (overly) verbose C style */
3
4#include <stdlib.h>
5#include <stdio.h>
6#include <string.h>
7
8/* we only need two types to implement a Lisp interpreter:
9 I unsigned integer (either 16 bit, 32 bit or 64 bit unsigned)
10 L Lisp expression (double with NaN boxing)
11 I variables and function parameters are named as follows:
12 i any unsigned integer, e.g. a NaN-boxed ordinal value
13 t a NaN-boxed tag
14 L variables and function parameters are named as follows:
15 x,y any Lisp expression
16 n number
17 t list
18 f function, a lambda closure or Lisp primitive
19 p pair, a cons of two Lisp expressions
20 e,d environment, a list of pairs, e.g. created with (define v x)
21 v the name of a variable (an atom) or a list of variables */
22#define I unsigned
23#define L double
24
25/* T(x) returns the tag bits of a NaN-boxed Lisp expression x */
26#define T(x) *(unsigned long long*)&x >> 48
27
28/* address of the atom heap is at the bottom of the cell stack */
29#define A (char*)cell
30
31/* number of cells for the shared stack and atom heap, increase N as desired */
32#define N 1024
33
34/* hp: top of the atom heap pointer, A+hp with hp=0 points to the first atom string in cell[]
35 sp: cell stack pointer, the stack starts at the top of cell[] with sp=N
36 safety invariant: hp <= sp<<3 */
37I hp = 0, sp = N;
38
39/* atom, primitive, cons, closure and nil tags for NaN boxing */
40I ATOM = 0x7ff8, PRIM = 0x7ff9, CONS = 0x7ffa, CLOS = 0x7ffb, NIL = 0x7ffc;
41
42/* cell[N] array of Lisp expressions, shared by the stack and atom heap */
43L cell[N];
44
45/* Lisp constant expressions () (nil), #t, ERR, and the global environment env */
46L nil, tru, err, env;
47
48/* NaN-boxing specific functions:
49 box(t,i): returns a new NaN-boxed double with tag t and ordinal i
50 ord(x): returns the ordinal of the NaN-boxed double x
51 num(n): convert or check number n (does nothing, e.g. could check for NaN)
52 equ(x,y): returns nonzero if x equals y */
53L box(I t, I i) {
54 L x;
55 *(unsigned long long*)&x = (unsigned long long)t << 48 | i;
56 return x;
57}
58
59I ord(L x) {
60 return *(unsigned long long*)&x; /* the return value is narrowed to 32 bit unsigned integer to remove the tag */
61}
62
63L num(L n) {
64 return n;
65}
66
67I equ(L x, L y) {
68 return *(unsigned long long*)&x == *(unsigned long long*)&y;
69}
70
71/* interning of atom names (Lisp symbols), returns a unique NaN-boxed ATOM */
72L atom(const char *s) {
73 I i = 0;
74 while (i < hp && strcmp(A+i, s)) /* search for a matching atom name on the heap */
75 i += strlen(A+i)+1;
76 if (i == hp) { /* if not found */
77 hp += strlen(strcpy(A+i, s))+1; /* allocate and add a new atom name to the heap */
78 if (hp > sp<<3) /* abort when out of memory */
79 abort();
80 }
81 return box(ATOM, i);
82}
83
84/* construct pair (x . y) returns a NaN-boxed CONS */
85L cons(L x, L y) {
86 cell[--sp] = x; /* push the car value x */
87 cell[--sp] = y; /* push the cdr value y */
88 if (hp > sp<<3) /* abort when out of memory */
89 abort();
90 return box(CONS, sp);
91}
92
93/* return the car of a pair or ERR if not a pair */
94L car(L p) {
95 return (T(p) & ~(CONS^CLOS)) == CONS ? cell[ord(p)+1] : err;
96}
97
98/* return the cdr of a pair or ERR if not a pair */
99L cdr(L p) {
100 return (T(p) & ~(CONS^CLOS)) == CONS ? cell[ord(p)] : err;
101}
102
103/* construct a pair to add to environment e, returns the list ((v . x) . e) */
104L pair(L v, L x, L e) {
105 return cons(cons(v, x), e);
106}
107
108/* construct a lambda closure with variables v body x environment e, returns a NaN-boxed CLOS */
109L closure(L v, L x, L e) {
110 return box(CLOS, ord(pair(v, x, equ(e, env) ? nil : e)));
111}
112
113/* look up a symbol v in environment e, return its value or ERR if not found */
114L assoc(L v, L e) {
115 while (T(e) == CONS && !equ(v, car(car(e))))
116 e = cdr(e);
117 return T(e) == CONS ? cdr(car(e)) : err;
118}
119
120/* not(x) is nonzero if x is the Lisp () empty list a.k.a. nil or false */
121I not(L x) {
122 return T(x) == NIL;
123}
124
125/* let(x) is nonzero if x has more than one item, used by let* */
126I let(L x) {
127 return !not(x) && !not(cdr(x));
128}
129
130/* return a new list of evaluated Lisp expressions t in environment e */
131L eval(L, L);
132L evlis(L t, L e) {
133 return T(t) == CONS ? cons(eval(car(t), e), evlis(cdr(t), e)) : T(t) == ATOM ? assoc(t,e) : nil;
134}
135
136/* Lisp primitives:
137 (eval x) return evaluated x (such as when x was quoted)
138 (quote x) special form, returns x unevaluated "as is"
139 (cons x y) construct pair (x . y)
140 (car p) car of pair p
141 (cdr p) cdr of pair p
142 (+ n1 n2 ... nk) sum of n1 to nk
143 (- n1 n2 ... nk) n1 minus sum of n2 to nk
144 (* n1 n2 ... nk) product of n1 to nk
145 (/ n1 n2 ... nk) n1 divided by the product of n2 to nk
146 (int n) integer part of n
147 (< n1 n2) #t if n1<n2, otherwise ()
148 (eq? x y) #t if x equals y, otherwise ()
149 (pair? x) #t if x is a non-empty list, a cons cell or closure
150 (or x1 x2 ... xk) first x that is not (), otherwise ()
151 (and x1 x2 ... xk) last x if all x are not (), otherwise ()
152 (not x) #t if x is (), otherwise ()
153 (cond (x1 y1)
154 (x2 y2)
155 ...
156 (xk yk)) the first yi for which xi evaluates to non-()
157 (if x y z) if x is non-() then y else z
158 (let* (v1 x1)
159 (v2 x2)
160 ...
161 y) sequentially binds each variable v1 to xi to evaluate y
162 (lambda v x) construct a closure
163 (define v x) define a named value globally */
164L f_eval(L t, L e) {
165 return eval(car(evlis(t, e)), e);
166}
167
168L f_quote(L t, L _) {
169 return car(t);
170}
171
172L f_cons(L t, L e) {
173 t = evlis(t, e);
174 return cons(car(t), car(cdr(t)));
175}
176
177L f_car(L t, L e) {
178 return car(car(evlis(t, e)));
179}
180
181L f_cdr(L t, L e) {
182 return cdr(car(evlis(t, e)));
183}
184
185L f_add(L t, L e) {
186 L n;
187 t = evlis(t, e);
188 n = car(t);
189 while (!not(t = cdr(t)))
190 n += car(t);
191 return num(n);
192}
193
194L f_sub(L t, L e) {
195 L n;
196 t = evlis(t, e);
197 n = car(t);
198 while (!not(t = cdr(t)))
199 n -= car(t);
200 return num(n);
201}
202
203L f_mul(L t, L e) {
204 L n;
205 t = evlis(t, e);
206 n = car(t);
207 while (!not(t = cdr(t)))
208 n *= car(t);
209 return num(n);
210}
211
212L f_div(L t, L e) {
213 L n;
214 t = evlis(t, e);
215 n = car(t);
216 while (!not(t = cdr(t)))
217 n /= car(t);
218 return num(n);
219}
220
221L f_int(L t, L e) {
222 L n = car(evlis(t, e));
223 return n<1e16 && n>-1e16 ? (long long)n : n;
224}
225
226L f_lt(L t, L e) {
227 return t = evlis(t, e), car(t) - car(cdr(t)) < 0 ? tru : nil;
228}
229
230L f_eq(L t, L e) {
231 return t = evlis(t, e), equ(car(t), car(cdr(t))) ? tru : nil;
232}
233
234L f_pair(L t,L e) {
235 L x = car(evlis(t,e));
236 return T(x) == CONS ? tru : nil;
237}
238
239L f_or(L t,L e) {
240 L x = nil;
241 while (!not(t) && not(x = eval(car(t),e)))
242 t = cdr(t);
243 return x;
244}
245
246L f_and(L t,L e) {
247 L x = tru;
248 while (!not(t) && !not(x = eval(car(t),e)))
249 t = cdr(t);
250 return x;
251}
252
253L f_not(L t, L e) {
254 return not(car(evlis(t, e))) ? tru : nil;
255}
256
257L f_cond(L t, L e) {
258 while (!not(t) && not(eval(car(car(t)), e)))
259 t = cdr(t);
260 return eval(car(cdr(car(t))), e);
261}
262
263L f_if(L t, L e) {
264 return eval(car(cdr(not(eval(car(t), e)) ? cdr(t) : t)), e);
265}
266
267L f_leta(L t, L e) {
268 for (; let(t); t = cdr(t))
269 e = pair(car(car(t)), eval(car(cdr(car(t))), e), e);
270 return eval(car(t), e);
271}
272
273L f_lambda(L t, L e) {
274 return closure(car(t), car(cdr(t)), e);
275}
276
277L f_define(L t, L e) {
278 env = pair(car(t), eval(car(cdr(t)), e), env);
279 return car(t);
280}
281
282/* table of Lisp primitives, each has a name s and function pointer f */
283struct {
284 const char *s;
285 L (*f)(L, L);
286} prim[] = {
287 {"eval", f_eval},
288 {"quote", f_quote},
289 {"cons", f_cons},
290 {"car", f_car},
291 {"cdr", f_cdr},
292 {"+", f_add},
293 {"-", f_sub},
294 {"*", f_mul},
295 {"/", f_div},
296 {"int", f_int},
297 {"<", f_lt},
298 {"eq?", f_eq},
299 {"pair?", f_pair},
300 {"or", f_or},
301 {"and", f_and},
302 {"not", f_not},
303 {"cond", f_cond},
304 {"if", f_if},
305 {"let*", f_leta},
306 {"lambda", f_lambda},
307 {"define", f_define},
308 {0}};
309
310/* create environment by extending e with variables v bound to values t */
311L bind(L v, L t, L e) {
312 return not(v) ? e :
313 T(v) == CONS ? bind(cdr(v), cdr(t), pair(car(v), car(t), e)) :
314 pair(v, t, e);
315}
316
317/* apply closure f to arguments t in environemt e */
318L reduce(L f, L t, L e) {
319 return eval(cdr(car(f)), bind(car(car(f)), evlis(t, e), not(cdr(f)) ? env : cdr(f)));
320}
321
322/* apply closure or primitive f to arguments t in environment e, or return ERR */
323L apply(L f, L t, L e) {
324 return T(f) == PRIM ? prim[ord(f)].f(t, e) :
325 T(f) == CLOS ? reduce(f, t, e) :
326 err;
327}
328
329/* evaluate x and return its value in environment e */
330L eval(L x, L e) {
331 return T(x) == ATOM ? assoc(x, e) :
332 T(x) == CONS ? apply(eval(car(x), e), cdr(x), e) :
333 x;
334}
335
336/* tokenization buffer and the next character that we are looking at */
337char buf[40], see = ' ';
338
339/* advance to the next character */
340void look() {
341 int c = getchar();
342 see = c;
343 if (c == EOF)
344 exit(0);
345}
346
347/* return nonzero if we are looking at character c, ' ' means any white space */
348I seeing(char c) {
349 return c == ' ' ? see > 0 && see <= c : see == c;
350}
351
352/* return the look ahead character from standard input, advance to the next */
353char get() {
354 char c = see;
355 look();
356 return c;
357}
358
359/* tokenize into buf[], return first character of buf[] */
360char scan() {
361 I i = 0;
362 while (seeing(' '))
363 look();
364 if (seeing('(') || seeing(')') || seeing('\''))
365 buf[i++] = get();
366 else
367 do
368 buf[i++] = get();
369 while (i < 39 && !seeing('(') && !seeing(')') && !seeing(' '));
370 buf[i] = 0;
371 return *buf;
372}
373
374/* return the Lisp expression read from standard input */
375L parse();
376L Read() {
377 scan();
378 return parse();
379}
380
381/* return a parsed Lisp list */
382L list() {
383 L x;
384 if (scan() == ')')
385 return nil;
386 if (!strcmp(buf, ".")) {
387 x = Read();
388 scan();
389 return x;
390 }
391 x = parse();
392 return cons(x, list());
393}
394
395/* return a parsed Lisp expression x quoted as (quote x) */
396L quote() {
397 return cons(atom("quote"), cons(Read(), nil));
398}
399
400/* return a parsed atomic Lisp expression (a number or an atom) */
401L atomic() {
402 L n; I i;
403 return (sscanf(buf, "%lg%n", &n, &i) > 0 && !buf[i]) ? n :
404 atom(buf);
405}
406
407/* return a parsed Lisp expression */
408L parse() {
409 return *buf == '(' ? list() :
410 *buf == '\'' ? quote() :
411 atomic();
412}
413
414/* display a Lisp list t */
415void print(L);
416void printlist(L t) {
417 for (putchar('('); ; putchar(' ')) {
418 print(car(t));
419 t = cdr(t);
420 if (not(t))
421 break;
422 if (T(t) != CONS) {
423 printf(" . ");
424 print(t);
425 break;
426 }
427 }
428 putchar(')');
429}
430
431/* display a Lisp expression x */
432void print(L x) {
433 if (T(x) == NIL)
434 printf("()");
435 else if (T(x) == ATOM)
436 printf("%s", A+ord(x));
437 else if (T(x) == PRIM)
438 printf("<%s>", prim[ord(x)].s);
439 else if (T(x) == CONS)
440 printlist(x);
441 else if (T(x) == CLOS)
442 printf("{%u}", ord(x));
443 else
444 printf("%.10lg", x);
445}
446
447/* garbage collection removes temporary cells, keeps global environment */
448void gc() {
449 sp = ord(env);
450}
451
452/* Lisp initialization and REPL */
453int main() {
454 I i;
455 printf("tinylisp");
456 nil = box(NIL, 0);
457 err = atom("ERR");
458 tru = atom("#t");
459 env = pair(tru, tru, nil);
460 for (i = 0; prim[i].s; ++i)
461 env = pair(atom(prim[i].s), box(PRIM, i), env);
462 while (1) {
463 printf("\n%u>", sp-hp/8);
464 print(eval(Read(), env));
465 gc();
466 }
467}